Skip to content

haskell-gargantext
haskell-gargantext
Commit 013e9d66 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

Merge remote-tracking branch 'origin/adinapoli/issue-261' into dev

parents 2e537215 ccfb8554
Hide whitespace changes
Inline Side-by-side
Showing with 755 additions and 270 deletions
.gitlab-ci.yml
View file @ 013e9d66
# Optimising CI speed by using tips from https://blog.nimbleways.com/let-s-make-faster-gitlab-ci-cd-pipelines/
image: adinapoli/gargantext:v2.1
image: adinapoli/gargantext:v2.3
variables:
STACK_ROOT: "${CI_PROJECT_DIR}/.stack-root"
STACK_OPTS: "--system-ghc"
CABAL_STORE_DIR: "${CI_PROJECT_DIR}/.cabal"
CORENLP: "4.5.4"
FF_USE_FASTZIP: "true"
ARTIFACT_COMPRESSION_LEVEL: "fast"
CACHE_COMPRESSION_LEVEL: "fast"
......@@ -77,12 +78,17 @@ test:
mkdir -p /root/.cache/cabal/logs
chown -R test:test /root/.cache/cabal/logs/
chown -R test:test /root/.cache/cabal/packages/hackage.haskell.org/
nix-shell --run "chown -R test:test /root/.config/ && su -m test -c \"export PATH=$PATH:$TEST_NIX_PATH && cd /builds/gargantext/haskell-gargantext && $CABAL --store-dir=$CABAL_STORE_DIR v2-test --test-show-details=streaming --flags test-crypto --ghc-options='-O0 -fclear-plugins'\""
mkdir -p /builds/gargantext/haskell-gargantext/devops/coreNLP/stanford-corenlp-current
cp -R /root/devops/coreNLP/stanford-corenlp-${CORENLP}/* /builds/gargantext/haskell-gargantext/devops/coreNLP/stanford-corenlp-current/
nix-shell --run "chown -R test:test /root/.config/ && su -m test -c \"export PATH=$PATH:$TEST_NIX_PATH && cd /builds/gargantext/haskell-gargantext; $CABAL --store-dir=$CABAL_STORE_DIR v2-test --test-show-details=streaming --flags test-crypto --ghc-options='-O0 -fclear-plugins'\""
chown -R root:root dist-newstyle/
chown -R root:root /root/
chown -R root:root $CABAL_STORE_DIR
chown -R root:root /root/.cache/cabal/logs/
chown -R root:root /root/.cache/cabal/packages/hackage.haskell.org/
chown -Rh root:root /builds/gargantext/haskell-gargantext/devops/coreNLP/stanford-corenlp-current
#docs:
# stage: docs
......
bin/gargantext-init/Main.hs
View file @ 013e9d66
......@@ -25,7 +25,7 @@ import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, )
import Gargantext.Database.Prelude (Cmd, DBCmd)
import Gargantext.Database.Query.Table.Node (getOrMkList)
import Gargantext.Database.Query.Table.User (insertNewUsers, )
import Gargantext.Prelude
......@@ -73,7 +73,7 @@ main = do
pure (masterUserId, masterRootId, masterCorpusId, masterListId)
withDevEnv iniPath $ \env -> do
_ <- runCmdDev env (initFirstTriggers secret :: Cmd GargError [Int64])
_ <- runCmdDev env (initFirstTriggers secret :: DBCmd GargError [Int64])
_ <- runCmdDev env createUsers
x <- runCmdDev env initMaster
_ <- runCmdDev env mkRoots
......
bin/update-cabal-project
View file @ 013e9d66
......@@ -11,8 +11,8 @@ STORE_DIR="${1:-$DEFAULT_STORE}"
# `expected_cabal_project_freeze_hash` with the
# `sha256sum` result calculated on the `cabal.project` and `cabal.project.freeze`.
# This ensures the files stay deterministic so that CI cache can kick in.
expected_cabal_project_hash="eb12c232115b3fffa1f81add7c83d921e5899c7712eddee6100ff8df7305088e"
expected_cabal_project_freeze_hash="b7acfd12c970323ffe2c6684a13130db09d8ec9fa5676a976afed329f1ef3436"
expected_cabal_project_hash="297d2ac44b8a2e65a9d7bbbe1fb6e5e0ff46b144300501c14e5e424e77aa1abf"
expected_cabal_project_freeze_hash="2d3704d107bd8d08056ce4f0eb1f42202cb7f49a67c62a2445a6c70c7235f861"
cabal --store-dir=$STORE_DIR v2-update 'hackage.haskell.org,2023-06-24T21:28:46Z'
......
cabal.project
View file @ 013e9d66
......@@ -7,6 +7,16 @@ with-compiler: ghc-8.10.7
packages:
./
source-repository-package
type: git
location: https://github.com/adinapoli/boolexpr.git
tag: 91928b5d7f9342e9865dde0d94862792d2b88779
source-repository-package
type: git
location: https://github.com/adinapoli/haskell-opaleye.git
tag: e9a29582ac66198dd2c2fdc3f8c8a4b1e6fbe004
source-repository-package
type: git
location: https://github.com/alpmestan/accelerate.git
......@@ -56,11 +66,6 @@ source-repository-package
location: https://github.com/delanoe/patches-map
tag: 76cae88f367976ff091e661ee69a5c3126b94694
source-repository-package
type: git
location: https://github.com/garganscript/haskell-opaleye.git
tag: a5693a2010e6d13f51cdc576fa1dc9985e79ee0e
source-repository-package
type: git
location: https://gitlab.iscpif.fr/amestanogullari/accelerate-utility.git
......
cabal.project.freeze
View file @ 013e9d66
......@@ -384,7 +384,6 @@ constraints: any.AC-Angle ==1.0,
any.bodhi ==0.1.0,
any.boltzmann-samplers ==0.1.1.0,
any.boolean-like ==0.1.1.0,
any.boolexpr ==0.2,
any.boolsimplifier ==0.1.8,
any.boots ==0.2.0.1,
any.bordacount ==0.1.0.0,
......
devops/docker/Dockerfile
View file @ 013e9d66
FROM ubuntu:jammy
## NOTA BENE: In order for this to be built successfully, you have to run ./devops/coreNLP/build.sh first.
ARG DEBIAN_FRONTEND=noninteractive
ARG GHC=8.10.7
ARG STACK=2.7.3
ARG CABAL=3.10.1.0
ARG CORENLP=4.5.4
ARG CORE
COPY ./shell.nix /builds/gargantext/shell.nix
COPY ./nix/pkgs.nix /builds/gargantext/nix/pkgs.nix
COPY ./nix/pinned-22.05.nix /builds/gargantext/nix/pinned-22.05.nix
......@@ -14,6 +18,8 @@ COPY ./nix/overlays/Cabal-syntax-3.10.1.0.nix /builds/gargantext/nix/ov
COPY ./nix/overlays/directory-1.3.7.0.nix /builds/gargantext/nix/overlays/directory-1.3.7.0.nix
COPY ./nix/overlays/hackage-security-0.6.2.3.nix /builds/gargantext/nix/overlays/hackage-security-0.6.2.3.nix
COPY ./nix/overlays/process-1.6.15.0.nix /builds/gargantext/nix/overlays/process-1.6.15.0.nix
COPY ./devops/coreNLP/build.sh /root/devops/coreNLP/build.sh
COPY ./devops/coreNLP/startServer.sh /root/devops/coreNLP/startServer.sh
ENV TZ=Europe/Rome
RUN apt-get update && \
......@@ -43,7 +49,9 @@ RUN apt-get update && \
wget \
vim \
xz-utils \
zlib1g-dev && \
zlib1g-dev \
openjdk-18-jdk \
unzip && \
apt-get clean && rm -rf /var/lib/apt/lists/* && \
mkdir -m 0755 /nix && groupadd -r nixbld && chown root /nix && \
for n in $(seq 1 10); do useradd -c "Nix build user $n" -d /var/empty -g nixbld -G nixbld -M -N -r -s "$(command -v nologin)" "nixbld$n"; done
......@@ -52,6 +60,8 @@ RUN gpg --batch --keyserver keys.openpgp.org --recv-keys 7D1E8AFD1D4A16D71FA
gpg --batch --keyserver keyserver.ubuntu.com --recv-keys FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01
SHELL ["/bin/bash", "-o", "pipefail", "-c"]
RUN cd /root/devops/coreNLP; ./build.sh
RUN set -o pipefail && \
bash <(curl -L https://releases.nixos.org/nix/nix-2.15.0/install) --no-daemon && \
locale-gen en_US.UTF-8 && chown root -R /nix
......
devops/postgres/schema.sql
View file @ 013e9d66
......@@ -272,7 +272,7 @@ CREATE INDEX ON public.contexts USING btree (user_id, typename, parent_id
CREATE INDEX ON public.contexts USING btree (id, typename, date ASC);
CREATE INDEX ON public.contexts USING btree (id, typename, date DESC);
CREATE INDEX ON public.contexts USING btree (typename, id);
CREATE UNIQUE INDEX IF NOT EXISTS ON public.contexts USING btree (hash_id);
CREATE UNIQUE INDEX ON public.contexts USING btree (hash_id);
CREATE INDEX ON public.nodescontexts_nodescontexts USING btree (nodescontexts1, nodescontexts2);
-- CREATE UNIQUE INDEX ON public.nodes USING btree (((hyperdata ->> 'uniqId'::text)));
......
gargantext.cabal
View file @ 013e9d66
......@@ -58,6 +58,7 @@ library
Gargantext.API.Node
Gargantext.API.Node.Corpus.New
Gargantext.API.Node.Corpus.Types
Gargantext.API.Node.Corpus.Update
Gargantext.API.Node.File
Gargantext.API.Node.Share
Gargantext.API.Prelude
......@@ -85,6 +86,7 @@ library
Gargantext.Core.Text.Terms
Gargantext.Core.Text.Terms.Eleve
Gargantext.Core.Text.Terms.Mono
Gargantext.Core.Text.Terms.Mono.Stem.En
Gargantext.Core.Text.Terms.Multi
Gargantext.Core.Text.Terms.Multi.Lang.En
Gargantext.Core.Text.Terms.Multi.Lang.Fr
......@@ -112,13 +114,17 @@ library
Gargantext.Core.Viz.Types
Gargantext.Database.Action.Flow
Gargantext.Database.Action.Flow.Types
Gargantext.Database.Action.Search
Gargantext.Database.Action.User
Gargantext.Database.Action.User.New
Gargantext.Database.Admin.Config
Gargantext.Database.Admin.Trigger.Init
Gargantext.Database.Admin.Types.Hyperdata
Gargantext.Database.Admin.Types.Hyperdata.Corpus
Gargantext.Database.Admin.Types.Hyperdata.Document
Gargantext.Database.Admin.Types.Node
Gargantext.Database.Prelude
Gargantext.Database.Query.Facet
Gargantext.Database.Query.Table.NgramsPostag
Gargantext.Database.Query.Table.Node
Gargantext.Database.Query.Table.Node.Error
......@@ -126,6 +132,7 @@ library
Gargantext.Database.Query.Tree.Root
Gargantext.Database.Query.Table.User
Gargantext.Database.Schema.Ngrams
Gargantext.Database.Schema.Node
Gargantext.Database.Schema.User
Gargantext.Defaults
Gargantext.System.Logging
......@@ -173,7 +180,6 @@ library
Gargantext.API.Node.Corpus.New.File
Gargantext.API.Node.Corpus.New.Types
Gargantext.API.Node.Corpus.Searx
Gargantext.API.Node.Corpus.Update
Gargantext.API.Node.Document.Export
Gargantext.API.Node.Document.Export.Types
Gargantext.API.Node.DocumentsFromWriteNodes
......@@ -250,7 +256,6 @@ library
Gargantext.Core.Text.Samples.PL
Gargantext.Core.Text.Samples.ZH
Gargantext.Core.Text.Terms.Mono.Stem
Gargantext.Core.Text.Terms.Mono.Stem.En
Gargantext.Core.Text.Terms.Mono.Token
Gargantext.Core.Text.Terms.Mono.Token.En
Gargantext.Core.Text.Terms.Multi.Group
......@@ -288,7 +293,6 @@ library
Gargantext.Database.Action.Metrics.NgramsByContext
Gargantext.Database.Action.Metrics.TFICF
Gargantext.Database.Action.Node
Gargantext.Database.Action.Search
Gargantext.Database.Action.Share
Gargantext.Database.Action.TSQuery
Gargantext.Database.Admin.Access
......@@ -298,11 +302,9 @@ library
Gargantext.Database.Admin.Trigger.NodesContexts
Gargantext.Database.Admin.Types.Hyperdata.Any
Gargantext.Database.Admin.Types.Hyperdata.Contact
Gargantext.Database.Admin.Types.Hyperdata.Corpus
Gargantext.Database.Admin.Types.Hyperdata.CorpusField
Gargantext.Database.Admin.Types.Hyperdata.Dashboard
Gargantext.Database.Admin.Types.Hyperdata.Default
Gargantext.Database.Admin.Types.Hyperdata.Document
Gargantext.Database.Admin.Types.Hyperdata.File
Gargantext.Database.Admin.Types.Hyperdata.Folder
Gargantext.Database.Admin.Types.Hyperdata.Frame
......@@ -315,7 +317,6 @@ library
Gargantext.Database.Admin.Types.Metrics
Gargantext.Database.GargDB
Gargantext.Database.Query
Gargantext.Database.Query.Facet
Gargantext.Database.Query.Facet.Types
Gargantext.Database.Query.Filter
Gargantext.Database.Query.Join
......@@ -344,7 +345,6 @@ library
Gargantext.Database.Schema.ContextNodeNgrams
Gargantext.Database.Schema.ContextNodeNgrams2
Gargantext.Database.Schema.NgramsPostag
Gargantext.Database.Schema.Node
Gargantext.Database.Schema.Node_NodeNgramsNodeNgrams
Gargantext.Database.Schema.NodeContext
Gargantext.Database.Schema.NodeContext_NodeContext
......@@ -884,6 +884,8 @@ test-suite garg-test-tasty
Core.Text.Flow
Core.Utils
Database.Operations
Database.Operations.DocumentSearch
Database.Operations.Types
Graph.Clustering
Graph.Distance
Ngrams.Lang
......@@ -942,11 +944,13 @@ test-suite garg-test-tasty
, lens >= 5.2.2 && < 5.3
, monad-control >= 1.0.3 && < 1.1
, mtl ^>= 2.2.2
, network-uri
, parsec ^>= 3.1.14.0
, patches-class ^>= 0.1.0.1
, patches-map ^>= 0.1.0.1
, postgres-options >= 0.2 && < 0.3
, postgresql-simple >= 0.6.4 && < 0.7
, process ^>= 1.6.13.2
, quickcheck-instances ^>= 0.3.25.2
, raw-strings-qq
, recover-rtti >= 0.4 && < 0.5
......@@ -971,6 +975,8 @@ test-suite garg-test-hspec
main-is: hspec/Main.hs
other-modules:
Database.Operations
Database.Operations.DocumentSearch
Database.Operations.Types
Paths_gargantext
hs-source-dirs:
test
......@@ -1022,11 +1028,13 @@ test-suite garg-test-hspec
, lens >= 5.2.2 && < 5.3
, monad-control >= 1.0.3 && < 1.1
, mtl ^>= 2.2.2
, network-uri
, parsec ^>= 3.1.14.0
, patches-class ^>= 0.1.0.1
, patches-map ^>= 0.1.0.1
, postgres-options >= 0.2 && < 0.3
, postgresql-simple >= 0.6.4 && < 0.7
, process ^>= 1.6.13.2
, quickcheck-instances ^>= 0.3.25.2
, raw-strings-qq
, recover-rtti >= 0.4 && < 0.5
......
src/Gargantext/API/Node/Corpus/Searx.hs
View file @ 013e9d66
......@@ -16,7 +16,7 @@ import Gargantext.Core.Text.List.Group.WithStem ({-StopSize(..),-} GroupParams(.
import Gargantext.Core.Text.Terms (TermType(..))
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Action.Flow (insertMasterDocs) --, DataText(..))
import Gargantext.Database.Action.Flow (addDocumentsToHyperCorpus) --, DataText(..))
import Gargantext.Database.Action.Flow.List (flowList_DbRepo)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.User (getUserId)
......@@ -33,13 +33,12 @@ import Gargantext.Prelude.Config
import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
import Network.HTTP.Client
import Network.HTTP.Client.TLS
import Protolude (catMaybes, encodeUtf8, rightToMaybe, Text)
import Protolude (catMaybes, encodeUtf8, rightToMaybe, Text, void)
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as T
import qualified Data.Text as Text
import qualified Gargantext.Core.Text.Corpus.API as API
import qualified Gargantext.Database.Query.Table.Node.Document.Add as Doc (add)
import qualified Prelude
langToSearx :: Lang -> Text
......@@ -133,8 +132,7 @@ insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) =
-}
--_ <- flowDataText user (DataNew [docs']) (Multi l) cId Nothing logStatus
let mCorpus = Nothing :: Maybe HyperdataCorpus
ids <- insertMasterDocs mCorpus (Multi l) docs'
_ <- Doc.add cId ids
void $ addDocumentsToHyperCorpus server mCorpus (Multi l) cId docs'
(_masterUserId, _masterRootId, masterCorpusId)
<- getOrMk_RootWithCorpus (UserName userMaster) (Left "") mCorpus
let gp = GroupWithPosTag l server HashMap.empty
......
src/Gargantext/API/Node/Corpus/Update.hs
View file @ 013e9d66
......@@ -7,17 +7,18 @@ import Control.Lens
import Control.Monad
import Data.Proxy
import Gargantext.Core
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Admin.Types.Hyperdata.Corpus
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude
import Gargantext.Utils.Jobs
-- | Updates the 'HyperdataCorpus' with the input 'Lang'.
addLanguageToCorpus :: (FlowCmdM env err m, MonadJobStatus m)
addLanguageToCorpus :: (HasNodeError err, DbCmd' env err m, MonadJobStatus m)
=> CorpusId
-> Lang
-> m ()
......
src/Gargantext/API/Node/DocumentUpload.hs
View file @ 013e9d66
......@@ -16,17 +16,17 @@ import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Prelude
import Gargantext.Core (Lang(..))
import Gargantext.Core.NLP (nlpServerGet)
import Gargantext.Core.Text.Corpus.Parsers.Date (dateSplit)
import Gargantext.Core.Text.Terms (TermType(..))
import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
import Gargantext.Database.Action.Flow (addDocumentsToHyperCorpus)
import Gargantext.Database.Action.Flow.Types
import Gargantext.Core.Text.Terms (TermType(..))
import Gargantext.Database.Action.Flow (insertMasterDocs)
import Gargantext.Database.Admin.Types.Hyperdata.Corpus
import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
import qualified Gargantext.Database.Query.Table.Node.Document.Add as Doc (add)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.Node (getClosestParentIdByType')
import Gargantext.Prelude
import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus(..))
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
......@@ -117,6 +117,6 @@ documentUpload nId doc = do
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ view du_language doc }
docIds <- insertMasterDocs (Nothing :: Maybe HyperdataCorpus) (Multi EN) [hd]
_ <- Doc.add cId docIds
pure docIds
let lang = EN
ncs <- view $ nlpServerGet lang
addDocumentsToHyperCorpus ncs (Nothing :: Maybe HyperdataCorpus) (Multi lang) cId [hd]
src/Gargantext/API/Search.hs
View file @ 013e9d66
......@@ -17,24 +17,28 @@ Count API part of Gargantext.
module Gargantext.API.Search
where
import Data.Aeson hiding (defaultTaggedObject)
-- import Data.List (concat)
import Data.Aeson hiding (defaultTaggedObject)
import Data.Swagger hiding (fieldLabelModifier, Contact)
import Data.Text (Text)
import GHC.Generics (Generic)
import Gargantext.API.Prelude (GargServer)
import Gargantext.Core.Text.Corpus.Query (RawQuery (..), parseQuery)
import Gargantext.Core.Types.Query (Limit, Offset)
import Gargantext.Core.Types.Search
import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
import Gargantext.Database.Action.Flow.Pairing (isPairedWith)
import Gargantext.Database.Action.Search
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Admin.Types.Node hiding (DEBUG)
import Gargantext.Database.Query.Facet
import Gargantext.Prelude
import Gargantext.System.Logging
import Gargantext.Utils.Aeson (defaultTaggedObject)
import Servant
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import qualified Data.Text as T
import Data.Either
-----------------------------------------------------------------------
-- TODO-ACCESS: CanSearch? or is it part of CanGetNode
......@@ -48,22 +52,28 @@ type API results = Summary "Search endpoint"
-----------------------------------------------------------------------
-- | Api search function
api :: NodeId -> GargServer (API SearchResult)
api nId (SearchQuery q SearchDoc) o l order =
SearchResult <$> SearchResultDoc
<$> map (toRow nId)
<$> searchInCorpus nId False q o l order
-- <$> searchInCorpus nId False (concat q) o l order
api nId (SearchQuery q SearchContact) o l order = do
-- printDebug "isPairedWith" nId
aIds <- isPairedWith nId NodeAnnuaire
-- TODO if paired with several corpus
case head aIds of
Nothing -> pure $ SearchResult
$ SearchNoResult "[G.A.Search] pair corpus with an Annuaire"
Just aId -> SearchResult
<$> SearchResultContact
<$> map (toRow aId)
<$> searchInCorpusWithContacts nId aId q o l order
api nId (SearchQuery rawQuery SearchDoc) o l order = do
case parseQuery rawQuery of
Left err -> pure $ SearchResult $ SearchNoResult (T.pack err)
Right q -> do
$(logLocM) DEBUG $ T.pack "New search started with query = " <> (getRawQuery rawQuery)
SearchResult <$> SearchResultDoc
<$> map (toRow nId)
<$> searchInCorpus nId False q o l order
api nId (SearchQuery rawQuery SearchContact) o l order = do
case parseQuery rawQuery of
Left err -> pure $ SearchResult $ SearchNoResult (T.pack err)
Right q -> do
-- printDebug "isPairedWith" nId
aIds <- isPairedWith nId NodeAnnuaire
-- TODO if paired with several corpus
case head aIds of
Nothing -> pure $ SearchResult
$ SearchNoResult "[G.A.Search] pair corpus with an Annuaire"
Just aId -> SearchResult
<$> SearchResultContact
<$> map (toRow aId)
<$> searchInCorpusWithContacts nId aId q o l order
api _nId (SearchQuery _q SearchDocWithNgrams) _o _l _order = undefined
-----------------------------------------------------------------------
......@@ -82,7 +92,7 @@ instance Arbitrary SearchType where
-----------------------------------------------------------------------
data SearchQuery =
SearchQuery { query :: ![Text]
SearchQuery { query :: !RawQuery
, expected :: !SearchType
}
deriving (Generic)
......@@ -97,7 +107,7 @@ instance ToSchema SearchQuery
-}
instance Arbitrary SearchQuery where
arbitrary = elements [SearchQuery ["electrodes"] SearchDoc]
arbitrary = elements [SearchQuery (RawQuery "electrodes") SearchDoc]
-- arbitrary = elements [SearchQuery "electrodes" 1 ] --SearchDoc]
-----------------------------------------------------------------------
data SearchResult =
......
src/Gargantext/API/Server.hs
View file @ 013e9d66
......@@ -83,7 +83,7 @@ showAsServantErr :: GargError -> ServerError
showAsServantErr (GargNodeError err@(NoListFound {})) = err404 { errBody = BL8.pack $ show err }
showAsServantErr (GargNodeError err@NoRootFound) = err404 { errBody = BL8.pack $ show err }
showAsServantErr (GargNodeError err@NoCorpusFound) = err404 { errBody = BL8.pack $ show err }
showAsServantErr (GargNodeError err@NoUserFound) = err404 { errBody = BL8.pack $ show err }
showAsServantErr (GargNodeError err@NoUserFound{}) = err404 { errBody = BL8.pack $ show err }
showAsServantErr (GargNodeError err@(DoesNotExist {})) = err404 { errBody = BL8.pack $ show err }
showAsServantErr (GargServerError err) = err
showAsServantErr a = err500 { errBody = BL8.pack $ show a }
......@@ -92,7 +92,7 @@ showAsServantJSONErr :: GargError -> ServerError
showAsServantJSONErr (GargNodeError err@(NoListFound {})) = err404 { errBody = Aeson.encode err }
showAsServantJSONErr (GargNodeError err@NoRootFound) = err404 { errBody = Aeson.encode err }
showAsServantJSONErr (GargNodeError err@NoCorpusFound) = err404 { errBody = Aeson.encode err }
showAsServantJSONErr (GargNodeError err@NoUserFound) = err404 { errBody = Aeson.encode err }
showAsServantJSONErr (GargNodeError err@NoUserFound{}) = err404 { errBody = Aeson.encode err }
showAsServantJSONErr (GargNodeError err@(DoesNotExist {})) = err404 { errBody = Aeson.encode err }
showAsServantJSONErr (GargServerError err) = err
showAsServantJSONErr a = err500 { errBody = Aeson.encode a }
src/Gargantext/API/Table.hs
View file @ 013e9d66
......@@ -36,6 +36,7 @@ import Data.Maybe
import Data.Swagger
import Data.Text (Text())
import GHC.Generics (Generic)
import Prelude
import Servant
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
......@@ -43,16 +44,19 @@ import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import Gargantext.API.HashedResponse
import Gargantext.API.Ngrams.Types (TabType(..))
import Gargantext.API.Prelude (GargServer)
import Gargantext.Core.Text.Corpus.Query (RawQuery, parseQuery, getRawQuery)
import Gargantext.Core.Types (TableResult(..))
import Gargantext.Core.Types.Query (Offset, Limit)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Action.Learn (FavOrTrash(..), moreLike)
import Gargantext.Database.Action.Search
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Facet (FacetDoc , runViewDocuments, runCountDocuments, OrderBy(..), runViewAuthorsDoc)
import Gargantext.Database.Admin.Types.Node hiding (ERROR, DEBUG)
import Gargantext.Database.Prelude -- (Cmd, CmdM)
import Gargantext.Database.Query.Facet (FacetDoc , runViewDocuments, runCountDocuments, OrderBy(..), runViewAuthorsDoc)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Prelude
import Gargantext.System.Logging
import qualified Data.Text as T
------------------------------------------------------------------------
......@@ -61,7 +65,7 @@ type TableApi = Summary "Table API"
:> QueryParam "limit" Limit
:> QueryParam "offset" Offset
:> QueryParam "orderBy" OrderBy
:> QueryParam "query" Text
:> QueryParam "query" RawQuery
:> QueryParam "year" Text
:> Get '[JSON] (HashedResponse FacetTableResult)
:<|> Summary "Table API (POST)"
......@@ -77,7 +81,7 @@ data TableQuery = TableQuery
, tq_limit :: Limit
, tq_orderBy :: OrderBy
, tq_view :: TabType
, tq_query :: Text
, tq_query :: RawQuery
} deriving (Generic)
type FacetTableResult = TableResult FacetDoc
......@@ -101,46 +105,72 @@ tableApi id' = getTableApi id'
:<|> getTableHashApi id'
getTableApi :: HasNodeError err
getTableApi :: (CmdM env err m, HasNodeError err, MonadLogger m)
=> NodeId
-> Maybe TabType
-> Maybe Limit
-> Maybe Offset
-> Maybe OrderBy
-> Maybe RawQuery
-> Maybe Text
-> Maybe Text
-> Cmd err (HashedResponse FacetTableResult)
getTableApi cId tabType mLimit mOffset mOrderBy mQuery mYear = do
-- printDebug "[getTableApi] mQuery" mQuery
-- printDebug "[getTableApi] mYear" mYear
t <- getTable cId tabType mOffset mLimit mOrderBy mQuery mYear
pure $ constructHashedResponse t
postTableApi :: HasNodeError err
=> NodeId -> TableQuery -> Cmd err FacetTableResult
postTableApi cId (TableQuery o l order ft "") = getTable cId (Just ft) (Just o) (Just l) (Just order) Nothing Nothing
postTableApi cId (TableQuery o l order ft q) = case ft of
Docs -> searchInCorpus' cId False [q] (Just o) (Just l) (Just order)
Trash -> searchInCorpus' cId True [q] (Just o) (Just l) (Just order)
x -> panic $ "not implemented in tableApi " <> (cs $ show x)
getTableHashApi :: HasNodeError err
=> NodeId -> Maybe TabType -> Cmd err Text
-> m (HashedResponse FacetTableResult)
getTableApi cId tabType mLimit mOffset mOrderBy mQuery mYear =
case mQuery of
Nothing -> get_table
Just "" -> get_table
Just q -> case tabType of
Just Docs
-> do
$(logLocM) DEBUG $ "New search with query " <> getRawQuery q
constructHashedResponse <$> searchInCorpus' cId False q mOffset mLimit mOrderBy
Just Trash
-> constructHashedResponse <$> searchInCorpus' cId True q mOffset mLimit mOrderBy
_ -> get_table
where
get_table = do
$(logLocM) DEBUG $ "getTable cId = " <> T.pack (show cId)
t <- getTable cId tabType mOffset mLimit mOrderBy mQuery mYear
pure $ constructHashedResponse t
postTableApi :: (CmdM env err m, MonadLogger m, HasNodeError err) => NodeId -> TableQuery -> m FacetTableResult
postTableApi cId tq = case tq of
TableQuery o l order ft "" -> do
$(logLocM) DEBUG $ "New search with no query"
getTable cId (Just ft) (Just o) (Just l) (Just order) Nothing Nothing
TableQuery o l order ft q -> case ft of
Docs -> do
$(logLocM) DEBUG $ "New search with query " <> getRawQuery q
searchInCorpus' cId False q (Just o) (Just l) (Just order)
Trash -> searchInCorpus' cId True q (Just o) (Just l) (Just order)
x -> panic $ "not implemented in tableApi " <> (cs $ show x)
getTableHashApi :: (CmdM env err m, HasNodeError err, MonadLogger m)
=> NodeId
-> Maybe TabType
-> m Text
getTableHashApi cId tabType = do
HashedResponse { hash = h } <- getTableApi cId tabType Nothing Nothing Nothing Nothing Nothing
pure h
searchInCorpus' :: CorpusId
searchInCorpus' :: (CmdM env err m, MonadLogger m)
=> CorpusId
-> Bool
-> [Text]
-> RawQuery
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Cmd err FacetTableResult
-> m FacetTableResult
searchInCorpus' cId t q o l order = do
docs <- searchInCorpus cId t q o l order
countAllDocs <- searchCountInCorpus cId t q
pure $ TableResult { tr_docs = docs, tr_count = countAllDocs }
case parseQuery q of
-- FIXME(adn) The error handling needs to be monomorphic over GargErr.
Left noParseErr -> do
$(logLocM) ERROR $ "Invalid input query " <> (getRawQuery q) <> " , error = " <> (T.pack noParseErr)
pure $ TableResult 0 []
Right boolQuery -> do
docs <- searchInCorpus cId t boolQuery o l order
countAllDocs <- searchCountInCorpus cId t boolQuery
pure $ TableResult { tr_docs = docs, tr_count = countAllDocs }
getTable :: HasNodeError err
......@@ -149,13 +179,15 @@ getTable :: HasNodeError err
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Maybe Text
-> Maybe RawQuery
-> Maybe Text
-> Cmd err FacetTableResult
getTable cId ft o l order query year = do
getTable cId ft o l order raw_query year = do
docs <- getTable' cId ft o l order query year
docsCount <- runCountDocuments cId (ft == Just Trash) query year
pure $ TableResult { tr_docs = docs, tr_count = docsCount }
where
query = getRawQuery <$> raw_query
getTable' :: HasNodeError err
=> NodeId
......
src/Gargantext/Core/Text/Corpus/Query.hs
View file @ 013e9d66
......@@ -6,6 +6,7 @@ module Gargantext.Core.Text.Corpus.Query (
, Limit(..)
, getQuery
, parseQuery
, mapQuery
, renderQuery
, interpretQuery
, ExternalAPIs(..)
......@@ -93,3 +94,6 @@ parseQuery (RawQuery txt) = bimap show (Query . BoolExpr.boolTreeToCNF) $
renderQuery :: Query -> RawQuery
renderQuery (Query cnf) = RawQuery . T.pack $ BoolExpr.boolExprPrinter (showsPrec 0) (BoolExpr.fromCNF cnf) ""
mapQuery :: (Term -> Term) -> Query -> Query
mapQuery f = Query . fmap f . getQuery
src/Gargantext/Core/Text/Terms.hs
View file @ 013e9d66
......@@ -56,7 +56,7 @@ import Gargantext.Core.Text.Terms.Mono.Stem (stem)
import Gargantext.Core.Text.Terms.Mono.Token.En (tokenize)
import Gargantext.Core.Text.Terms.Multi (multiterms)
import Gargantext.Core.Types
import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Database.Query.Table.Ngrams (insertNgrams)
import Gargantext.Database.Query.Table.NgramsPostag (NgramsPostag(..), insertNgramsPostag, np_form, np_lem)
import Gargantext.Database.Schema.Ngrams (Ngrams(..), NgramsType(..), ngramsTerms, text2ngrams, NgramsId)
......@@ -121,9 +121,10 @@ instance Hashable ExtractedNgrams
class ExtractNgramsT h
where
extractNgramsT :: HasText h
=> TermType Lang
=> NLPServerConfig
-> TermType Lang
-> h
-> Cmd err (HashMap ExtractedNgrams (Map NgramsType Int, TermsCount))
-> DBCmd err (HashMap ExtractedNgrams (Map NgramsType Int, TermsCount))
------------------------------------------------------------------------
enrichedTerms :: Lang -> PosTagAlgo -> POS -> Terms -> NgramsPostag
enrichedTerms l pa po (Terms ng1 ng2) =
......@@ -148,7 +149,7 @@ extracted2ngrams (SimpleNgrams ng) = ng
extracted2ngrams (EnrichedNgrams ng) = view np_form ng
---------------------------
insertExtractedNgrams :: [ ExtractedNgrams ] -> Cmd err (HashMap Text NgramsId)
insertExtractedNgrams :: [ ExtractedNgrams ] -> DBCmd err (HashMap Text NgramsId)
insertExtractedNgrams ngs = do
let (s, e) = List.partition isSimpleNgrams ngs
m1 <- insertNgrams (map unSimpleNgrams s)
......
src/Gargantext/Core/Types/Individu.hs
View file @ 013e9d66
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-|
Module : Gargantext.Core.Types.Individu
......@@ -25,11 +26,19 @@ import GHC.Generics (Generic)
import Gargantext.Database.Admin.Types.Node (NodeId, UserId)
import Gargantext.Prelude hiding (reverse)
import qualified Gargantext.Prelude.Crypto.Auth as Auth
import qualified Data.Text as T
-- FIXME UserName used twice
data User = UserDBId UserId | UserName Text | RootId NodeId | UserPublic
deriving (Eq)
renderUser :: User -> T.Text
renderUser = \case
UserDBId urId -> T.pack (show urId)
UserName txt -> txt
RootId nId -> T.pack (show nId)
UserPublic -> T.pack "public"
type Username = Text
type HashPassword = Auth.PasswordHash Auth.Argon2
......
src/Gargantext/Database/Action/Flow.hs
View file @ 013e9d66
......@@ -38,6 +38,7 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
, flowAnnuaire
, insertMasterDocs
, saveDocNgramsWith
, addDocumentsToHyperCorpus
, reIndexWith
, docNgrams
......@@ -73,7 +74,7 @@ import Data.Tuple.Extra (first, second)
import GHC.Generics (Generic)
import GHC.Num (fromInteger)
import Gargantext.API.Ngrams.Tools (getTermsWith)
import Gargantext.Core (Lang(..), PosTagAlgo(..))
import Gargantext.Core (Lang(..), PosTagAlgo(..), NLPServerConfig)
import Gargantext.Core (withDefaultLanguage)
import Gargantext.Core.Ext.IMTUser (readFile_Annuaire)
import Gargantext.Core.Flow.Types
......@@ -287,25 +288,43 @@ flow :: forall env err m a c.
flow c u cn la mfslw (mLength, docsC) jobHandle = do
(_userId, userCorpusId, listId) <- createNodes u cn c
-- TODO if public insertMasterDocs else insertUserDocs
runConduit $ zipSources (yieldMany [1..]) docsC
nlpServer <- view $ nlpServerGet (_tt_lang la)
runConduit $ zipSources (yieldMany ([1..] :: [Int])) docsC
.| CList.chunksOf 100
.| mapM_C (\docs -> void $ insertDocs' docs >>= Doc.add userCorpusId)
.| mapM_C (addDocumentsWithProgress nlpServer userCorpusId)
.| sinkNull
$(logLocM) DEBUG "Calling flowCorpusUser"
flowCorpusUser (la ^. tt_lang) u userCorpusId listId c mfslw
where
insertDocs' :: [(Integer, a)] -> m [NodeId]
insertDocs' [] = pure []
insertDocs' docs = do
$(logLocM) DEBUG $ T.pack $ "calling insertDoc, ([idx], mLength) = " <> show (fst <$> docs, mLength)
ids <- insertMasterDocs c la (snd <$> docs)
addDocumentsWithProgress :: NLPServerConfig -> CorpusId -> [(Int, a)] -> m ()
addDocumentsWithProgress nlpServer userCorpusId docsChunk = do
$(logLocM) DEBUG $ T.pack $ "calling insertDoc, ([idx], mLength) = " <> show (fst <$> docsChunk, mLength)
docs <- addDocumentsToHyperCorpus nlpServer c la userCorpusId (map snd docsChunk)
markProgress (length docs) jobHandle
pure ids
-- | Given a list of corpus documents and a 'NodeId' identifying the 'CorpusId', adds
-- the given documents to the corpus. Returns the Ids of the inserted documents.
addDocumentsToHyperCorpus :: ( DbCmd' env err m
, HasNodeError err
, FlowCorpus document
, MkCorpus corpus
)
=> NLPServerConfig
-> Maybe corpus
-> TermType Lang
-> CorpusId
-> [document]
-> m [DocId]
addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do
ids <- insertMasterDocs ncs mb_hyper la docs
void $ Doc.add corpusId ids
pure ids
------------------------------------------------------------------------
createNodes :: ( FlowCmdM env err m
createNodes :: ( DbCmd' env err m, HasNodeError err
, MkCorpus c
)
=> User
......@@ -371,15 +390,17 @@ flowCorpusUser l user userCorpusId listId ctype mfslw = do
pure userCorpusId
insertMasterDocs :: ( FlowCmdM env err m
insertMasterDocs :: ( DbCmd' env err m
, HasNodeError err
, FlowCorpus a
, MkCorpus c
)
=> Maybe c
=> NLPServerConfig
-> Maybe c
-> TermType Lang
-> [a]
-> m [DocId]
insertMasterDocs c lang hs = do
insertMasterDocs ncs c lang hs = do
(masterUserId, _, masterCorpusId) <- getOrMk_RootWithCorpus (UserName userMaster) (Left corpusMasterName) c
(ids', documentsWithId) <- insertDocs masterUserId masterCorpusId (map (toNode masterUserId Nothing) hs )
_ <- Doc.add masterCorpusId ids'
......@@ -392,7 +413,7 @@ insertMasterDocs c lang hs = do
mapNgramsDocs' :: HashMap ExtractedNgrams (Map NgramsType (Map NodeId (Int, TermsCount)))
<- mapNodeIdNgrams
<$> documentIdWithNgrams
(extractNgramsT $ withLang lang documentsWithId)
(extractNgramsT ncs $ withLang lang documentsWithId)
documentsWithId
lId <- getOrMkList masterCorpusId masterUserId
......@@ -402,7 +423,7 @@ insertMasterDocs c lang hs = do
-- _cooc <- insertDefaultNode NodeListCooc lId masterUserId
pure ids'
saveDocNgramsWith :: (FlowCmdM env err m)
saveDocNgramsWith :: (DbCmd' env err m)
=> ListId
-> HashMap ExtractedNgrams (Map NgramsType (Map NodeId (Int, TermsCount)))
-> m ()
......@@ -438,9 +459,10 @@ saveDocNgramsWith lId mapNgramsDocs' = do
------------------------------------------------------------------------
-- TODO Type NodeDocumentUnicised
insertDocs :: ( FlowCmdM env err m
insertDocs :: ( DbCmd' env err m
-- , FlowCorpus a
, FlowInsertDB a
, HasNodeError err
)
=> UserId
-> CorpusId
......@@ -486,9 +508,9 @@ mergeData rs = catMaybes . map toDocumentWithId . Map.toList
------------------------------------------------------------------------
documentIdWithNgrams :: HasNodeError err
=> (a
-> Cmd err (HashMap b (Map NgramsType Int, TermsCount)))
-> DBCmd err (HashMap b (Map NgramsType Int, TermsCount)))
-> [Indexed NodeId a]
-> Cmd err [DocumentIdWithNgrams a b]
-> DBCmd err [DocumentIdWithNgrams a b]
documentIdWithNgrams f = traverse toDocumentIdWithNgrams
where
toDocumentIdWithNgrams d = do
......@@ -519,10 +541,10 @@ mapNodeIdNgrams = HashMap.unionsWith (Map.unionWith (Map.unionWith addTuples)) .
------------------------------------------------------------------------
instance ExtractNgramsT HyperdataContact
where
extractNgramsT l hc = HashMap.mapKeys (cleanExtractedNgrams 255) <$> extract l hc
extractNgramsT _ncs l hc = HashMap.mapKeys (cleanExtractedNgrams 255) <$> extract l hc
where
extract :: TermType Lang -> HyperdataContact
-> Cmd err (HashMap ExtractedNgrams (Map NgramsType Int, TermsCount))
-> DBCmd err (HashMap ExtractedNgrams (Map NgramsType Int, TermsCount))
extract _l hc' = do
let authors = map text2ngrams
$ maybe ["Nothing"] (\a -> [a])
......@@ -533,15 +555,15 @@ instance ExtractNgramsT HyperdataContact
instance ExtractNgramsT HyperdataDocument
where
extractNgramsT :: TermType Lang
extractNgramsT :: NLPServerConfig
-> TermType Lang
-> HyperdataDocument
-> Cmd err (HashMap ExtractedNgrams (Map NgramsType Int, TermsCount))
extractNgramsT lang hd = HashMap.mapKeys (cleanExtractedNgrams 255) <$> extractNgramsT' lang hd
-> DBCmd err (HashMap ExtractedNgrams (Map NgramsType Int, TermsCount))
extractNgramsT ncs lang hd = HashMap.mapKeys (cleanExtractedNgrams 255) <$> extractNgramsT' hd
where
extractNgramsT' :: TermType Lang
-> HyperdataDocument
-> Cmd err (HashMap ExtractedNgrams (Map NgramsType Int, TermsCount))
extractNgramsT' lang' doc = do
extractNgramsT' :: HyperdataDocument
-> DBCmd err (HashMap ExtractedNgrams (Map NgramsType Int, TermsCount))
extractNgramsT' doc = do
let source = text2ngrams
$ maybe "Nothing" identity
$ _hd_source doc
......@@ -554,11 +576,9 @@ instance ExtractNgramsT HyperdataDocument
$ maybe ["Nothing"] (splitOn Authors (doc^. hd_bdd))
$ _hd_authors doc
ncs <- view (nlpServerGet $ lang' ^. tt_lang)
termsWithCounts' <- map (\(t, cnt) -> (enrichedTerms (lang' ^. tt_lang) CoreNLP NP t, cnt))
termsWithCounts' <- map (\(t, cnt) -> (enrichedTerms (lang ^. tt_lang) CoreNLP NP t, cnt))
<$> concat
<$> liftBase (extractTerms ncs lang' $ hasText doc)
<$> liftBase (extractTerms ncs lang $ hasText doc)
pure $ HashMap.fromList
$ [(SimpleNgrams source, (Map.singleton Sources 1, 1)) ]
......@@ -568,7 +588,7 @@ instance ExtractNgramsT HyperdataDocument
instance (ExtractNgramsT a, HasText a) => ExtractNgramsT (Node a)
where
extractNgramsT l (Node { _node_hyperdata = h }) = extractNgramsT l h
extractNgramsT ncs l (Node { _node_hyperdata = h }) = extractNgramsT ncs l h
instance HasText a => HasText (Node a)
where
......@@ -592,9 +612,11 @@ extractInsert :: FlowCmdM env err m
=> [Node HyperdataDocument] -> m ()
extractInsert docs = do
let documentsWithId = map (\doc -> Indexed (doc ^. node_id) doc) docs
let lang = EN
ncs <- view $ nlpServerGet lang
mapNgramsDocs' <- mapNodeIdNgrams
<$> documentIdWithNgrams
(extractNgramsT $ withLang (Multi EN) documentsWithId)
(extractNgramsT ncs $ withLang (Multi lang) documentsWithId)
documentsWithId
_ <- insertExtractedNgrams $ HashMap.keys mapNgramsDocs'
pure ()
......
src/Gargantext/Database/Action/Flow/Utils.hs
View file @ 013e9d66
......@@ -17,7 +17,7 @@ import Data.Map.Strict (Map)
import Data.HashMap.Strict (HashMap)
import Gargantext.Core.Types (TermsCount)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Database.Query.Table.ContextNodeNgrams
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Types
......@@ -35,7 +35,7 @@ data DocumentIdWithNgrams a b =
insertDocNgrams :: ListId
-> HashMap (Indexed NgramsId Ngrams) (Map NgramsType (Map DocId (Int, TermsCount)))
-> Cmd err Int
-> DBCmd err Int
insertDocNgrams lId m = do
-- printDebug "[insertDocNgrams] ns" ns
insertContextNodeNgrams ns
......
src/Gargantext/Database/Action/Search.hs
View file @ 013e9d66
......@@ -11,51 +11,90 @@ Portability : POSIX
{-# LANGUAGE Arrows #-}
{-# LANGUAGE LambdaCase #-}
module Gargantext.Database.Action.Search where
module Gargantext.Database.Action.Search (
searchInCorpus
, searchInCorpusWithContacts
, searchCountInCorpus
, searchInCorpusWithNgrams
, searchDocInDatabase
) where
import Control.Arrow (returnA)
import Control.Lens ((^.), view)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.Text (Text, unpack, intercalate)
import Data.Profunctor.Product (p4)
import Data.Text (Text, unpack)
import Data.Time (UTCTime)
import Gargantext.Core
import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
import Gargantext.Core.Types
import Gargantext.Core.Types.Query (IsTrash, Limit, Offset)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..), HyperdataContact(..))
import Gargantext.Database.Prelude (Cmd, runOpaQuery, runCountOpaQuery)
import Gargantext.Database.Prelude (runOpaQuery, runCountOpaQuery, DBCmd)
import Gargantext.Database.Query.Facet
import Gargantext.Database.Query.Filter
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Database.Query.Table.Context
import Gargantext.Database.Query.Table.ContextNodeNgrams (queryContextNodeNgramsTable)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Database.Query.Table.NodeContext
import Gargantext.Database.Query.Table.NodeContext_NodeContext
import Gargantext.Database.Schema.Context
import Gargantext.Database.Schema.ContextNodeNgrams (ContextNodeNgramsPoly(..))
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.Context
import Gargantext.Prelude
import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
import Opaleye hiding (Order)
import Data.Profunctor.Product (p4)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Gargantext.Core.Text.Corpus.Query as API
import qualified Opaleye as O hiding (Order)
import Data.BoolExpr
import qualified Data.Text as T
--
-- Interpreting a query into a Postgres' TSQuery
--
queryToTsSearch :: API.Query -> Field SqlTSQuery
queryToTsSearch q = sqlToTSQuery $ T.unpack $ (API.interpretQuery q transformAST)
where
transformAST :: BoolExpr Term -> T.Text
transformAST ast = case ast of
BAnd sub1 sub2
-> " (" <> transformAST sub1 <> " & " <> transformAST sub2 <> ") "
BOr sub1 sub2
-> " (" <> transformAST sub1 <> " | " <> transformAST sub2 <> ") "
BNot (BConst (Negative term))
-> transformAST (BConst (Positive term)) -- double negation
BNot sub
-> "!" <> transformAST sub
-- BTrue cannot happen is the query parser doesn't support parsing 'TRUE' alone.
BTrue
-> T.empty
-- BTrue cannot happen is the query parser doesn't support parsing 'FALSE' alone.
BFalse
-> T.empty
BConst (Positive (Term term))
-> T.intercalate " & " $ T.words term
-- We can handle negatives via `ANDNOT` with itself.
BConst (Negative (Term term))
-> "!" <> term
------------------------------------------------------------------------
searchDocInDatabase :: HasDBid NodeType
=> ParentId
-> Text
-> Cmd err [(NodeId, HyperdataDocument)]
-> DBCmd err [(NodeId, HyperdataDocument)]
searchDocInDatabase p t = runOpaQuery (queryDocInDatabase p t)
where
-- | Global search query where ParentId is Master Node Corpus Id
queryDocInDatabase :: ParentId -> Text -> O.Select (Column SqlInt4, Column SqlJsonb)
queryDocInDatabase _p q = proc () -> do
row <- queryNodeSearchTable -< ()
restrict -< (_ns_search row) @@ (sqlTSQuery (unpack q))
restrict -< (_ns_search row) @@ (sqlToTSQuery (unpack q))
restrict -< (_ns_typename row) .== (sqlInt4 $ toDBid NodeDocument)
returnA -< (_ns_id row, _ns_hyperdata row)
......@@ -71,7 +110,7 @@ searchInCorpusWithNgrams :: HasDBid NodeType
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Cmd err [FacetDoc]
-> DBCmd err [FacetDoc]
searchInCorpusWithNgrams _cId _lId _t _ngt _q _o _l _order = undefined
-- | Compute TF-IDF for all 'ngramIds' in given 'CorpusId'. In this
......@@ -79,11 +118,11 @@ searchInCorpusWithNgrams _cId _lId _t _ngt _q _o _l _order = undefined
-- ratio of "number of times our terms appear in given document" and
-- "number of all terms in document" and return a sorted list of
-- document ids
tfidfAll :: (HasDBid NodeType, HasNodeError err) => CorpusId -> [Int] -> Cmd err [Int]
tfidfAll cId ngramIds = do
_tfidfAll :: (HasDBid NodeType, HasNodeError err) => CorpusId -> [Int] -> DBCmd err [Int]
_tfidfAll cId ngramIds = do
let ngramIdsSet = Set.fromList ngramIds
lId <- defaultList cId
docsWithNgrams <- runOpaQuery (queryListWithNgrams lId ngramIds) :: Cmd err [(Int, Int, Int)]
docsWithNgrams <- runOpaQuery (_queryListWithNgrams lId ngramIds) :: DBCmd err [(Int, Int, Int)]
-- NOTE The query returned docs with ANY ngramIds. We need to further
-- restrict to ALL ngramIds.
let docsNgramsM =
......@@ -111,8 +150,8 @@ tfidfAll cId ngramIds = do
-- | Query for searching the 'context_node_ngrams' table so that we
-- find docs with ANY given 'ngramIds'.
queryListWithNgrams :: ListId -> [Int] -> Select (Column SqlInt4, Column SqlInt4, Column SqlInt4)
queryListWithNgrams lId ngramIds = proc () -> do
_queryListWithNgrams :: ListId -> [Int] -> Select (Column SqlInt4, Column SqlInt4, Column SqlInt4)
_queryListWithNgrams lId ngramIds = proc () -> do
row <- queryContextNodeNgramsTable -< ()
restrict -< (_cnng_node_id row) .== (pgNodeId lId)
restrict -< in_ (sqlInt4 <$> ngramIds) (_cnng_ngrams_id row)
......@@ -133,31 +172,29 @@ queryListWithNgrams lId ngramIds = proc () -> do
searchInCorpus :: HasDBid NodeType
=> CorpusId
-> IsTrash
-> [Text]
-> API.Query
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Cmd err [FacetDoc]
-> DBCmd err [FacetDoc]
searchInCorpus cId t q o l order = runOpaQuery
$ filterWith o l order
$ queryInCorpus cId t
$ intercalate " | "
$ map stemIt q
$ API.mapQuery (Term . stemIt . getTerm) q
searchCountInCorpus :: HasDBid NodeType
=> CorpusId
-> IsTrash
-> [Text]
-> Cmd err Int
-> API.Query
-> DBCmd err Int
searchCountInCorpus cId t q = runCountOpaQuery
$ queryInCorpus cId t
$ intercalate " | "
$ map stemIt q
$ API.mapQuery (Term . stemIt . getTerm) q
queryInCorpus :: HasDBid NodeType
=> CorpusId
-> IsTrash
-> Text
-> API.Query
-> O.Select FacetDocRead
queryInCorpus cId t q = proc () -> do
c <- queryContextSearchTable -< ()
......@@ -169,7 +206,7 @@ queryInCorpus cId t q = proc () -> do
else matchMaybe (view nc_category <$> nc) $ \case
Nothing -> toFields False
Just c' -> c' .>= sqlInt4 1
restrict -< (c ^. cs_search) @@ sqlTSQuery (unpack q)
restrict -< (c ^. cs_search) @@ queryToTsSearch q
restrict -< (c ^. cs_typename ) .== sqlInt4 (toDBid NodeDocument)
returnA -< FacetDoc { facetDoc_id = c^.cs_id
, facetDoc_created = c^.cs_date
......@@ -185,23 +222,22 @@ searchInCorpusWithContacts
:: HasDBid NodeType
=> CorpusId
-> AnnuaireId
-> [Text]
-> API.Query
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Cmd err [FacetPaired Int UTCTime HyperdataContact Int]
-> DBCmd err [FacetPaired Int UTCTime HyperdataContact Int]
searchInCorpusWithContacts cId aId q o l _order =
runOpaQuery $ limit' l
$ offset' o
$ orderBy (desc _fp_score)
$ selectGroup cId aId
$ intercalate " | "
$ map stemIt q
$ API.mapQuery (Term . stemIt . getTerm) q
selectGroup :: HasDBid NodeType
=> CorpusId
-> AnnuaireId
-> Text
-> API.Query
-> Select FacetPairedRead
selectGroup cId aId q = proc () -> do
(a, b, c, d) <- aggregate (p4 (groupBy, groupBy, groupBy, O.sum))
......@@ -213,7 +249,7 @@ selectContactViaDoc
:: HasDBid NodeType
=> CorpusId
-> AnnuaireId
-> Text
-> API.Query
-> SelectArr ()
( Field SqlInt4
, Field SqlTimestamptz
......@@ -225,7 +261,7 @@ selectContactViaDoc cId aId query = proc () -> do
(contact, annuaire, _, corpus, doc) <- queryContactViaDoc -< ()
restrict -< matchMaybe (view cs_search <$> doc) $ \case
Nothing -> toFields False
Just s -> s @@ sqlTSQuery (unpack query)
Just s -> s @@ queryToTsSearch query
restrict -< (view cs_typename <$> doc) .=== justFields (sqlInt4 (toDBid NodeDocument))
restrict -< (view nc_node_id <$> corpus) .=== justFields (pgNodeId cId)
restrict -< (view nc_node_id <$> annuaire) .=== justFields (pgNodeId aId)
......
src/Gargantext/Database/Action/User.hs
View file @ 013e9d66
......@@ -28,7 +28,7 @@ getUserLightWithId :: HasNodeError err => UserId -> DBCmd err UserLight
getUserLightWithId i = do
candidates <- head <$> getUsersWithId (UserDBId i)
case candidates of
Nothing -> nodeError NoUserFound
Nothing -> nodeError (NoUserFound (UserDBId i))
Just u -> pure u
getUserLightDB :: HasNodeError err => User -> DBCmd err UserLight
......@@ -44,7 +44,7 @@ getUserId :: HasNodeError err
getUserId u = do
maybeUser <- getUserId' u
case maybeUser of
Nothing -> nodeError NoUserFound
Nothing -> nodeError (NoUserFound u)
Just u' -> pure u'
getUserId' :: HasNodeError err
......
src/Gargantext/Database/Admin/Trigger/ContextNodeNgrams.hs
View file @ 013e9d66
......@@ -20,11 +20,12 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Core
-- import Gargantext.Core.Types.Main (ListType(CandidateTerm))
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd, execPGSQuery)
-- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (execPGSQuery, DBCmd)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
triggerCountInsert :: HasDBid NodeType => Cmd err Int64
triggerCountInsert :: HasDBid NodeType => DBCmd err Int64
triggerCountInsert = execPGSQuery query (toDBid NodeDocument, toDBid NodeList)
where
query :: DPS.Query
......@@ -60,7 +61,7 @@ triggerCountInsert = execPGSQuery query (toDBid NodeDocument, toDBid NodeList)
EXECUTE PROCEDURE set_ngrams_global_count();
|]
triggerCountInsert2 :: HasDBid NodeType => Cmd err Int64
triggerCountInsert2 :: HasDBid NodeType => DBCmd err Int64
triggerCountInsert2 = execPGSQuery query ( toDBid NodeCorpus
, toDBid NodeDocument
, toDBid NodeList
......
src/Gargantext/Database/Admin/Trigger/Contexts.hs
View file @ 013e9d66
......@@ -20,12 +20,13 @@ import Data.Text (Text)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Core (HasDBid(..))
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd, execPGSQuery)
-- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (execPGSQuery, DBCmd)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
triggerSearchUpdate :: HasDBid NodeType => Cmd err Int64
triggerSearchUpdate :: HasDBid NodeType => DBCmd err Int64
triggerSearchUpdate = execPGSQuery query ( toDBid NodeDocument
, toDBid NodeDocument
, toDBid NodeContact
......@@ -37,10 +38,10 @@ triggerSearchUpdate = execPGSQuery query ( toDBid NodeDocument
RETURNS trigger AS $$
begin
IF new.typename = ? AND new.hyperdata @> '{"language_iso2":"EN"}' THEN
new.search := to_tsvector( 'english' , (new.hyperdata ->> 'title') || ' ' || (new.hyperdata ->> 'abstract'));
new.search := to_tsvector( 'english' , new.hyperdata::jsonb );
ELSIF new.typename = ? AND new.hyperdata @> '{"language_iso2":"FR"}' THEN
new.search := to_tsvector( 'french' , (new.hyperdata ->> 'title') || ' ' || (new.hyperdata ->> 'abstract'));
new.search := to_tsvector( 'english' , new.hyperdata::jsonb );
ELSIF new.typename = ? THEN
new.search := to_tsvector( 'french' , (new.hyperdata ->> 'prenom')
......@@ -48,7 +49,7 @@ triggerSearchUpdate = execPGSQuery query ( toDBid NodeDocument
|| ' ' || (new.hyperdata ->> 'fonction')
);
ELSE
new.search := to_tsvector( 'english' , (new.hyperdata ->> 'title') || ' ' || (new.hyperdata ->> 'abstract'));
new.search := to_tsvector( 'english' , new.hyperdata::jsonb );
END IF;
return new;
end
......@@ -69,7 +70,7 @@ triggerSearchUpdate = execPGSQuery query ( toDBid NodeDocument
type Secret = Text
triggerUpdateHash :: HasDBid NodeType => Secret -> Cmd err Int64
triggerUpdateHash :: HasDBid NodeType => Secret -> DBCmd err Int64
triggerUpdateHash secret = execPGSQuery query ( toDBid NodeDocument
, toDBid NodeContact
, secret
......
src/Gargantext/Database/Admin/Trigger/Init.hs
View file @ 013e9d66
......@@ -20,16 +20,17 @@ import Data.Text (Text)
import Gargantext.Database.Admin.Trigger.ContextNodeNgrams (triggerCountInsert, triggerCountInsert2)
import Gargantext.Database.Admin.Trigger.Contexts (triggerSearchUpdate, triggerUpdateHash)
import Gargantext.Database.Admin.Trigger.NodesContexts ({-triggerDeleteCount,-} triggerInsertCount, triggerUpdateAdd, triggerUpdateDel, MasterListId) -- , triggerCoocInsert)
import Gargantext.Database.Prelude (Cmd)
-- , triggerCoocInsert)
import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Prelude
------------------------------------------------------------------------
initFirstTriggers :: Text -> Cmd err [Int64]
initFirstTriggers :: Text -> DBCmd err [Int64]
initFirstTriggers secret = do
t0 <- triggerUpdateHash secret
pure [t0]
initLastTriggers :: MasterListId -> Cmd err [Int64]
initLastTriggers :: MasterListId -> DBCmd err [Int64]
initLastTriggers lId = do
t0 <- triggerSearchUpdate
t1 <- triggerCountInsert
......
src/Gargantext/Database/Admin/Trigger/NodesContexts.hs
View file @ 013e9d66
......@@ -20,13 +20,14 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Core
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd, execPGSQuery)
-- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (execPGSQuery, DBCmd)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
type MasterListId = ListId
triggerInsertCount :: MasterListId -> Cmd err Int64
triggerInsertCount :: MasterListId -> DBCmd err Int64
triggerInsertCount lId = execPGSQuery query (lId, nodeTypeId NodeList)
where
query :: DPS.Query
......@@ -62,7 +63,7 @@ triggerInsertCount lId = execPGSQuery query (lId, nodeTypeId NodeList)
|]
triggerUpdateAdd :: MasterListId -> Cmd err Int64
triggerUpdateAdd :: MasterListId -> DBCmd err Int64
triggerUpdateAdd lId = execPGSQuery query (lId, nodeTypeId NodeList)
where
query :: DPS.Query
......@@ -102,7 +103,7 @@ triggerUpdateAdd lId = execPGSQuery query (lId, nodeTypeId NodeList)
|]
triggerUpdateDel :: MasterListId -> Cmd err Int64
triggerUpdateDel :: MasterListId -> DBCmd err Int64
triggerUpdateDel lId = execPGSQuery query (lId, nodeTypeId NodeList)
where
query :: DPS.Query
......@@ -144,7 +145,7 @@ triggerUpdateDel lId = execPGSQuery query (lId, nodeTypeId NodeList)
triggerDeleteCount :: MasterListId -> Cmd err Int64
triggerDeleteCount :: MasterListId -> DBCmd err Int64
triggerDeleteCount lId = execPGSQuery query (lId, toDBid NodeList)
where
query :: DPS.Query
......
src/Gargantext/Database/Prelude.hs
View file @ 013e9d66
......@@ -138,7 +138,7 @@ runOpaQuery :: Default FromFields fields haskells
-> DBCmd err [haskells]
runOpaQuery q = mkCmd $ \c -> runSelect c q
runCountOpaQuery :: Select a -> Cmd err Int
runCountOpaQuery :: Select a -> DBCmd err Int
runCountOpaQuery q = do
counts <- mkCmd $ \c -> runSelect c $ countRows q
-- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
......@@ -151,7 +151,7 @@ formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
runPGSQuery :: ( CmdM env err m
runPGSQuery :: ( DbCmd' env err m
, PGS.FromRow r, PGS.ToRow q
)
=> PGS.Query -> q -> m [r]
......@@ -189,7 +189,7 @@ runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
hPutStrLn stderr (fromQuery q)
throw (SomeException e)
execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> DBCmd err Int64
execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
------------------------------------------------------------------------
......
src/Gargantext/Database/Query/Table/ContextNodeNgrams.hs
View file @ 013e9d66
......@@ -23,7 +23,7 @@ module Gargantext.Database.Query.Table.ContextNodeNgrams
where
import Gargantext.Database.Admin.Types.Node (pgNodeId, pgContextId)
import Gargantext.Database.Prelude (Cmd, mkCmd)
import Gargantext.Database.Prelude (mkCmd, DBCmd)
import Gargantext.Database.Schema.Ngrams (pgNgramsTypeId)
import Gargantext.Database.Schema.ContextNodeNgrams
import Gargantext.Database.Schema.Prelude
......@@ -34,7 +34,7 @@ queryContextNodeNgramsTable :: Query ContextNodeNgramsRead
queryContextNodeNgramsTable = selectTable contextNodeNgramsTable
-- | Insert utils
insertContextNodeNgrams :: [ContextNodeNgrams] -> Cmd err Int
insertContextNodeNgrams :: [ContextNodeNgrams] -> DBCmd err Int
insertContextNodeNgrams = insertContextNodeNgramsW
. map (\(ContextNodeNgrams c n ng nt w dc) ->
ContextNodeNgrams (pgContextId c)
......@@ -45,7 +45,7 @@ insertContextNodeNgrams = insertContextNodeNgramsW
(sqlInt4 dc)
)
insertContextNodeNgramsW :: [ContextNodeNgramsWrite] -> Cmd err Int
insertContextNodeNgramsW :: [ContextNodeNgramsWrite] -> DBCmd err Int
insertContextNodeNgramsW nnnw =
mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
where
......
src/Gargantext/Database/Query/Table/ContextNodeNgrams2.hs
View file @ 013e9d66
......@@ -25,7 +25,7 @@ module Gargantext.Database.Query.Table.ContextNodeNgrams2
import Gargantext.Database.Schema.Prelude
import Gargantext.Database.Schema.ContextNodeNgrams2
import Gargantext.Database.Admin.Types.Node (pgNodeId)
import Gargantext.Database.Prelude (Cmd, mkCmd)
import Gargantext.Database.Prelude (mkCmd, DBCmd)
import Prelude
......@@ -33,7 +33,7 @@ queryContextNodeNgrams2Table :: Query ContextNodeNgrams2Read
queryContextNodeNgrams2Table = selectTable contextNodeNgrams2Table
-- | Insert utils
insertContextNodeNgrams2 :: [ContextNodeNgrams2] -> Cmd err Int
insertContextNodeNgrams2 :: [ContextNodeNgrams2] -> DBCmd err Int
insertContextNodeNgrams2 = insertContextNodeNgrams2W
. map (\(ContextNodeNgrams2 n1 n2 w) ->
ContextNodeNgrams2 (pgNodeId n1)
......@@ -41,7 +41,7 @@ insertContextNodeNgrams2 = insertContextNodeNgrams2W
(sqlDouble w)
)
insertContextNodeNgrams2W :: [ContextNodeNgrams2Write] -> Cmd err Int
insertContextNodeNgrams2W :: [ContextNodeNgrams2Write] -> DBCmd err Int
insertContextNodeNgrams2W nnnw =
mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
where
......
src/Gargantext/Database/Query/Table/Ngrams.hs
View file @ 013e9d66
......@@ -28,7 +28,7 @@ import Data.HashMap.Strict (HashMap)
import Data.Map.Strict (Map)
import Data.Text (Text)
import Gargantext.Core.Types
import Gargantext.Database.Prelude (runOpaQuery, Cmd, formatPGSQuery, runPGSQuery)
import Gargantext.Database.Prelude (runOpaQuery, Cmd, formatPGSQuery, runPGSQuery, DBCmd)
import Gargantext.Database.Query.Join (leftJoin3)
import Gargantext.Database.Query.Table.ContextNodeNgrams2
import Gargantext.Database.Query.Table.NodeNgrams (queryNodeNgramsTable)
......@@ -73,14 +73,14 @@ _dbGetNgramsDb = runOpaQuery queryNgramsTable
-- TODO-ACCESS: access must not be checked here but when insertNgrams is called.
insertNgrams :: [Ngrams] -> Cmd err (HashMap Text NgramsId)
insertNgrams :: [Ngrams] -> DBCmd err (HashMap Text NgramsId)
insertNgrams ns =
if List.null ns
then pure HashMap.empty
else HashMap.fromList <$> map (\(Indexed i t) -> (t, i)) <$> (insertNgrams' ns)
-- TODO-ACCESS: access must not be checked here but when insertNgrams' is called.
insertNgrams' :: [Ngrams] -> Cmd err [Indexed Int Text]
insertNgrams' :: [Ngrams] -> DBCmd err [Indexed Int Text]
insertNgrams' ns = runPGSQuery queryInsertNgrams (PGS.Only $ Values fields ns)
where
fields = map (\t -> QualifiedIdentifier Nothing t) ["text", "int4"]
......
src/Gargantext/Database/Query/Table/NgramsPostag.hs
View file @ 013e9d66
......@@ -24,7 +24,7 @@ import Data.Hashable (Hashable)
import Data.Text (Text)
import Gargantext.Core
import Gargantext.Core.Types
import Gargantext.Database.Prelude (Cmd, runPGSQuery, runPGSQuery_)
import Gargantext.Database.Prelude (Cmd, runPGSQuery, runPGSQuery_, DBCmd)
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.Prelude
import Gargantext.Database.Query.Table.Ngrams
......@@ -65,7 +65,7 @@ toInsert (NgramsPostag l a p form lem) =
, view ngramsSize lem
)
insertNgramsPostag :: [NgramsPostag] -> Cmd err (HashMap Text NgramsId)
insertNgramsPostag :: [NgramsPostag] -> DBCmd err (HashMap Text NgramsId)
insertNgramsPostag xs =
if List.null xs
then pure HashMap.empty
......@@ -86,7 +86,7 @@ insertNgramsPostag xs =
pure $ HashMap.union ns' nps'
insertNgramsPostag' :: [NgramsPostagInsert] -> Cmd err [Indexed Text Int]
insertNgramsPostag' :: [NgramsPostagInsert] -> DBCmd err [Indexed Text Int]
insertNgramsPostag' ns = runPGSQuery queryInsertNgramsPostag (PGS.Only $ Values fields ns)
where
......
src/Gargantext/Database/Query/Table/Node.hs
View file @ 013e9d66
......@@ -171,7 +171,7 @@ getClosestParentIdByType' nId nType = do
getChildrenByType :: HasDBid NodeType
=> NodeId
-> NodeType
-> Cmd err [NodeId]
-> DBCmd err [NodeId]
getChildrenByType nId nType = do
result <- runPGSQuery query (PGS.Only nId)
children_lst <- mapM (\(id, _) -> getChildrenByType id nType) result
......@@ -260,7 +260,7 @@ getNode nId = do
Just r -> pure r
getNodeWith :: (HasNodeError err, JSONB a)
=> NodeId -> proxy a -> Cmd err (Node a)
=> NodeId -> proxy a -> DBCmd err (Node a)
getNodeWith nId _ = do
maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
case maybeNode of
......@@ -275,7 +275,7 @@ insertDefaultNode :: HasDBid NodeType
insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
insertDefaultNodeIfNotExists :: HasDBid NodeType
=> NodeType -> ParentId -> UserId -> Cmd err [NodeId]
=> NodeType -> ParentId -> UserId -> DBCmd err [NodeId]
insertDefaultNodeIfNotExists nt p u = do
children <- getChildrenByType p nt
case children of
......@@ -399,19 +399,19 @@ instance MkCorpus HyperdataAnnuaire
getOrMkList :: (HasNodeError err, HasDBid NodeType)
=> ParentId
-> UserId
-> Cmd err ListId
-> DBCmd err ListId
getOrMkList pId uId =
maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
where
mkList' pId' uId' = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId' uId'
-- | TODO remove defaultList
defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err ListId
defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> DBCmd err ListId
defaultList cId =
maybe (nodeError (NoListFound cId)) (pure . view node_id) . headMay =<< getListsWithParentId cId
defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err (Maybe NodeId)
defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId cId
getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
getListsWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataList]
getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
src/Gargantext/Database/Query/Table/Node/Document/Add.hs
View file @ 013e9d66
......@@ -28,12 +28,12 @@ import Database.PostgreSQL.Simple.ToRow (ToRow(..))
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import GHC.Generics (Generic)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, runPGSQuery, formatPGSQuery)
import Gargantext.Database.Prelude (Cmd, runPGSQuery, formatPGSQuery, DBCmd)
import Gargantext.Prelude
---------------------------------------------------------------------------
add :: CorpusId -> [ContextId] -> Cmd err [Only Int]
add :: CorpusId -> [ContextId] -> DBCmd err [Only Int]
add pId ns = runPGSQuery queryAdd (Only $ Values fields inputData)
where
fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
......
src/Gargantext/Database/Query/Table/Node/Document/Insert.hs
View file @ 013e9d66
......@@ -73,7 +73,7 @@ import GHC.Generics (Generic)
import Gargantext.Core (HasDBid(toDBid))
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, runPGSQuery{-, formatPGSQuery-})
import Gargantext.Database.Prelude (runPGSQuery, DBCmd{-, formatPGSQuery-})
import Gargantext.Database.Schema.Node (NodePoly(..))
import qualified Gargantext.Defaults as Defaults
import Gargantext.Prelude
......@@ -93,7 +93,7 @@ import Database.PostgreSQL.Simple (formatQuery)
-- ParentId : folder ID which is parent of the inserted documents
-- Administrator of the database has to create a uniq index as following SQL command:
-- `create unique index on contexts table (typename, parent_id, (hyperdata ->> 'uniqId'));`
insertDb :: (InsertDb a, HasDBid NodeType) => UserId -> Maybe ParentId -> [a] -> Cmd err [ReturnId]
insertDb :: (InsertDb a, HasDBid NodeType) => UserId -> Maybe ParentId -> [a] -> DBCmd err [ReturnId]
insertDb u p = runPGSQuery queryInsert . Only . Values fields . map (insertDb' u p)
where
fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
......
src/Gargantext/Database/Query/Table/Node/Error.hs
View file @ 013e9d66
......@@ -14,17 +14,19 @@ import Control.Lens (Prism', (#), (^?))
import Control.Monad.Except (MonadError(..))
import Data.Aeson
import Data.Text (Text, pack)
import qualified Data.Text as T
import Prelude hiding (null, id, map, sum)
import Gargantext.Database.Admin.Types.Node (ListId, NodeId(..))
import Gargantext.Prelude hiding (sum, head)
import Gargantext.Core.Types.Individu
------------------------------------------------------------------------
data NodeError = NoListFound { listId :: ListId }
| NoRootFound
| NoCorpusFound
| NoUserFound
| NoUserFound User
| MkNode
| UserNoParent
| HasParent
......@@ -35,13 +37,14 @@ data NodeError = NoListFound { listId :: ListId }
| DoesNotExist NodeId
| NeedsConfiguration
| NodeError Text
| QueryNoParse Text
instance Show NodeError
where
show (NoListFound {}) = "No list found"
show NoRootFound = "No Root found"
show NoCorpusFound = "No Corpus found"
show NoUserFound = "No user found"
show (NoUserFound ur) = "User(" <> T.unpack (renderUser ur) <> ") not found"
show MkNode = "Cannot make node"
show NegativeId = "Node with negative Id"
......@@ -53,6 +56,7 @@ instance Show NodeError
show (DoesNotExist n) = "Node does not exist (" <> show n <> ")"
show NeedsConfiguration = "Needs configuration"
show (NodeError e) = "NodeError: " <> cs e
show (QueryNoParse err) = "QueryNoParse: " <> T.unpack err
instance ToJSON NodeError where
toJSON (NoListFound { listId = NodeId listId }) =
......
src/Gargantext/Database/Query/Table/NodeNgrams.hs
View file @ 013e9d66
......@@ -67,7 +67,7 @@ listInsertDb :: Show a => ListId
-> (ListId -> a -> [NodeNgramsW])
-> a
-- -> Cmd err [Returning]
-> Cmd err (Map NgramsType (Map Text Int))
-> DBCmd err (Map NgramsType (Map Text Int))
listInsertDb l f ngs = Map.map Map.fromList
<$> Map.fromListWith (<>)
<$> List.map (\(Returning t tx id) -> (fromJust t, [(tx, id)]))
......@@ -75,7 +75,7 @@ listInsertDb l f ngs = Map.map Map.fromList
<$> insertNodeNgrams (f l ngs)
-- TODO optimize with size of ngrams
insertNodeNgrams :: [NodeNgramsW] -> Cmd err [Returning]
insertNodeNgrams :: [NodeNgramsW] -> DBCmd err [Returning]
insertNodeNgrams nns = runPGSQuery query (PGS.Only $ Values fields nns')
where
fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"
......
stack.yaml
View file @ 013e9d66
......@@ -44,8 +44,8 @@ extra-deps:
- git: https://github.com/alpmestan/ekg-json.git
commit: fd7e5d7325939103cd87d0dc592faf644160341c
# Databases libs
- git: https://github.com/garganscript/haskell-opaleye.git
commit: a5693a2010e6d13f51cdc576fa1dc9985e79ee0e
- git: https://github.com/adinapoli/haskell-opaleye.git
commit: e9a29582ac66198dd2c2fdc3f8c8a4b1e6fbe004
- git: https://github.com/robstewart57/rdf4h.git
commit: 4fd2edf30c141600ffad6d730cc4c1c08a6dbce4
# External Data API connectors
......@@ -98,12 +98,14 @@ extra-deps:
commit: b9fca8beee0f23c17a6b2001ec834d071709e6e7
subdirs:
- packages/base
# Temporary fork of boolexpr
- git: https://github.com/adinapoli/boolexpr.git
commit: 91928b5d7f9342e9865dde0d94862792d2b88779
# Others dependencies (using stack resolver)
- HSvm-0.1.1.3.22
- KMP-0.2.0.0@sha256:6dfbac03ef00ebd9347234732cb86a40f62ab5a80c0cc6bedb8eb51766f7df28,2562
- MissingH-1.4.3.0@sha256:32f9892ec98cd21df4f4d3ed8d95a3831ae74287ea0641d6f09b2dc6ef061d39,4859
- Unique-0.4.7.8@sha256:9661f45aa31dde119a2114566166ea38b011a45653337045ee4ced75636533c0,2067
- boolexpr-0.2
- constraints-extras-0.3.1.0@sha256:12016ebb91ad5ed2c82bf7e48c6bd6947d164d33c9dca5ac3965de1bb6c780c0,1777
- context-0.2.0.0@sha256:6b643adb4a64fe521873d08df0497f71f88e18b9ecff4b68b4eef938e446cfc9,1886
- dependent-sum-0.7.1.0@sha256:0e419237f5b86da3659772afff9cab355c0f8d5b3fdb15a5b30e673d8dc83941,2147
......
test-data/docker-compose.yml 0 → 100644
View file @ 013e9d66
version: '3'
services:
corenlp:
image: 'cgenie/corenlp-garg:4.5.4'
ports:
- 9000:9000
test-data/test_config.ini
View file @ 013e9d66
......@@ -16,3 +16,8 @@ MAX_DOCS_SCRAPERS = 10000
JS_JOB_TIMEOUT = 1800
JS_ID_TIMEOUT = 1800
PUBMED_API_KEY = "no_key"
[nlp]
EN = corenlp://localhost:9000
FR = spacy://localhost:8001
All = corenlp://localhost:9000
test/Core/Text/Corpus/Query.hs
View file @ 013e9d66
......@@ -42,6 +42,10 @@ tests = withResource pubmedSettings (const (pure ())) $ \getPubmedKey ->
, testProperty "Parses 'A AND B -C' (left associative)" testParse05
, testProperty "Parses 'A AND (B -C)' (right associative)" testParse05_01
, testProperty "Parses (A OR B OR NOT C) AND (D OR E OR F) -(G OR H OR I)" testParse06
, testProperty "It supports '\"Haskell\" AND \"Idris\"'" testParse07
, testProperty "It supports 'Haskell AND Idris'" testParse07_01
, testProperty "It supports 'Raphael'" testParse07_02
, testProperty "It supports 'Niki', 'Ajeje' and 'Orf'" testParse07_03
, testCase "Parses words into a single constant" testWordsIntoConst
, testGroup "Arxiv expression converter" [
testCase "It supports 'A AND B'" testArxiv01_01
......@@ -124,6 +128,27 @@ testParse06 =
)
)
testParse07 :: Property
testParse07 =
translatesInto "\"Haskell\" AND \"Agda\""
((BConst (Positive "Haskell") `BAnd` (BConst (Positive "Agda"))))
testParse07_01 :: Property
testParse07_01 =
translatesInto "Haskell AND Agda"
((BConst (Positive "Haskell") `BAnd` (BConst (Positive "Agda"))))
testParse07_02 :: Property
testParse07_02 =
translatesInto "Raphael"
((BConst (Positive "Raphael")))
testParse07_03 :: Property
testParse07_03 =
translatesInto "Niki" ((BConst (Positive "Niki"))) .&&.
translatesInto "Ajeje" ((BConst (Positive "Ajeje"))) .&&.
translatesInto "Orf" ((BConst (Positive "Orf")))
testWordsIntoConst :: Assertion
testWordsIntoConst =
let (expected :: BoolExpr Term) =
......
test/Database/Operations.hs
View file @ 013e9d66
......@@ -3,33 +3,32 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE TypeFamilies #-}
module Database.Operations (
tests
) where
import Control.Exception hiding (assert)
import Control.Lens hiding (elements)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.IORef
import Data.Pool hiding (withResource)
import Data.String
import Database.PostgreSQL.Simple
import Gargantext.API.Node.Corpus.Update
import Gargantext.Core
import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.User
import Gargantext.Database.Action.User.New
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Admin.Types.Hyperdata.Corpus
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.Node (mk, getCorporaWithParentId, getOrMkList)
import Gargantext.Database.Query.Tree.Root (getRootId)
import Gargantext.Database.Schema.Node (NodePoly(..))
import Gargantext.Prelude
import Gargantext.Prelude.Config
import Prelude
import Shelly hiding (FilePath, run)
import Test.QuickCheck.Monadic
import Test.Hspec
import Test.Tasty.HUnit hiding (assert)
import Test.Tasty.QuickCheck
import qualified Data.Pool as Pool
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
......@@ -38,7 +37,16 @@ import qualified Database.PostgreSQL.Simple.Options as Client
import qualified Database.Postgres.Temp as Tmp
import qualified Shelly as SH
import Database.Operations.Types
import Database.Operations.DocumentSearch
import Paths_gargantext
import Test.Hspec
import Test.QuickCheck.Monadic
import Test.Tasty.HUnit hiding (assert)
import Test.Tasty.QuickCheck
import Gargantext.Database.Admin.Trigger.Init
import Gargantext.Database.Action.Flow
import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
-- | Keeps a log of usernames we have already generated, so that our
-- roundtrip tests won't fail.
......@@ -57,45 +65,6 @@ dbUser = "gargantua"
dbPassword = "gargantua_test"
dbName = "gargandb_test"
newtype Counter = Counter { _Counter :: IORef Int }
deriving Eq
instance Show Counter where
show (Counter _) = "Counter"
emptyCounter :: IO Counter
emptyCounter = Counter <$> newIORef 0
nextCounter :: Counter -> IO Int
nextCounter (Counter ref) = atomicModifyIORef' ref (\old -> (succ old, old))
data TestEnv = TestEnv {
test_db :: !DBHandle
, test_config :: !GargConfig
, test_usernameGen :: !Counter
}
newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
deriving ( Functor, Applicative, Monad
, MonadReader TestEnv, MonadError IOException
, MonadBase IO
, MonadBaseControl IO
)
data DBHandle = DBHandle {
_DBHandle :: Pool PG.Connection
, _DBTmp :: Tmp.DB
}
instance HasNodeError IOException where
_NodeError = prism' (userError . show) (const Nothing)
instance HasConnectionPool TestEnv where
connPool = to (_DBHandle . test_db)
instance HasConfig TestEnv where
hasConfig = to test_config
fakeIniPath :: IO FilePath
fakeIniPath = getDataFileName "test-data/test_config.ini"
......@@ -144,11 +113,22 @@ withTestDB = bracket setup teardown
tests :: Spec
tests = sequential $ aroundAll withTestDB $ describe "Database" $ do
describe "Read/Writes" $
describe "Prelude" $ do
it "setup DB triggers" setupEnvironment
describe "Read/Writes" $ do
describe "User creation" $ do
it "Simple write/read" writeRead01
it "Simple duplicate" mkUserDup
it "Read/Write roundtrip" prop_userCreationRoundtrip
describe "Corpus creation" $ do
it "Simple write/read" corpusReadWrite01
it "Can add language to Corpus" corpusAddLanguage
it "Can add documents to a Corpus" corpusAddDocuments
describe "Corpus search" $ do
it "Can stem query terms" stemmingTest
it "Can perform a simple search inside documents" corpusSearch01
it "Can perform search by author in documents" corpusSearch02
it "Can perform more complex searches using the boolean API" corpusSearch03
data ExpectedActual a =
Expected a
......@@ -160,6 +140,16 @@ instance Eq a => Eq (ExpectedActual a) where
(Actual a) == (Expected b) = a == b
_ == _ = False
setupEnvironment :: TestEnv -> IO ()
setupEnvironment env = flip runReaderT env $ runTestMonad $ do
void $ initFirstTriggers "secret_key"
void $ new_user $ mkNewUser (userMaster <> "@cnrs.com") (GargPassword "secret_key")
(masterUserId, _masterRootId, masterCorpusId)
<- getOrMk_RootWithCorpus (UserName userMaster)
(Left corpusMasterName)
(Nothing :: Maybe HyperdataCorpus)
masterListId <- getOrMkList masterCorpusId masterUserId
void $ initLastTriggers masterListId
writeRead01 :: TestEnv -> Assertion
writeRead01 env = do
......@@ -170,14 +160,14 @@ writeRead01 env = do
uid1 <- new_user nur1
uid2 <- new_user nur2
liftBase $ uid1 `shouldBe` 1
liftBase $ uid2 `shouldBe` 2
liftBase $ uid1 `shouldBe` 2
liftBase $ uid2 `shouldBe` 3
-- Getting the users by username returns the expected IDs
uid1' <- getUserId (UserName "alfredo")
uid2' <- getUserId (UserName "paul")
liftBase $ uid1' `shouldBe` 1
liftBase $ uid2' `shouldBe` 2
liftBase $ uid1' `shouldBe` 2
liftBase $ uid2' `shouldBe` 3
mkUserDup :: TestEnv -> Assertion
mkUserDup env = do
......@@ -206,3 +196,26 @@ prop_userCreationRoundtrip env = monadicIO $ do
uid <- runEnv env (new_user nur)
ur' <- runEnv env (getUserId (UserName $ _nu_username nur))
run (Expected uid `shouldBe` Actual ur')
-- | We test that we can create and later read-back a 'Corpus'.
corpusReadWrite01 :: TestEnv -> Assertion
corpusReadWrite01 env = do
flip runReaderT env $ runTestMonad $ do
uid <- getUserId (UserName "alfredo")
parentId <- getRootId (UserName "alfredo")
[corpusId] <- mk (Just "Test_Corpus") (Nothing :: Maybe HyperdataCorpus) parentId uid
liftIO $ corpusId `shouldBe` NodeId 416
-- Retrieve the corpus by Id
[corpus] <- getCorporaWithParentId parentId
liftIO $ corpusId `shouldBe` (_node_id corpus)
-- | We test that we can update the existing language for a 'Corpus'.
corpusAddLanguage :: TestEnv -> Assertion
corpusAddLanguage env = do
flip runReaderT env $ runTestMonad $ do
parentId <- getRootId (UserName "alfredo")
[corpus] <- getCorporaWithParentId parentId
liftIO $ (_hc_lang . _node_hyperdata $ corpus) `shouldBe` Just EN -- defaults to English
addLanguageToCorpus (_node_id corpus) IT
[corpus'] <- getCorporaWithParentId parentId
liftIO $ (_hc_lang . _node_hyperdata $ corpus') `shouldBe` Just IT
test/Database/Operations/DocumentSearch.hs 0 → 100644
View file @ 013e9d66
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Database.Operations.DocumentSearch where
import Prelude
import Control.Monad.Reader
import Data.Aeson.QQ.Simple
import Data.Aeson.Types
import Data.Maybe
import Gargantext.Core
import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.Flow
import Gargantext.Database.Action.Search
import Gargantext.Database.Admin.Types.Hyperdata.Document
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Tree.Root
import Gargantext.Database.Schema.Node (NodePoly(..))
import Network.URI (parseURI)
import Database.Operations.Types
import Test.Hspec.Expectations
import Test.Tasty.HUnit
import Gargantext.Core.Text.Terms.Mono.Stem.En
import Gargantext.Database.Admin.Config (userMaster)
import qualified Data.Text as T
import qualified Gargantext.Core.Text.Corpus.Query as API
import Gargantext.Database.Query.Facet
exampleDocument_01 :: HyperdataDocument
exampleDocument_01 = either error id $ parseEither parseJSON $ [aesonQQ|
{ "doi":"01"
, "publication_day":6
, "language_iso2":"EN"
, "publication_minute":0
, "publication_month":7
, "language_iso3":"eng"
, "publication_second":0
, "authors":"Nils Hovdenak, Kjell Haram"
, "publication_year":2012
, "publication_date":"2012-07-06 00:00:00+00:00"
, "language_name":"English"
, "realdate_full_":"2012 01 12"
, "source":"European journal of obstetrics, gynecology, and reproductive biology Institute"
, "abstract":"The literature was searched for publications on minerals and vitamins during pregnancy and the possible influence of supplements on pregnancy outcome."
, "title":"Influence of mineral and vitamin supplements on pregnancy outcome."
, "publication_hour":0
}
|]
exampleDocument_02 :: HyperdataDocument
exampleDocument_02 = either error id $ parseEither parseJSON $ [aesonQQ|
{ "doi":""
, "uniqId": "1405.3072v3"
, "bdd": "Arxiv"
, "publication_day":6
, "language_iso2":"EN"
, "publication_second":0
, "authors":"Ajeje Brazorf, Manuel Agnelli"
, "publication_year":2012
, "publication_date":"2012-07-06 00:00:00+00:00"
, "language_name":"English"
, "realdate_full_":"2012 01 12"
, "source":"Malagrotta Institute of Technology"
, "abstract":"We present PyPlasm, an innovative approach to computational graphics"
, "title":"PyPlasm: computational geometry made easy"
, "publication_hour":0
}
|]
exampleDocument_03 :: HyperdataDocument
exampleDocument_03 = either error id $ parseEither parseJSON $ [aesonQQ|
{
"bdd": "Arxiv"
, "doi": ""
, "url": "http://arxiv.org/pdf/1405.3072v2"
, "title": "Haskell for OCaml programmers"
, "source": ""
, "uniqId": "1405.3072v2"
, "authors": "Raphael Poss, Herbert Ballerina"
, "abstract": " This introduction to Haskell is written to optimize learning by programmers who already know OCaml. "
, "institutes": ""
, "language_iso2": "EN"
, "publication_date": "2014-05-13T09:10:32Z"
, "publication_year": 2014
}
|]
exampleDocument_04 :: HyperdataDocument
exampleDocument_04 = either error id $ parseEither parseJSON $ [aesonQQ|
{
"bdd": "Arxiv"
, "doi": ""
, "url": "http://arxiv.org/pdf/1407.5670v1"
, "title": "Rust for functional programmers"
, "source": ""
, "uniqId": "1407.5670v1"
, "authors": "Raphael Poss"
, "abstract": " This article provides an introduction to Rust , a systems language by Mozilla , to programmers already familiar with Haskell , OCaml or other functional languages. " , "institutes": ""
, "language_iso2": "EN"
, "publication_date": "2014-07-21T21:20:31Z"
, "publication_year": 2014
}
|]
nlpServerConfig :: NLPServerConfig
nlpServerConfig =
let uri = parseURI "http://localhost:9000"
in NLPServerConfig CoreNLP (fromMaybe (error "parseURI for nlpServerConfig failed") uri)
corpusAddDocuments :: TestEnv -> Assertion
corpusAddDocuments env = do
flip runReaderT env $ runTestMonad $ do
-- NOTE(adn) We need to create user 'gargantua'(!!) in order
-- for 'addDocumentsToHyperCorpus' to work.
parentId <- getRootId (UserName userMaster)
[corpus] <- getCorporaWithParentId parentId
let corpusId = _node_id corpus
ids <- addDocumentsToHyperCorpus nlpServerConfig
(Just $ _node_hyperdata $ corpus)
(Multi EN)
corpusId
[exampleDocument_01, exampleDocument_02, exampleDocument_03, exampleDocument_04]
liftIO $ length ids `shouldBe` 4
stemmingTest :: TestEnv -> Assertion
stemmingTest _env = do
stemIt "Ajeje" `shouldBe` "Ajeje"
stemIt "PyPlasm:" `shouldBe` "PyPlasm:"
mkQ :: T.Text -> API.Query
mkQ txt = either (\e -> error $ "(query) = " <> T.unpack txt <> ": " <> e) id . API.parseQuery . API.RawQuery $ txt
corpusSearch01 :: TestEnv -> Assertion
corpusSearch01 env = do
flip runReaderT env $ runTestMonad $ do
parentId <- getRootId (UserName userMaster)
[corpus] <- getCorporaWithParentId parentId
results1 <- searchInCorpus (_node_id corpus) False (mkQ "mineral") Nothing Nothing Nothing
results2 <- searchInCorpus (_node_id corpus) False (mkQ "computational") Nothing Nothing Nothing
liftIO $ length results1 `shouldBe` 1
liftIO $ length results2 `shouldBe` 1
-- | Check that we support more complex queries
corpusSearch02 :: TestEnv -> Assertion
corpusSearch02 env = do
flip runReaderT env $ runTestMonad $ do
parentId <- getRootId (UserName userMaster)
[corpus] <- getCorporaWithParentId parentId
results1 <- searchInCorpus (_node_id corpus) False (mkQ "Raphael") Nothing Nothing Nothing
results2 <- searchInCorpus (_node_id corpus) False (mkQ "Raphael Poss") Nothing Nothing Nothing
liftIO $ do
length results1 `shouldBe` 2 -- Haskell & Rust
map facetDoc_title results2 `shouldBe` ["Haskell for OCaml programmers", "Rust for functional programmers"]
-- | Check that we support more complex queries via the bool API
corpusSearch03 :: TestEnv -> Assertion
corpusSearch03 env = do
flip runReaderT env $ runTestMonad $ do
parentId <- getRootId (UserName userMaster)
[corpus] <- getCorporaWithParentId parentId
results1 <- searchInCorpus (_node_id corpus) False (mkQ "\"Manuel Agnelli\"") Nothing Nothing Nothing
results2 <- searchInCorpus (_node_id corpus) False (mkQ "Raphael AND -Rust") Nothing Nothing Nothing
results3 <- searchInCorpus (_node_id corpus) False (mkQ "(Raphael AND (NOT Rust)) OR PyPlasm") Nothing Nothing Nothing
liftIO $ do
length results1 `shouldBe` 1
map facetDoc_title results2 `shouldBe` ["Haskell for OCaml programmers"]
map facetDoc_title results3 `shouldBe` ["PyPlasm: computational geometry made easy", "Haskell for OCaml programmers"]
test/Database/Operations/Types.hs 0 → 100644
View file @ 013e9d66
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Database.Operations.Types where
import Control.Exception
import Control.Lens
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.IORef
import Data.Pool
import Gargantext
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Prelude
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Prelude.Config
import Gargantext.Utils.Jobs
import Prelude
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.Postgres.Temp as Tmp
import qualified Gargantext.API.Admin.EnvTypes as EnvTypes
newtype Counter = Counter { _Counter :: IORef Int }
deriving Eq
instance Show Counter where
show (Counter _) = "Counter"
emptyCounter :: IO Counter
emptyCounter = Counter <$> newIORef 0
nextCounter :: Counter -> IO Int
nextCounter (Counter ref) = atomicModifyIORef' ref (\old -> (succ old, old))
data TestEnv = TestEnv {
test_db :: !DBHandle
, test_config :: !GargConfig
, test_usernameGen :: !Counter
}
newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
deriving ( Functor, Applicative, Monad
, MonadReader TestEnv, MonadError IOException
, MonadBase IO
, MonadBaseControl IO
, MonadFail
, MonadIO
)
instance MonadJobStatus TestMonad where
type JobHandle TestMonad = EnvTypes.ConcreteJobHandle GargError
type JobType TestMonad = GargJob
type JobOutputType TestMonad = JobLog
type JobEventType TestMonad = JobLog
getLatestJobStatus _ = TestMonad (pure noJobLog)
withTracer _ jh n = n jh
markStarted _ _ = TestMonad $ pure ()
markProgress _ _ = TestMonad $ pure ()
markFailure _ _ _ = TestMonad $ pure ()
markComplete _ = TestMonad $ pure ()
markFailed _ _ = TestMonad $ pure ()
addMoreSteps _ _ = TestMonad $ pure ()
data DBHandle = DBHandle {
_DBHandle :: Pool PG.Connection
, _DBTmp :: Tmp.DB
}
instance HasNodeError IOException where
_NodeError = prism' (userError . show) (const Nothing)
instance HasConnectionPool TestEnv where
connPool = to (_DBHandle . test_db)
instance HasConfig TestEnv where
hasConfig = to test_config
test/hspec/Main.hs
View file @ 013e9d66
......@@ -3,10 +3,29 @@ module Main where
import Gargantext.Prelude
import Control.Exception
import Shelly hiding (FilePath)
import System.Process
import System.IO
import qualified Database.Operations as DB
import Test.Hspec
startCoreNLPServer :: IO ProcessHandle
startCoreNLPServer = do
devNull <- openFile "/dev/null" WriteMode
let p = proc "./startServer.sh" []
(_, _, _, hdl) <- createProcess $ p { cwd = Just "devops/coreNLP/stanford-corenlp-current"
, delegate_ctlc = True
, create_group = True
, std_out = UseHandle devNull
, std_err = UseHandle devNull
}
pure hdl
stopCoreNLPServer :: ProcessHandle -> IO ()
stopCoreNLPServer = interruptProcessGroupOf
-- It's especially important to use Hspec for DB tests, because,
-- unlike 'tasty', 'Hspec' has explicit control over parallelism,
-- and it's important that DB tests are run according to a very
......@@ -14,5 +33,11 @@ import Test.Hspec
-- Unfortunately it's not possibly to use the 'tasty-hspec' adapter
-- because by the time we get a 'TestTree' out of the adapter library,
-- the information about parallelism is lost.
--
-- /IMPORTANT/: For these tests to run correctly, you have to run
-- ./devops/coreNLP/build.sh first. You have to run it only /once/,
-- and then you are good to go for the time being.
main :: IO ()
main = hspec DB.tests
main = do
hSetBuffering stdout NoBuffering
bracket startCoreNLPServer stopCoreNLPServer (const (hspec DB.tests))
test/tasty/Main.hs
View file @ 013e9d66
......@@ -14,7 +14,6 @@ import Gargantext.Prelude
import qualified Core.Text.Corpus.Query as CorpusQuery
import qualified Core.Utils as Utils
import qualified Database.Operations as DB
import qualified Graph.Clustering as Graph
import qualified Ngrams.NLP as NLP
import qualified Ngrams.Query as NgramsQuery
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment