Merge branch 'dev' into dev-epo-patents

.gitlab-ci.yml

@@ -12,6 +12,7 @@ variables:
 stages:
   - stack
   - cabal
+  - bench
   - test
 
 stack:
@@ -34,7 +35,19 @@ cabal:
       - .cabal/
     policy: pull-push
   script:
-    - nix-shell --run "./bin/update-cabal-project $CABAL_STORE_DIR && cabal --store-dir=$CABAL_STORE_DIR v2-build --ghc-options='-O0 -fclear-plugins'"
+    - nix-shell --run "./bin/update-cabal-project $CABAL_STORE_DIR && cabal --store-dir=$CABAL_STORE_DIR v2-build --ghc-options='-O2 -fclear-plugins'"
+  allow_failure: false
+
+bench:
+  stage: bench
+  cache:
+    key: cabal.project
+    paths:
+      - dist-newstyle/
+      - .cabal/
+    policy: pull-push
+  script:
+    - nix-shell --run "./bin/update-cabal-project $CABAL_STORE_DIR && cabal --store-dir=$CABAL_STORE_DIR v2-bench --ghc-options='-O2 -fclear-plugins'"
   allow_failure: false
 
 test:
@@ -59,14 +72,17 @@ test:
       export TEST_NIX_PATH=$(nix-shell --run "echo -n \$PATH")
       echo $CABAL
       echo $TEST_NIX_PATH
+      git config --global --add safe.directory '*'
       nix-shell --run "./bin/update-cabal-project $CABAL_STORE_DIR"
       mkdir -p /root/.cache/cabal/logs
       chown -R test:test /root/.cache/cabal/logs/
-      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 --ghc-options='-O0 -fclear-plugins'\""
+      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'\""
       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/
 
 #docs:
 #  stage: docs

CHANGELOG.md

+## Version 0.0.6.9.9.7.6.3
+
+* [BACK][TESTS] Make a start on benchmarking, add more tests
+
+## Version 0.0.6.9.9.7.6.2
+
+* [BACK][FIX] CI
+* [FRONT][FEAT] Restoring APIs for tests
+
+## Version 0.0.6.9.9.7.6.1
+
+* [BACK][API/DATA] OpenAlex connection
+* [BACK][DOC][README: Add note about libraries devlopment (#260)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/260)
+
+## Version 0.0.6.9.9.7.6
+
+* [BACK][FIX][[ArXiv][TextFlow] Ngrams Table empty (#258)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/258)
+* [BACK][FIX][[Corpus HAL API] Abstract in both languages FR+EN instead of only 1 language (#244)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/244)
+* [FRONT][ERGO][API key pubmed (#593)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/593)
+* [FRONT][FACTO][Tree on the right (#511)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/511)
+* [FRONT][FIX][Single document upload doesn't work when abstract is empty (#592)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/592)
+* [FRONT][RENDER][[Node Phylo] Form render improvements (#581)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/581)
+
 ## Version 0.0.6.9.9.7.5.1
 
 * [BACK][FIX][[Corpus HAL API] Abstract in both languages FR+EN instead of only 1 language (#244)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/244)

README.md

@@ -37,7 +37,7 @@ Disclaimer: since this project is still in development, this document remains in
   git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
   cd haskell-gargantext
   ```
-#### 1. Installation
+### Installation
 
 This project can be built with either Stack or Cabal. For historical reasons, we generate a `cabal.project` from the `stack.yaml`, and we do not commit the former to the repo, to have a single "source of truth".
 However, it's always possible to generate a `cabal.project` thanks to [stack2cabal](https://hackage.haskell.org/package/stack2cabal).
@@ -64,7 +64,7 @@ nix-shell
 
 This will take a bit of time the first time.
 
-#### Build: choose cabal (new) or stack (old)
+### Build: choose cabal (new) or stack (old)
 
 #### With Cabal (recommanded)
 
@@ -166,12 +166,29 @@ From the Backend root folder (haskell-gargantext):
 ``` shell
 ./start
 # The start script runs following commands:
+# - `./bin/install` to update and build the project
 # - `docker compose up` to run the Docker for postgresql from devops/docker folder
 # - `cabal run gargantext-server -- --ini gargantext.ini --run Prod` to run other services through `nix-shell`
 ```
 
 For frontend development and compilation, see the [Frontend Readme.md](https://gitlab.iscpif.fr/gargantext/purescript-gargantext#dev)
 
+### Working on libraries
+
+When a devlopment is needed on libraries (for instance, the HAL crawler in https://gitlab.iscpif.fr/gargantext/crawlers):
+
+1. Ongoing devlopment (on local repo):
+   1. In `cabal.project`:
+      - add `../hal` to `packages:`
+      - turn off (temporarily) the `hal` in `source-repository-package` 
+   2. When changes work and tests are OK, commit in repo `hal`
+2. When changes are commited / merged:
+   1. Get the hash id, and edit `stack.yaml` with the **new commit id**
+   2. run `./bin/update-cabal-project`
+      - get an error that sha256 don't match, so update the `./bin/update-cabal-project` with new sha256 hash
+      - run again `./bin/update-cabal-project` (to make sure it's a fixed point now)
+
+> Note: without `stack.yaml` we would have to only fix `cabal.project` -> `source-repository-package` commit id. Sha256 is there to make sure CI reruns the tests.
 
 ## Use Cases <a name="use-cases"></a>
 

bench/Main.hs

+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
+module Main where
+
+import Gargantext.Core.Types.Individu
+import Gargantext.Prelude.Crypto.Auth (createPasswordHash)
+
+import Test.Tasty.Bench
+
+main :: IO ()
+main = defaultMain
+  [ bgroup "Benchmarks"
+    [ bgroup "User creation" [
+      bench "createPasswordHash"  $ whnfIO (createPasswordHash "rabbit")
+    , bench "toUserHash"  $
+        whnfIO (toUserHash $ NewUser "alfredo" "alfredo@well-typed.com" (GargPassword "rabbit"))
+    ]
+    ]
+  ]

bin/gargantext-admin/Main.hs

@@ -18,6 +18,7 @@ module Main where
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Prelude (GargError)
 import Gargantext.Database.Action.User.New (newUsers)
+import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (Cmd'')
 import Gargantext.Prelude
 import System.Environment (getArgs)
@@ -28,6 +29,6 @@ main = do
   (iniPath:mails) <- getArgs
 
   withDevEnv iniPath $ \env -> do
-    x <- runCmdDev env ((newUsers $ map cs mails) :: Cmd'' DevEnv GargError Int64)
+    x <- runCmdDev env ((newUsers $ map cs mails) :: Cmd'' DevEnv GargError [UserId])
     putStrLn $ show x
   pure ()

bin/gargantext-server/Main.hs

@@ -16,15 +16,19 @@ Script to start gargantext with different modes (Dev, Prod, Mock).
 {-# LANGUAGE Strict               #-}
 {-# LANGUAGE TypeOperators        #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TypeFamilies #-}
 
 
 module Main where
 
 
+import Data.String (String)
 import Data.Text (unpack)
 import Data.Version (showVersion)
-import Gargantext.API (startGargantext, Mode(..)) -- , startGargantextMock)
+import Gargantext.API (startGargantext) -- , startGargantextMock)
+import Gargantext.API.Admin.EnvTypes
 import Gargantext.Prelude
+import Gargantext.System.Logging
 import Options.Generic
 import System.Exit (exitSuccess)
 import qualified Paths_gargantext as PG -- cabal magic build module
@@ -49,14 +53,26 @@ data MyOptions w =
 instance ParseRecord (MyOptions Wrapped)
 deriving instance Show (MyOptions Unwrapped)
 
+-- | A plain logger in the IO monad, waiting for more serious logging solutions like
+-- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229
+instance HasLogger IO where
+  data instance Logger IO        = IOLogger
+  type instance LogInitParams IO = ()
+  type instance LogPayload IO    = String
+  initLogger                     = \() -> pure IOLogger
+  destroyLogger                  = \_  -> pure ()
+  logMsg = \IOLogger lvl msg ->
+    let pfx = "[" <> show lvl <> "] "
+    in putStrLn $ pfx <> msg
+  logTxt lgr lvl msg = logMsg lgr lvl (unpack msg)
 
 main :: IO ()
-main = do
+main = withLogger () $ \ioLogger -> do
   MyOptions myMode myPort myIniFile myVersion  <- unwrapRecord
           "Gargantext server"
   ---------------------------------------------------------------
   if myVersion then do
-    putStrLn $ "Version: " <> showVersion PG.version
+    logMsg ioLogger INFO $ "Version: " <> showVersion PG.version
     System.Exit.exitSuccess
   else
     return ()
@@ -73,6 +89,6 @@ main = do
   let start = case myMode of
         Mock -> panic "[ERROR] Mock mode unsupported"
         _ -> startGargantext myMode myPort' (unpack myIniFile')
-  putStrLn $ "Starting with " <> show myMode <> " mode."
+  logMsg ioLogger INFO $ "Starting with " <> show myMode <> " mode."
   start
   ---------------------------------------------------------------

bin/gargantext_tmux

@@ -3,5 +3,5 @@
 tmux new -d -s gargantext './server' \; \
             split-window -h -d 'cd ./purescript-gargantext ; ./server' \; \
             select-pane -t 1 \; \
-            split-window -d    'cd deps/nlp/CoreNLP ; ./startServer.sh' \; \
+            split-window -d    'cd devops/docker/nlp/stanford/ ; docker-compose up' \; \
             split-window -d    'cd deps/nlp/spacy-server ; docker-compose up' \; \

bin/update-cabal-project

@@ -7,10 +7,12 @@ STORE_DIR="${1:-$DEFAULT_STORE}"
 
 # README!
 # Every time you modify the `stack.yaml` and as result the relevant `cabal.project`
-# changes, you have to make sure to update the `expected_cabal_projet_hash` with the
-# `sha256sum` result calculated on the `cabal.project`. This ensures the `cabal.project`
-# stays deterministic so that CI cache can kick in.
-expected_cabal_project_hash="720a064535707fc28b8c7b67b1560698d13610a4c1f8a79176b4c5bd40514979"
+# changes, you have to make sure to update the `expected_cabal_project_hash` and
+# `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"
 
 cabal --store-dir=$STORE_DIR v2-update 'hackage.haskell.org,2023-06-24T21:28:46Z'
 
@@ -23,9 +25,16 @@ fi
 stack2cabal --no-run-hpack -p '2023-06-24 21:28:46'
 
 actual_cabal_project_hash=$(sha256sum cabal.project | awk '{printf "%s",$1}')
+actual_cabal_project_freeze_hash=$(sha256sum cabal.project.freeze | awk '{printf "%s",$1}')
 if [[ $actual_cabal_project_hash != $expected_cabal_project_hash ]]; then
   echo "ERROR! hash mismatch between expected cabal.project and the one computed by stack2cabal."
   exit 1
 else
   echo "cabal.project updated successfully."
 fi
+if [[ $actual_cabal_project_freeze_hash != $expected_cabal_project_freeze_hash ]]; then
+  echo "ERROR! hash mismatch between expected cabal.project.freeze and the one computed by stack2cabal."
+  exit 1
+else
+  echo "cabal.project.freeze updated successfully."
+fi

cabal.project

@@ -66,11 +66,6 @@ source-repository-package
     location: https://gitlab.iscpif.fr/amestanogullari/accelerate-utility.git
     tag: a3875fe652d3bb5acb522674c22c6c814c1b4ad0
 
-source-repository-package
-    type: git
-    location: https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude
-    tag: 8f97fef4dfd941d773914ad058d8e02ce2bb1a3e
-
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/cgenie/patches-class.git
@@ -79,7 +74,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/arxiv-api.git
-    tag: 2d7e5753cbbce248b860b571a0e9885415c846f7
+    tag: eb130c71fa17adaceed6ff66beefbccb13df51ba
 
 source-repository-package
     type: git
@@ -99,7 +94,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/openalex.git
-    tag: dab07cb89e8ab8eaaff8619f5e21d944d9c526ab
+    tag: 1cf872fb3bd0e3e44af31247833c4b6bb7d0dca5
 
 source-repository-package
     type: git
@@ -111,6 +106,11 @@ source-repository-package
     location: https://gitlab.iscpif.fr/gargantext/gargantext-graph.git
     tag: 588e104fe7593210956610cab0041fd16584a4ce
 
+source-repository-package
+    type: git
+    location: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude
+    tag: 8f97fef4dfd941d773914ad058d8e02ce2bb1a3e
+
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/haskell-igraph.git
@@ -151,7 +151,7 @@ source-repository-package
 source-repository-package
     type: git
     location: ssh://git@gitlab.iscpif.fr:20022/gargantext/crawlers/epo.git
-    tag: ac9f20b36e8659267d7525fe2c74c7286a0350cb
+    tag: 4918c32679edaba87d05bed88ea1c3024813946d
 
 allow-older: *
 allow-newer: *

cabal.project.freeze

@@ -1205,12 +1205,12 @@ constraints: any.AC-Angle ==1.0,
              any.hslua-module-text ==0.3.0.1,
              any.hsp ==0.10.0,
              any.hsparql ==0.3.8,
-             any.hspec ==2.7.10,
+             any.hspec ==2.11.1,
              any.hspec-attoparsec ==0.1.0.2,
              any.hspec-checkers ==0.1.0.2,
              any.hspec-contrib ==0.5.1,
-             any.hspec-core ==2.7.10,
-             any.hspec-discover ==2.7.10,
+             any.hspec-core ==2.11.1,
+             any.hspec-discover ==2.11.1,
              any.hspec-expectations ==0.8.3,
              any.hspec-expectations-json ==1.0.0.4,
              any.hspec-expectations-lifted ==0.10.0,
@@ -2385,7 +2385,7 @@ constraints: any.AC-Angle ==1.0,
              any.tasty-focus ==1.0.1,
              any.tasty-golden ==2.3.5,
              any.tasty-hedgehog ==1.1.0.0,
-             any.tasty-hspec ==1.1.6,
+             any.tasty-hspec ==1.2.0.3,
              any.tasty-hunit ==0.10.0.3,
              any.tasty-hunit-compat ==0.2.0.1,
              any.tasty-inspection-testing ==0.1,

devops/docker/nlp/stanford/docker-compose.yaml

+version: '3'
+
+services:
+
+  corenlp:
+    #image: 'cgenie/corenlp-garg:latest'
+    image: 'cgenie/corenlp-garg:4.5.4'
+    ports:
+      - 9000:9000
+volumes:
+  js-cache:

devops/postgres/schema.sql

@@ -265,14 +265,14 @@ CREATE INDEX        ON public.nodes USING btree (user_id, typename, parent_id);
 CREATE INDEX        ON public.nodes USING btree (id, typename, date ASC);
 CREATE INDEX        ON public.nodes USING btree (id, typename, date DESC);
 CREATE INDEX        ON public.nodes USING btree (typename, id);
-CREATE UNIQUE INDEX ON public.nodes USING btree (hash_id);
+CREATE UNIQUE INDEX IF NOT EXISTS ON public.nodes USING btree (hash_id);
 
 CREATE INDEX        ON public.contexts USING gin (hyperdata);
 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 ON public.contexts USING btree (hash_id);
+CREATE UNIQUE INDEX IF NOT EXISTS 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

@@ -5,7 +5,7 @@ cabal-version: 2.0
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.6.9.9.7.5.1
+version: 0.0.6.9.9.7.6.3
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -33,6 +33,13 @@ data-files:
     test-data/test_config.ini
     .clippy.dhall
 
+-- When enabled, it swaps the hashing algorithm
+-- with a quicker (and less secure) version, which
+-- runs faster in tests.
+flag test-crypto
+  default: False
+  manual: True
+
 library
   exposed-modules:
       Gargantext
@@ -106,6 +113,7 @@ library
       Gargantext.Core.Viz.Types
       Gargantext.Database.Action.Flow
       Gargantext.Database.Action.Flow.Types
+      Gargantext.Database.Action.User
       Gargantext.Database.Action.User.New
       Gargantext.Database.Admin.Config
       Gargantext.Database.Admin.Trigger.Init
@@ -116,9 +124,12 @@ library
       Gargantext.Database.Query.Table.Node
       Gargantext.Database.Query.Table.Node.Error
       Gargantext.Database.Query.Table.Node.UpdateOpaleye
+      Gargantext.Database.Query.Tree.Root
       Gargantext.Database.Query.Table.User
       Gargantext.Database.Schema.Ngrams
+      Gargantext.Database.Schema.User
       Gargantext.Defaults
+      Gargantext.System.Logging
       Gargantext.Utils.Jobs
       Gargantext.Utils.Jobs.Internal
       Gargantext.Utils.Jobs.Map
@@ -281,7 +292,6 @@ library
       Gargantext.Database.Action.Search
       Gargantext.Database.Action.Share
       Gargantext.Database.Action.TSQuery
-      Gargantext.Database.Action.User
       Gargantext.Database.Admin.Access
       Gargantext.Database.Admin.Bashql
       Gargantext.Database.Admin.Trigger.ContextNodeNgrams
@@ -331,7 +341,6 @@ library
       Gargantext.Database.Query.Table.NodesNgramsRepo
       Gargantext.Database.Query.Tree
       Gargantext.Database.Query.Tree.Error
-      Gargantext.Database.Query.Tree.Root
       Gargantext.Database.Schema.Context
       Gargantext.Database.Schema.ContextNodeNgrams
       Gargantext.Database.Schema.ContextNodeNgrams2
@@ -346,7 +355,6 @@ library
       Gargantext.Database.Schema.NodeNodeNgrams2
       Gargantext.Database.Schema.NodesNgramsRepo
       Gargantext.Database.Schema.Prelude
-      Gargantext.Database.Schema.User
       Gargantext.Database.Types
       Gargantext.Utils.Aeson
       Gargantext.Utils.JohnSnowNLP
@@ -371,6 +379,8 @@ library
       RecordWildCards
       StrictData
   ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-signatures -Wunused-binds -Wunused-imports -Werror -freduction-depth=300 -fplugin=Clippy
+  if flag(test-crypto)
+    cpp-options: -DTEST_CRYPTO
   build-depends:
       HSvm ^>= 0.1.1.3.22
     , KMP ^>= 0.2.0.0
@@ -868,9 +878,9 @@ executable gargantext-upgrade
     , text ^>= 1.2.4.1
   default-language: Haskell2010
 
-test-suite garg-test
+test-suite garg-test-tasty
   type: exitcode-stdio-1.0
-  main-is: Main.hs
+  main-is: tasty/Main.hs
   other-modules:
       Core.Text
       Core.Text.Corpus.Query
@@ -939,6 +949,7 @@ test-suite garg-test
     , gargantext
     , gargantext-prelude
     , hspec ^>= 2.7.10
+    , hspec-core
     , hspec-expectations >= 0.8 && < 0.9
     , http-client ^>= 0.6.4.1
     , http-client-tls ^>= 0.3.5.3
@@ -961,9 +972,103 @@ test-suite garg-test
     , tasty-hspec
     , tasty-hunit
     , tasty-quickcheck
+    , tasty-smallcheck
     , text ^>= 1.2.4.1
     , time ^>= 1.9.3
     , tmp-postgres >= 1.34.1 && < 1.35
     , unordered-containers ^>= 0.2.16.0
     , validity ^>= 0.11.0.1
   default-language: Haskell2010
+
+test-suite garg-test-hspec
+  type: exitcode-stdio-1.0
+  main-is: hspec/Main.hs
+  other-modules:
+      Database.Operations
+      Paths_gargantext
+  hs-source-dirs:
+      test
+  default-extensions:
+      DataKinds
+      DeriveGeneric
+      FlexibleContexts
+      FlexibleInstances
+      GADTs
+      GeneralizedNewtypeDeriving
+      ImportQualifiedPost
+      MultiParamTypeClasses
+      NamedFieldPuns
+      NoImplicitPrelude
+      OverloadedStrings
+      RankNTypes
+      RecordWildCards
+      StrictData
+      DataKinds
+      DeriveGeneric
+      FlexibleContexts
+      FlexibleInstances
+      GeneralizedNewtypeDeriving
+      ImportQualifiedPost
+      MultiParamTypeClasses
+      NoImplicitPrelude
+      OverloadedStrings
+      RankNTypes
+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      QuickCheck ^>= 2.14.2
+    , aeson ^>= 1.5.6.0
+    , async ^>= 2.2.4
+    , base ^>= 4.14.3.0
+    , boolexpr ^>= 0.2
+    , bytestring ^>= 0.10.12.0
+    , conduit ^>= 1.3.4.2
+    , containers ^>= 0.6.5.1
+    , crawlerArxiv
+    , duckling ^>= 0.2.0.0
+    , extra ^>= 1.7.9
+    , gargantext
+    , gargantext-prelude
+    , hspec ^>= 2.7.10
+    , hspec-core
+    , hspec-expectations >= 0.8 && < 0.9
+    , http-client ^>= 0.6.4.1
+    , http-client-tls ^>= 0.3.5.3
+    , lens >= 5.2.2 && < 5.3
+    , monad-control >= 1.0.3 && < 1.1
+    , mtl ^>= 2.2.2
+    , 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
+    , quickcheck-instances ^>= 0.3.25.2
+    , raw-strings-qq
+    , recover-rtti >= 0.4 && < 0.5
+    , resource-pool >= 0.2.3.2 && < 0.2.4
+    , servant-job
+    , shelly >= 1.9 && < 2
+    , stm ^>= 2.5.0.1
+    , tasty ^>= 1.4.2.1
+    , tasty-hspec
+    , tasty-hunit
+    , tasty-quickcheck
+    , tasty-smallcheck
+    , text ^>= 1.2.4.1
+    , time ^>= 1.9.3
+    , tmp-postgres >= 1.34.1 && < 1.35
+    , unordered-containers ^>= 0.2.16.0
+    , validity ^>= 0.11.0.1
+  default-language: Haskell2010
+
+benchmark garg-bench
+  main-is:       Main.hs
+  hs-source-dirs: bench
+  type:          exitcode-stdio-1.0
+  build-depends: base
+               , bytestring
+               , gargantext
+               , gargantext-prelude
+               , tasty-bench
+  ghc-options:   "-with-rtsopts=-A32m"
+  if impl(ghc >= 8.6)
+    ghc-options: "-with-rtsopts=--nonmoving-gc"

src/Gargantext/API.hs

@@ -29,13 +29,14 @@ Pouillard (who mainly made it).
 {-# LANGUAGE BangPatterns         #-}
 {-# LANGUAGE NumericUnderscores   #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
 module Gargantext.API
       where
 
 import Control.Concurrent
 import Control.Exception (catch, finally, SomeException{-, displayException, IOException-})
-import Control.Lens
+import Control.Lens hiding (Level)
 import Control.Monad.Except
 import Control.Monad.Reader (runReaderT)
 import Data.Either
@@ -46,9 +47,8 @@ import Data.Text.Encoding (encodeUtf8)
 import Data.Text.IO (putStrLn)
 import Data.Validity
 import GHC.Base (Applicative)
-import GHC.Generics (Generic)
 import Gargantext.API.Admin.Auth.Types (AuthContext)
-import Gargantext.API.Admin.EnvTypes (Env)
+import Gargantext.API.Admin.EnvTypes (Env, Mode(..))
 import Gargantext.API.Admin.Settings (newEnv)
 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
 import Gargantext.API.EKG
@@ -69,14 +69,12 @@ import Servant
 import System.FilePath
 import qualified Gargantext.Database.Prelude as DB
 import qualified System.Cron.Schedule as Cron
-
-data Mode = Dev | Mock | Prod
-  deriving (Show, Read, Generic)
+import Gargantext.System.Logging
 
 -- | startGargantext takes as parameters port number and Ini file.
 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
-startGargantext mode port file = do
-  env <- newEnv port file
+startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
+  env <- newEnv logger port file
   runDbCheck env
   portRouteInfo port
   app <- makeApp env

src/Gargantext/API/Admin/EnvTypes.hs

@@ -2,15 +2,18 @@
 
 {-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Gargantext.API.Admin.EnvTypes (
     GargJob(..)
   , Env(..)
+  , Mode(..)
   , mkJobHandle
   , env_logger
   , env_manager
   , env_self_url
   , menv_firewall
+  , dev_env_logger
 
   , MockEnv(..)
   , DevEnv(..)
@@ -18,7 +21,7 @@ module Gargantext.API.Admin.EnvTypes (
   , ConcreteJobHandle -- opaque
   ) where
 
-import Control.Lens hiding ((:<))
+import Control.Lens hiding (Level, (:<))
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Pool (Pool)
@@ -29,24 +32,62 @@ import Network.HTTP.Client (Manager)
 import Servant.Client (BaseUrl)
 import Servant.Job.Async (HasJobEnv(..), Job)
 import qualified Servant.Job.Async as SJ
-import System.Log.FastLogger
 import qualified Servant.Job.Core
 
-import Gargantext.API.Admin.Types
+import Data.List ((\\))
+import qualified Data.Text as T
 import Gargantext.API.Admin.Orchestrator.Types
+import Gargantext.API.Admin.Types
 import Gargantext.API.Job
-import Gargantext.API.Prelude (GargM)
-import Gargantext.Core.NodeStory
+import Gargantext.API.Prelude (GargM, GargError)
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
 import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
+import Gargantext.Core.NodeStory
 import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(..))
 import Gargantext.Prelude.Mail.Types (MailConfig)
+import Gargantext.System.Logging
+import qualified System.Log.FastLogger as FL
 
 import qualified Gargantext.Utils.Jobs.Monad as Jobs
 import Gargantext.Utils.Jobs.Map (LoggerM, J(..), jTask, rjGetLog)
 
+data Mode = Dev | Mock | Prod
+  deriving (Show, Read, Generic)
+
+-- | Given the 'Mode' the server is running in, it returns the list of
+-- allowed levels. For example for production we ignore everything which
+-- has priority lower than "warning".
+modeToLoggingLevels :: Mode -> [LogLevel]
+modeToLoggingLevels = \case
+   Dev  -> [minBound .. maxBound]
+   Mock -> [minBound .. maxBound]
+   -- For production, accepts everything but DEBUG.
+   Prod -> [minBound .. maxBound] \\ [DEBUG]
+
+instance MonadLogger (GargM Env GargError) where
+  getLogger = asks _env_logger
+
+instance HasLogger (GargM Env GargError) where
+  data instance Logger (GargM Env GargError)  =
+    GargLogger {
+        logger_mode    :: Mode
+      , logger_set     :: FL.LoggerSet
+      }
+  type instance LogInitParams (GargM Env GargError) = Mode
+  type instance LogPayload (GargM Env GargError)    = FL.LogStr
+  initLogger                = \mode -> do
+    logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
+    pure $ GargLogger mode logger_set
+  destroyLogger             = \GargLogger{..}  -> liftIO $ FL.rmLoggerSet logger_set
+  logMsg = \(GargLogger mode logger_set) lvl msg -> do
+    let pfx = "[" <> show lvl <> "] "
+    when (lvl `elem` (modeToLoggingLevels mode)) $
+      liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
+  logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)
+
+
 data GargJob
   = TableNgramsJob
   | ForgotPasswordJob
@@ -72,7 +113,7 @@ data GargJob
 -- we need to remember to force the fields to WHNF at that point.
 data Env = Env
   { _env_settings  :: ~Settings
-  , _env_logger    :: ~LoggerSet
+  , _env_logger    :: ~(Logger (GargM Env GargError))
   , _env_pool      :: ~(Pool Connection)
   , _env_nodeStory :: ~NodeStoryEnv
   , _env_manager   :: ~Manager
@@ -186,6 +227,8 @@ instance Jobs.MonadJobStatus (GargM Env err) where
                                        Just msg -> jobLogFailTotalWithMessage msg latest
                          )
 
+  addMoreSteps steps jh = updateJobProgress jh (jobLogAddMore steps)
+
 data MockEnv = MockEnv
   { _menv_firewall :: !FireWall
   }
@@ -193,9 +236,31 @@ data MockEnv = MockEnv
 
 makeLenses ''MockEnv
 
+instance MonadLogger (GargM DevEnv GargError) where
+  getLogger = asks _dev_env_logger
+
+instance HasLogger (GargM DevEnv GargError) where
+  data instance Logger (GargM DevEnv GargError)  =
+    GargDevLogger {
+        dev_logger_mode    :: Mode
+      , dev_logger_set     :: FL.LoggerSet
+      }
+  type instance LogInitParams (GargM DevEnv GargError) = Mode
+  type instance LogPayload (GargM DevEnv GargError)    = FL.LogStr
+  initLogger                = \mode -> do
+    dev_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
+    pure $ GargDevLogger mode dev_logger_set
+  destroyLogger             = \GargDevLogger{..}  -> liftIO $ FL.rmLoggerSet dev_logger_set
+  logMsg = \(GargDevLogger mode logger_set) lvl msg -> do
+    let pfx = "[" <> show lvl <> "] "
+    when (lvl `elem` (modeToLoggingLevels mode)) $
+      liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
+  logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)
+
 data DevEnv = DevEnv
   { _dev_env_settings  :: !Settings
   , _dev_env_config    :: !GargConfig
+  , _dev_env_logger    :: !(Logger (GargM DevEnv GargError))
   , _dev_env_pool      :: !(Pool Connection)
   , _dev_env_nodeStory :: !NodeStoryEnv
   , _dev_env_mail      :: !MailConfig
@@ -229,6 +294,8 @@ instance Jobs.MonadJobStatus (GargM DevEnv err) where
 
   markFailed _ _ = pure ()
 
+  addMoreSteps _ _ = pure ()
+
 instance HasConfig DevEnv where
   hasConfig = dev_env_config
 

src/Gargantext/API/Admin/Settings.hs

@@ -37,12 +37,12 @@ import System.Directory
 -- import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
 import System.IO (FilePath, hClose)
 import System.IO.Temp (withTempFile)
-import System.Log.FastLogger
 import qualified Data.ByteString.Lazy as L
 
 
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Types
+import Gargantext.API.Prelude
 -- import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
 import Gargantext.Core.NLP (nlpServerMap)
 import Gargantext.Database.Prelude (databaseParameters, hasConfig)
@@ -54,6 +54,7 @@ import qualified Gargantext.Utils.Jobs       as Jobs
 import qualified Gargantext.Utils.Jobs.Monad as Jobs
 import qualified Gargantext.Utils.Jobs.Queue as Jobs
 import qualified Gargantext.Utils.Jobs.Settings as Jobs
+import Gargantext.System.Logging
 
 devSettings :: FilePath -> IO Settings
 devSettings jwkFile = do
@@ -176,8 +177,8 @@ readRepoEnv repoDir = do
 devJwkFile :: FilePath
 devJwkFile = "dev.jwk"
 
-newEnv :: PortNumber -> FilePath -> IO Env
-newEnv port file = do
+newEnv :: Logger (GargM Env GargError) -> PortNumber -> FilePath -> IO Env
+newEnv logger port file = do
   !manager_env  <- newTlsManager
   !settings'    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
   when (port /= settings' ^. appPort) $
@@ -200,7 +201,6 @@ newEnv port file = do
                         & Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_job_timeout)
                         & Jobs.l_jsIDTimeout  .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_id_timeout)
   !jobs_env     <- Jobs.newJobEnv jobs_settings prios' manager_env
-  !logger        <- newStderrLoggerSet defaultBufSize
   !config_mail  <- Mail.readConfig file
   !nlp_env      <- nlpServerMap <$> NLP.readConfig file
 

src/Gargantext/API/Dev.hs

@@ -29,16 +29,17 @@ import qualified Gargantext.Prelude.Mail as Mail
 import qualified Gargantext.Prelude.NLP as NLP
 import Servant
 import System.IO (FilePath)
+import Gargantext.System.Logging
 
 type IniPath  = FilePath
 -------------------------------------------------------------------
 withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
-withDevEnv iniPath k = do
-  env <- newDevEnv
+withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do
+  env <- newDevEnv logger
   k env -- `finally` cleanEnv env
 
   where
-    newDevEnv = do
+    newDevEnv logger = do
       cfg     <- readConfig         iniPath
       dbParam <- databaseParameters iniPath
       --nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
@@ -49,6 +50,7 @@ withDevEnv iniPath k = do
       nlp_config <- NLP.readConfig iniPath
       pure $ DevEnv
         { _dev_env_pool     = pool
+        , _dev_env_logger     = logger
         , _dev_env_nodeStory  = nodeStory_env
         , _dev_env_settings = setts
         , _dev_env_config   = cfg

src/Gargantext/API/Job.hs

@@ -31,7 +31,7 @@ addErrorEvent message = addEvent "ERROR" message
 
 jobLogProgress :: Int -> JobLog -> JobLog
 jobLogProgress n jl = over (scst_succeeded . _Just) (+ n) $
-                      over (scst_remaining . _Just) (\x -> x - n) jl
+                      over (scst_remaining . _Just) (\x -> max 0 (x - n)) jl
 
 -- | Mark a job as completely done, by adding the 'remaining' into 'succeeded'.
 -- At the end 'scst_remaining' will be 0, and 'scst_succeeded' will be 'oldvalue + remaining'.
@@ -41,6 +41,9 @@ jobLogComplete jl =
   in jl & over scst_succeeded (Just . maybe remainingNow ((+) remainingNow))
         & over scst_remaining (const (Just 0))
 
+jobLogAddMore :: Int -> JobLog -> JobLog
+jobLogAddMore moreSteps jl = jl & over (scst_remaining . _Just) (+ moreSteps)
+
 jobLogFailures :: Int -> JobLog -> JobLog
 jobLogFailures n jl = over (scst_failed . _Just) (+ n) $
                 over (scst_remaining . _Just) (\x -> x - n) jl

src/Gargantext/API/Node/Corpus/New.hs

@@ -21,20 +21,20 @@ module Gargantext.API.Node.Corpus.New
 
 import Conduit
 import Control.Lens hiding (elements, Empty)
-import Control.Monad
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
-import qualified Data.ByteString.Base64 as BSB64
+import Data.ByteString.Base64 qualified as BSB64
 import Data.Conduit.Internal (zipSources)
 import Data.Either
 import Data.Swagger
 import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Text qualified as T
+import EPO qualified
 import GHC.Generics (Generic)
 import Servant
 import Servant.Job.Utils (jsonOptions)
 -- import Servant.Multipart
-import qualified Data.Text.Encoding as TE
+import Data.Text.Encoding qualified as TE
 -- import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary
 
@@ -59,14 +59,14 @@ import Gargantext.Database.Admin.Types.Node (CorpusId, NodeType(..))
 import Gargantext.Database.Prelude (hasConfig)
 import Gargantext.Database.Query.Table.Node (getNodeWith)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
-import Gargantext.Database.Query.Table.User (getUserPubmedAPIKey)
 import Gargantext.Database.Schema.Node (node_hyperdata)
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (gc_max_docs_parsers)
 import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
-import qualified Gargantext.Core.Text.Corpus.API as API
-import qualified Gargantext.Core.Text.Corpus.Parsers as Parser (FileType(..), parseFormatC)
-import qualified Gargantext.Database.GargDB as GargDB
+import Gargantext.Core.Text.Corpus.API qualified as API
+import Gargantext.Core.Text.Corpus.Parsers qualified as Parser (FileType(..), parseFormatC)
+import Gargantext.Database.GargDB qualified as GargDB
+import Gargantext.System.Logging
 
 ------------------------------------------------------------------------
 {-
@@ -145,12 +145,30 @@ data WithQuery = WithQuery
   , _wq_lang         :: !Lang
   , _wq_node_id      :: !Int
   , _wq_flowListWith :: !FlowSocialListWith
+  , _wq_pubmedAPIKey :: !(Maybe Text)
+  , _wq_epoAuthKey   :: !(Maybe EPO.AuthKey)
   }
   deriving (Show, Eq, Generic)
 
 makeLenses ''WithQuery
 instance FromJSON WithQuery where
   parseJSON = genericParseJSON $ jsonOptions "_wq_"
+  -- parseJSON = withObject "WithQuery" $ \o -> do
+  --   _wq_query <- o .: "query"
+  --   _wq_databases <- o .: "databases"
+  --   _wq_datafield <- o .:? "datafield"
+  --   _wq_lang <- o .: "lang"
+  --   _wq_node_id <- o .: "node_id"
+  --   _wq_flowListWith <- o .: "flowListWith"
+  --   _wq_pubmedAPIKey <- o .:? "pubmedAPIKey"
+  --   _wq_epoAuthKey' <- o .:? "epoAuthKey"  -- this is in form consumerKey:secretKey
+
+  --   let _wq_epoAuthKey = case (T.splitOn ":" <$> _wq_epoAuthKey') of
+  --         Just [consumer, secret] -> Just $ EPO.AuthKey { consumerKey = consumer
+  --                                                       , secretKey   = secret }
+  --         _ -> Nothing
+    
+  --   pure $ WithQuery { .. }
 instance ToJSON WithQuery where
   toJSON = genericToJSON $ jsonOptions "_wq_"
 instance ToSchema WithQuery where
@@ -163,6 +181,8 @@ instance Arbitrary WithQuery where
                         <*> arbitrary
                         <*> arbitrary
                         <*> arbitrary
+                        <*> arbitrary
+                        <*> arbitrary
 
 ------------------------------------------------------------------------
 
@@ -200,17 +220,19 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
                                          , _wq_databases = dbs
                                          , _wq_datafield = datafield
                                          , _wq_lang = l
-                                         , _wq_flowListWith = flw }) maybeLimit jobHandle = do
+                                         , _wq_flowListWith = flw
+                                         , _wq_pubmedAPIKey = mPubmedAPIKey
+                                         , _wq_epoAuthKey = mEPOAuthKey }) maybeLimit jobHandle = do
   -- TODO ...
-  -- printDebug "[addToCorpusWithQuery] (cid, dbs)" (cid, dbs)
-  -- printDebug "[addToCorpusWithQuery] datafield" datafield
-  -- printDebug "[addToCorpusWithQuery] flowListWith" flw
+  $(logLocM) DEBUG $ T.pack $ "(cid, dbs) " <> show (cid, dbs)
+  $(logLocM) DEBUG $ T.pack $ "datafield  " <> show datafield
+  $(logLocM) DEBUG $ T.pack $ "flowListWith " <> show flw
 
   addLanguageToCorpus cid l
 
   case datafield of
     Just Web -> do
-      -- printDebug "[addToCorpusWithQuery] processing web request" datafield
+      $(logLocM) DEBUG $ T.pack $ "processing web request " <> show datafield
 
       markStarted 1 jobHandle
 
@@ -225,21 +247,21 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
       -- TODO if cid is folder -> create Corpus
       --      if cid is corpus -> add to corpus
       --      if cid is root   -> create corpus in Private
-      -- printDebug "[G.A.N.C.New] getDataText with query" q
+      $(logLocM) DEBUG $ T.pack $ "getDataText with query: " <> show q
       let db = database2origin dbs
-      mPubmedAPIKey <- getUserPubmedAPIKey user
+      -- mPubmedAPIKey <- getUserPubmedAPIKey user
       -- printDebug "[addToCorpusWithQuery] mPubmedAPIKey" mPubmedAPIKey
-      eTxt <- getDataText db (Multi l) q mPubmedAPIKey maybeLimit
+      eTxt <- getDataText db (Multi l) q mPubmedAPIKey mEPOAuthKey maybeLimit
 
       -- printDebug "[G.A.N.C.New] lTxts" lTxts
       case eTxt of
         Right txt -> do
           -- TODO Sum lenghts of each txt elements
-
+          $(logLocM) DEBUG "Processing dataText results"
           markProgress 1 jobHandle
 
-          void $ flowDataText user txt (Multi l) cid (Just flw) jobHandle
-          -- printDebug "corpus id" cids
+          corpusId <- flowDataText user txt (Multi l) cid (Just flw) jobHandle
+          $(logLocM) DEBUG $ T.pack $ "corpus id " <> show corpusId
           -- printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
           sendMail user
           -- TODO ...
@@ -247,6 +269,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
 
         Left err -> do
           -- printDebug "Error: " err
+          $(logLocM) ERROR (T.pack $ show err)
           markFailed (Just $ T.pack (show err)) jobHandle
 
 type AddWithForm = Summary "Add with FormUrlEncoded to corpus endpoint"

src/Gargantext/API/Node/DocumentUpload.hs

@@ -93,7 +93,7 @@ documentUpload nId doc = do
         Just c  -> c
         Nothing -> panic $ T.pack $ "[G.A.N.DU] Node has no corpus parent: " <> show nId
 
-  (theFullDate, (year, month, day)) <- liftBase $ dateSplit EN
+  (theFullDate, (year, month, day)) <- liftBase $ dateSplit
                                                         $ Just
                                                         $ view du_date doc
 

src/Gargantext/API/Prelude.hs

@@ -49,6 +49,7 @@ import Servant
 import Servant.Job.Async
 import Servant.Job.Core (HasServerError(..), serverError)
 import qualified Servant.Job.Types as SJ
+import Gargantext.System.Logging
 
 class HasJoseError e where
   _JoseError :: Prism' e Jose.Error
@@ -88,7 +89,7 @@ type GargServerC env err m =
 
 type GargServerT env err m api = GargServerC env err m => ServerT api m
 
-type GargServer api = forall env err m. GargServerT env err m api
+type GargServer api = forall env err m. MonadLogger m => GargServerT env err m api
 
 -- This is the concrete monad. It needs to be used as little as possible.
 type GargM env err = ReaderT env (ExceptT err IO)

src/Gargantext/Core.hs

@@ -17,6 +17,7 @@ module Gargantext.Core
 import Data.Aeson
 import Data.Either(Either(Left))
 import Data.Hashable (Hashable)
+import Data.LanguageCodes qualified as ISO639
 import Data.Maybe (fromMaybe)
 import Data.Morpheus.Types (GQLType)
 import Data.Swagger
@@ -45,6 +46,7 @@ import qualified Data.Map as Map
 -- | All languages supported
 -- NOTE: Use international country codes
 -- https://en.wikipedia.org/wiki/List_of_ISO_3166_country_codes
+-- TODO This should be deprecated in favor of iso-639 library
 data Lang = All
           | DE
           | EL
@@ -93,6 +95,28 @@ instance Hashable Lang
 instance Arbitrary Lang where
   arbitrary = arbitraryBoundedEnum
 
+toISO639 :: Lang -> Maybe ISO639.ISO639_1
+toISO639 DE = Just ISO639.DE
+toISO639 EL = Just ISO639.EL
+toISO639 EN = Just ISO639.EN
+toISO639 ES = Just ISO639.ES
+toISO639 FR = Just ISO639.FR
+toISO639 IT = Just ISO639.IT
+toISO639 PL = Just ISO639.PL
+toISO639 PT = Just ISO639.PT
+toISO639 RU = Just ISO639.RU
+toISO639 UK = Just ISO639.UK
+toISO639 ZH = Just ISO639.ZH
+toISO639 All = Nothing
+
+toISO639EN :: Lang -> ISO639.ISO639_1
+toISO639EN l = fromMaybe ISO639.EN $ toISO639 l
+
+iso639ToText :: ISO639.ISO639_1 -> Text
+iso639ToText la = pack [a, b]
+  where
+    (a, b) = ISO639.toChars la
+
 -- | https://en.wikipedia.org/wiki/List_of_ISO_639-1_codes
 toISO639Lang :: Lang -> Maybe Text
 toISO639Lang All = Nothing
@@ -108,6 +132,20 @@ toISO639Lang RU = Just "ru"
 toISO639Lang UK = Just "uk"
 toISO639Lang ZH = Just "zh"
 
+toGargLang :: ISO639.ISO639_1 -> Maybe Lang
+toGargLang ISO639.DE = Just DE
+toGargLang ISO639.EL = Just EL
+toGargLang ISO639.EN = Just EN
+toGargLang ISO639.ES = Just ES
+toGargLang ISO639.FR = Just FR
+toGargLang ISO639.IT = Just IT
+toGargLang ISO639.PL = Just PL
+toGargLang ISO639.PT = Just PT
+toGargLang ISO639.RU = Just RU
+toGargLang ISO639.UK = Just UK
+toGargLang ISO639.ZH = Just ZH
+toGargLang _         = Nothing
+
 allLangs :: [Lang]
 allLangs = [minBound .. maxBound]
 

src/Gargantext/Core/Text/Corpus/API.hs

@@ -19,13 +19,15 @@ module Gargantext.Core.Text.Corpus.API
   ) where
 
 import Conduit
+import Control.Monad.Except
 import Data.Bifunctor
 import Data.Either (Either(..))
+import Data.LanguageCodes qualified as ISO639
 import Data.Maybe
 import Data.Text qualified as T
-import EPO qualified as EPO
+import EPO qualified
 import Gargantext.API.Admin.Orchestrator.Types (ExternalAPIs(..), externalAPIs)
-import Gargantext.Core (Lang(..))
+import Gargantext.Core (Lang(..), toISO639)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
 import Gargantext.Prelude
 import Gargantext.Core.Text.Corpus.API.Arxiv   qualified as Arxiv
@@ -56,20 +58,27 @@ get :: ExternalAPIs
     -- -> IO [HyperdataDocument]
     -> IO (Either GetCorpusError (Maybe Integer, ConduitT () HyperdataDocument IO ()))
 get externalAPI la q mPubmedAPIKey mEPOAuthKey limit = do
-  case Corpus.parseQuery q of
-    Left err -> pure $ Left $ InvalidInputQuery q (T.pack err)
-    Right corpusQuery -> case externalAPI of
-      OpenAlex -> first ExternalAPIError <$>
-                    OpenAlex.get (fromMaybe "" Nothing {- email -}) q la limit
-      PubMed -> first ExternalAPIError <$>
-                  PUBMED.get (fromMaybe "" mPubmedAPIKey) corpusQuery limit
-      --docs <- PUBMED.get   q default_limit -- EN only by default
-      --pure (Just $ fromIntegral $ length docs, yieldMany docs)
-      Arxiv   -> Right <$> Arxiv.get la corpusQuery limit
-      HAL     -> first ExternalAPIError <$> HAL.getC  la (Corpus.getRawQuery q) (Corpus.getLimit <$> limit)
-      IsTex   -> do docs <- ISTEX.get la (Corpus.getRawQuery q) (Corpus.getLimit <$> limit)
-                    pure $ Right (Just $ fromIntegral $ length docs, yieldMany docs)
-      Isidore -> do docs <- ISIDORE.get la (Corpus.getLimit <$> limit) (Just $ Corpus.getRawQuery q) Nothing
-                    pure $ Right (Just $ fromIntegral $ length docs, yieldMany docs)
-      EPO -> first ExternalAPIError <$>
-               EPOAPI.get mEPOAuthKey q la limit
+  -- For PUBMED, HAL, IsTex, Isidore and OpenAlex, we want to send the query as-it.
+  -- For Arxiv we parse the query into a structured boolean query we submit over.
+  case externalAPI of
+      PubMed   ->
+        first ExternalAPIError <$> PUBMED.get (fromMaybe "" mPubmedAPIKey) q limit
+      OpenAlex ->
+        first ExternalAPIError <$> OpenAlex.get (fromMaybe "" Nothing {- email -}) q langISO639 limit
+      Arxiv    -> runExceptT $ do
+        corpusQuery <- ExceptT (pure parse_query)
+        ExceptT $ fmap Right (Arxiv.get la corpusQuery limit)
+      HAL      ->
+        first ExternalAPIError <$> HAL.getC langISO639 (Corpus.getRawQuery q) (Corpus.getLimit <$> limit)
+      IsTex    -> do
+        docs <- ISTEX.get la (Corpus.getRawQuery q) (Corpus.getLimit <$> limit)
+        pure $ Right (Just $ fromIntegral $ length docs, yieldMany docs)
+      Isidore  -> do
+        docs <- ISIDORE.get la (Corpus.getLimit <$> limit) (Just $ Corpus.getRawQuery q) Nothing
+        pure $ Right (Just $ fromIntegral $ length docs, yieldMany docs)
+      EPO -> do
+        (count, docsC) <- EPOAPI.get mEPOAuthKey q (fromMaybe ISO639.EN langISO639) limit
+        pure $ Right (Just count, docsC)
+  where
+    parse_query = first (InvalidInputQuery q . T.pack) $ Corpus.parseQuery q
+    langISO639 = toISO639 la

src/Gargantext/Core/Text/Corpus/API/Hal.hs

@@ -18,7 +18,7 @@ import Data.LanguageCodes qualified as ISO639
 import Data.Map.Strict qualified as Map
 import Data.Maybe
 import Data.Text (Text, pack, intercalate)
-import Gargantext.Core (Lang(..))
+-- import Gargantext.Core (Lang(..), toISO639Lang)
 import Gargantext.Core.Text.Corpus.Parsers.Date qualified as Date
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
 import Gargantext.Defaults qualified as Defaults
@@ -28,40 +28,29 @@ import HAL.Client qualified as HAL
 import HAL.Doc.Corpus qualified as HAL
 import Servant.Client (ClientError)
 
-toLang :: Lang -> Maybe ISO639.ISO639_1
-toLang DE = Just ISO639.DE
-toLang EL = Just ISO639.EL
-toLang EN = Just ISO639.EN
-toLang ES = Just ISO639.ES
-toLang FR = Just ISO639.FR
-toLang IT = Just ISO639.IT
-toLang PL = Just ISO639.PL
-toLang PT = Just ISO639.PT
-toLang RU = Just ISO639.RU
-toLang UK = Just ISO639.UK
-toLang ZH = Just ISO639.ZH
-toLang All = Nothing
-
-get :: Lang -> Text -> Maybe Int -> IO [HyperdataDocument]
+get :: Maybe ISO639.ISO639_1 -> Text -> Maybe Int -> IO [HyperdataDocument]
 get la q ml = do
-  eDocs <- HAL.getMetadataWith [q] (Just 0) (fromIntegral <$> ml) (toLang la)
+  eDocs <- HAL.getMetadataWith [q] (Just 0) (fromIntegral <$> ml) la
   either (panic . pack . show) (\d -> mapM (toDoc' la) $ HAL._docs d) eDocs
 
-getC :: Lang -> Text -> Maybe Int -> IO (Either ClientError (Maybe Integer, ConduitT () HyperdataDocument IO ()))
+getC :: Maybe ISO639.ISO639_1
+     -> Text
+     -> Maybe Int
+     -> IO (Either ClientError (Maybe Integer, ConduitT () HyperdataDocument IO ()))
 getC la q ml = do
-  eRes <- HAL.getMetadataWithC [q] (Just 0) (fromIntegral <$> ml) (toLang la)
+  eRes <- HAL.getMetadataWithC [q] (Just 0) (fromIntegral <$> ml) la
   pure $ (\(len, docsC) -> (len, docsC .| mapMC (toDoc' la))) <$> eRes
 --  case eRes of
 --    Left err -> panic $ pack $ show err
 --    Right (len, docsC) -> pure (len, docsC .| mapMC (toDoc' la))
 
-toDoc' :: Lang -> HAL.Corpus -> IO HyperdataDocument
+toDoc' :: Maybe ISO639.ISO639_1 -> HAL.Corpus -> IO HyperdataDocument
 toDoc' la (HAL.Corpus { .. }) = do
   -- printDebug "[toDoc corpus] h" h
   (utctime, (pub_year, pub_month, pub_day)) <-
-        Date.dateSplit la (maybe (Just $ pack $ show Defaults.year) Just _corpus_date)
+        Date.dateSplit (maybe (Just $ pack $ show Defaults.year) Just _corpus_date)
   let abstractDefault = intercalate " " _corpus_abstract
-  let abstract = case toLang la of
+  let abstract = case la of
         Nothing -> abstractDefault
         Just l  -> fromMaybe abstractDefault (intercalate " " <$> Map.lookup l _corpus_abstract_lang_map)
   pure HyperdataDocument { _hd_bdd = Just "Hal"

src/Gargantext/Core/Text/Corpus/API/Isidore.hs

@@ -35,13 +35,13 @@ get la l q a = do
   let
     printErr (DecodeFailure e _) = panic e
     printErr e                   = panic (cs $ show e)
-    
+
     toIsidoreDocs :: Reply -> [IsidoreDoc]
     toIsidoreDocs (ReplyOnly r) = [r]
     toIsidoreDocs (Replies  rs) = rs
 
   iDocs <- either printErr _content <$> Isidore.get l q a
-  
+
   hDocs <- mapM (\d -> isidoreToDoc la d) (toIsidoreDocs iDocs)
   pure hDocs
 
@@ -58,7 +58,7 @@ isidoreToDoc l (IsidoreDoc t a d u s as) = do
     author :: Author -> Text
     author (Author fn ln) = (_name fn) <> ", " <> (_name ln)
     author (Authors aus) = Text.intercalate ". " $ map author aus
-    
+
     creator2text :: Creator -> Text
     creator2text (Creator au)   = author au
     creator2text (Creators aus') = Text.intercalate ". " $ map author aus'
@@ -67,9 +67,9 @@ isidoreToDoc l (IsidoreDoc t a d u s as) = do
     langText (LangText _l t1) = t1
     langText (OnlyText t2   ) = t2
     langText (ArrayText ts  ) = Text.intercalate " " $ map langText ts
-    
-  (utcTime, (pub_year, pub_month, pub_day)) <- Date.dateSplit l (maybe (Just $ Text.pack $ show Defaults.year) (Just) d)
-    
+
+  (utcTime, (pub_year, pub_month, pub_day)) <- Date.dateSplit (maybe (Just $ Text.pack $ show Defaults.year) (Just) d)
+
   pure HyperdataDocument
          { _hd_bdd = Just "Isidore"
          , _hd_doi = Nothing
@@ -91,5 +91,3 @@ isidoreToDoc l (IsidoreDoc t a d u s as) = do
          , _hd_publication_second = Nothing
          , _hd_language_iso2 = Just $ (Text.pack . show) l
          }
-
-

src/Gargantext/Core/Text/Corpus/API/Istex.hs

@@ -82,7 +82,7 @@ toDoc :: Lang -> ISTEX.Document -> IO HyperdataDocument
 toDoc la (ISTEX.Document i t a ab d s) = do
   --printDebug "ISTEX date" d
   (utctime, (pub_year, pub_month, pub_day)) <-
-        Date.dateSplit la (maybe (Just $ pack $ show Defaults.year) (Just . pack . show) d)
+        Date.dateSplit (maybe (Just $ pack $ show Defaults.year) (Just . pack . show) d)
   --printDebug "toDoc Istex" (utctime, (pub_year, pub_month, pub_day))
   pure $ HyperdataDocument { _hd_bdd       = Just "Istex"
                            , _hd_doi       = Just i

src/Gargantext/Core/Text/Corpus/API/OpenAlex.hs

@@ -10,8 +10,9 @@ Portability : POSIX
 module Gargantext.Core.Text.Corpus.API.OpenAlex where
 
 import Conduit
+import Data.LanguageCodes qualified as ISO639
 import Data.Text qualified as T
-import Gargantext.Core (Lang, toISO639Lang)
+import Gargantext.Core (iso639ToText)
 import Gargantext.Core.Text.Corpus.Query as Corpus
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
 import Protolude
@@ -22,12 +23,12 @@ import Servant.Client (ClientError)
 
 get :: Text
     -> Corpus.RawQuery
-    -> Lang
+    -> Maybe ISO639.ISO639_1
     -> Maybe Limit
     -> IO (Either ClientError (Maybe Integer, ConduitT () HyperdataDocument IO ()))
 get _email q lang mLimit = do
-  let limit = getLimit $ fromMaybe 10000 mLimit
-  let mFilter = (\l -> "language:" <> l) <$> toISO639Lang lang
+  let limit = getLimit $ fromMaybe 1000 mLimit
+  let mFilter = (\l -> "language:" <> iso639ToText l) <$> lang
   eRes <- OA.fetchWorksC Nothing mFilter $ Just $ Corpus.getRawQuery q
   pure $ (\(len, docsC) -> (len, docsC .| takeC limit .| mapC toDoc)) <$> eRes
 

src/Gargantext/Core/Text/Corpus/API/Pubmed.hs

@@ -45,6 +45,15 @@ import PUBMED.Types (Config(..))
 
 -- | A pubmed query.
 -- See: https://www.ncbi.nlm.nih.gov/books/NBK25499/#chapter4.ESearch
+-- The documentation for PUBMED says:
+-- Values for query keys may also be provided in term if they are preceeded by a
+-- '#' (%23 in the URL). While only one query_key parameter can be provided to ESearch,
+-- any number of query keys can be combined in term. Also, if query keys are provided in term,
+-- they can be combined with OR or NOT in addition to AND.
+-- Example:
+-- esearch.fcgi?db=pubmed&term=%231+AND+asthma&WebEnv=<webenv string>&usehistory=y
+--
+-- Therefore, we can pretty-print our 'Query' back into something that PubMed could understand.
 newtype ESearch = ESearch { _ESearch :: [EscapeItem] }
   deriving stock (Show, Eq)
   deriving newtype (Semigroup, Monoid)
@@ -86,24 +95,15 @@ convertQuery q = ESearch (interpretQuery q transformAST)
       BConst (Negative (Term term))
         -> [QN "NOT+", QE (TE.encodeUtf8 term)]
 
--- | TODO put default pubmed query in gargantext.ini
--- by default: 10K docs
 get :: Text
-    -> Corpus.Query
+    -> Corpus.RawQuery
     -> Maybe Limit
     -> IO (Either ClientError (Maybe Integer, ConduitT () HyperdataDocument IO ()))
 get apiKey q l = do
-  -- The documentation for PUBMED says:
-  -- Values for query keys may also be provided in term if they are preceeded by a
-  -- '#' (%23 in the URL). While only one query_key parameter can be provided to ESearch,
-  -- any number of query keys can be combined in term. Also, if query keys are provided in term,
-  -- they can be combined with OR or NOT in addition to AND.
-  -- Example:
-  -- esearch.fcgi?db=pubmed&term=%231+AND+asthma&WebEnv=<webenv string>&usehistory=y
-  --
-  -- Therefore, we can pretty-print our 'Query' back into something that PubMed could understand.
+  -- NOTE(adinapoli): For now we do not interpret the PUBMED query into something
+  -- more structured, like an 'ESearch' term, but we could, in the future.
   eRes <- runReaderT PubMed.getMetadataWithC (Config { apiKey  = Just apiKey
-                                                     , query   = getESearch $ convertQuery q
+                                                     , query   = getRawQuery q
                                                      , perPage = Just 200
                                                      , mWebEnv = Nothing })
   let takeLimit = case l of

src/Gargantext/Core/Text/Corpus/Parsers.hs

@@ -236,7 +236,7 @@ toDoc ff d = do
 
       let dateToParse = DT.replace " " "" <$> lookup "PY" d  -- <> Just " " <> lookup "publication_date" d
       -- printDebug "[G.C.T.C.Parsers] dateToParse" dateToParse
-      (utcTime, (pub_year, pub_month, pub_day)) <- Date.dateSplit lang dateToParse
+      (utcTime, (pub_year, pub_month, pub_day)) <- Date.dateSplit dateToParse
 
       let hd = HyperdataDocument { _hd_bdd = Just $ DT.pack $ show ff
                              , _hd_doi = lookup "doi" d

src/Gargantext/Core/Text/Corpus/Parsers/Date.hs

@@ -48,10 +48,10 @@ import qualified Data.List         as List
 ------------------------------------------------------------------------
 -- | Parse date to Ints
 -- TODO add hours, minutes and seconds
-dateSplit :: Lang -> Maybe Text -> IO (Maybe UTCTime, (Maybe Year, Maybe Month, Maybe Day))
-dateSplit _ Nothing    = pure (Nothing, (Nothing, Nothing, Nothing))
-dateSplit l (Just txt) = do
-  utcTime <- parse l txt
+dateSplit :: Maybe Text -> IO (Maybe UTCTime, (Maybe Year, Maybe Month, Maybe Day))
+dateSplit Nothing    = pure (Nothing, (Nothing, Nothing, Nothing))
+dateSplit (Just txt) = do
+  utcTime <- parse txt
   let (y, m, d) = split' utcTime
   pure (Just utcTime, (Just y, Just m,Just d))
 
@@ -72,15 +72,15 @@ type Day   = Int
 -- 1900-04-01 19:00:00 UTC
 -- >>> parse EN (pack "April 1 1900")
 -- 1900-04-01 00:00:00 UTC
-parse :: Lang -> Text -> IO UTCTime
-parse lang s = do
+parse :: Text -> IO UTCTime
+parse s = do
   -- printDebug "Date: " s
   let result = dateFlow (DucklingFailure s)
   --printDebug "Date': " dateStr'
   case result of
     DateFlowSuccess ok -> pure ok
     DateFlowFailure    -> (withDebugMode (DebugMode True)
-                                        "[G.C.T.P.T.Date parse]" (lang,s)
+                                        "[G.C.T.P.T.Date parse]" s
                                         $ getCurrentTime)
     _                   -> panic "[G.C.T.C.Parsers.Date] parse: Should not happen"
 
@@ -206,4 +206,3 @@ parseDateWithDuckling lang input options = do
   --pure $ parseAndResolve (rulesFor (locale ctx) (HashSet.fromList [(This Time)])) input ctx
   -- TODO check/test Options False or True
   analyze input contxt options $ HashSet.fromList [(Seal Time)]
-

src/Gargantext/Core/Text/Corpus/Parsers/Wikidata.hs

 {-|
 Module      : Gargantext.Core.Text.Corpus.Parsers.Wikidata
 <<<<<<< HEAD
-Description : To query Wikidata 
+Description : To query Wikidata
 =======
 Description : To query Wikidata
 >>>>>>> dev-clustering
@@ -68,7 +68,7 @@ wikiPageToDocument m wr = do
       source     = Nothing
       abstract   = Just $ concat $ take m sections
 
-  (date, (year, month, day)) <- dateSplit EN $ head
+  (date, (year, month, day)) <- dateSplit $ head
                     $ catMaybes
                     [ wr ^. wr_yearStart
                     , wr ^. wr_yearEnd
@@ -130,4 +130,3 @@ wikidataQuery n = List.unlines
       ,"     }"
       ,"       LIMIT " <> (cs $ show n)
       ]
-

src/Gargantext/Core/Text/Terms/Multi/PosTagging.hs

@@ -22,11 +22,13 @@ Source: https://en.wikipedia.org/wiki/Part-of-speech_tagging
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeOperators     #-}
 
-module Gargantext.Core.Text.Terms.Multi.PosTagging
-  where
+module Gargantext.Core.Text.Terms.Multi.PosTagging where
 
+import Control.Exception (catch, throwIO)
 import Data.Aeson
+import Data.ByteString.Lazy.Char8 qualified as BSL
 import Data.ByteString.Lazy.Internal (ByteString)
+import Data.Map qualified as Map
 import Data.Set (fromList)
 import Data.Text (Text, splitOn, pack, toLower)
 import Gargantext.Core (Lang(..))
@@ -35,8 +37,6 @@ import Gargantext.Core.Types
 import Gargantext.Prelude
 import Network.HTTP.Simple
 import Network.URI (URI(..))
-import qualified Data.ByteString.Lazy.Char8 as BSL
-import qualified Data.Map as Map
 
 -- import qualified Gargantext.Utils.SpacyNLP as SpacyNLP
 
@@ -82,7 +82,15 @@ corenlp' uri lang txt = do
   req <- parseRequest $
          "POST " <> show (uri { uriQuery = "?properties=" <> (BSL.unpack $ encode $ toJSON $ Map.fromList properties) })
    -- curl -XPOST 'http://localhost:9000/?properties=%7B%22annotators%22:%20%22tokenize,ssplit,pos,ner%22,%20%22outputFormat%22:%20%22json%22%7D' -d 'hello world, hello' | jq .
-  httpJSON $ setRequestBodyLBS (cs txt) req
+  --   printDebug "[corenlp] sending body" $ (cs txt :: ByteString)
+  catch (httpJSON $ setRequestBodyLBS (cs txt) req) $ \e ->
+    case e of
+      JSONParseException _req res _err -> do
+        let body = getResponseBody res
+        printDebug "[corenlp'] request text" (cs txt :: ByteString)
+        printDebug "[corenlp'] response body (error)" body
+        throwIO e
+      JSONConversionException _req _res _err -> throwIO e
   where
     properties_ :: [(Text, Text)]
     properties_ = case lang of

src/Gargantext/Core/Types/Individu.hs

+{-# LANGUAGE CPP #-}
+
 {-|
 Module      : Gargantext.Core.Types.Individu
 Description : Short description
@@ -15,11 +17,11 @@ Individu defintions
 module Gargantext.Core.Types.Individu
   where
 
-import Data.Aeson
 import Control.Monad.IO.Class (MonadIO)
-import GHC.Generics (Generic)
+import Data.Aeson
 import Data.Swagger
 import Data.Text (Text, pack, reverse)
+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
@@ -68,8 +70,15 @@ toUserHash :: MonadIO m
          =>    NewUser GargPassword
          -> m (NewUser HashPassword)
 toUserHash (NewUser u m (GargPassword p)) = do
-  h <- Auth.createPasswordHash p
+  salt <- Auth.newSalt
+  let h = Auth.hashPasswordWithSalt params salt (Auth.mkPassword p)
   pure $ NewUser u m h
+  where
+#if TEST_CRYPTO
+    params = Auth.defaultParams { Auth.argon2MemoryCost = 4096 }
+#else
+    params = Auth.defaultParams
+#endif
 
 -- TODO remove
 arbitraryUsersHash :: MonadIO m

src/Gargantext/Database/Action/Flow.hs

@@ -55,21 +55,34 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
 
 import Conduit
 import Control.Lens hiding (elements, Indexed)
+import Control.Monad (void)
 import Data.Aeson.TH (deriveJSON)
+import Data.Conduit qualified as C
 import Data.Conduit.Internal (zipSources)
+import Data.Conduit.List qualified as CL
+import Data.Conduit.List qualified as CList
 import Data.Either
+import Data.Foldable (for_)
 import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HashMap
 import Data.Hashable (Hashable)
 import Data.List (concat)
+import Data.List qualified as List
 import Data.Map.Strict (Map, lookup)
+import Data.Map.Strict qualified as Map
 import Data.Maybe (catMaybes)
 import Data.Monoid
 import Data.Proxy
 import Data.Set (Set)
+import Data.Set qualified as Set
 import Data.Swagger
+import Data.Text qualified as T
 import Data.Tuple.Extra (first, second)
+import EPO qualified
 import GHC.Generics (Generic)
+import GHC.Num (fromInteger)
 import Gargantext.API.Ngrams.Tools (getTermsWith)
+import Gargantext.API.Ngrams.Types qualified as NT
 import Gargantext.Core (Lang(..), PosTagAlgo(..))
 import Gargantext.Core (withDefaultLanguage)
 import Gargantext.Core.Ext.IMTUser (readFile_Annuaire)
@@ -77,6 +90,7 @@ import Gargantext.Core.Flow.Types
 import Gargantext.Core.NLP (nlpServerGet)
 import Gargantext.Core.NodeStory (HasNodeStory)
 import Gargantext.Core.Text
+import Gargantext.Core.Text.Corpus.API qualified as API
 import Gargantext.Core.Text.Corpus.Parsers (parseFile, FileFormat, FileType, splitOn)
 import Gargantext.Core.Text.List (buildNgramsLists)
 import Gargantext.Core.Text.List.Group.WithStem ({-StopSize(..),-} GroupParams(..))
@@ -90,6 +104,7 @@ import Gargantext.Core.Types.Main
 import Gargantext.Core.Types.Query (Limit)
 import Gargantext.Core.Utils (addTuples)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Data.HashMap.Strict.Utils qualified as HashMap
 import Gargantext.Database.Action.Flow.List
 import Gargantext.Database.Action.Flow.Types
 import Gargantext.Database.Action.Flow.Utils (insertDocNgrams, DocumentIdWithNgrams(..))
@@ -97,11 +112,12 @@ import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContex
 import Gargantext.Database.Action.Search (searchDocInDatabase)
 import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
 import Gargantext.Database.Admin.Types.Hyperdata
-import Gargantext.Database.Admin.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
+import Gargantext.Database.Admin.Types.Node hiding (DEBUG) -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.ContextNodeNgrams2
 import Gargantext.Database.Query.Table.Ngrams
 import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Query.Table.Node.Document.Add qualified as Doc (add)
 import Gargantext.Database.Query.Table.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
@@ -113,26 +129,16 @@ import Gargantext.Database.Schema.Node (node_hyperdata)
 import Gargantext.Database.Types
 import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Hash (Hash)
+import Gargantext.System.Logging
 import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
+import PUBMED.Types qualified as PUBMED
 import System.FilePath (FilePath)
-import qualified Data.Conduit      as C
-import qualified Data.Conduit.List as CL
-import qualified Data.Conduit.List as CList
-import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Map.Strict as Map
-import qualified Data.Set            as Set
-import qualified Data.Text as T
-import qualified Gargantext.API.Ngrams.Types as NT
-import qualified Gargantext.Core.Text.Corpus.API as API
-import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
-import qualified Gargantext.Database.Query.Table.Node.Document.Add  as Doc  (add)
-import qualified PUBMED.Types as PUBMED
 
 ------------------------------------------------------------------------
 -- Imports for upgrade function
 import Gargantext.Database.Query.Tree.Root (getRootId)
 import Gargantext.Database.Query.Tree (findNodesId)
-import qualified Data.List as List
+
 ------------------------------------------------------------------------
 -- TODO use internal with API name (could be old data)
 data DataOrigin = InternalOrigin { _do_api :: API.ExternalAPIs }
@@ -166,12 +172,13 @@ getDataText :: FlowCmdM env err m
             -> TermType Lang
             -> API.RawQuery
             -> Maybe PUBMED.APIKey
+            -> Maybe EPO.AuthKey
             -> Maybe API.Limit
             -> m (Either API.GetCorpusError DataText)
-getDataText (ExternalOrigin api) la q mPubmedAPIKey li = do
-  eRes <- liftBase $ API.get api (_tt_lang la) q mPubmedAPIKey li
+getDataText (ExternalOrigin api) la q mPubmedAPIKey mEPOAuthKey li = do
+  eRes <- liftBase $ API.get api (_tt_lang la) q mPubmedAPIKey mEPOAuthKey li
   pure $ DataNew <$> eRes
-getDataText (InternalOrigin _) _la q _ _li = do
+getDataText (InternalOrigin _) _la q _ _ _li = do
   (_masterUserId, _masterRootId, cId) <- getOrMk_RootWithCorpus
                                            (UserName userMaster)
                                            (Left "")
@@ -186,7 +193,7 @@ getDataText_Debug :: FlowCmdM env err m
             -> Maybe API.Limit
             -> m ()
 getDataText_Debug a l q li = do
-  result <- getDataText a l q Nothing li
+  result <- getDataText a l q Nothing Nothing li
   case result of
     Left  err -> liftBase $ putStrLn $ show err
     Right res -> liftBase $ printDataText res
@@ -205,12 +212,15 @@ flowDataText :: forall env err m.
                 -> JobHandle m
                 -> m CorpusId
 flowDataText u (DataOld ids) tt cid mfslw _ = do
+  $(logLocM) DEBUG $ T.pack $ "Found " <> show (length ids) <> " old node IDs"
   (_userId, userCorpusId, listId) <- createNodes u (Right [cid]) corpusType
   _ <- Doc.add userCorpusId ids
   flowCorpusUser (_tt_lang tt) u userCorpusId listId corpusType mfslw
   where
     corpusType = (Nothing :: Maybe HyperdataCorpus)
-flowDataText u (DataNew (mLen, txtC)) tt cid mfslw jobHandle =
+flowDataText u (DataNew (mLen, txtC)) tt cid mfslw jobHandle = do
+  $(logLocM) DEBUG $ T.pack $ "Found " <> show mLen <> " new documents to process"
+  for_ (mLen <&> fromInteger) (`addMoreSteps` jobHandle)
   flowCorpus u (Right [cid]) tt mfslw (mLen, (transPipe liftBase txtC)) jobHandle
 
 ------------------------------------------------------------------------
@@ -279,59 +289,23 @@ 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
+  runConduit $ zipSources (yieldMany [1..]) docsC
                  .| CList.chunksOf 100
-                 .| mapMC insertDocs'
-                 .| mapM_C (\ids' -> do
-                               _ <- Doc.add userCorpusId ids'
-                               pure ())
-                 .| sinkList
-
-  _ <- flowCorpusUser (la ^. tt_lang) u userCorpusId listId c mfslw
-
---  ids <- traverse (\(idx, doc) -> do
---                      id <- insertMasterDocs c la doc
---                      logStatus JobLog { _scst_succeeded = Just $ 1 + idx
---                                       , _scst_failed    = Just 0
---                                       , _scst_remaining = Just $ length docs - idx
---                                       , _scst_events    = Just []
---                                       }
---                      pure id
---                  ) (zip [1..] docs)
-  --printDebug "[flow] calling flowCorpusUser" (0 :: Int)
-  pure userCorpusId
-  --flowCorpusUser (la ^. tt_lang) u cn c ids mfslw
+                 .| mapM_C (\docs -> void $ insertDocs' docs >>= Doc.add 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
-      -- printDebug "[flow] calling insertDoc, ([idx], mLength) = " (fst <$> docs, mLength)
+      $(logLocM) DEBUG $ T.pack $ "calling insertDoc, ([idx], mLength) = " <> show (fst <$> docs, mLength)
       ids <- insertMasterDocs c la (snd <$> docs)
-      let maxIdx = maximum (fst <$> docs)
-      case mLength of
-        Nothing -> pure ()
-        Just _len -> do
-
-          let succeeded = fromIntegral (1 + maxIdx)
-          -- let remaining = fromIntegral (len - maxIdx)
-          -- Reconstruct the correct update state by using 'markStarted' and the other primitives.
-          -- We do this slightly awkward arithmetic such that when we call 'markProgress' we reduce
-          -- the number of 'remaining' of exactly '1 + maxIdx', and we will end up with a 'JobLog'
-          -- looking like this:
-          -- JobLog
-          -- { _scst_succeeded = Just $ fromIntegral $ 1 + maxIdx
-          -- , _scst_failed    = Just 0
-          -- , _scst_remaining = Just $ fromIntegral $ len - maxIdx
-          -- , _scst_events    = Just []
-          -- }
-          -- markStarted (remaining + succeeded) jobHandle
-          markProgress succeeded jobHandle
-
+      markProgress (length docs) jobHandle
       pure ids
 
-
-
 ------------------------------------------------------------------------
 createNodes :: ( FlowCmdM env err m
                , MkCorpus c

src/Gargantext/Database/Action/Flow/Types.hs

@@ -30,6 +30,7 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Prelude (CmdM)
 import Gargantext.Database.Query.Table.Node.Document.Insert
 import Gargantext.Database.Query.Tree.Error (HasTreeError)
+import Gargantext.System.Logging
 
 type FlowCmdM env err m =
   ( CmdM     env err m
@@ -37,6 +38,7 @@ type FlowCmdM env err m =
   , HasNodeError err
   , HasInvalidError err
   , HasTreeError err
+  , MonadLogger m
   )
 
 type FlowCorpus a = ( AddUniqId      a

src/Gargantext/Database/Action/User.hs

@@ -16,7 +16,7 @@ module Gargantext.Database.Action.User
 import Data.Text (Text)
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (Cmd, DBCmd)
+import Gargantext.Database.Prelude (DBCmd)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.User
 import Gargantext.Database.Query.Table.Node.Error
@@ -24,14 +24,14 @@ import Gargantext.Database.Schema.Node
 import Gargantext.Prelude
 
 ------------------------------------------------------------------------
-getUserLightWithId :: HasNodeError err => Int -> Cmd err UserLight
+getUserLightWithId :: HasNodeError err => UserId -> DBCmd err UserLight
 getUserLightWithId i = do
   candidates <- head <$> getUsersWithId (UserDBId i)
   case candidates of
     Nothing -> nodeError NoUserFound
     Just u  -> pure u
 
-getUserLightDB :: HasNodeError err => User -> Cmd err UserLight
+getUserLightDB :: HasNodeError err => User -> DBCmd err UserLight
 getUserLightDB u = do
   userId <- getUserId u
   userLight <- getUserLightWithId userId

src/Gargantext/Database/Action/User/New.hs

@@ -28,6 +28,7 @@ import Gargantext.Core.Mail
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Action.Flow (getOrMkRoot)
+import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..))
 import Gargantext.Database.Query.Table.User
@@ -41,13 +42,13 @@ import qualified Data.Text as Text
 -- be valid (i.e. a valid username needs to be inferred via 'guessUsername').
 newUser :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
         => EmailAddress
-        -> m Int64
+        -> m UserId
 newUser emailAddress = do
   cfg <- view mailSettings
   pwd <- gargPass
   let nur = mkNewUser emailAddress (GargPassword pwd)
-  affectedRows <- new_user nur
-  withNotification (SendEmail True) cfg Invitation $ pure (affectedRows, nur)
+  new_user_id <- new_user nur
+  withNotification (SendEmail True) cfg Invitation $ pure (new_user_id, nur)
 
 ------------------------------------------------------------------------
 -- | A DB-specific action to create a single user.
@@ -56,8 +57,12 @@ newUser emailAddress = do
 -- use 'newUser' instead for standard Gargantext code.
 new_user :: HasNodeError err
          => NewUser GargPassword
-         -> DBCmd err Int64
-new_user = new_users . (:[])
+         -> DBCmd err UserId
+new_user rq = do
+  ur <- new_users [rq]
+  case head ur of
+    Nothing   -> nodeError MkNode
+    Just uid  -> pure uid
 
 ------------------------------------------------------------------------
 -- | A DB-specific action to bulk-create users.
@@ -67,17 +72,16 @@ new_user = new_users . (:[])
 new_users :: HasNodeError err
           => [NewUser GargPassword]
           -- ^ A list of users to create.
-          -> DBCmd err Int64
+          -> DBCmd err [UserId]
 new_users us = do
-  us' <- liftBase         $ mapM toUserHash us
-  r   <- insertUsers      $ map  toUserWrite us'
-  _   <- mapM getOrMkRoot $ map  (\u -> UserName   (_nu_username u)) us
-  pure r
+  us'   <- liftBase        $ mapM toUserHash us
+  void  $ insertUsers      $ map  toUserWrite us'
+  mapM (fmap fst . getOrMkRoot) $ map  (\u -> UserName   (_nu_username u)) us
 
 ------------------------------------------------------------------------
 newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
          => [EmailAddress]
-         -> m Int64
+         -> m [UserId]
 newUsers us = do
   config <- view $ mailSettings
   us' <- mapM (\ea -> mkNewUser ea . GargPassword <$> gargPass) us
@@ -102,14 +106,14 @@ guessUserName n = case splitOn "@" n of
 
 ------------------------------------------------------------------------
 newUsers' :: HasNodeError err
-         => MailConfig -> [NewUser GargPassword] -> Cmd err Int64
+         => MailConfig -> [NewUser GargPassword] -> Cmd err [UserId]
 newUsers' cfg us = do
   us' <- liftBase         $ mapM toUserHash  us
-  r   <- insertUsers      $ map  toUserWrite us'
-  _   <- mapM getOrMkRoot $ map  (\u -> UserName   (_nu_username u)) us
+  void $ insertUsers      $ map  toUserWrite us'
+  urs <- mapM (fmap fst . getOrMkRoot) $ map  (\u -> UserName   (_nu_username u)) us
   _   <- mapM (\u -> mail cfg (Invitation u)) us
   -- printDebug "newUsers'" us
-  pure r
+  pure urs
 
 ------------------------------------------------------------------------
 -- | Updates a user's password, notifying the user via email, if necessary.

src/Gargantext/Database/Query/Table/Node.hs

@@ -195,7 +195,7 @@ getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument
 getListsModelWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataModel]
 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
 
-getCorporaWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataCorpus]
+getCorporaWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataCorpus]
 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 
 ------------------------------------------------------------------------
@@ -271,7 +271,7 @@ getNodeWith nId _ = do
 ------------------------------------------------------------------------
 -- | Sugar to insert Node with NodeType in Database
 insertDefaultNode :: HasDBid NodeType
-                  => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
+                  => NodeType -> ParentId -> UserId -> DBCmd err [NodeId]
 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 
 insertDefaultNodeIfNotExists :: HasDBid NodeType
@@ -382,7 +382,7 @@ data CorpusType = CorpusDocument | CorpusContact
 
 class MkCorpus a
   where
-    mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
+    mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> DBCmd err [NodeId]
 
 instance MkCorpus HyperdataCorpus
   where

src/Gargantext/Database/Query/Table/Node/Document/Add.hs

@@ -39,6 +39,13 @@ add pId ns = runPGSQuery queryAdd (Only $ Values fields inputData)
     fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
     inputData = prepare pId ns
 
+-- | Adds a single document. Useful for debugging purposes, but
+-- not as efficient as adding documents in bulk via 'add'.
+add_one :: CorpusId -> ContextId -> Cmd err [Only Int]
+add_one pId ctxId = runPGSQuery queryAdd (Only $ Values fields [InputData pId ctxId])
+  where
+    fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
+
 add_debug :: CorpusId -> [ContextId] -> Cmd err ByteString
 add_debug pId ns = formatPGSQuery queryAdd (Only $ Values fields inputData)
   where

src/Gargantext/Database/Query/Table/Node/Document/Insert.hs

@@ -58,7 +58,7 @@ import Control.Lens (set, view)
 import Control.Lens.Cons
 import Control.Lens.Prism
 import Data.Aeson (toJSON, ToJSON)
-import Data.Char (isAlpha)
+import Data.Char (isAlphaNum)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 -- import Data.ByteString (ByteString)
@@ -233,7 +233,7 @@ instance UniqParameters (Node a)
 
 
 filterText :: Text -> Text
-filterText = DT.toLower . (DT.filter isAlpha)
+filterText = DT.toLower . (DT.filter isAlphaNum)
 
 
 instance (UniqParameters a, ToJSON a, HasDBid NodeType) => AddUniqId (Node a)

src/Gargantext/Database/Query/Table/Node/UpdateOpaleye.hs

@@ -26,7 +26,7 @@ import Gargantext.Database.Prelude (Cmd, mkCmd, DBCmd)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Error
 
-import Debug.Trace (trace)
+-- import Debug.Trace (trace)
 
 updateHyperdata :: HyperdataC a => NodeId -> a -> DBCmd err Int64
 updateHyperdata i h = mkCmd $ \c -> putStrLn "before runUpdate_" >>
@@ -34,7 +34,7 @@ updateHyperdata i h = mkCmd $ \c -> putStrLn "before runUpdate_" >>
                                     putStrLn "after runUpdate_" >> return res
 
 updateHyperdataQuery :: HyperdataC a => NodeId -> a -> Update Int64
-updateHyperdataQuery i h = seq h' $ trace "updateHyperdataQuery: encoded JSON" $ Update
+updateHyperdataQuery i h = seq h' $ {- trace "updateHyperdataQuery: encoded JSON" $ -} Update
    { uTable      = nodeTable
    , uUpdateWith = updateEasy (\  (Node { .. })
                                 -> Node { _node_hyperdata = h', .. }

src/Gargantext/Database/Query/Table/User.hs

@@ -72,7 +72,7 @@ import Gargantext.Database.Admin.Config (nodeTypeId)
 ------------------------------------------------------------------------
 -- TODO: on conflict, nice message
 insertUsers :: [UserWrite] -> DBCmd err Int64
-insertUsers us = mkCmd $ \c -> runInsert_ c insert
+insertUsers us = mkCmd $ \c -> runInsert c insert
   where
     insert = Insert userTable us rCount Nothing
 

src/Gargantext/Database/Query/Tree/Root.hs

@@ -23,7 +23,7 @@ import Gargantext.Database.Action.User (getUserId, getUsername)
 import Gargantext.Database.Admin.Config
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (Cmd, runOpaQuery, DBCmd)
+import Gargantext.Database.Prelude (runOpaQuery, DBCmd)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
@@ -34,7 +34,7 @@ import Opaleye (restrict, (.==), Select)
 import Opaleye.SqlTypes (sqlStrictText, sqlInt4)
 
 
-getRootId :: (HasNodeError err) => User -> Cmd err NodeId
+getRootId :: (HasNodeError err) => User -> DBCmd err NodeId
 getRootId u = do
   maybeRoot <- head <$> getRoot u
   case maybeRoot of
@@ -66,7 +66,7 @@ getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a)
                       => User
                       -> Either CorpusName [CorpusId]
                       -> Maybe a
-                      -> Cmd err (UserId, RootId, CorpusId)
+                      -> DBCmd err (UserId, RootId, CorpusId)
 getOrMk_RootWithCorpus user cName c = do
   (userId, rootId) <- getOrMkRoot user
   corpusId'' <- if user == UserName userMaster

src/Gargantext/System/Logging.hs

+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies    #-}
+
+module Gargantext.System.Logging (
+    LogLevel(..)
+  , HasLogger(..)
+  , MonadLogger(..)
+  , logM
+  , logLocM
+  , withLogger
+  , withLoggerHoisted
+  ) where
+
+import Language.Haskell.TH hiding (Type)
+import Control.Exception.Lifted (bracket)
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Control
+import Data.Kind (Type)
+import Prelude
+import qualified Data.Text as T
+import qualified Language.Haskell.TH.Syntax        as TH
+
+data LogLevel =
+  -- | Debug messages
+  DEBUG
+  -- | Information
+  | INFO
+  -- | Normal runtime conditions
+  | NOTICE
+  -- | General Warnings
+  | WARNING
+  -- | General Errors
+  | ERROR
+  -- | Severe situations
+  | CRITICAL
+  -- | Take immediate action
+  | ALERT
+  -- | System is unusable
+  | EMERGENCY
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+-- | This is a barebore logging interface which we
+-- can extend to plug a proper logging library, without
+-- the details of the logger cropping up everywhere in
+-- the rest of the codebase.
+class HasLogger m where
+  data family Logger m        :: Type
+  type family LogInitParams m :: Type
+  type family LogPayload m    :: Type
+  initLogger    :: LogInitParams m -> (forall m1. MonadIO m1 => m1 (Logger m))
+  destroyLogger :: Logger m        -> (forall m1. MonadIO m1 => m1 ())
+  logMsg        :: Logger m        -> LogLevel -> LogPayload m -> m ()
+  logTxt        :: Logger m        -> LogLevel -> T.Text -> m ()
+
+-- | Separate typeclass to get hold of a 'Logger' from within a monad.
+-- We keey 'HasLogger' and 'MonadLogger' separate to enforce compositionality,
+-- i.e. we can still give instances to 'HasLogger' for things like 'IO' without
+-- having to force actually acquiring a logger for those monads.
+class HasLogger m => MonadLogger m where
+  getLogger :: m (Logger m)
+
+-- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
+logM :: (Monad m, MonadLogger m) => LogLevel -> T.Text -> m ()
+logM level msg = do
+  logger <- getLogger
+  logTxt logger level msg
+
+-- | Like 'logM', but it automatically adds the file and line number to
+-- the output log.
+logLocM :: ExpQ
+logLocM = [| \level msg ->
+  let loc = $(getLocTH)
+  in logM level (formatWithLoc loc msg)
+  |]
+
+formatWithLoc :: Loc -> T.Text -> T.Text
+formatWithLoc loc msg = "[" <> locationToText <> "] " <> msg
+  where
+    locationToText :: T.Text
+    locationToText = T.pack $ (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
+      where
+        line = show . fst . loc_start
+        char = show . snd . loc_start
+
+getLocTH :: ExpQ
+getLocTH = [| $(location >>= liftLoc) |]
+
+liftLoc :: Loc -> Q Exp
+liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
+    $(TH.lift a)
+    $(TH.lift b)
+    $(TH.lift c)
+    ($(TH.lift d1), $(TH.lift d2))
+    ($(TH.lift e1), $(TH.lift e2))
+    |]
+
+-- | exception-safe combinator that creates and destroys a logger.
+-- Think about it like a 'bracket' function from 'Control.Exception'.
+withLogger :: (MonadBaseControl IO m, MonadIO m, HasLogger m)
+           => LogInitParams m
+           -> (Logger m -> m a)
+           -> m a
+withLogger params = bracket (initLogger params) destroyLogger
+
+-- | Like 'withLogger', but it allows creating a 'Logger' that can run in
+-- a different monad from within an 'IO' action.
+withLoggerHoisted :: (MonadBaseControl IO m, HasLogger m)
+                  => LogInitParams m
+                  -> (Logger m -> IO a)
+                  -> IO a
+withLoggerHoisted params act = bracket (initLogger params) destroyLogger act

src/Gargantext/Utils/Jobs/Monad.hs

@@ -212,3 +212,6 @@ class MonadJobStatus m where
   -- | Finish tracking a job by marking all the remaining steps as failed. Attach an optional
   -- message to the failure.
   markFailed :: Maybe T.Text -> JobHandle m -> m ()
+
+  -- | Add 'n' more steps to the running computation, they will be marked as remaining.
+  addMoreSteps :: MonadJobStatus m => Int -> JobHandle m -> m ()

stack.yaml

@@ -21,7 +21,7 @@ nix:
 allow-newer: true
 
 extra-deps:
-- git: https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude
+- git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude
   commit: 8f97fef4dfd941d773914ad058d8e02ce2bb1a3e
 - git: https://gitlab.iscpif.fr/gargantext/gargantext-graph.git
   commit: 588e104fe7593210956610cab0041fd16584a4ce
@@ -58,11 +58,11 @@ extra-deps:
 - git: https://gitlab.iscpif.fr/gargantext/crawlers/isidore.git
   commit: 3db385e767d2100d8abe900833c6e7de3ac55e1b
 - git: https://gitlab.iscpif.fr/gargantext/crawlers/arxiv-api.git
-  commit: 2d7e5753cbbce248b860b571a0e9885415c846f7
+  commit: eb130c71fa17adaceed6ff66beefbccb13df51ba
 - git: https://gitlab.iscpif.fr/gargantext/crawlers/openalex.git
   commit: dab07cb89e8ab8eaaff8619f5e21d944d9c526ab
 - git: ssh://git@gitlab.iscpif.fr:20022/gargantext/crawlers/epo.git
-  commit: ac9f20b36e8659267d7525fe2c74c7286a0350cb
+  commit: dd45fb91eca6150c2d8f8930ec87bf23f081b2e2
   # NP libs
 - git: https://github.com/alpmestan/servant-job.git
   commit: b4182487cfe479777c11ca19f3c0d47840b376f6
@@ -118,6 +118,9 @@ extra-deps:
 - hgal-2.0.0.2@sha256:13d58afd0668b9cb881c612eff8488a0e289edd4bbffa893df4beee60cfeb73b,653
 - hsparql-0.3.8
 - hstatistics-0.3.1
+- hspec-2.11.1
+- hspec-core-2.11.1
+- hspec-discover-2.11.1
 - hspec-expectations-0.8.3
 - json-stream-0.4.2.4@sha256:8b7f17d54a6e1e6311756270f8bcf51e91bab4300945400de66118470dcf51b9,4716
 - located-base-0.1.1.1@sha256:7c6395f2b6fbf2d5f76c3514f774423838c0ea94e1c6a5530dd3c94b30c9d1c8,1904
@@ -135,6 +138,7 @@ extra-deps:
 - stemmer-0.5.2@sha256:823aec56249ec2619f60a2c0d1384b732894dbbbe642856d337ebfe9629a0efd,4082
 - taggy-0.2.1@sha256:7bc55ddba178971dc6052163597f0445a0a2b5b0ca0e84ce651d53d722e3c265,4662
 - taggy-lens-0.1.2@sha256:091ca81d02bd3d7fb493dce0148e1a38f25eb178a1ebd751043a23239e5e3265,3009
+- tasty-hspec-1.2.0.3
 - tmp-postgres-1.34.1.0
 - vector-0.12.3.0@sha256:0ae2c1ba86f0077910be242ec6802cc3d7725fe7b2bea6987201aa3737b239b5,7953
 - xmlbf-0.6.1@sha256:57867fcb39e0514d17b3328ff5de8d241a18482fc89bb742d9ed820a6a2a5187,1540

test/Core/Text/Corpus/Query.hs

@@ -226,7 +226,7 @@ testPubMedCovid_01 getPubmedKey = do
   case mb_key of
     Nothing -> pure ()
     Just k  -> withValidQuery "\"Covid\"" $ \query -> do
-      res <- Pubmed.get (_PubmedApiKey k) query (Just 1)
+      res <- Pubmed.get (_PubmedApiKey k) (renderQuery query) (Just 1)
       case res of
         Left err       -> fail (show err)
         Right (_, cnd) -> do
@@ -241,7 +241,7 @@ testPubMedCovid_02 getPubmedKey = do
   case mb_key of
     Nothing -> pure ()
     Just k  -> withValidQuery "\"Covid\" AND \"Alzheimer\"" $ \query -> do
-      res <- Pubmed.get (_PubmedApiKey k) query (Just 1)
+      res <- Pubmed.get (_PubmedApiKey k) (renderQuery query) (Just 1)
       case res of
         Left err       -> fail (show err)
         Right (_, cnd) -> do

test/Database/Operations.hs

 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE TupleSections        #-}
+{-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans      #-}
 
-module Database.Operations where
+module Database.Operations (
+   tests
+  ) where
 
-import Control.Exception
-import Control.Lens
+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.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.Prelude
 import Gargantext.Prelude.Config
 import Prelude
-import Shelly hiding (FilePath)
-import Test.Tasty
-import Test.Tasty.HUnit
-import Test.Tasty.Hspec
+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
 import qualified Database.PostgreSQL.Simple as PG
 import qualified Database.PostgreSQL.Simple.Options as Client
 import qualified Database.Postgres.Temp as Tmp
+import qualified Shelly as SH
 
 import Paths_gargantext
 
+-- | Keeps a log of usernames we have already generated, so that our
+-- roundtrip tests won't fail.
+uniqueArbitraryNewUser :: Int -> Gen (NewUser GargPassword)
+uniqueArbitraryNewUser currentIx = do
+  ur <- (`mappend` (T.pack (show currentIx) <> "-")) <$> ascii_txt
+  let email = ur <> "@foo.com"
+  NewUser <$> pure ur <*> pure email <*> elements arbitraryPassword
+  where
+   ascii_txt :: Gen T.Text
+   ascii_txt = fmap (T.pack . getPrintableString) arbitrary
 
 -- | Test DB settings.
 dbUser, dbPassword, dbName :: String
 dbUser = "gargantua"
 dbPassword = "gargantua_test"
-dbName = "gargandbV5"
+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_db          :: !DBHandle
+  , test_config      :: !GargConfig
+  , test_usernameGen :: !Counter
   }
 
 newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
@@ -52,7 +82,7 @@ newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
            , MonadBaseControl IO
            )
 
-data DBHandle = DBHandle { 
+data DBHandle = DBHandle {
     _DBHandle :: Pool PG.Connection
   , _DBTmp    :: Tmp.DB
   }
@@ -72,9 +102,6 @@ fakeIniPath = getDataFileName "test-data/test_config.ini"
 gargDBSchema :: IO FilePath
 gargDBSchema = getDataFileName "devops/postgres/schema.sql"
 
-gargDBExtensionsSchema :: IO FilePath
-gargDBExtensionsSchema = getDataFileName "devops/postgres/extensions.sql"
-
 teardown :: TestEnv -> IO ()
 teardown TestEnv{..} = do
   destroyAllResources $ _DBHandle test_db
@@ -87,7 +114,7 @@ bootstrapDB tmpDB pool _cfg = Pool.withResource pool $ \conn -> do
   schemaPath <- gargDBSchema
   let connString = Tmp.toConnectionString tmpDB
   (res,ec) <- shelly $ silently $ escaping False $ do
-    result <- run "psql" ["-d", "\"" <> TE.decodeUtf8 connString <> "\"", "<", fromString schemaPath]
+    result <- SH.run "psql" ["-d", "\"" <> TE.decodeUtf8 connString <> "\"", "<", fromString schemaPath]
     (result,) <$> lastExitCode
   unless (ec == 0) $ throwIO (userError $ show ec <> ": " <> T.unpack res)
 
@@ -107,26 +134,75 @@ setup = do
     Right db -> do
       gargConfig <- fakeIniPath >>= readConfig
       pool <- createPool (PG.connectPostgreSQL (Tmp.toConnectionString db))
-                         (PG.close)
-                         2
-                         60
-                         2
+                         (PG.close) 2 60 2
       bootstrapDB db pool gargConfig
-      pure $ TestEnv (DBHandle pool db) gargConfig
+      ugen <- emptyCounter
+      pure $ TestEnv (DBHandle pool db) gargConfig ugen
+
+withTestDB :: (TestEnv -> IO ()) -> IO ()
+withTestDB = bracket setup teardown
+
+tests :: Spec
+tests = sequential $ aroundAll withTestDB $ describe "Database" $ do
+  describe "Read/Writes" $
+    describe "User creation" $ do
+      it "Simple write/read" writeRead01
+      it "Simple duplicate"  mkUserDup
+      it "Read/Write roundtrip" prop_userCreationRoundtrip
+
+data ExpectedActual a =
+    Expected a
+  | Actual a
+  deriving Show
 
-tests :: TestTree
-tests = withResource setup teardown $
-  \getEnv -> testGroup "Database" [unitTests getEnv]
+instance Eq a => Eq (ExpectedActual a) where
+  (Expected a) == (Actual b)   = a == b
+  (Actual a)   == (Expected b) = a == b
+  _ == _ = False
 
-unitTests :: IO TestEnv -> TestTree
-unitTests getEnv = testGroup "Read/Writes"
-  [ testCase "Simple write" (write01 getEnv)
-  ]
 
-write01 :: IO TestEnv -> Assertion
-write01 getEnv = do
-  env <- getEnv
+writeRead01 :: TestEnv -> Assertion
+writeRead01 env = do
   flip runReaderT env $ runTestMonad $ do
-    let nur = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
-    x <- new_user nur
-    liftBase $ x `shouldBe` 1
\ No newline at end of file
+    let nur1 = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
+    let nur2 = mkNewUser "paul@acme.com" (GargPassword "my_secret")
+
+    uid1 <- new_user nur1
+    uid2 <- new_user nur2
+
+    liftBase $ uid1 `shouldBe` 1
+    liftBase $ uid2 `shouldBe` 2
+
+    -- 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
+
+mkUserDup :: TestEnv -> Assertion
+mkUserDup env = do
+  let x = flip runReaderT env $ runTestMonad $ do
+            -- This should fail, because user 'alfredo' exists already.
+            let nur = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
+            new_user nur
+  --
+  -- SqlError {sqlState = "23505", sqlExecStatus = FatalError
+  --          , sqlErrorMsg = "duplicate key value violates unique constraint \"auth_user_username_idx1\""
+  --          , sqlErrorDetail = "Key (username)=(alfredo) already exists.", sqlErrorHint = ""
+  --          }
+  --
+  -- Postgres increments the underlying SERIAL for the user even if the request fails, see
+  -- https://stackoverflow.com/questions/37204749/serial-in-postgres-is-being-increased-even-though-i-added-on-conflict-do-nothing
+  -- This means that the next available ID is '3'.
+  x `shouldThrow` (\SqlError{..} -> sqlErrorDetail == "Key (username)=(alfredo) already exists.")
+
+runEnv :: TestEnv -> TestMonad a -> PropertyM IO a
+runEnv env act = run (flip runReaderT env $ runTestMonad act)
+
+prop_userCreationRoundtrip :: TestEnv -> Property
+prop_userCreationRoundtrip env = monadicIO $ do
+  nextAvailableCounter <- run (nextCounter $ test_usernameGen env)
+  nur  <- pick (uniqueArbitraryNewUser nextAvailableCounter)
+  uid <- runEnv env (new_user nur)
+  ur' <- runEnv env (getUserId (UserName $ _nu_username nur))
+  run (Expected uid `shouldBe` Actual ur')

test/Parsers/Date.hs

@@ -18,7 +18,6 @@ module Parsers.Date where
 import Test.Hspec
 import Test.QuickCheck
 
-import Control.Applicative ((<*>))
 import Data.Either (Either(..))
 import Data.Time (ZonedTime(..))
 import Data.Text (pack, Text)

test/Parsers/Types.hs

@@ -25,7 +25,6 @@ import Test.QuickCheck.Instances ()
 import Text.Parsec.Pos
 import Text.Parsec.Error (ParseError, Message(..), newErrorMessage)
 import Data.Time.LocalTime (ZonedTime (..), TimeZone (..), TimeOfDay(..), LocalTime(..))
-import Data.Eq (Eq(..))
 import Data.Either (Either(..))
 
 deriving instance Eq ZonedTime

test/Utils/Jobs.hs

@@ -228,6 +228,7 @@ instance MonadJobStatus MyDummyMonad where
   markFailure steps mb_msg jh = MyDummyMonad (markFailure steps mb_msg jh)
   markComplete jh             = MyDummyMonad (markComplete jh)
   markFailed mb_msg jh        = MyDummyMonad (markFailed mb_msg jh)
+  addMoreSteps steps jh       = MyDummyMonad (addMoreSteps steps jh)
 
 runMyDummyMonad :: Env -> MyDummyMonad a -> IO a
 runMyDummyMonad env m = do

test/hspec/Main.hs

+
+module Main where
+
+import Gargantext.Prelude
+
+import qualified Database.Operations     as DB
+
+import Test.Hspec
+
+-- 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
+-- precise order, as they are not independent from each other.
+-- 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.
+main :: IO ()
+main = hspec DB.tests

test/Main.hs → test/tasty/Main.hs

-{-|
+{--|
 Module      : Main.hs
-Description : Main for Gargantext Tests
+Description : Main for Gargantext Tasty Tests
 Copyright   : (c) CNRS, 2017-Present
 License     : AGPL + CECILL v3
 Maintainer  : team@gargantext.org
@@ -8,6 +8,7 @@ Stability   : experimental
 Portability : POSIX
 -}
 
+module Main where
 
 import Gargantext.Prelude
 
@@ -44,5 +45,4 @@ main = do
     , NgramsQuery.tests
     , CorpusQuery.tests
     , JSON.tests
-    , DB.tests
     ]