.gitlab-ci.yml

 # Optimising CI speed by using tips from https://blog.nimbleways.com/let-s-make-faster-gitlab-ci-cd-pipelines/
-#image: adinapoli/gargantext:v3.4
-image: cgenie/gargantext:9.4.8
+image: cgenie/gargantext:9.6.6
 
 variables:
   STACK_ROOT: "${CI_PROJECT_DIR}/.stack-root"
   STACK_OPTS: "--system-ghc"
-  CABAL_STORE_DIR: "${CI_PROJECT_DIR}/.cabal"
-  CORENLP: "4.5.4"
+  STORE_DIR: "${CI_PROJECT_DIR}/.cabal"
+  CABAL_DIR: "${CI_PROJECT_DIR}/.cabal"
   FF_USE_FASTZIP: "true"
   ARTIFACT_COMPRESSION_LEVEL: "fast"
   CACHE_COMPRESSION_LEVEL: "fast"
+  XDG_CACHE_HOME: "/builds/gargantext/.cache"
 
 stages:
   - cabal
@@ -26,6 +26,8 @@ stack:
       - .stack-work/
   script:
     - echo "Building the project from '$CI_PROJECT_DIR'"
+    - git config --global --add safe.directory $XDG_CACHE_HOME/nix/tarball-cache
+    - git config --global --add safe.directory '*'
     - nix-shell --run "stack build --no-terminal --fast --dry-run"
   allow_failure: false
 
@@ -38,7 +40,9 @@ cabal:
       - .cabal/
     policy: pull-push
   script:
-    - nix-shell --run "./bin/update-project-dependencies $CABAL_STORE_DIR && cabal --store-dir=$CABAL_STORE_DIR v2-build all --flags 'test-crypto no-phylo-debug-logs' --ghc-options='-O0 -fclear-plugins'"
+    - git config --global --add safe.directory $XDG_CACHE_HOME/nix/tarball-cache
+    - git config --global --add safe.directory '*'
+    - nix-shell --run "./bin/update-project-dependencies $STORE_DIR && cabal --store-dir=$STORE_DIR v2-build all --flags 'test-crypto no-phylo-debug-logs' --ghc-options='-O0 -fclear-plugins'"
   allow_failure: false
 
 bench:
@@ -51,66 +55,49 @@ bench:
       - .cabal/
     policy: pull-push
   script:
-    - nix-shell --run "./bin/update-project-dependencies $CABAL_STORE_DIR && cabal --store-dir=$CABAL_STORE_DIR v2-bench --flags +no-phylo-debug-logs --ghc-options='-O2 -fclear-plugins'"
+    - nix-shell --run "./bin/update-project-dependencies $STORE_DIR && cabal --store-dir=$STORE_DIR v2-bench --flags +no-phylo-debug-logs --ghc-options='-O2 -fclear-plugins'"
   allow_failure: true
 
 test:
   stage: test
+  # The tests needs to run as the 'test' user, because they leverage the
+  # initdb utility from postgres that cannot be run by 'root'.
+  before_script:
+    - echo "Creating test user..."
+    - mkdir -p /home/test
+    - mkdir -p /root/.config
+    - useradd -U test
+    - chown -R test:test dist-newstyle/
+    - chown -R test:test /root/
+    - chown -R test:test $STORE_DIR
+    - chown -R test:test ${CABAL_DIR}
+    - mkdir -p "$XDG_CACHE_HOME/nix"
+    - chown -R test:test "$XDG_CACHE_HOME/nix"
+
   cache:
     key: cabal.project
     paths:
       - dist-newstyle/
       - .cabal/
     policy: pull-push
-  # The tests needs to run as the 'test' user, because they leverage the
-  # initdb utility from postgres that cannot be run by 'root'.
   script:
     - |
-      mkdir -p /home/test
-      mkdir -p /root/.config
-      useradd -U test
-      chown -R test:test dist-newstyle/
-      chown -R test:test /root/
-      chown -R test:test $CABAL_STORE_DIR
+      git config --global --add safe.directory $XDG_CACHE_HOME/nix/tarball-cache
+      git config --global --add safe.directory '*'
+      export TEST_TMPDIR="${CI_PROJECT_DIR}/tmp"
+      mkdir -p "$TEST_TMPDIR"
       export CABAL=$(nix-shell --run "which cabal")
+      echo "Found cabal at ${CABAL}"
       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-project-dependencies $CABAL_STORE_DIR"
+      echo "Found test nix path at ${TEST_NIX_PATH}"
+      nix-shell --run "./bin/update-project-dependencies $STORE_DIR"
       mkdir -p /root/.cache/cabal/logs
       chown -R test:test /root/.cache/cabal/logs/
-      chown -R test:test /root/.cache/cabal/packages/hackage.haskell.org/
+      chown -R test:test "$TEST_TMPDIR"
 
-      mkdir -p /builds/gargantext/haskell-gargantext/devops/coreNLP/stanford-corenlp-current
-      cp -R /root/devops/coreNLP/stanford-corenlp-${CORENLP}/* /builds/gargantext/haskell-gargantext/devops/coreNLP/stanford-corenlp-current/
+      nix-shell --run "chown -R test:test /root/.config/ && su -m test -c \"export PATH=$PATH:$TEST_NIX_PATH && export TMPDIR=$TEST_TMPDIR && cd /builds/gargantext/haskell-gargantext; $CABAL --store-dir=$STORE_DIR v2-test --test-show-details=streaming --flags 'test-crypto no-phylo-debug-logs' --ghc-options='-O0 -fclear-plugins'\""
 
-      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 no-phylo-debug-logs' --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 $STORE_DIR
       chown -R root:root /root/.cache/cabal/logs/
-      chown -R root:root /root/.cache/cabal/packages/hackage.haskell.org/
-      chown -Rh root:root /builds/gargantext/haskell-gargantext/devops/coreNLP/stanford-corenlp-current
-
-#docs:
-#  stage: docs
-#  cache:
-#    key: stack.yaml
-#    paths:
-#      - .stack-root/
-#      - .stack-work/
-#    policy: pull
-#  script:
-#    - nix-shell --run "stack build --no-terminal --haddock --no-haddock-deps --fast --dry-run"
-#    - cp -R "$(stack path --local-install-root)"/doc ./output
-#  # FIXME(adinapoli) Currently Gitlab 11.x doesn't support the 'rules' keyword.
-#  # rules:
-#  # - if: '$CI_MERGE_REQUEST_IID' # Run job on Merge Requests
-#  only:
-#    - merge_requests
-#  artifacts:
-#    paths:
-#      - ./output
-#    expire_in: 1 week
-#  allow_failure: true

CHANGELOG.md

+## Version 0.0.7.4.7
+
+* [BACK][FIX][Adjust the output of the UpdateList tests (#460)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/460)
+* [BACK][FIX][Import/export in SQLite format (#362)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/362)
+* [FRONT][FIX][When the progress bar is empty: say: waiting task (#503)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/503)
+
+## Version 0.0.7.4.6
+
+
+* [BACK][FIX][project in `docker-compose` (#450)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/450)
+* [BACK][FIX][Upgrade GHC to 9.6.x (#436)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/436) and [Merge Request](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/395)
+* [BACK][FIX][Error during import of term in TSV format (#381)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/381)
+* [BACK][FIX][Loading a terms file with empty terms gives an undecipherable and inconsistent error (#395)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/395) and [Merge Request](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/399)
+
+## Version 0.0.7.4.5.1
+
+* [FRONT][FIX][[Corpus import/upload] The error message has disappeared on version 0.0.7.4.2 at least (#728)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/728)
+
+## Version 0.0.7.4.5
+
+* [BACK][FIX][Error when uploading a specific TSV file (#433)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/433)
+
+## Version 0.0.7.4.4
+
+* [BACK][FIX][Order 1 advanced distance (#445)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/445)
+* [FRONT][FIX][Frontend for bridgeness method choice (#730)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/730)
+* [FRONT][FIX][Unify CSS files to a single syntax format (#712)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/712)
+* [FRONT][FIX][Upgrade sigma.js (#705)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/705)
+* [FRONT][FIX][Subcorpus frontend (#718)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/718)
+* [FRONT][FIX][[Corpus upload] Fix an error on form select "NoList" option (#729)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/729)
+* [FRONT][FIX][Basic feature flag hook (#721)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/721)
+
+## Version 0.0.7.4.3
+
+* [BACK][UPGRADE][Remove obsolete GHC option (#388)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/388)
+* [BACK][REFACT][Error in corpus upload / construction are not reflected in the overall JobStatus (#390)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/390)
+* [BACK][FIX][Write test(s) for "ngrams scores do not account for trashed documents" (#391)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/391)
+
 ## Version 0.0.7.4.2
 
 * [BACK][FIX][Let users create a Subcorpus (#384)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/384)

bench/Main.hs

 {-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Main where
 
@@ -9,9 +14,19 @@ import Gargantext.Core.Viz.Phylo.API.Tools (readPhylo)
 import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo)
 import Gargantext.Core.Viz.Phylo.PhyloTools
 import Gargantext.Prelude.Crypto.Auth (createPasswordHash)
-
-import Test.Tasty.Bench
 import Paths_gargantext
+import qualified Data.Array.Accelerate as A
+import qualified Data.Array.Accelerate as Accelerate
+import qualified Data.Array.Accelerate.LLVM.Native as LLVM
+import qualified Data.Array.Accelerate.Interpreter as Naive
+import qualified Data.List.Split as Split
+import qualified Data.Massiv.Array as Massiv
+import qualified Gargantext.Core.LinearAlgebra as LA
+import qualified Gargantext.Core.Methods.Matrix.Accelerate.Utils as Accelerate
+import qualified Gargantext.Core.Methods.Similarities.Accelerate.Distributional as Accelerate
+import qualified Numeric.LinearAlgebra.Data as HM
+import Test.Tasty.Bench
+import Data.Array.Accelerate ((:.))
 
 phyloConfig :: PhyloConfig
 phyloConfig = PhyloConfig {
@@ -37,10 +52,38 @@ phyloConfig = PhyloConfig {
   , exportFilter = [ByBranchSize {_branch_size = 3.0}]
   }
 
+matrixValues :: [Int]
+matrixValues = [ 1 .. 10_000 ]
+
+matrixDim :: Int
+matrixDim = 100
+
+testMatrix :: A.Matrix Int
+testMatrix = A.fromList (A.Z A.:. matrixDim A.:. matrixDim) $ matrixValues
+{-# INLINE testMatrix #-}
+
+testVector :: A.Array (A.Z :. Int :. Int :. Int) Int
+testVector = A.fromList (A.Z A.:. 20 A.:. 20 A.:. 20) $ matrixValues
+{-# INLINE testVector #-}
+
+testMassivMatrix :: Massiv.Matrix Massiv.U Int
+testMassivMatrix = Massiv.fromLists' Massiv.Par $ Split.chunksOf matrixDim $ matrixValues
+{-# INLINE testMassivMatrix #-}
+
+testMassivVector :: Massiv.Array Massiv.U Massiv.Ix3 Int
+testMassivVector = LA.accelerate2Massiv3DMatrix testVector
+{-# INLINE testMassivVector #-}
+
 main :: IO ()
 main = do
   _issue290Phylo     <- force . setConfig phyloConfig <$> (readPhylo =<< getDataFileName "bench-data/phylo/issue-290.json")
   issue290PhyloSmall <- force . setConfig phyloConfig <$> (readPhylo =<< getDataFileName "bench-data/phylo/issue-290-small.json")
+  let !accInput       = force testMatrix
+  let !accVector      = force testVector
+  let !massivVector   = force testMassivVector
+  let !(accDoubleInput :: Accelerate.Matrix Double) = force $ Naive.run $ Accelerate.map Accelerate.fromIntegral (Accelerate.use testMatrix)
+  let !massivInput    = force testMassivMatrix
+  let !(massivDoubleInput :: Massiv.Matrix Massiv.U Double) = force $ Massiv.computeP $ Massiv.map fromIntegral testMassivMatrix
   defaultMain
     [ bgroup "Benchmarks"
       [ bgroup "User creation" [
@@ -51,5 +94,59 @@ main = do
       , bgroup "Phylo" [
           bench "toPhylo (small)" $ nf toPhylo issue290PhyloSmall
       ]
+      , bgroup "logDistributional2" [
+          bench "Accelerate (Naive)" $ nf (Accelerate.logDistributional2With @Double Naive.run) accInput
+      ,   bench "Accelerate (LLVM)"  $ nf (Accelerate.logDistributional2With @Double LLVM.run) accInput
+      ,   bench "Massiv"  $ nf (LA.logDistributional2 @_ @Double) massivInput
+      ]
+      , bgroup "distributional" [
+          bench "Accelerate (Naive)" $ nf (Accelerate.distributionalWith @Double Naive.run) accInput
+      ,   bench "Accelerate (LLVM)"  $ nf (Accelerate.distributionalWith @Double LLVM.run) accInput
+      ,   bench "Massiv (reference implementation)" $ nf (LA.distributionalReferenceImplementation @_ @Double) massivInput
+      ,   bench "Massiv " $ nf (LA.distributional @_ @Double) massivInput
+      ]
+      , bgroup "diag" [
+          bench "Accelerate (Naive)" $ nf (Naive.run . Accelerate.diag . Accelerate.use) accInput
+      ,   bench "Accelerate (LLVM)"  $ nf (LLVM.run  . Accelerate.diag . Accelerate.use) accInput
+      ,   bench "Massiv " $ nf (LA.diag @_) massivInput
+      ]
+      , bgroup "matrixIdentity" [
+          bench "Accelerate (Naive)" $ nf (Naive.run . Accelerate.matrixIdentity @Double) 1000
+      ,   bench "Accelerate (LLVM)"  $ nf (LLVM.run  . Accelerate.matrixIdentity @Double) 1000
+      ,   bench "Massiv" $ nf (LA.matrixIdentity @Double) 1000
+      ,   bench "HMatrix" $ nf (HM.ident @Double) 1000
+      ]
+      , bgroup "matrixEye" [
+          bench "Accelerate (Naive)" $ nf (Naive.run . Accelerate.matrixEye @Double) 1000
+      ,   bench "Accelerate (LLVM)"  $ nf (LLVM.run  . Accelerate.matrixEye @Double) 1000
+      ,   bench "Massiv " $ nf (LA.matrixEye @Double) 1000
+      ]
+      , bgroup "matMaxMini" [
+          bench "Accelerate (Naive)" $ nf (Naive.run . Accelerate.matMaxMini @Double . Accelerate.use) accDoubleInput
+      ,   bench "Accelerate (LLVM)"  $ nf (LLVM.run  . Accelerate.matMaxMini @Double . Accelerate.use) accDoubleInput
+      ,   bench "Massiv " $ nf LA.matMaxMini massivDoubleInput
+      ]
+      , bgroup "(.*)" [
+          bench "Accelerate (Naive)" $ nf (\v -> Naive.run $ (Accelerate.use v) Accelerate..* (Accelerate.use v)) accDoubleInput
+      ,   bench "Accelerate (LLVM)"  $ nf (\v -> LLVM.run $ (Accelerate.use v) Accelerate..* (Accelerate.use v)) accDoubleInput
+      ,   bench "Massiv " $ nf (\v -> (v LA..* v) :: Massiv.Matrix Massiv.U Double) massivDoubleInput
+      ]
+      , bgroup "sumRows" [
+          bench "Accelerate (Naive)" $ nf (Naive.run . Accelerate.sum . Accelerate.use) accVector
+      ,   bench "Accelerate (LLVM)"  $ nf (LLVM.run . Accelerate.sum . Accelerate.use) accVector
+      ,   bench "Massiv "            $ nf LA.sumRows massivVector
+      ]
+      , bgroup "sumMin_go" [
+          bench "Accelerate (Naive)" $ nf (Naive.run . Accelerate.sumMin_go 100 . Accelerate.use) accDoubleInput
+      ,   bench "Accelerate (LLVM)"  $ nf (LLVM.run . Accelerate.sumMin_go 100 . Accelerate.use) accDoubleInput
+      ,   bench "Massiv "            $ nf (Massiv.compute @Massiv.U . LA.sumMin_go 100) massivDoubleInput
+      ]
+      , bgroup "termDivNan" [
+          bench "Accelerate (Naive)" $
+            nf (\m -> Naive.run $ Accelerate.termDivNan (Accelerate.use m) (Accelerate.use m)) accDoubleInput
+      ,   bench "Accelerate (LLVM)" $
+            nf (\m -> LLVM.run $ Accelerate.termDivNan (Accelerate.use m) (Accelerate.use m)) accDoubleInput
+      ,   bench "Massiv " $ nf (\m -> LA.termDivNan @Massiv.U m m) massivDoubleInput
+      ]
       ]
     ]

bin/gargantext-cli/CLI/Import.hs

@@ -19,6 +19,7 @@ module CLI.Import where
 
 import CLI.Parsers
 import CLI.Types
+import Control.Monad.Catch (MonadCatch)
 import Gargantext.API.Admin.EnvTypes (DevEnv(..), DevJobHandle(..))
 import Gargantext.API.Dev (withDevEnv, runCmdGargDev)
 import Gargantext.API.Errors.Types ( BackendInternalError )
@@ -26,7 +27,6 @@ import Gargantext.API.Node () -- instances
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..))
 import Gargantext.Core.Types.Individu (User(..))
-import Gargantext.Core.Types.Query
 import Gargantext.Database.Action.Flow (flowCorpusFile, flowAnnuaire, TermType(..))
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Admin.Types.Node (CorpusId)
@@ -39,18 +39,18 @@ import qualified Data.Text as T
 
 
 importCLI :: ImportArgs -> IO ()
-importCLI (ImportArgs fun user name settingsPath limit corpusPath) = do
+importCLI (ImportArgs fun user name settingsPath corpusPath) = do
   let
     tt     = Multi EN
     format = TsvGargV3
-    corpus :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
+    corpus :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, MonadCatch m, JobHandle m ~ DevJobHandle) => m CorpusId
     mkCorpusUser = MkCorpusUserNormalCorpusName (UserName $ cs user) (cs name :: Text)
-    corpus = flowCorpusFile mkCorpusUser limit tt  format Plain corpusPath Nothing DevJobHandle
+    corpus = flowCorpusFile mkCorpusUser tt  format Plain corpusPath Nothing DevJobHandle
 
-    corpusTsvHal :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
-    corpusTsvHal = flowCorpusFile mkCorpusUser limit tt TsvHal Plain corpusPath Nothing DevJobHandle
+    corpusTsvHal :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, MonadCatch m, JobHandle m ~ DevJobHandle) => m CorpusId
+    corpusTsvHal = flowCorpusFile mkCorpusUser tt TsvHal Plain corpusPath Nothing DevJobHandle
 
-    annuaire :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
+    annuaire :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, MonadCatch m, JobHandle m ~ DevJobHandle) => m CorpusId
     annuaire = flowAnnuaire (MkCorpusUserNormalCorpusName (UserName $ cs user) "Annuaire") (Multi EN) corpusPath DevJobHandle
 
   withDevEnv settingsPath $ \env -> do
@@ -76,7 +76,7 @@ import_p = fmap CCMD_import $ ImportArgs
   <*> ( option str ( long "user") )
   <*> ( option str ( long "name") )
   <*> settings_p
-  <*> (fmap Limit ( option auto ( long "limit" <> metavar "INT" <> help "The limit for the query") ))
+  -- <*> (fmap Limit ( option auto ( long "limit" <> metavar "INT" <> help "The limit for the query") ))
   <*> ( option str ( long "corpus-path" <> help "Path to corpus file") )
 
 function_p :: String -> Either String ImportFunction

bin/gargantext-cli/CLI/Ini.hs

@@ -19,17 +19,17 @@ Import a corpus binary.
 module CLI.Ini where
 
 import CLI.Types
-import Control.Monad.Logger (LogLevel(LevelDebug))
-import Data.Text qualified as T
-import Data.Text.IO qualified as T (writeFile)
 import Database.PostgreSQL.Simple qualified as PGS
-import Gargantext.Core.Config qualified as Config
+import Data.Text.IO qualified as T (writeFile)
+import Data.Text qualified as T
 import Gargantext.Core.Config.Ini.Ini qualified as Ini
 import Gargantext.Core.Config.Ini.Mail qualified as IniMail
 import Gargantext.Core.Config.Ini.NLP qualified as IniNLP
+import Gargantext.Core.Config qualified as Config
 import Gargantext.Core.Config.Types qualified as CTypes
 import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..))
 import Gargantext.Prelude
+import Gargantext.System.Logging (LogLevel(..))
 import Options.Applicative
 import Servant.Client.Core (parseBaseUrl)
 import Toml qualified
@@ -87,7 +87,10 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
                                                   , _wsDefaultVisibilityTimeout = 1
                                                   , _wsDefaultDelay = 0
                                                   , _wsDatabase = connInfo { PGS.connectDatabase = "pgmq"} }
-                    , _gc_log_level = LevelDebug
+                    , _gc_logging = Config.LogConfig {
+                        _lc_log_level = INFO
+                      , _lc_log_file = Nothing
+                      }
                     }
   where
     _ac_scrapyd_url =

bin/gargantext-cli/CLI/Init.hs

@@ -29,12 +29,13 @@ import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMkRootWithCorpus)
 import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (DBCmd, DBCmdWithEnv)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getOrMkList)
 import Gargantext.Database.Query.Table.User (insertNewUsers, )
 import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserMaster))
 import Gargantext.Prelude
 import Options.Applicative
+import Gargantext.Core.Types.Individu (toUserHash)
 
 
 initCLI :: InitArgs -> IO ()
@@ -45,34 +46,36 @@ initCLI (InitArgs settingsPath) = do
   putStrLn ("Enter master user (gargantua) _email_ :" :: Text)
   email     <- getLine
 
+  hashedUsers <- NE.fromList <$> mapM toUserHash (NewUser "gargantua" (cs email) (GargPassword $ cs password) : arbitraryNewUsers)
+
   cfg       <- readConfig         settingsPath
   let secret = _s_secret_key $ _gc_secrets cfg
 
-  let createUsers :: forall env. DBCmdWithEnv env BackendInternalError Int64
-      createUsers = insertNewUsers (NewUser "gargantua" (cs email) (GargPassword $ cs password)
-                                   NE.:| arbitraryNewUsers
-                                   )
+  let createUsers :: DBUpdate BackendInternalError Int64
+      createUsers = insertNewUsers hashedUsers
 
   let
-    mkRoots :: forall env. DBCmdWithEnv env BackendInternalError [(UserId, RootId)]
-    mkRoots = mapM getOrMkRoot $ map UserName ("gargantua" : arbitraryUsername)
+    mkRoots :: DBUpdate BackendInternalError [(UserId, RootId)]
+    mkRoots = mapM (getOrMkRoot cfg) $ map UserName ("gargantua" : arbitraryUsername)
     -- TODO create all users roots
 
   let
-    initMaster :: forall env. DBCmdWithEnv env BackendInternalError (UserId, RootId, CorpusId, ListId)
+    initMaster :: DBUpdate BackendInternalError (UserId, RootId, CorpusId, ListId)
     initMaster = do
       (masterUserId, masterRootId, masterCorpusId)
-                  <- getOrMkRootWithCorpus MkCorpusUserMaster
+                  <- getOrMkRootWithCorpus cfg MkCorpusUserMaster
                                             (Nothing :: Maybe HyperdataCorpus)
       masterListId <- getOrMkList masterCorpusId masterUserId
       _triggers    <- initLastTriggers masterListId
       pure (masterUserId, masterRootId, masterCorpusId, masterListId)
 
   withDevEnv settingsPath $ \env -> do
-    _ <- runCmdDev env (initFirstTriggers secret :: DBCmd BackendInternalError [Int64])
-    _ <- runCmdDev env createUsers
-    x <- runCmdDev env initMaster
-    _ <- runCmdDev env mkRoots
+    x <- runCmdDev env $ runDBTx $ do
+      _ <- initFirstTriggers secret
+      _ <- createUsers
+      x' <- initMaster
+      _  <- mkRoots
+      pure x'
     putStrLn (show x :: Text)
 
 initCmd :: HasCallStack => Mod CommandFields CLI

bin/gargantext-cli/CLI/Server.hs

+{-# LANGUAGE TemplateHaskell #-}
 {-|
 Module      : CLI.Server
 Description : Gargantext Server
@@ -12,31 +13,48 @@ Portability : POSIX
 
 module CLI.Server where
 
-import Data.Version (showVersion)
 import CLI.Parsers (settings_p)
 import CLI.Types
 import CLI.Worker (runAllWorkers)
+import Control.Concurrent.Async qualified as Async
+import Control.Monad.IO.Class
+import Data.Text qualified as T
+import Data.Version (showVersion)
 import GHC.IO.Encoding (setLocaleEncoding, utf8)
 import Gargantext.API (startGargantext)
 import Gargantext.API.Admin.EnvTypes (Mode(..))
+import Gargantext.Core.Config
 import Gargantext.Core.Config.Types (_SettingsFile)
+import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Prelude
-import Gargantext.System.Logging (withLogger, logMsg, LogLevel(..), Logger)
+import Gargantext.System.Logging
 import Options.Applicative
 import Paths_gargantext qualified as PG -- cabal magic build module
 
-
+withServerCLILogger :: ServerArgs
+                    -> (Logger IO -> IO a)
+                    -> IO a
+withServerCLILogger ServerArgs{..} f = do
+  cfg  <- liftIO $ readConfig server_toml
+  withLogger (cfg ^. gc_logging) $ \logger -> f logger
 
 serverCLI :: CLIServer -> IO ()
-serverCLI (CLIS_start serverArgs) = withLogger () $ \ioLogger ->
+serverCLI (CLIS_start serverArgs) = withServerCLILogger serverArgs $ \ioLogger ->
   startServerCLI ioLogger serverArgs
 
-serverCLI (CLIS_startAll serverArgs@(ServerArgs { .. })) = withLogger () $ \ioLogger -> do
+serverCLI (CLIS_startAll serverArgs@(ServerArgs { .. })) = withServerCLILogger serverArgs $ \ioLogger -> do
   withAsync (startServerCLI ioLogger serverArgs) $ \aServer -> do
-    runAllWorkers ioLogger server_toml
-    wait aServer
-
-serverCLI (CLIS_version) = withLogger () $ \ioLogger -> do
+    res <- Async.race (runAllWorkers ioLogger server_toml) (waitCatch aServer)
+    case res of
+      Left ()  -> pure ()
+      Right (Left ex)
+        -> do
+          $(logLoc) ioLogger ERROR $ "Exception raised when running the server:\n\n" <> T.pack (displayException ex)
+          exitFailure
+      Right (Right ())
+        -> pure ()
+
+serverCLI (CLIS_version) = withLogger (LogConfig Nothing DEBUG) $ \ioLogger -> do
     -- Sets the locale to avoid encoding issues like in #284.
   setLocaleEncoding utf8
   logMsg ioLogger INFO $ "Version: " <> showVersion PG.version
@@ -58,13 +76,13 @@ serverParser = hsubparser (
 
 start_p :: Parser CLIServer
 start_p = fmap CLIS_start $ ServerArgs
-  <$> mode_p 
+  <$> mode_p
   <*> port_p
   <*> settings_p
 
 start_all_p :: Parser CLIServer
 start_all_p = fmap CLIS_startAll $ ServerArgs
-  <$> mode_p 
+  <$> mode_p
   <*> port_p
   <*> settings_p
 
@@ -81,7 +99,7 @@ port_p = option auto ( long "port"
                     <> showDefault
                     <> value 8008
                     <> help "Port" )
-  
+
 version_p :: Parser CLIServer
 version_p = pure CLIS_version
 

bin/gargantext-cli/CLI/Server/Routes.hs

@@ -14,8 +14,8 @@ import Data.Aeson.Encode.Pretty
 import Data.ByteString qualified as B
 import Data.ByteString.Lazy qualified as BL
 import Gargantext.API.Routes.Named
+import Gargantext.Prelude
 import Options.Applicative
-import Prelude
 import Servant.API
 import Servant.API.Routes
 import Servant.API.WebSocket qualified as WS (WebSocketPending)
@@ -52,6 +52,6 @@ instance HasRoutes Raw where
 routesCLI :: CLIRoutes -> IO ()
 routesCLI = \case
   CLIR_list
-    -> printRoutes @(NamedRoutes API)
+    -> printRoutesSorted @(NamedRoutes API)
   (CLIR_export filePath)
     -> B.writeFile filePath . BL.toStrict $ encodePretty (getRoutes @(NamedRoutes API))

bin/gargantext-cli/CLI/Types.hs

@@ -19,7 +19,6 @@ import Data.Text (Text)
 import Gargantext.API.Admin.EnvTypes (Mode)
 import Gargantext.Core.Config.Types (SettingsFile(..))
 import Gargantext.Core.Types (NodeId)
-import Gargantext.Core.Types.Query
 import Prelude
 
 newtype CorpusFile = CorpusFile { _CorpusFile :: FilePath }
@@ -55,7 +54,6 @@ data ImportArgs = ImportArgs
   , imp_user     :: !Text
   , imp_name     :: !Text
   , imp_settings :: !SettingsFile
-  , imp_limit    :: !Limit
   , imp_corpus_path :: !FilePath
   } deriving (Show, Eq)
 

bin/gargantext-cli/CLI/Worker.hs

@@ -19,7 +19,7 @@ import CLI.Parsers
 import Control.Concurrent.Async (forConcurrently_)
 import Data.List qualified as List (cycle, concat, take)
 import Data.Text qualified as T
-import Gargantext.Core.Config (hasConfig, gc_worker)
+import Gargantext.Core.Config (hasConfig, gc_worker, gc_logging)
 import Gargantext.Core.Config.Types (SettingsFile(..))
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.Config.Worker (WorkerDefinition(..), WorkerSettings(..), findDefinitionByName)
@@ -42,33 +42,36 @@ workerCLI (CLIW_run (WorkerArgs { .. })) = do
                        $ List.take 72
                        $ List.cycle ["_"]) :: Prelude.String)
 
-  ___
-  putText "GarganText worker"
-  putText $ "worker_name: " <> worker_name
-  putText $ "worker toml: " <> T.pack (_SettingsFile worker_toml)
-  ___
-
   withWorkerEnv worker_toml $ \env -> do
-    let ws = env ^. hasConfig . gc_worker
-    case findDefinitionByName ws worker_name of
-      Nothing -> do
-        let workerNames = _wdName <$> (_wsDefinitions ws)
-        let availableWorkers = T.intercalate ", " workerNames
-        putText $ "Worker definition not found! Available workers: " <> availableWorkers
-      Just wd -> do
-        putText $ "Starting worker '" <> worker_name <> "'"
-        putText $ "gc config: " <> show (env ^. hasConfig)
-        putText $ "Worker settings: " <> show ws
-        ___
-        if worker_run_single then
-          withPGMQWorkerSingleCtrlC env wd $ \a _state -> do
-            wait a
-        else
-          withPGMQWorkerCtrlC env wd $ \a _state -> do
-            -- _ <- runReaderT (sendJob Ping) env
-            wait a
-workerCLI (CLIW_runAll (WorkerAllArgs { .. })) = withLogger () $ \ioLogger -> do
-  runAllWorkers ioLogger worker_toml
+    let log_cfg = env ^. hasConfig . gc_logging
+    withLogger log_cfg $ \ioLogger -> do
+      ___
+      logMsg ioLogger INFO "GarganText worker"
+      logMsg ioLogger INFO $ "worker_name: " <> T.unpack worker_name
+      logMsg ioLogger INFO $ "worker toml: " <> _SettingsFile worker_toml
+      ___
+      
+      let ws = env ^. hasConfig . gc_worker
+      case findDefinitionByName ws worker_name of
+        Nothing -> do
+          let workerNames = _wdName <$> (_wsDefinitions ws)
+          let availableWorkers = T.intercalate ", " workerNames
+          putText $ "Worker definition not found! Available workers: " <> availableWorkers
+        Just wd -> do
+          logMsg ioLogger INFO $ "Starting worker '" <> T.unpack worker_name <> "'"
+          logMsg ioLogger DEBUG $ "gc config: " <> show (env ^. hasConfig)
+          logMsg ioLogger DEBUG $ "Worker settings: " <> show ws
+          ___
+          if worker_run_single then
+            withPGMQWorkerSingleCtrlC env wd $ \a _state -> do
+              wait a
+          else
+            withPGMQWorkerCtrlC env wd $ \a _state -> do
+              -- _ <- runReaderT (sendJob Ping) env
+              wait a
+workerCLI (CLIW_runAll (WorkerAllArgs { .. })) = withWorkerEnv worker_toml $ \env -> do
+  let log_cfg = env ^. hasConfig . gc_logging
+  withLogger log_cfg $ \ioLogger -> runAllWorkers ioLogger worker_toml
 workerCLI (CLIW_stats (WorkerStatsArgs { .. })) = do
   putStrLn ("worker toml: " <> _SettingsFile ws_toml)
 
@@ -123,6 +126,15 @@ stats_p = fmap CLIW_stats $ WorkerStatsArgs
   <$> settings_p
 
 
+-- | Runs all the workers concurrently.
+-- /NOTE/: Be very careful, this IS a BLOCKING operation, despite its usage
+-- of 'forConcurrently_' under the hood. In particular 'forConcurrently_' will
+-- execute the inner action in parallel discarding the results, but the inner
+-- action has still to terminate!
+-- That is /NOT/ the case for this function, which is meant to start the infinite
+-- loop for the workers, so beware when using this, make sure that the calling
+-- code is using this properly (for example along the use of 'race' or a similar
+-- function from async).
 runAllWorkers :: Logger IO -> SettingsFile -> IO ()
 runAllWorkers ioLogger worker_toml = do
   cfg <- readConfig worker_toml

bin/install-cabal2stack

-#!/usr/bin/env bash
-
-set -euxo pipefail
-
-current_dir=$(basename "$PWD")
-
-if [ "$current_dir" == "bin" ]; then
-    source ./setup-ci-environment
-else
-    source ./bin/setup-ci-environment
-fi
-
-cabal --store-dir=$STORE_DIR v2-update "hackage.haskell.org,${INDEX_STATE}"
-
-# Install cabal2stack if it can't be found.
-if ! cabal2stack --help &> /dev/null
-then
-    echo "cabal2stack could not be found"
-    CURDIR=$PWD
-    git clone https://github.com/iconnect/cabal2stack.git cabal2stack-installer
-    cd cabal2stack-installer
-    cabal --store-dir=$STORE_DIR v2-install --index-state="${INDEX_STATE}" --overwrite-policy=always
-    cd $CURDIR
-    rm -rf cabal2stack-installer
-fi

bin/scripts/server

@@ -7,4 +7,6 @@ LOGFILE=$FOLDER"/"$FILE
 
 mkdir -p $FOLDER
 
-nix-shell --run "~/.cabal/bin/gargantext-server --toml gargantext-settings.toml --run Prod +RTS > $LOGFILE 2>&1 & tail -F $LOGFILE"
+#nix-shell --run "~/.cabal/bin/gargantext-server --toml gargantext-settings.toml --run Prod +RTS > $LOGFILE 2>&1 & tail -F $LOGFILE"
+
+nix-shell --run "cabal  v2-run  gargantext server -- start-all -m Dev -p 8008 -c gargantext-settings.toml" #> $LOGFILE 2>&1 & tail -F $LOGFILE"

bin/setup-ci-environment

@@ -4,4 +4,4 @@ set -euxo pipefail
 
 DEFAULT_STORE=$HOME/.cabal
 STORE_DIR="${1:-$DEFAULT_STORE}"
-INDEX_STATE="2023-12-10T10:34:46Z"
+INDEX_STATE="2025-02-17T10:13:39Z"

bin/update-project-dependencies

@@ -6,10 +6,8 @@ current_dir=$(basename "$PWD")
 
 if [ "$current_dir" == "bin" ]; then
     source ./setup-ci-environment
-    ./install-cabal2stack
 else
     source ./bin/setup-ci-environment
-    ./bin/install-cabal2stack
 fi
 
 # README!
@@ -18,12 +16,12 @@ fi
 # 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="1abcdd99d5d50660e640be8a340c90331a84ef266d174c7ca6099c1c04ef65ea"
-expected_cabal_project_freeze_hash="32310c4d4e7b4679dcb90dcfcd0d6d1b175dbf885a77ffddca16d422998a521c"
+expected_cabal_project_hash="c7e0466c8d4c1ca88b4f3d62d022bd29329d44afc48fffbcfacf0f65293acba8"
+expected_cabal_project_freeze_hash="553b98aadb35506a305bd740cdd71f5fadc1e6d55d10f91cf39daa6735a63d78" 
 
 
 cabal --store-dir=$STORE_DIR v2-build --dry-run
-cabal2stack --system-ghc --allow-newer --resolver lts-21.25 --resolver-file devops/stack/lts-21.25.yaml -o stack.yaml
+cabal2stack --system-ghc --allow-newer --resolver lts-22.43 --resolver-file devops/stack/lts-22.43.yaml -o stack.yaml
 
 # Run 'sed' to remove the constraint for 'gargantext', as it doesn't make sense and
 # for the test we need to run this with a different flag.

cabal.project

 -- Generated by stack2cabal
 
 -- index-state: 2023-12-10T10:34:46Z
-index-state: 2024-09-12T03:02:26Z
+index-state: 2025-02-17T10:13:39Z
 
-with-compiler: ghc-9.4.8
+with-compiler: ghc-9.6.6
 optimization: 2
+benchmarks: False
+tests: True
 
 packages:
     ./
@@ -14,13 +16,6 @@ source-repository-package
     location: https://github.com/AccelerateHS/accelerate.git
     tag: 334d05519436bb7f20f9926ec76418f5b8afa359
 
-source-repository-package
-    type: git
-    location: https://github.com/AccelerateHS/accelerate-llvm.git
-    tag: 2b5d69448557e89002c0179ea1aaf59bb757a6e3
-    subdir: accelerate-llvm-native/
-            accelerate-llvm/
-
 -- Patch for "Allow NOT to backtrack"
 source-repository-package
     type: git
@@ -32,18 +27,6 @@ source-repository-package
     location: https://gitlab.iscpif.fr/gargantext/opaleye-textsearch.git
     tag: 04b5c9044fef44393b66bffa258ca0b0f59c1087
 
-source-repository-package
-    type: git
-    location: https://github.com/adinapoli/llvm-hs.git
-    tag: 7533a9ccd3bfe77141745f6b61039a26aaf5c83b
-    subdir: llvm-hs
-            llvm-hs-pure
-
-source-repository-package
-    type: git
-    location: https://github.com/alpmestan/accelerate-arithmetic.git
-    tag: a110807651036ca2228a76507ee35bbf7aedf87a
-
 source-repository-package
     type: git
     location: https://github.com/alpmestan/hmatrix.git
@@ -56,11 +39,6 @@ source-repository-package
     tag: bc6ca8058077b0b5702ea4b88bd4189cfcad267a
     subdir: sparse-linear
 
-source-repository-package
-    type: git
-    location: https://github.com/chessai/eigen.git
-    tag: 1790fdf9138970dde0dbabf8b270698145a4a88c
-
 source-repository-package
     type: git
     location: https://github.com/delanoe/data-time-segment.git
@@ -71,11 +49,6 @@ source-repository-package
     location: https://github.com/delanoe/patches-map
     tag: 76cae88f367976ff091e661ee69a5c3126b94694
 
-source-repository-package
-    type: git
-    location: https://gitlab.iscpif.fr/amestanogullari/accelerate-utility.git
-    tag: a3875fe652d3bb5acb522674c22c6c814c1b4ad0
-
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/arxiv-api.git
@@ -99,12 +72,12 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/istex.git
-    tag: 521ca54f1502b13f629eff2223aaf5007e6d52ec
+    tag: 894482ef97eadce6b1c13ebced1edfe394b5be5e
 
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/openalex.git
-    tag: a80e0ea57379d23f5e18a412606a71471b8ef681
+    tag: c86412b5b8713b2bdd63b2bed2a2259c5d143a88
 
 source-repository-package
     type: git
@@ -114,17 +87,19 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/gargantext-graph.git
-    tag: 588e104fe7593210956610cab0041fd16584a4ce
+    tag: 316d48b6a89593faaf1f2102e9714cea7e416e56
+    subdir: gargantext-graph-core
 
+-- Support for GHC 9.6.x
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude
-    tag: bb15d828d5ef36eeaa84cccb00598b585048c88e
+    tag: 214b31a2db46de5a2cac24231a3c07a1c4c3fab9
 
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/haskell-igraph.git
-    tag: 9f8a2f4a014539826a4eab3215cc70c0813f20cb
+    tag: 05e62da3aa466b7d0608d4918b030dc024119b32
 
 source-repository-package
     type: git
@@ -141,10 +116,11 @@ source-repository-package
     location: https://gitlab.iscpif.fr/gargantext/iso639.git
     tag: eab929d106833ded8011a0d6705135e3fc506a9c
 
+-- GHC 9.6.6 support
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/patches-class.git
-    tag: 3668d28607867a88b2dfc62158139b3cfd629ddb
+    tag: a591716220cfcabffa24eb29cbaa2517023642af
 
 source-repository-package
     type: git
@@ -156,12 +132,12 @@ source-repository-package
     location: https://github.com/haskell-github-trust/ekg-json
     tag: bd0592818882f9cf34d2991d01f7dcb3d8bca309
 
--- FIXME(adn) Compat-shim while we wait for upstream to catch-up
+-- NOTE(adn) This forks binds to nng.
 source-repository-package
     type: git
-    location: https://github.com/garganscript/nanomsg-haskell
-    tag: 5868db564d7d3c4568ccd11c852292b834d26c55
-    
+    location: https://github.com/adinapoli/nanomsg-haskell
+    tag: 2d69707bf639be2055e3228dab38cc4f2a658111
+
 source-repository-package
     type: git
     location: https://github.com/adinapoli/http-reverse-proxy.git
@@ -170,7 +146,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/fpringle/servant-routes.git
-    tag: 7694f62af6bc1596d754b42af16da131ac403b3a
+    tag: c3c558d9278ef239a474f1e1b69afc461be60d01
 
 source-repository-package
     type: git
@@ -180,7 +156,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/haskell-bee
-    tag: 69b7388a62f2afb5cb5609beac96e8cb35e94478
+    tag: 4a9c709613554eed0189b486de2126c18797088c
     subdir: haskell-bee/
             haskell-bee-pgmq/
             haskell-bee-tests/
@@ -190,23 +166,21 @@ source-repository-package
     location: https://gitlab.iscpif.fr/gargantext/haskell-throttle
     tag: 02f5ed9ee2d6cce45161addf945b88bc6adf9059
 
-        
 allow-newer: MissingH:base
-           , accelerate-arithmetic:accelerate
-           , accelerate-utility:accelerate
-           , base:*
-           , crawlerHAL:servant
+           , *:base
+           , crawlerHAL:*
+           , epo-api-client:http-client-tls
+           , openalex:http-client-tls
            , iso639:aeson
            , iso639:text
-           , servant-ekg:base
            , servant-ekg:hashable
            , servant-ekg:servant
            , servant-ekg:text
            , servant-ekg:time
-           , servant-xml-conduit:base
            , servant-xml-conduit:bytestring
            , servant-xml-conduit:servant
-           , stemmer:base
+           , servant-auth-server:data-default-class
+           , wuss:template-haskell
 allow-older: aeson:hashable
            , crawlerHAL:servant-client
            , haskell-bee:stm
@@ -216,7 +190,7 @@ allow-older: aeson:hashable
 
 package gargantext
     ghc-options: -fwrite-ide-info
-    
+
 package hmatrix
     ghc-options: -O2 -fsimpl-tick-factor=10000 -fdicts-cheap -fdicts-strict -flate-dmd-anal -fno-state-hack
 

devops/coreNLP/.gitignore

-stanford-corenlp-*

devops/coreNLP/Dockerfile

-FROM openjdk
-
-#ADD home/debian/CoreNLP /CoreNLP
-ADD stanford-corenlp-current /CoreNLP
-WORKDIR /CoreNLP
-
-CMD ./startServer.sh

devops/coreNLP/build.sh

-#!/bin/bash
-
-# releases are here:
-# https://stanfordnlp.github.io/CoreNLP/history.html
-
-VERSION=4.5.4
-FILE="stanford-corenlp-${VERSION}.zip"
-DIR_V="stanford-corenlp-${VERSION}"
-DIR="stanford-corenlp-current"
-URL="http://nlp.stanford.edu/software/${FILE}"
-
-[ ! -f ${FILE} ] && echo 'Fetching file' && wget ${URL} -O ${FILE}
-
-[ ! -d ${DIR_V} ] && echo 'Unzipping file' && unzip ./${FILE}
-
-[ ! -L ${DIR} ] && echo "Symlinking ${DIR_V} -> ${DIR}" && ln -s ${DIR_V} ${DIR}
-
-[ ! -f ${DIR}/startServer.sh ] && echo "Copying startServer.sh" && cp ./startServer.sh ${DIR}/
-
-echo "You can now build with: docker build -t cgenie/corenlp-garg:${VERSION}" --pull .

devops/coreNLP/startServer.sh

-#!/bin/sh
-
-java -mx4g -cp "*" edu.stanford.nlp.pipeline.StanfordCoreNLPServer -port 9000 -timeout 15000

devops/docker/Dockerfile

@@ -3,76 +3,51 @@ FROM ubuntu:noble
 ## NOTA BENE: In order for this to be built successfully, you have to run ./devops/coreNLP/build.sh first.
 
 ARG DEBIAN_FRONTEND=noninteractive
-ARG GHC=9.4.8
-ARG CORENLP=4.5.4
-ARG CORE
-COPY ./shell.nix                                       /builds/gargantext/shell.nix
-COPY ./nix/pkgs.nix                                    /builds/gargantext/nix/pkgs.nix
-COPY ./nix/pinned-23.11.nix                            /builds/gargantext/nix/pinned-23.11.nix
-COPY ./devops/coreNLP/build.sh                         /root/devops/coreNLP/build.sh
-COPY ./devops/coreNLP/startServer.sh                   /root/devops/coreNLP/startServer.sh
-COPY ./bin/setup-ci-environment                        /builds/gargantext/bin/setup-ci-environment
-COPY ./bin/install-cabal2stack                         /builds/gargantext/bin/install-cabal2stack
 
 ENV TZ=Europe/Rome
+ENV LANG='en_US.UTF-8' LANGUAGE='en_US:en' LC_ALL='en_US.UTF-8'
+ENV USER=root
+ENV SHELL /bin/bash
+ENV PATH=/root/.nix-profile/bin:$PATH
+ENV PATH=/root/.local/bin:$PATH
+
+
 RUN apt-get update && \
     apt-get install --no-install-recommends -y \
       apt-transport-https \
-      autoconf \
-      automake \
-      build-essential \
       ca-certificates \
       curl \
-      gcc \
       git \
       gnupg2 \
-      libffi-dev \
-      libffi8 \
-      libgmp-dev \
-      libgmp10 \
-      libncurses-dev \
-      libncurses6 \
-      libnuma-dev \
-      libtinfo6 \
       locales \
-      lsb-release \
       software-properties-common \
-      strace \
       sudo \
-      wget \
-      vim \
       xz-utils \
-      zlib1g-dev \
-      openjdk-21-jdk \
+      #zlib1g-dev \
       unzip && \
     apt-get clean && rm -rf /var/lib/apt/lists/* && \
     mkdir -m 0755 /nix && groupadd -r nixbld && chown root /nix && \
-    for n in $(seq 1 10); do useradd -c "Nix build user $n" -d /var/empty -g nixbld -G nixbld -M -N -r -s "$(command -v nologin)" "nixbld$n"; done
-
-RUN gpg --batch --keyserver keys.openpgp.org     --recv-keys 7D1E8AFD1D4A16D71FADA2F2CCC85C0E40C06A8C && \
+    for n in $(seq 1 10); do useradd -c "Nix build user $n" -d /var/empty -g nixbld -G nixbld -M -N -r -s "$(command -v nologin)" "nixbld$n"; done && \
+    gpg --batch --keyserver keys.openpgp.org     --recv-keys 7D1E8AFD1D4A16D71FADA2F2CCC85C0E40C06A8C && \
     gpg --batch --keyserver keyserver.ubuntu.com --recv-keys FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01
-SHELL ["/bin/bash", "-o", "pipefail", "-c"]
 
-RUN cd /root/devops/coreNLP; ./build.sh
+SHELL ["/bin/bash", "-o", "pipefail", "-c"]
 
 RUN set -o pipefail && \
-    bash <(curl -L https://releases.nixos.org/nix/nix-2.15.0/install) --no-daemon && \
-    locale-gen en_US.UTF-8 && chown root -R /nix
-
-ENV LANG='en_US.UTF-8' LANGUAGE='en_US:en' LC_ALL='en_US.UTF-8'
-ENV USER=root
-ENV SHELL /bin/bash
-RUN . "$HOME/.nix-profile/etc/profile.d/nix.sh" && \
+    locale-gen en_US.UTF-8 && \
+    bash <(curl -L https://releases.nixos.org/nix/nix-2.26.2/install) --no-daemon && \
+    chown root -R /nix && \
+    . "$HOME/.nix-profile/etc/profile.d/nix.sh" && \
     mkdir -p "/builds/gargantext/" && chmod 777 -R "/builds/gargantext" && \
     echo "source $HOME/.nix-profile/etc/profile.d/nix.sh" >> "$HOME/.bashrc" && \
-    echo `which nix-env`
+    echo `which nix-env` && \
+    . $HOME/.bashrc && nix-env --version
 
-ENV PATH=/root/.nix-profile/bin:$PATH
-
-RUN . $HOME/.bashrc && nix-env --version
-
-ENV PATH=/root/.local/bin:$PATH
+# We want to cache nix artifacts in the Dockerfile to improve CI speed
+COPY ./shell.nix /nix-ci-build/
+COPY ./nix       /nix-ci-build/
+RUN set -o pipefail && \
+    pushd /nix-ci-build/ && nix-build shell.nix && popd
 
-RUN cd /builds/gargantext && nix-shell --run "./bin/install-cabal2stack"
 WORKDIR "/builds/gargantext/"
 

devops/docker/docker-compose.yaml

 version: '3'
+name: 'gargantext'
 
 services:
-  caddy:
-    image: caddy:alpine
-    ports:
-      - 8108:8108
-    volumes:
-      - ./Caddyfile:/etc/caddy/Caddyfile:ro
-      - ../../purescript-gargantext:/srv/purescript-gargantext:ro
+  # caddy:
+  #   image: caddy:alpine
+  #   ports:
+  #     - 8108:8108
+  #   volumes:
+  #     - ./Caddyfile:/etc/caddy/Caddyfile:ro
+  #     - ../../purescript-gargantext:/srv/purescript-gargantext:ro
 
   #postgres11:
   #  #image: 'postgres:latest'
@@ -61,12 +62,6 @@ services:
   #   volumes:
   #     - pgadmin:/var/lib/pgadmin
 
-  corenlp:
-    #image: 'cgenie/corenlp-garg:latest'
-    image: 'cgenie/corenlp-garg:4.5.4'
-    ports:
-      - 9000:9000
-
   # johnsnownlp:
   #   image: 'johnsnowlabs/nlp-server:latest'
   #   volumes:

devops/install-corenlp

-#!/bin/bash
-
-if [ ! -d coreNLP ]; then
-    mkdir -v coreNLP
-fi
-
-pushd coreNLP
-
-wget https://dl.gargantext.org/coreNLP.tar.bz2
-tar xvjf coreNLP.tar.bz2
-pushd home/debian/CoreNLP
-./startServer.sh

gargantext-settings.toml_toModify

@@ -102,7 +102,7 @@ pass = PASSWORD_TO_CHANGE
 
 [logs]
 log_file = "/var/log/gargantext/backend.log"
-log_level = "LevelDebug"
+log_level = "info"
 log_formatter = "verbose"
 
 
@@ -124,8 +124,8 @@ smtp_host = "localhost"
 
 
 [notifications]
-central-exchange = { bind = "tcp://*:5560", connect = "tcp://localhost:5560" }
-dispatcher = { bind = "tcp://*:5561", connect = "tcp://localhost:5561" }
+central-exchange = { bind = "tcp://*:5560", connect = "tcp://127.0.0.1:5560" }
+dispatcher = { bind = "tcp://*:5561", connect = "tcp://127.0.0.1:5561" }
 
 
 [nlp]

hie.yaml

@@ -4,61 +4,61 @@ cradle:
       component: "lib:gargantext"
 
     - path: "./bin/gargantext-cli/Main.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Admin.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/FileDiff.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/FilterTermsAndCooc.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Import.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Ini.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Init.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Invitations.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/ObfuscateDB.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Parsers.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Phylo.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Phylo/Common.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Phylo/Profile.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
+
+    - path: "./bin/gargantext-cli/CLI/Server.hs"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Server/Routes.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Types.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Upgrade.hs"
-      component: "gargantext:exe:gargantext-cli"
-
-    - path: "./bin/gargantext-cli/Paths_gargantext.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
-    - path: "./bin/gargantext-server/Main.hs"
-      component: "gargantext:exe:gargantext-server"
+    - path: "./bin/gargantext-cli/CLI/Worker.hs"
+      component: "gargantext:exe:gargantext"
 
-    - path: "./bin/gargantext-server/Paths_gargantext.hs"
-      component: "gargantext:exe:gargantext-server"
+    - path: "./bin/gargantext-cli/Paths_gargantext.hs"
+      component: "gargantext:exe:gargantext"
 
     - path: "./test"
       component: "gargantext:test:garg-test-tasty"
@@ -68,9 +68,3 @@ cradle:
 
     - path: "./test"
       component: "gargantext:test:garg-test-hspec"
-
-    - path: "./bench/Main.hs"
-      component: "gargantext:bench:garg-bench"
-
-    - path: "./bench/Paths_gargantext.hs"
-      component: "gargantext:bench:garg-bench"

nix/cabal2stack.nix

+{ lib,
+  ghc,
+  haskellPackages,
+  fetchFromGitHub }:
+
+let
+  src = fetchFromGitHub {
+    repo = "cabal2stack";
+    owner = "iconnect";
+    rev = "e4960683f518ab4c964e7646706fe2a7e1bf751a";
+    hash = "sha256-KE9VUXFy9QfRmu/+DFcgxV/E6oPBAR7hRaFrSt93eeY=";
+  };
+in
+with haskellPackages;
+mkDerivation {
+  inherit src;
+  pname = "cabal2stack";
+  version = "0";
+  isExecutable = true;
+  executableHaskellDepends = [ base
+                               aeson
+                               cabal-plan
+                               HsYAML
+                               HsYAML-aeson
+                               optics-core
+                               optics-extra
+                               optparse-applicative
+                               transformers ];
+  patches = [
+    ./patches/cabal2stack.patch
+  ];
+  license = lib.licenses.bsd3;
+  mainProgram = "cabal2stack"; 
+}

nix/corenlp.nix

+# https://nixos.wiki/wiki/Java
+
+{ fetchzip,
+  makeWrapper,
+  stdenv,
+  writeShellScript,
+  jre,
+
+  version ? "4.5.9",
+  hash ? "sha256-DOGBkGJfvR1PoXz2CNoo58HXwGLxvPKMChRqlrFtQLQ=", 
+}:
+
+stdenv.mkDerivation (finalAttrs:
+  let
+    startServer = writeShellScript "startCoreNLPServer.sh" ''
+      set -x
+      PORT=9000
+  
+      while getopts ':p:h' opt; do
+        case $opt in
+          (p) PORT=$OPTARG;;
+          (h) echo "$(basename $0) [-p 9000]"
+              exit 0
+              ;;
+        esac
+      done
+  
+      shift "$((OPTIND - 1))"
+
+      ${jre}/bin/java -mx4g -cp "$CORENLP_PATH/*" edu.stanford.nlp.pipeline.StanfordCoreNLPServer -port $PORT -timeout 15000 "$@"
+    '';
+    # see https://huggingface.co/stanfordnlp/CoreNLP/commits/main
+    versionCommits = {
+      "4.5.8" = "34264e88b7add9e0045f4727bc7d1872385f06aa";
+      "4.5.9" = "06f79ee8b1ec475d7630b1871bfd75a57c77ffa4";
+    };
+    commit = versionCommits."${finalAttrs.version}";
+  in
+
+  {
+    name = "corenlp";
+    inherit version;
+    src = fetchzip {
+      inherit hash;
+      # url = "http://nlp.stanford.edu/software/stanford-corenlp-${finalAttrs.version}.zip";
+      # huggin face is more stable
+      url = "https://huggingface.co/stanfordnlp/CoreNLP/resolve/${commit}/stanford-corenlp-latest.zip";
+    };
+    buildInputs = [
+      jre
+    ];
+    nativeBuildInputs = [
+      makeWrapper
+    ];
+    phases = [ "unpackPhase" "installPhase" ];
+    installPhase = ''
+      runHook preInstall
+      mkdir -p $out/bin
+      mkdir -p $out/share/corenlp
+      cp -r . $out/share/corenlp
+      makeWrapper ${startServer} $out/bin/startCoreNLPServer.sh \
+        --set CORENLP_PATH "$out/share/corenlp"
+      runHook postInstall
+    '';
+  }
+)

nix/graphviz.nix

+{ fetchFromGitLab,
+  fetchpatch,
+  graphviz }:
+let
+  graphviz_dev = graphviz.overrideAttrs (finalAttrs: previousAttrs: {
+    version = "11.0.0~dev";
+    src = fetchFromGitLab {
+      owner = "graphviz";
+      repo = "graphviz";
+      rev = "f3ec849249ef9cb824feb7f97449d7159e1dcb4e"; # head as of 2024-03-25, see gargantext#329
+      hash = "sha256-s86IqWz6zeKbcRqpV3cVQBVviHbhUSX1U8GVuJBfjC4=";
+    };
+  });
+in
+graphviz_dev.overrideAttrs
+  (finalAttrs: previousAttrs: {
+    # Increase the YY_BUF_SIZE, see https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/290#note_9015
+    patches = [
+      (fetchpatch {
+        url = "https://gist.githubusercontent.com/adinapoli/e93ca7b1d714d27f4af537716b03e3bb/raw/b9cc297c3465878da2d18ee92a3f9b8273923493/graphviz-yy-buf-size.patch";
+        sha256 = "sha256-8Q3tf37iYaPV50P+Vf/n263ordECiu5eKwONCy3ynV8=";
+      })
+    ];
+  })

nix/igraph.nix

+{ fetchFromGitHub,
+
+  igraph,
+
+  arpack,
+  blas,
+  glpk,
+  gmp,
+  lapack,
+  libxml2,
+  nanomsg,
+  plfit,
+  llvmPackages,
+  
+  version ? "0.10.4",
+  hash ? "sha256-LsTOxUktGZcp46Ec9QH3+9C+VADMYTZZCjKF1gp36xk=" }:
+
+igraph.overrideAttrs (finalAttrs: previousAttrs: {
+  inherit version;
+
+  nativeBuildInputs = previousAttrs.nativeBuildInputs;
+
+  src = fetchFromGitHub {
+    inherit hash;
+    owner = "igraph";
+    repo = "igraph";
+    rev = version;
+  };
+
+  postPatch = ''
+    echo "${version}" > IGRAPH_VERSION
+  '';
+
+  outputs = [ "dev" "out" "doc" ];
+
+  buildInputs = [
+    arpack
+    blas
+    glpk
+    gmp
+    lapack
+    libxml2
+    nanomsg
+    plfit
+    llvmPackages.openmp
+  ];
+
+  cmakeFlags = [
+    "-DIGRAPH_USE_INTERNAL_BLAS=OFF"
+    "-DIGRAPH_USE_INTERNAL_LAPACK=OFF"
+    "-DIGRAPH_USE_INTERNAL_ARPACK=OFF"
+    "-DIGRAPH_USE_INTERNAL_GLPK=OFF"
+    "-DIGRAPH_USE_INTERNAL_GMP=OFF"
+    "-DIGRAPH_USE_INTERNAL_PLFIT=OFF"
+    "-DIGRAPH_GLPK_SUPPORT=ON"
+    "-DIGRAPH_GRAPHML_SUPPORT=OFF"
+    "-DIGRAPH_OPENMP_SUPPORT=ON"
+    "-DIGRAPH_ENABLE_LTO=AUTO"
+    "-DIGRAPH_ENABLE_TLS=ON"
+    "-DBUILD_SHARED_LIBS=ON"
+    "-DCMAKE_INSTALL_PREFIX=${placeholder "out"}"
+    "-DCMAKE_INSTALL_LIBDIR=${placeholder "out"}/lib"
+    "-DCMAKE_INSTALL_DATADIR=${placeholder "out"}/share"
+  ];
+
+  doCheck = false;
+
+  postInstall = ''
+    mkdir -p "$out/share"
+    cp -r doc "$out/share"
+  '';
+
+  postFixup = previousAttrs.postFixup + ''
+    echo "Copying files where they belong .."
+    CUR_DIR=$PWD
+    cd "$dev/include/igraph" && cp *.h ../
+    cd $CUR_DIR
+  '';
+
+})

nix/patches/cabal2stack.patch

+diff --git i/cabal2stack.cabal w/cabal2stack.cabal
+index 69767a2..92c4895 100644
+--- i/cabal2stack.cabal
++++ w/cabal2stack.cabal
+@@ -26,14 +26,14 @@ executable cabal2stack
+ 
+   -- boot dependencies
+   build-depends:
+-    , base          >=4.12     && <4.18
++    , base          >=4.12     && <5
+     , bytestring    ^>=0.10.8.2 || ^>=0.11.3.0
+     , containers    ^>=0.6.0.1
+     , directory     ^>=1.3.3.0
+     , filepath      ^>=1.4.2.1
+     , process       ^>=1.6.5.0
+     , text          >=1.2.3.0 && <2.1
+-    , transformers  ^>=0.5.6.2
++    , transformers  >=0.5.6.2 && < 0.7
+ 
+   -- other dependencies
+   build-depends:
+@@ -43,4 +43,4 @@ executable cabal2stack
+     , HsYAML-aeson          ^>=0.2.0.1
+     , optics-core           ^>=0.4
+     , optics-extra          ^>=0.4
+-    , optparse-applicative  ^>=0.17.0.0
++    , optparse-applicative  >=0.17.0.0 && < 0.20

nix/pinned-24.05.nix

+import (builtins.fetchGit {
+  name = "nixos-24.05";
+  url = "https://github.com/nixos/nixpkgs";
+  ref = "refs/heads/nixos-24.05";
+  rev = "63dacb46bf939521bdc93981b4cbb7ecb58427a0";
+})

nix/pinned-25.05.darwin.nix

+import (builtins.fetchTarball "https://github.com/NixOS/nixpkgs/archive/32fb99ba93fea2798be0e997ea331dd78167f814.tar.gz")

nix/pinned-25.05.nix

+import (builtins.fetchTarball "https://github.com/NixOS/nixpkgs/archive/c46290747b2aaf090f48a478270feb858837bf11.tar.gz")

nix/pkgs.nix

-{ pkgs       ? import ./pinned-23.11.nix {} }:
+{ pkgs ? import (if builtins.elem builtins.currentSystem ["x86_64-darwin" "aarch64-darwin"]
+                 then ./pinned-25.05.darwin.nix
+                 else ./pinned-25.05.nix) {} }:
 
 rec {
   inherit pkgs;
-  ghc948 = if pkgs.stdenv.isDarwin
-           then pkgs.haskell.compiler.ghc948.overrideAttrs (finalAttrs: previousAttrs: {
-                patches = previousAttrs.patches ++ [
-                            # Reverts the linking behavior of GHC to not resolve `-libc++` to `c++`.
-                            (pkgs.fetchpatch {
-                              url = "https://gist.githubusercontent.com/adinapoli/bf722db15f72763bf79dff13a3104b6f/raw/362da0aa3db5c530e0d276183ba68569f216d65a/ghc947-macOS-loadArchive-fix.patch";
-                              sha256 = "sha256-0tHrkWRKFWUewj3uIA0DujVCXo1qgX2lA5p0MIsAHYs=";
-                            })
-                          ];
-                })
-           else pkgs.haskell.compiler.ghc948;
-  cabal_install_3_10_2_1 = pkgs.haskell.lib.compose.justStaticExecutables pkgs.haskell.packages.ghc948.cabal-install;
-  graphviz_dev = pkgs.graphviz.overrideAttrs (finalAttrs: previousAttrs: {
-    version = "11.0.0~dev";
-    src = pkgs.fetchFromGitLab {
-      owner = "graphviz";
-      repo = "graphviz";
-      rev = "f3ec849249ef9cb824feb7f97449d7159e1dcb4e"; # head as of 2024-03-25, see gargantext#329
-      hash = "sha256-s86IqWz6zeKbcRqpV3cVQBVviHbhUSX1U8GVuJBfjC4=";
-    };
-  });
-  graphviz = graphviz_dev.overrideAttrs (finalAttrs: previousAttrs: {
-                # Increase the YY_BUF_SIZE, see https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/290#note_9015
-                patches = [
-                            (pkgs.fetchpatch {
-                              url = "https://gist.githubusercontent.com/adinapoli/e93ca7b1d714d27f4af537716b03e3bb/raw/b9cc297c3465878da2d18ee92a3f9b8273923493/graphviz-yy-buf-size.patch";
-                              sha256 = "sha256-8Q3tf37iYaPV50P+Vf/n263ordECiu5eKwONCy3ynV8=";
-                            })
-                          ];
-                });
-
-  # nng180 = pkgs.nng.overrideAttrs (new: old: rec {
-  #   version = "1.8.0";
-  # });
+  ghc966 = pkgs.haskell.compiler.ghc966;
+  cabal_install = pkgs.haskell.lib.compose.justStaticExecutables pkgs.haskell.packages.ghc966.cabal-install;
   
-  igraph_0_10_4 = pkgs.igraph.overrideAttrs (finalAttrs: previousAttrs: {
-    version = "0.10.4";
-
-    nativeBuildInputs = previousAttrs.nativeBuildInputs or [] ++ [ pkgs.clang_12 ];
-
-    src = pkgs.fetchFromGitHub {
-      owner = "igraph";
-      repo = "igraph";
-      rev = "0.10.4";
-      hash = "sha256-LsTOxUktGZcp46Ec9QH3+9C+VADMYTZZCjKF1gp36xk=";
-    };
-
-    postPatch = ''
-      echo "0.10.4" > IGRAPH_VERSION
-    '';
-
-    outputs = [ "out" "doc" ];
-
-    buildInputs = [
-      pkgs.arpack
-      pkgs.blas
-      pkgs.glpk
-      pkgs.gmp
-      pkgs.lapack
-      pkgs.libxml2
-      pkgs.nanomsg
-      pkgs.plfit
-    ] ++ pkgs.lib.optionals pkgs.stdenv.cc.isClang [
-      pkgs.llvmPackages.openmp
-    ];
-
-    cmakeFlags = [
-      "-DIGRAPH_USE_INTERNAL_BLAS=OFF"
-      "-DIGRAPH_USE_INTERNAL_LAPACK=OFF"
-      "-DIGRAPH_USE_INTERNAL_ARPACK=OFF"
-      "-DIGRAPH_USE_INTERNAL_GLPK=OFF"
-      "-DIGRAPH_USE_INTERNAL_GMP=OFF"
-      "-DIGRAPH_USE_INTERNAL_PLFIT=OFF"
-      "-DIGRAPH_GLPK_SUPPORT=ON"
-      "-DIGRAPH_GRAPHML_SUPPORT=OFF"
-      "-DIGRAPH_OPENMP_SUPPORT=ON"
-      "-DIGRAPH_ENABLE_LTO=AUTO"
-      "-DIGRAPH_ENABLE_TLS=ON"
-      "-DBUILD_SHARED_LIBS=ON"
-    ];
-
-    postInstall = ''
-      mkdir -p "$out/share"
-      cp -r doc "$out/share"
-    '';
-
-    postFixup = previousAttrs.postFixup + ''
-      CUR_DIR=$PWD
-      cd "$out/include/igraph" && cp *.h ../
-      cd $CUR_DIR
-    '';
-
+  graphviz = pkgs.callPackage ./graphviz.nix {};
+  igraph_0_10_4 = pkgs.callPackage ./igraph.nix {};
+  corenlp = pkgs.callPackage ./corenlp.nix { };  # 4.5.8
+  cabal2stack = pkgs.callPackage ./cabal2stack.nix { ghc = ghc966; };
+  nng_notls = pkgs.nng.overrideAttrs (old: {
+    cmakeFlags = (old.cmakeFlags or []) ++ [ "-DNNG_ENABLE_TLS=OFF" ];
   });
+  
   hsBuildInputs = [
-    ghc948
-    cabal_install_3_10_2_1
+    ghc966
+    cabal_install
     pkgs.haskellPackages.alex
     pkgs.haskellPackages.happy
     pkgs.haskellPackages.pretty-show
   ];
   nonhsBuildInputs = with pkgs; [
+    #haskell-language-server
+    blas
     bzip2
+    cabal2stack
+    corenlp
+    curl
     czmq
     docker-compose
+    expat
+    gfortran
     git
     gmp
+    graphviz
     gsl
-    #haskell-language-server
     hlint
-    libffi
+    icu
+    igraph_0_10_4
+    jre
     lapack
-    lzma
+    libffi
+    libpqxx
+    libsodium
+    nng_notls
+    nil  # nix language server
     pcre
     pkg-config
     postgresql
+    stdenv.cc.cc
     xz
     zlib
-    blas
-    gfortran7
-    expat
-    icu
-    graphviz
-    clang_12
-    llvm_12
-    gcc12
-    igraph_0_10_4
-    libpqxx
-    libsodium
-    nanomsg
-    # nng180
     zeromq
     curl
   ] ++ ( lib.optionals stdenv.isDarwin [
@@ -139,8 +60,8 @@ rec {
        ]);
   libPaths = pkgs.lib.makeLibraryPath nonhsBuildInputs;
   shellHook = ''
-    export LD_LIBRARY_PATH="${pkgs.gfortran7.cc.lib}:${libPaths}:$LD_LIBRARY_PATH"
-    export LIBRARY_PATH="${pkgs.gfortran7.cc.lib}:${libPaths}"
+    export LD_LIBRARY_PATH="${pkgs.gfortran.cc.lib}:${libPaths}:$LD_LIBRARY_PATH"
+    export LIBRARY_PATH="${pkgs.gfortran.cc.lib}:${libPaths}"
     export PATH="${pkgs.gccStdenv}/bin:$PATH"
     export NIX_CC="${pkgs.gccStdenv}"
     export CC="${pkgs.gccStdenv}/bin/gcc"

shell.nix

@@ -3,9 +3,8 @@ let
   myBuildInputs = [
     pkgs.pkgs.docker-compose
     #pkgs.pkgs.haskell-language-server
-    pkgs.pkgs.stack
     pkgs.pkgs.websocat
-  ];
+  ] ++ pkgs.pkgs.lib.optional (!pkgs.pkgs.stdenv.isDarwin) pkgs.pkgs.stack;
 in
 pkgs.pkgs.mkShell {
   name = pkgs.shell.name;

src/Gargantext/API.hs

@@ -48,69 +48,68 @@ import Gargantext.API.Middleware (logStdoutDevSanitised)
 import Gargantext.API.Routes.Named (API)
 import Gargantext.API.Routes.Named.EKG (EkgAPI)
 import Gargantext.API.Server.Named (server)
-import Gargantext.Core.Config (gc_notifications_config, gc_frontend_config)
+import Gargantext.Core.Config
 import Gargantext.Core.Config.Types (CORSOrigin(..), CORSSettings, MicroServicesProxyStatus(..), NotificationsConfig(..), PortNumber, SettingsFile(..), corsAllowedOrigins, fc_appPort, fc_cors, fc_cookie_settings, microServicesProxyStatus)
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.Notifications (withNotifications)
 import Gargantext.Database.Prelude qualified as DB
 import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
 import Gargantext.Prelude hiding (putStrLn, to)
-import Gargantext.System.Logging (withLoggerHoisted)
+import Gargantext.System.Logging (withLoggerIO, renderLogLevel)
 import Network.HTTP.Types hiding (Query)
 import Network.Wai (Middleware, Request, requestHeaders)
 import Network.Wai.Handler.Warp hiding (defaultSettings)
 import Network.Wai.Middleware.Cors
 import Network.Wai.Middleware.RequestLogger (logStdout)
--- import Paths_gargantext (getDataDir)
 import Servant hiding (Header)
 import Servant.Client.Core.BaseUrl (showBaseUrl)
 import System.Clock qualified as Clock
 import System.Cron.Schedule qualified as Cron
--- import System.FilePath
 
 -- | startGargantext takes as parameters port number and Toml file.
 startGargantext :: Mode -> PortNumber -> SettingsFile -> IO ()
-startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mode $ \logger -> do
+startGargantext mode port sf@(SettingsFile settingsFile) = do
   config <- readConfig sf <&> (gc_frontend_config . fc_appPort) .~ port
-  when (port /= config ^. gc_frontend_config . fc_appPort) $
-    panicTrace "TODO: conflicting settings of port"
-  let nc = config ^. gc_notifications_config
-  withNotifications nc $ \dispatcher -> do
-    env <- newEnv logger config dispatcher
-    let fc = env ^. env_config . gc_frontend_config
-    let proxyStatus = microServicesProxyStatus fc
-    runDbCheck env
-    portRouteInfo nc port proxyStatus
-    app <- makeApp env
-    mid <- makeGargMiddleware (fc ^. fc_cors) mode
-    periodicActions <- schedulePeriodicActions env
-  
-    let runServer = run port (mid app) `finally` stopGargantext periodicActions
-    case proxyStatus of
-      PXY_disabled
-        -> runServer -- the proxy is disabled, do not spawn the application
-      PXY_enabled proxyPort
-        -> do
-          proxyCache <- InMemory.newCache (Just oneHour)
-          let runProxy  = run proxyPort (mid (microServicesProxyApp proxyCache env))
-          Async.race_ runServer runProxy
-  
+  withLoggerIO (config ^. gc_logging) $ \logger -> do
+    when (port /= config ^. gc_frontend_config . fc_appPort) $
+      panicTrace "TODO: conflicting settings of port"
+    withNotifications config $ \dispatcher -> do
+      env <- newEnv logger config dispatcher
+      let fc = env ^. env_config . gc_frontend_config
+      let proxyStatus = microServicesProxyStatus fc
+      runDbCheck env
+      startupInfo config port proxyStatus
+      app <- makeApp env
+      mid <- makeGargMiddleware (fc ^. fc_cors) mode
+      periodicActions <- schedulePeriodicActions env
+
+      let runServer = run port (mid app) `finally` stopGargantext periodicActions
+      case proxyStatus of
+        PXY_disabled
+          -> runServer -- the proxy is disabled, do not spawn the application
+        PXY_enabled proxyPort
+          -> do
+            proxyCache <- InMemory.newCache (Just oneHour)
+            let runProxy  = run proxyPort (mid (microServicesProxyApp proxyCache env))
+            Async.race_ runServer runProxy
+
   where runDbCheck env = do
           r <- runExceptT (runReaderT DB.dbCheck env) `catch`
             (\(err :: SomeException) -> pure $ Left err)
           case r of
             Right True  -> pure ()
             Right False -> panicTrace $
-              "You must run 'gargantext init " <> pack settingsFile <>
+              "You must run 'gargantext init -c " <> pack settingsFile <>
               "' before running gargantext-server (only the first time)."
             Left err -> panicTrace $ "Unexpected exception:" <> show err
         oneHour = Clock.fromNanoSecs 3600_000_000_000
 
-portRouteInfo :: NotificationsConfig -> PortNumber -> MicroServicesProxyStatus -> IO ()
-portRouteInfo nc mainPort proxyStatus = do
+startupInfo :: GargConfig -> PortNumber -> MicroServicesProxyStatus -> IO ()
+startupInfo config mainPort proxyStatus = do
   putStrLn   "=========================================================================================================="
-  putStrLn   " GarganText Main Routes"
+  putStrLn   " GarganText Server"
   putStrLn   "=========================================================================================================="
+  putStrLn $ " - Log Level ...............................: " <> renderLogLevel ll
   putStrLn $ " - Web GarganText Frontend..................: " <> "http://localhost:" <> toUrlPiece mainPort <> "/index.html"
   putStrLn $ " - Swagger UI (API documentation)...........: " <> "http://localhost:" <> toUrlPiece mainPort <> "/swagger-ui"
   putStrLn $ " - Playground GraphQL (API documentation)...: " <> "http://localhost:" <> toUrlPiece mainPort <> "/gql"
@@ -121,6 +120,8 @@ portRouteInfo nc mainPort proxyStatus = do
   putStrLn $ " - WebSocket address........................: " <> "ws://localhost:" <> toUrlPiece mainPort <> "/ws"
   putStrLn   "=========================================================================================================="
   where
+    nc = config ^. gc_notifications_config
+    ll = config ^. gc_logging . lc_log_level
     renderProxyStatus = case proxyStatus of
       PXY_disabled ->
         " - Microservices proxy .....................: DISABLED (enable in gargantext-settings.toml)"

src/Gargantext/API/Admin/Auth.hs

@@ -24,7 +24,6 @@ And you have the main viz
 
 -}
 
-{-# LANGUAGE MonoLocalBinds      #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -62,7 +61,7 @@ import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
 import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
 import Gargantext.Database.Action.User.New (guessUserName)
 import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId)
-import Gargantext.Database.Prelude (Cmd, IsDBEnvExtra, IsDBCmd)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.User
 import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
 import Gargantext.Database.Query.Tree.Root (getRoot)
@@ -100,14 +99,14 @@ checkAuthRequest couldBeEmail (GargPassword p) = do
         Nothing      -> couldBeEmail -- we are sure this is not an email
         Just (u,_)   -> u            -- this was an email in fact
 
-  candidate <- head <$> getUsersWith usrname
+  candidate <- head <$> runDBQuery (getUsersWith usrname)
   case candidate of
     Nothing -> pure InvalidUser
     Just (UserLight { userLight_password = GargPassword h, .. }) ->
       case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
         Auth.PasswordCheckFail    -> pure InvalidPassword
         Auth.PasswordCheckSuccess -> do
-          muId <- head <$> getRoot (UserName usrname)
+          muId <- head <$> runDBQuery (getRoot (UserName usrname))
           case _node_id <$> muId of
             Nothing  -> pure InvalidUser
             Just nodeId -> do
@@ -144,12 +143,13 @@ withAccessM :: ( IsDBCmd env err m )
             -> m a
             -> m a
 withAccessM (AuthenticatedUser nodeId _userId) (PathNode id) m = do
-  d <- id `isDescendantOf` nodeId
+  d <- runDBQuery (id `isDescendantOf` nodeId)
   if d then m else m -- serverError err401
 
 withAccessM (AuthenticatedUser nodeId _userId) (PathNodeNode cId docId) m = do
-  _a <- isIn cId docId -- TODO use one query for all ?
-  _d <- cId `isDescendantOf` nodeId
+  runDBQuery $ do
+    void $ isIn cId docId -- TODO use one query for all ?
+    void $ (cId `isDescendantOf` nodeId)
   if True -- a && d
      then m
      else m -- serverError err401
@@ -249,7 +249,7 @@ forgotPasswordGet (Just uuid) = do
     Nothing -> throwError $ _ServerError # err404 { errBody = "Not found" }
     Just uuid' -> do
       -- fetch user
-      us <- getUsersWithForgotPasswordUUID uuid'
+      us <- runDBQuery $ getUsersWithForgotPasswordUUID uuid'
       case us of
         [u] -> forgotPasswordGetUser u
         _ -> throwError $ _ServerError # err404 { errBody = "Not found" }
@@ -266,12 +266,10 @@ forgotPasswordGetUser (UserLight { .. }) = do
   hashed <- liftBase $ Auth.hashPassword $ Auth.mkPassword password
   let hashed' = Auth.unPasswordHash hashed
   let userPassword = UserLight { userLight_password = GargPassword hashed', .. }
-  _ <- updateUserPassword userPassword
 
-  -- display this briefly in the html
-
-  -- clear the uuid so that the page can't be refreshed
-  _ <- updateUserForgotPasswordUUID $ UserLight { userLight_forgot_password_uuid = Nothing, .. }
+  runDBTx $ do
+    void $ updateUserPassword userPassword
+    void $ updateUserForgotPasswordUUID $ UserLight { userLight_forgot_password_uuid = Nothing, .. }
 
   pure $ ForgotPasswordGet password
 
@@ -286,7 +284,7 @@ forgotUserPassword (UserLight { .. }) = do
   let userUUID = UserLight { userLight_forgot_password_uuid = Just $ toText uuid, .. }
 
   -- save user with that uuid
-  _ <- updateUserForgotPasswordUUID userUUID
+  _ <- runDBTx $ updateUserForgotPasswordUUID userUUID
 
   -- send email with uuid link
   cfg <- view $ mailSettings
@@ -304,7 +302,7 @@ generateForgotPasswordUUID :: (IsDBEnvExtra env)
   => Cmd env err UUID
 generateForgotPasswordUUID = do
   uuid <- liftBase $ nextRandom
-  us <- getUsersWithForgotPasswordUUID uuid
+  us <- runDBQuery $ getUsersWithForgotPasswordUUID uuid
   case us of
     [] -> pure uuid
     _ -> generateForgotPasswordUUID

src/Gargantext/API/Admin/Auth/Types.hs

@@ -65,6 +65,8 @@ data AuthResponse = AuthResponse { _authRes_token   :: Token
                                  }
   deriving (Generic, Eq, Show)
 
+instance NFData AuthResponse where
+
 type Token  = Text
 type TreeId = NodeId
 

src/Gargantext/API/Admin/EnvTypes.hs

@@ -25,7 +25,7 @@ module Gargantext.API.Admin.EnvTypes (
   , env_jwt_settings
   , env_pool
   , env_nodeStory
-  
+
   , menv_firewall
   , dev_env_logger
 
@@ -38,19 +38,18 @@ module Gargantext.API.Admin.EnvTypes (
 import Control.Lens (to, view)
 import Data.List ((\\))
 import Data.Pool (Pool)
-import Data.Text qualified as T
 import Database.PostgreSQL.Simple (Connection)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog)
 import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Prelude (GargM, IsGargServer)
+import Gargantext.Core.Config
+import Gargantext.Core.Mail.Types (HasMail, mailSettings)
+import Gargantext.Core.NLP (HasNLPServer(..), nlpServerMap)
+import Gargantext.Core.NodeStory
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
 import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
 import Gargantext.Core.Notifications.Dispatcher (Dispatcher)
 import Gargantext.Core.Notifications.Dispatcher.Types (HasDispatcher(..))
-import Gargantext.Core.Config (GargConfig(..), gc_mail_config, gc_nlp_config, HasJWTSettings(..), HasConfig(..))
-import Gargantext.Core.Mail.Types (HasMail, mailSettings)
-import Gargantext.Core.NLP (HasNLPServer(..), nlpServerMap)
-import Gargantext.Core.NodeStory
 import Gargantext.Database.Prelude (HasConnectionPool(..))
 import Gargantext.Prelude hiding (to)
 import Gargantext.System.Logging
@@ -58,6 +57,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
 import Network.HTTP.Client (Manager)
 import Servant.Auth.Server (JWTSettings)
 import System.Log.FastLogger qualified as FL
+import Gargantext.System.Logging.Loggers
 
 
 data Mode = Dev | Mock | Prod
@@ -73,28 +73,6 @@ modeToLoggingLevels = \case
    -- For production, accepts everything but DEBUG.
    Prod -> [minBound .. maxBound] \\ [DEBUG]
 
-instance MonadLogger (GargM Env BackendInternalError) where
-  getLogger = asks _env_logger
-
-instance HasLogger (GargM Env BackendInternalError) where
-  data instance Logger (GargM Env BackendInternalError)  =
-    GargLogger {
-        logger_mode    :: Mode
-      , logger_set     :: FL.LoggerSet
-      }
-  type instance LogInitParams (GargM Env BackendInternalError) = Mode
-  type instance LogPayload (GargM Env BackendInternalError)    = 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 <> "] " :: Text
-    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)
-
-
 -- Do /not/ treat the data types of this type as strict, because it's convenient
 -- to be able to partially initialise things like an 'Env' during tests, without
 -- having to specify /everything/. This means that when we /construct/ an 'Env',
@@ -102,7 +80,7 @@ instance HasLogger (GargM Env BackendInternalError) where
 data Env = Env
   { _env_logger           :: ~(Logger (GargM Env BackendInternalError))
   , _env_pool             :: ~(Pool Connection)
-  , _env_nodeStory        :: ~NodeStoryEnv
+  , _env_nodeStory        :: ~(NodeStoryEnv BackendInternalError)
   , _env_manager          :: ~Manager
   , _env_config           :: ~GargConfig
   , _env_dispatcher       :: ~Dispatcher
@@ -118,15 +96,9 @@ instance HasConfig Env where
 instance HasConnectionPool Env where
   connPool = env_pool
 
-instance HasNodeStoryEnv Env where
+instance HasNodeStoryEnv Env BackendInternalError where
   hasNodeStory = env_nodeStory
 
-instance HasNodeStoryImmediateSaver Env where
-  hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
-
-instance HasNodeArchiveStoryImmediateSaver Env where
-  hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate
-
 instance HasJWTSettings Env where
   jwtSettings = env_jwt_settings
 
@@ -142,7 +114,10 @@ instance HasDispatcher Env Dispatcher where
 instance CET.HasCentralExchangeNotification Env where
   ce_notify m = do
     c <- asks (view env_config)
-    liftBase $ CE.notify (_gc_notifications_config c) m
+    liftBase $ CE.notify c m
+
+instance HasManager Env where
+  gargHttpManager = env_manager
 
 data FireWall = FireWall { unFireWall :: Bool }
 
@@ -158,27 +133,20 @@ instance MonadLogger (GargM DevEnv BackendInternalError) where
 
 instance HasLogger (GargM DevEnv BackendInternalError) where
   data instance Logger (GargM DevEnv BackendInternalError)  =
-    GargDevLogger {
-        dev_logger_mode    :: Mode
-      , dev_logger_set     :: FL.LoggerSet
-      }
-  type instance LogInitParams (GargM DevEnv BackendInternalError) = Mode
+    GargDevLogger { _GargDevLogger :: MonadicStdLogger FL.LogStr IO }
+  type instance LogInitParams (GargM DevEnv BackendInternalError) = LogConfig
   type instance LogPayload (GargM DevEnv BackendInternalError)    = 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 <> "] " :: Text
-    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)
+  initLogger cfg = fmap GargDevLogger $ (liftIO $ monadicStdLogger cfg)
+  destroyLogger = liftIO . _msl_destroy . _GargDevLogger
+  logMsg (GargDevLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
+  logTxt (GargDevLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
 
 data DevEnv = DevEnv
   { _dev_env_config    :: !GargConfig
+  , _dev_env_manager   :: ~Manager
   , _dev_env_logger    :: !(Logger (GargM DevEnv BackendInternalError))
   , _dev_env_pool      :: !(Pool Connection)
-  , _dev_env_nodeStory :: !NodeStoryEnv
+  , _dev_env_nodeStory :: !(NodeStoryEnv BackendInternalError)
   }
 
 makeLenses ''DevEnv
@@ -186,7 +154,7 @@ makeLenses ''DevEnv
 instance CET.HasCentralExchangeNotification DevEnv where
   ce_notify m = do
     nc <- asks (view dev_env_config)
-    liftBase $ CE.notify (_gc_notifications_config nc) m
+    liftBase $ CE.notify nc m
 
 -- | Our /mock/ job handle.
 data DevJobHandle = DevJobHandle
@@ -213,6 +181,8 @@ instance MonadJobStatus (GargM DevEnv err) where
 
   markFailed _ _ = pure ()
 
+  emitWarning _ _ = pure ()
+
   addMoreSteps _ _ = pure ()
 
 instance HasConfig DevEnv where
@@ -222,20 +192,29 @@ instance HasConnectionPool DevEnv where
   connPool = dev_env_pool
 
 
-instance HasNodeStoryEnv DevEnv where
+instance HasNodeStoryEnv DevEnv BackendInternalError where
   hasNodeStory = dev_env_nodeStory
 
-instance HasNodeStoryImmediateSaver DevEnv where
-  hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
-
-instance HasNodeArchiveStoryImmediateSaver DevEnv where
-  hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate
-
 instance HasMail DevEnv where
   mailSettings = dev_env_config . gc_mail_config
 
+instance HasManager DevEnv where
+  gargHttpManager = dev_env_manager
+
 instance HasNLPServer DevEnv where
   nlpServer = dev_env_config . gc_nlp_config . (to nlpServerMap)
 
-
 instance IsGargServer Env BackendInternalError (GargM Env BackendInternalError)
+
+instance HasLogger (GargM Env BackendInternalError) where
+  newtype instance Logger (GargM Env BackendInternalError)  =
+    GargLogger { _GargLogger :: MonadicStdLogger FL.LogStr IO }
+  type instance LogInitParams (GargM Env BackendInternalError) = LogConfig
+  type instance LogPayload (GargM Env BackendInternalError)    = FL.LogStr
+  initLogger cfg = fmap GargLogger $ (liftIO $ monadicStdLogger cfg)
+  destroyLogger = liftIO . _msl_destroy . _GargLogger
+  logMsg (GargLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
+  logTxt (GargLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
+
+instance MonadLogger (GargM Env BackendInternalError) where
+  getLogger = asks _env_logger

src/Gargantext/API/Admin/Orchestrator/Types.hs

@@ -17,39 +17,68 @@ Portability : POSIX
 module Gargantext.API.Admin.Orchestrator.Types
   where
 
-import Data.Aeson (genericParseJSON, genericToJSON)
+import Data.Aeson (genericParseJSON, genericToJSON, object, withObject, (.=), (.:), (.:?), Value(String))
+import Data.Aeson.Types (unexpected)
 import Data.Morpheus.Types ( GQLType(..), DropNamespace(..), typeDirective )
 import Data.Swagger (ToSchema, URL, declareNamedSchema, defaultSchemaOptions, genericDeclareNamedSchemaUnrestricted)
 -- import Gargantext.API.GraphQL.UnPrefix qualified as GQLU
 import Gargantext.Core.Types (TODO(..))
 import Gargantext.Core.Utils.Aeson (jsonOptions)
 import Gargantext.Prelude
-import Test.QuickCheck (elements)
-import Test.QuickCheck.Arbitrary
+import PUBMED.Types qualified as PUBMED
+
+
+type EPOAPIToken = Text
+type EPOAPIUser = Text
 
 ------------------------------------------------------------------------
 -- | Main Types
 -- TODO IsidoreAuth
 data ExternalAPIs = OpenAlex
-                  | PubMed
+                  | PubMed (Maybe PUBMED.APIKey)
                   | Arxiv
                   | HAL
                   | IsTex
                   | Isidore
-                  | EPO
-  deriving (Show, Eq, Generic, Enum, Bounded)
+                  | EPO (Maybe EPOAPIUser) (Maybe EPOAPIToken)
+  deriving (Show, Eq, Generic)
 
 
 -- | Main Instances
-instance FromJSON ExternalAPIs
-instance ToJSON ExternalAPIs
+instance FromJSON ExternalAPIs where
+  parseJSON = withObject "ExternalAPIs" $ \o -> do
+    db <- o .: "db"
+    case db of
+      "OpenAlex" -> pure OpenAlex
+      "PubMed" -> do
+        mAPIKey <- o .:? "api_key"
+        pure $ PubMed mAPIKey
+      "Arxiv" -> pure Arxiv
+      "HAL" -> pure HAL
+      "IsTex" -> pure IsTex
+      "Isidore" -> pure Isidore
+      "EPO" -> do
+        mAPIUser <- o .:? "api_user"
+        mAPIToken <- o .:? "api_token"
+        pure $ EPO mAPIUser mAPIToken
+      s -> unexpected (String s)
+instance ToJSON ExternalAPIs where
+  toJSON (PubMed mAPIKey) = object [ "db" .= toJSON ("PubMed" :: Text)
+                                   , "api_key" .= toJSON mAPIKey ]
+  toJSON (EPO mAPIUser mAPIToken) = object [ "db" .= toJSON ("EPO" :: Text)
+                                           , "api_user" .= toJSON mAPIUser
+                                           , "api_token" .= toJSON mAPIToken ]
+  toJSON t = object [ "db" .= toJSON (show t :: Text) ]
 
 externalAPIs :: [ExternalAPIs]
-externalAPIs = [minBound .. maxBound]
-
-instance Arbitrary ExternalAPIs
-  where
-    arbitrary = arbitraryBoundedEnum
+externalAPIs =
+  [ OpenAlex
+  , PubMed Nothing
+  , Arxiv
+  , HAL
+  , IsTex
+  , Isidore
+  , EPO Nothing Nothing ]
 
 instance ToSchema ExternalAPIs where
   declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
@@ -64,11 +93,6 @@ data ScraperEvent = ScraperEvent
   , _scev_date    :: !(Maybe Text)
   }
   deriving (Show, Generic, Eq)
-
-instance Arbitrary ScraperEvent where
-  arbitrary = ScraperEvent <$> elements [Nothing, Just "test message"]
-                           <*> elements [Nothing, Just "INFO", Just "WARN"]
-                           <*> elements [Nothing, Just "2018-04-18"]
 instance ToJSON ScraperEvent where
   toJSON = genericToJSON $ jsonOptions "_scev_"
 instance FromJSON ScraperEvent where
@@ -91,12 +115,6 @@ makeLenses ''JobLog
 noJobLog :: JobLog
 noJobLog = JobLog Nothing Nothing Nothing Nothing
 
-instance Arbitrary JobLog where
-  arbitrary = JobLog
-           <$> arbitrary
-           <*> arbitrary
-           <*> arbitrary
-           <*> arbitrary
 instance ToJSON JobLog where
   toJSON = genericToJSON $ jsonOptions "_scst_"
 instance FromJSON JobLog where

src/Gargantext/API/Admin/Settings.hs

@@ -27,10 +27,10 @@ import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
 import Gargantext.API.Admin.EnvTypes (Env(..))
 import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Prelude (GargM)
-import Gargantext.Core.Notifications.Dispatcher qualified as D
 import Gargantext.Core.Config (GargConfig(..))
 import Gargantext.Core.Config.Types (jwtSettings)
-import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
+import Gargantext.Core.NodeStory (mkNodeStoryEnv)
+import Gargantext.Core.Notifications.Dispatcher qualified as D
 import Gargantext.Prelude
 import Gargantext.System.Logging (Logger)
 import Network.HTTP.Client.TLS (newTlsManager)
@@ -62,7 +62,7 @@ settingsFromEnvironment =
     Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
              <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
              <*> optSetting "PORT" 3000
-             <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
+             <*> (parseLogLevel <$> optSetting "GGTX_LOG_LEVEL" "warn")
              <*> reqSetting "DB_SERVER"
              <*> (parseJwk <$> reqSetting "JWT_SECRET")
              <*> optSetting "SEND_EMAIL" SendEmailViaAws
@@ -150,7 +150,7 @@ newEnv logger config dispatcher = do
   -- putStrLn ("Overrides: " <> show prios :: Text)
   -- putStrLn ("New priorities: " <> show prios' :: Text)
   !pool          <- newPool $ _gc_database_config config
-  !nodeStory_env <- fromDBNodeStoryEnv pool
+  let !nodeStory_env = mkNodeStoryEnv
 
   -- secret        <- Jobs.genSecret
   -- let jobs_settings = (Jobs.defaultJobSettings 1 secret)

src/Gargantext/API/Auth/PolicyCheck.hs

@@ -33,6 +33,7 @@ module Gargantext.API.Auth.PolicyCheck (
   , nodePublishedEdit
   , moveChecks
   , publishChecks
+  , remoteExportChecks
   , userMe
   , alwaysAllow
   , alwaysDeny
@@ -46,25 +47,25 @@ import Gargantext.API.Errors (BackendInternalError)
 import Gargantext.API.Errors.Types (AccessPolicyErrorReason(..))
 import Gargantext.Core.Config (GargConfig(..), HasConfig(hasConfig))
 import Gargantext.Core.Config.Types (SecretsConfig(..))
-import Gargantext.Core.Types.Individu (User(UserName))
 import Gargantext.Core.Types (NodeId, UserId)
-import Gargantext.Database.Prelude (DBCmd)
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Core.Types.Individu (User(UserName))
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getNode)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.NodeNode
 import Gargantext.Database.Query.Tree (isDescendantOf, isOwnedBy, isSharedWith, lookupPublishPolicy)
 import Gargantext.Database.Query.Tree.Root (getRootId)
 import Gargantext.Database.Schema.Node (node_user_id)
 import Gargantext.Prelude
+import Servant (HasServer(..), ServerT)
 import Servant.API.Routes (HasRoutes(getRoutes))
 import Servant.Auth.Server.Internal.AddSetCookie (AddSetCookieApi, AddSetCookies(..), Nat(S))
 import Servant.Client.Core (HasClient(..), Client)
 import Servant.Ekg (HasEndpoint(..))
-import Servant (HasServer(..), ServerT)
+import Servant.OpenApi qualified as OpenAPI
 import Servant.Server.Internal.Delayed (addParameterCheck)
 import Servant.Server.Internal.DelayedIO (DelayedIO(..))
 import Servant.Swagger qualified as Swagger
-import Servant.OpenApi qualified as OpenAPI
 
 -------------------------------------------------------------------------------
 -- Types
@@ -155,41 +156,43 @@ accessPolicyManager = AccessPolicyManager (\ur ac -> interpretPolicy ur ac)
 
 
 check' :: HasNodeError err => AuthenticatedUser -> AccessCheck -> DBCmd err AccessResult
-check' (AuthenticatedUser loggedUserNodeId loggedUserUserId) = \case
-  AC_always_deny
-    -> pure $ Deny invalidUserPermissions
-  AC_always_allow
-    -> pure Allow
-  AC_user_node requestedNodeId
-    -> do ownedByMe <- requestedNodeId `isOwnedBy` loggedUserUserId
-          enforce invalidUserPermissions $ (loggedUserNodeId == requestedNodeId || ownedByMe)
-  AC_user requestedUserId
-    -> enforce invalidUserPermissions $ (loggedUserUserId == requestedUserId)
-  AC_master_user _requestedNodeId
-    -> do
-      masterUsername <- _s_master_user . _gc_secrets <$> view hasConfig
-      masterNodeId   <- getRootId (UserName masterUsername)
-      enforce invalidUserPermissions $ masterNodeId == loggedUserNodeId
-  AC_node_descendant nodeId
-    -> enforce nodeNotDescendant =<< nodeId `isDescendantOf` loggedUserNodeId
-  AC_node_shared nodeId
-    -> enforce nodeNotShared =<< nodeId `isSharedWith` loggedUserNodeId
-  AC_node_published_read nodeId
-    -> enforce nodeNotShared =<< isNodeReadOnly nodeId
-  AC_node_published_edit nodeId
-    -> do
-      mb_pp <- lookupPublishPolicy nodeId
-      targetNode <- getNode nodeId
-      let allowedOrNot = do
-            case mb_pp of
-              Nothing -> pure Allow
-              Just NPP_publish_no_edits_allowed
-                -> throwError not_editable
-              Just NPP_publish_edits_only_owner_or_super
-                -> enforce (nodeNotShared' not_editable) (targetNode ^. node_user_id == loggedUserUserId)
-      case allowedOrNot of
-        Left err -> enforce (nodeNotShared' err) False
-        Right _  -> pure Allow
+check' (AuthenticatedUser loggedUserNodeId loggedUserUserId) c = do
+  cfg <- view hasConfig
+  runDBQuery $ case c of
+    AC_always_deny
+      -> pure $ Deny invalidUserPermissions
+    AC_always_allow
+      -> pure Allow
+    AC_user_node requestedNodeId
+      -> do ownedByMe <- requestedNodeId `isOwnedBy` loggedUserUserId
+            enforce invalidUserPermissions $ (loggedUserNodeId == requestedNodeId || ownedByMe)
+    AC_user requestedUserId
+      -> enforce invalidUserPermissions $ (loggedUserUserId == requestedUserId)
+    AC_master_user _requestedNodeId
+      -> do
+        let masterUsername = _s_master_user . _gc_secrets $ cfg
+        masterNodeId   <- getRootId (UserName masterUsername)
+        enforce invalidUserPermissions $ masterNodeId == loggedUserNodeId
+    AC_node_descendant nodeId
+      -> enforce nodeNotDescendant =<< nodeId `isDescendantOf` loggedUserNodeId
+    AC_node_shared nodeId
+      -> enforce nodeNotShared =<< nodeId `isSharedWith` loggedUserNodeId
+    AC_node_published_read nodeId
+      -> enforce nodeNotShared =<< isNodeReadOnly nodeId
+    AC_node_published_edit nodeId
+      -> do
+        mb_pp <- lookupPublishPolicy nodeId
+        targetNode <- getNode nodeId
+        let allowedOrNot = do
+              case mb_pp of
+                Nothing -> pure Allow
+                Just NPP_publish_no_edits_allowed
+                  -> throwError not_editable
+                Just NPP_publish_edits_only_owner_or_super
+                  -> enforce (nodeNotShared' not_editable) (targetNode ^. node_user_id == loggedUserUserId)
+        case allowedOrNot of
+          Left err -> enforce (nodeNotShared' err) False
+          Right _  -> pure Allow
 
 -------------------------------------------------------------------------------
 -- Errors
@@ -211,7 +214,7 @@ nodeNotDescendant :: AccessPolicyErrorReason
 nodeNotDescendant = AccessPolicyErrorReason "Node is not a direct descendant."
 
 invalidUserPermissions :: AccessPolicyErrorReason
-invalidUserPermissions = AccessPolicyErrorReason "User not authorized to perform the operation."
+invalidUserPermissions = AccessPolicyErrorReason "User not authorized to perform the operation (typically due to wrong ownership)."
 
 -------------------------------------------------------------------------------
 -- Smart constructors of access checks
@@ -265,15 +268,21 @@ nodeWriteChecks nid =
 -- if:
 -- * He/she is a super user
 -- * He/she owns the target or the source
+-- * The node has been shared with the user
 moveChecks :: SourceId -> TargetId -> BoolExpr AccessCheck
 moveChecks (SourceId sourceId) (TargetId targetId) =
-  BAnd (nodeUser sourceId `BOr` nodeSuper sourceId)
-       (nodeUser targetId `BOr` nodeUser targetId)
+  BAnd (nodeUser sourceId `BOr` nodeSuper sourceId `BOr` nodeShared sourceId)
+       (nodeUser targetId `BOr` nodeUser targetId `BOr` nodeShared targetId)
 
 publishChecks :: NodeId -> BoolExpr AccessCheck
 publishChecks nodeId =
   (nodeUser nodeId `BOr` nodeSuper nodeId)
 
+-- | A user can export a node if he/she owns it, or if that's a super.
+remoteExportChecks :: NodeId -> BoolExpr AccessCheck
+remoteExportChecks nodeId =
+  (nodeUser nodeId `BOr` nodeSuper nodeId)
+
 alwaysAllow :: BoolExpr AccessCheck
 alwaysAllow = BConst . Positive $ AC_always_allow
 

src/Gargantext/API/Context.hs

@@ -21,9 +21,9 @@ import Gargantext.API.Admin.Auth.Types (PathId(..), AuthenticatedUser)
 import Gargantext.API.Prelude (IsGargServer)
 import Gargantext.API.Routes.Named.Context qualified as Named
 import Gargantext.Database.Admin.Types.Node (ContextId, contextId2NodeId)
-import Gargantext.Database.Prelude (JSONB)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Context (getContextWith)
-import Gargantext.Prelude 
+import Gargantext.Prelude
 import Servant.Server.Generic (AsServerT)
 
 -------------------------------------------------------------------
@@ -40,4 +40,4 @@ contextAPI :: ( IsGargServer env err m
 contextAPI p uId id' =
   withNamedAccess uId (PathNode $ contextId2NodeId id') contextAPI'
   where
-    contextAPI' = Named.ContextAPI $ getContextWith   id' p
+    contextAPI' = Named.ContextAPI $ runDBQuery (getContextWith   id' p)

src/Gargantext/API/Count.hs

-{-|
-Module      : Gargantext.API.Count
-Description : Server API
-Copyright   : (c) CNRS, 2017-Present
-License     : AGPL + CECILL v3
-Maintainer  : team@gargantext.org
-Stability   : experimental
-Portability : POSIX
-
-Count API part of Gargantext.
--}
-
-{-# OPTIONS_GHC -fno-warn-deprecations #-}
-
-{-# LANGUAGE TemplateHaskell    #-}
-{-# LANGUAGE TypeOperators      #-}
-{-# LANGUAGE DeriveAnyClass     #-}
-
-module Gargantext.API.Count (
-    countAPI
-  ) where
-
-import Gargantext.API.Count.Types
-import Gargantext.API.Routes.Named.Count qualified as Named
-import Gargantext.Prelude
-import Servant.Server.Generic (AsServerT)
-
------------------------------------------------------------------------
--- TODO-ACCESS: CanCount
--- TODO-EVENTS: No events as this is a read only query.
------------------------------------------------------------------------
-countAPI :: Query -> Named.CountAPI (AsServerT m)
-countAPI _ = Named.CountAPI undefined

src/Gargantext/API/Count/Types.hs

-{-|
-Module      : Gargantext.API.Count.Types
-Description : 
-Copyright   : (c) CNRS, 2017-Present
-License     : AGPL + CECILL v3
-Maintainer  : team@gargantext.org
-Stability   : experimental
-Portability : POSIX
-
--}
-
-{-# LANGUAGE TemplateHaskell    #-}
-
-module Gargantext.API.Count.Types (
-    Scraper(..)
-  , QueryBool(..)
-  , Query(..)
-  , Message(..)
-  , Code
-  , Error
-  , Errors
-  , Counts(..)
-  , Count(..)
-
-  -- * functions
-  , scrapers
-  ) where
-
-import Data.Swagger ( ToSchema(..), genericDeclareNamedSchema )
-import Data.Text (pack)
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
-import Gargantext.Prelude
-import Test.QuickCheck (elements)
-import Test.QuickCheck.Arbitrary (Arbitrary(..))
-
------------------------------------------------------------------------
-data Scraper = Pubmed | Hal | IsTex | Isidore
-  deriving (Eq, Show, Generic, Enum, Bounded)
-
-scrapers :: [Scraper]
-scrapers = [minBound..maxBound]
-
-instance FromJSON Scraper
-instance ToJSON   Scraper
-
-instance Arbitrary Scraper where
-    arbitrary = elements scrapers
-
-instance ToSchema Scraper
-
------------------------------------------------------------------------
-data QueryBool = QueryBool Text
-        deriving (Eq, Show, Generic)
-
-queries :: [QueryBool]
-queries =  [QueryBool (pack "(X OR X') AND (Y OR Y') NOT (Z OR Z')")]
---queries =  [QueryBool (pack "(X + X') * (Y + Y') - (Z + Z')")]
-
-instance Arbitrary QueryBool where
-    arbitrary = elements queries
-
-instance FromJSON QueryBool
-instance ToJSON   QueryBool
-
-instance ToSchema QueryBool
------------------------------------------------------------------------
-
-data Query = Query { query_query :: QueryBool
-                   , query_name  :: Maybe [Scraper]
-                   }
-                   deriving (Eq, Show, Generic)
-instance FromJSON Query
-instance ToJSON   Query
-
-instance Arbitrary Query where
-    arbitrary = elements [ Query q (Just n) 
-                         | q <- queries
-                         , n <- take 10 $ permutations scrapers
-                         ]
-
-instance ToSchema Query where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_")
-
------------------------------------------------------------------------
-type Code = Integer
-type Error  = Text
-type Errors = [Error]
-
------------------------------------------------------------------------
-data Message = Message Code Errors
-        deriving (Eq, Show, Generic)
-
-toMessage :: [(Code, Errors)] -> [Message]
-toMessage = map (\(c,err) -> Message c err)
-
-messages :: [Message]
-messages =  toMessage $ [ (400, ["Ill formed query             "])
-                        , (300, ["API connexion error          "])
-                        , (300, ["Internal Gargantext Error    "])
-                        ] <> take 10 ( repeat (200, [""]))
-
-instance Arbitrary Message where
-    arbitrary = elements messages
-
-instance ToSchema Message
------------------------------------------------------------------------
-data Counts = Counts { results :: [Either Message Count]
-                     } deriving (Eq, Show, Generic)
-
-
-instance Arbitrary Counts where
-    arbitrary = elements [Counts [ Right (Count Pubmed (Just 20 ))
-                                 , Right (Count IsTex  (Just 150))
-                                 , Right (Count Hal    (Just 150))
-                                 ]
-                         ]
-
-instance ToSchema Counts
-
------------------------------------------------------------------------
-data Count = Count { count_name    :: Scraper
-                   , count_count   :: Maybe Int
-                   }
-                   deriving (Eq, Show, Generic)
-
-instance ToSchema Count where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "count_")
---instance Arbitrary Count where
---    arbitrary = Count <$> arbitrary <*> arbitrary <*> arbitrary
-
---
--- JSON instances
---
-
-instance FromJSON Message
-instance ToJSON   Message
-
-$(deriveJSON (unPrefix "count_") ''Count)
-
-instance FromJSON Counts
-instance ToJSON   Counts
-

src/Gargantext/API/Dev.hs

@@ -14,35 +14,38 @@ module Gargantext.API.Dev where
 
 import Control.Lens (view)
 import Control.Monad (fail)
-import Data.Pool (withResource)
 import Database.PostgreSQL.Simple qualified as PGS
-import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) )
+import Data.Pool (withResource)
+import Gargantext.API.Admin.EnvTypes ( DevEnv(..) )
 import Gargantext.API.Admin.Settings ( newPool )
 import Gargantext.API.Errors.Types ( BackendInternalError )
 import Gargantext.API.Prelude ( GargM )
-import Gargantext.Core.Config (_gc_database_config)
+import Gargantext.Core.Config (_gc_database_config, gc_logging)
 import Gargantext.Core.Config.Types (SettingsFile(..))
-import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
+import Gargantext.Core.Config.Utils (readConfig)
+import Gargantext.Core.NodeStory (mkNodeStoryEnv)
 import Gargantext.Database.Prelude (Cmd, CmdRandom, connPool, runCmd)
 import Gargantext.Prelude
-import Gargantext.Core.Config.Utils (readConfig)
-import Gargantext.System.Logging ( withLoggerHoisted )
+import Gargantext.System.Logging ( withLoggerIO )
+import Network.HTTP.Client.TLS (newTlsManager)
 import Servant ( ServerError )
 
 -------------------------------------------------------------------
 withDevEnv :: SettingsFile -> (DevEnv -> IO a) -> IO a
-withDevEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
-  env <- newDevEnv logger
-  k env -- `finally` cleanEnv env
+withDevEnv settingsFile k = do
+  cfg <- readConfig settingsFile
+  withLoggerIO (cfg ^. gc_logging) $ \logger -> do
+    env <- newDevEnv logger cfg
+    k env -- `finally` cleanEnv env
 
   where
-    newDevEnv logger = do
-      cfg     <- readConfig         settingsFile
-      --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
+    newDevEnv logger cfg = do
       pool    <- newPool (_gc_database_config cfg)
-      nodeStory_env <- fromDBNodeStoryEnv pool
+      let nodeStory_env = mkNodeStoryEnv
+      manager <- newTlsManager
       pure $ DevEnv
         { _dev_env_pool     = pool
+        , _dev_env_manager    = manager
         , _dev_env_logger     = logger
         , _dev_env_nodeStory  = nodeStory_env
         , _dev_env_config   = cfg

src/Gargantext/API/Errors.hs

@@ -79,6 +79,11 @@ backendErrorToFrontendError = \case
          $ FE_validation_error $ case prettyValidation validationError of
              Nothing -> "unknown_validation_error"
              Just v  -> T.pack v
+  -- Worker errors might contain sensitive information, so we don't
+  -- want to expose that to the frontend.
+  InternalWorkerError _workerError
+    -> let msg = T.pack $ "An unexpected error occurred in one of the async worker tasks. Please check your server logs."
+       in mkFrontendErr' msg $ FE_internal_server_error msg
   AccessPolicyError accessPolicyError
     -> case accessPolicyError of
          AccessPolicyNodeError nodeError
@@ -176,6 +181,8 @@ nodeErrorToFrontendError ne = case ne of
     -> mkFrontendErrShow $ FE_node_is_read_only nodeId reason
   MoveError sourceId targetId reason
     -> mkFrontendErrShow $ FE_node_move_error sourceId targetId reason
+  NodeNotExportable nodeId reason
+    -> mkFrontendErrShow $ FE_node_export_error nodeId reason
 
   -- backward-compatibility shims, to remove eventually.
   DoesNotExist nid

src/Gargantext/API/Errors/Types.hs

@@ -35,6 +35,7 @@ module Gargantext.API.Errors.Types (
   , GraphQLError(..)
   , ToFrontendErrorData(..)
   , AccessPolicyErrorReason(..)
+  , HasBackendInternalError(..)
 
   -- * Constructing frontend errors
   , mkFrontendErrNoDiagnostic
@@ -48,8 +49,8 @@ module Gargantext.API.Errors.Types (
 
 import Control.Lens ((#), makePrisms, Prism')
 import Control.Monad.Fail (fail)
-import Data.Aeson (Value(..), (.:), (.=), object, withObject)
 import Data.Aeson.Types (typeMismatch, emptyArray)
+import Data.Aeson (Value(..), (.:), (.=), object, withObject)
 import Data.List.NonEmpty qualified as NE
 import Data.Singletons.TH ( SingI(sing), SingKind(fromSing) )
 import Data.Text qualified as T
@@ -67,6 +68,7 @@ import Gargantext.Prelude hiding (Location, WithStacktrace)
 import Gargantext.Utils.Dict (Dict(..))
 import Gargantext.Utils.Jobs.Monad qualified as Jobs
 import Servant (ServerError)
+import Control.Lens.Prism (prism')
 
 -- | A 'WithStacktrace' carries an error alongside its
 -- 'CallStack', to be able to print the correct source location
@@ -116,11 +118,18 @@ data BackendInternalError
   | InternalTreeError           !TreeError
   | InternalUnexpectedError     !SomeException
   | InternalValidationError     !Validation
+  | InternalWorkerError         !IOException
   | AccessPolicyError           !AccessPolicyErrorReason
   deriving (Show, Typeable)
 
 makePrisms ''BackendInternalError
 
+class HasBackendInternalError e where
+  _BackendInternalError :: Prism' e BackendInternalError
+
+instance HasBackendInternalError BackendInternalError where
+  _BackendInternalError = prism' identity Just
+
 instance ToJSON BackendInternalError where
   toJSON (InternalJobError s) =
     object [ ("status", toJSON ("IsFailure" :: Text))
@@ -258,8 +267,8 @@ newtype instance ToFrontendErrorData 'EC_400__node_creation_failed_no_parent =
 
 data instance ToFrontendErrorData 'EC_400__node_creation_failed_insert_node =
   FE_node_creation_failed_insert_node { necin_user_id   :: UserId
-                                            , necin_parent_id :: ParentId
-                                            }
+                                      , necin_parent_id :: Maybe ParentId
+                                      }
   deriving (Show, Eq, Generic)
 
 newtype instance ToFrontendErrorData 'EC_500__node_generic_exception =
@@ -278,6 +287,10 @@ data instance ToFrontendErrorData 'EC_403__node_move_error =
   FE_node_move_error { nme_source_id :: !NodeId, nme_target_id :: !NodeId, nme_reason :: !T.Text }
   deriving (Show, Eq, Generic)
 
+data instance ToFrontendErrorData 'EC_403__node_export_error =
+  FE_node_export_error { nee_node_id :: !NodeId, nee_reason :: !T.Text }
+  deriving (Show, Eq, Generic)
+
 --
 -- validation errors
 --
@@ -514,6 +527,15 @@ instance FromJSON (ToFrontendErrorData 'EC_403__node_move_error) where
     nme_reason  <- o .: "reason"
     pure FE_node_move_error{..}
 
+instance ToJSON (ToFrontendErrorData 'EC_403__node_export_error) where
+  toJSON FE_node_export_error{..} =
+    object [ "node_id" .= toJSON nee_node_id, "reason" .= toJSON nee_reason ]
+instance FromJSON (ToFrontendErrorData 'EC_403__node_export_error) where
+  parseJSON = withObject "FE_node_move_error" $ \o -> do
+    nee_node_id <- o .: "node_id"
+    nee_reason  <- o .: "reason"
+    pure FE_node_export_error{..}
+
 --
 -- validation errors
 --
@@ -728,6 +750,9 @@ instance FromJSON FrontendError where
       EC_403__node_move_error -> do
         (fe_data :: ToFrontendErrorData 'EC_403__node_move_error) <- o .: "data"
         pure FrontendError{..}
+      EC_403__node_export_error -> do
+        (fe_data :: ToFrontendErrorData 'EC_403__node_export_error) <- o .: "data"
+        pure FrontendError{..}
 
       -- validation error
       EC_400__validation_error -> do

src/Gargantext/API/Errors/Types/Backend.hs

@@ -35,6 +35,7 @@ data BackendErrorCode
   | EC_400__node_needs_configuration
   | EC_403__node_is_read_only
   | EC_403__node_move_error
+  | EC_403__node_export_error
   -- validation errors
   | EC_400__validation_error
   -- policy check errors

src/Gargantext/API/GraphQL.hs

@@ -15,7 +15,6 @@ Portability : POSIX
 {-# LANGUAGE KindSignatures #-}  -- for use of Endpoint (name :: Symbol)
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PartialTypeSignatures #-}  -- to automatically use suggested type hole signatures during compilation
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 
 module Gargantext.API.GraphQL where

src/Gargantext/API/GraphQL/Annuaire.hs

@@ -23,7 +23,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
   , cw_lastName
   , hc_who, ContactWhere, hc_where, cw_organization, cw_labTeamDepts, cw_role, cw_office, cw_country, cw_city, cw_touch, ct_mail, ct_phone, ct_url, hc_title, hc_source)
 import Gargantext.Database.Admin.Types.Node (ContextId (..))
-import Gargantext.Database.Prelude (IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Context (getContextWith)
 import Gargantext.Database.Schema.Node (node_hyperdata)
 import Gargantext.Prelude
@@ -71,7 +71,7 @@ dbAnnuaireContacts contact_id = do
 
   -- FIXME(adinapoli) This function seems a bit iffy, unless a 'contact_id'
   -- is just a synonym for a 'ContextId'.
-  c <- lift $ getContextWith (UnsafeMkContextId contact_id) (Proxy :: Proxy HyperdataContact)
+  c <- lift $ runDBQuery $ getContextWith (UnsafeMkContextId contact_id) (Proxy :: Proxy HyperdataContact)
   pure [toAnnuaireContact (contact_id, c ^. node_hyperdata)]
 
 toAnnuaireContact :: (Int, HyperdataContact) -> AnnuaireContact

src/Gargantext/API/GraphQL/Context.hs

@@ -22,8 +22,7 @@ import Data.Morpheus.Types
   , ResolverM
   , QUERY
   )
-import Data.Text (pack, unpack)
-import Data.Text qualified as Text
+import Data.Text (pack)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
 import Gargantext.API.Auth.PolicyCheck ( nodeWriteChecks, AccessPolicyManager )
@@ -33,7 +32,7 @@ import Gargantext.API.Prelude (GargM)
 import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument )
 import Gargantext.Database.Admin.Types.Node (ContextTitle, NodeId(..), NodeTypeId, UserId, unNodeId, ContextId (..))
-import Gargantext.Database.Prelude (IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.NodeContext (getNodeContext, getContextsForNgramsTerms, ContextForNgramsTerms(..), {- getContextNgrams, -} getContextNgramsMatchingFTS)
 import Gargantext.Database.Query.Table.NodeContext qualified as DNC
 import Gargantext.Database.Schema.NodeContext (NodeContext, NodeContextPoly(..))
@@ -97,7 +96,7 @@ data ContextsForNgramsArgs
   = ContextsForNgramsArgs
     { corpus_id    :: Int
     , ngrams_terms :: [Text]
-    , and_logic    :: Text
+    , and_logic    :: Bool
     } deriving (Generic, GQLType)
 
 data NodeContextCategoryMArgs = NodeContextCategoryMArgs
@@ -147,15 +146,16 @@ dbNodeContext context_id node_id = do
 --  user <- getUsersWithId user_id
 --  hyperdata <- getUserHyperdata user_id
 --  lift (map toUser <$> zip user hyperdata)
-  c <- lift $ getNodeContext (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id)
+  c <- lift $ runDBQuery $ getNodeContext (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id)
   pure $ toNodeContextGQL <$> [c]
 
 -- | Returns list of `ContextGQL` for given ngrams in given corpus id.
 dbContextForNgrams
   :: (IsDBEnvExtra env)
-  => Int -> [Text] -> Text -> GqlM e env [ContextGQL]
+  => Int -> [Text] -> Bool -> GqlM e env [ContextGQL]
 dbContextForNgrams node_id ngrams_terms and_logic = do
-  contextsForNgramsTerms <- lift $ getContextsForNgramsTerms (UnsafeMkNodeId node_id) ngrams_terms ( readMaybe $ unpack $ Text.toTitle and_logic )
+  contextsForNgramsTerms <- lift $ runDBQuery $
+    getContextsForNgramsTerms (UnsafeMkNodeId node_id) ngrams_terms and_logic
   --lift $ printDebug "[dbContextForNgrams] contextsForNgramsTerms" contextsForNgramsTerms
   pure $ toContextGQL <$> contextsForNgramsTerms
 
@@ -164,7 +164,7 @@ dbContextNgrams
   :: (IsDBEnvExtra env)
   => Int -> Int -> GqlM e env [Text]
 dbContextNgrams context_id list_id = do
-  lift $ getContextNgramsMatchingFTS (UnsafeMkContextId context_id) (UnsafeMkNodeId list_id)
+  lift $ runDBQuery $ getContextNgramsMatchingFTS (UnsafeMkContextId context_id) (UnsafeMkNodeId list_id)
 
 -- Conversion functions
 
@@ -228,5 +228,5 @@ updateNodeContextCategory :: (IsDBEnvExtra env)
                           -> GqlM' e env [Int]
 updateNodeContextCategory autUser mgr NodeContextCategoryMArgs { context_id, node_id, category } =
   withPolicy autUser mgr (nodeWriteChecks $ UnsafeMkNodeId node_id) $ do
-    void $ lift $ DNC.updateNodeContextCategory (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id) category
+    void $ lift $ runDBTx $ DNC.updateNodeContextCategory (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id) category
     pure [1]

src/Gargantext/API/GraphQL/Node.hs

@@ -24,7 +24,7 @@ import Gargantext.API.GraphQL.Types ( GqlM )
 import Gargantext.Core ( HasDBid(lookupDBid) )
 import Gargantext.Database.Admin.Types.Node (NodeType)
 import Gargantext.Database.Admin.Types.Node qualified as NN
-import Gargantext.Database.Prelude (IsDBEnvExtra)  -- , JSONB)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getClosestChildrenByType, getClosestParentIdByType, getNode)
 import Gargantext.Database.Schema.Node qualified as N
 import Gargantext.Prelude
@@ -74,14 +74,14 @@ dbNodes
   :: (IsDBEnvExtra env)
   => Int -> GqlM e env [Node]
 dbNodes node_id = do
-  node <- lift $ getNode $ NN.UnsafeMkNodeId node_id
+  node <- lift $ runDBQuery $ getNode $ NN.UnsafeMkNodeId node_id
   pure [toNode node]
 
 dbNodesCorpus
   :: (IsDBEnvExtra env)
   => Int -> GqlM e env [Corpus]
 dbNodesCorpus corpus_id = do
-  corpus <- lift $ getNode $ NN.UnsafeMkNodeId corpus_id
+  corpus <- lift $ runDBQuery $ getNode $ NN.UnsafeMkNodeId corpus_id
   pure [toCorpus corpus]
 
 data NodeParentArgs
@@ -116,19 +116,21 @@ dbParentNodes node_id parentType = do
   --     lift $ printDebug "[dbParentNodes] error reading parent type" (T.pack err)
   --     pure []
   --   Right parentType -> do
-      mNodeId <- lift $ getClosestParentIdByType (NN.UnsafeMkNodeId node_id) parentType -- (fromNodeTypeId parent_type_id)
+  lift $ runDBQuery $ do
+      mNodeId <- getClosestParentIdByType (NN.UnsafeMkNodeId node_id) parentType -- (fromNodeTypeId parent_type_id)
       case mNodeId of
         Nothing -> pure []
         Just id -> do
-          node <- lift $ getNode id
+          node <- getNode id
           pure [toNode node]
 
 dbChildNodes :: (IsDBEnvExtra env)
              => Int -> NodeType -> GqlM e env [Node]
 dbChildNodes node_id childType = do
-  childIds <- lift $ getClosestChildrenByType (NN.UnsafeMkNodeId node_id) childType -- (fromNodeTypeId parent_type_id)
-  children <- lift $ mapM getNode childIds
-  pure $ toNode <$> children
+  lift $ runDBQuery $ do
+    childIds <- getClosestChildrenByType (NN.UnsafeMkNodeId node_id) childType -- (fromNodeTypeId parent_type_id)
+    children <- mapM getNode childIds
+    pure $ toNode <$> children
 
 toNode :: NN.Node json -> Node
 toNode N.Node { .. } = Node { id = nid

src/Gargantext/API/GraphQL/PolicyCheck.hs

@@ -14,7 +14,8 @@ module Gargantext.API.GraphQL.PolicyCheck where
 
 import Prelude
 
-import Control.Monad.Except (MonadError(..), MonadTrans(..))
+import Control.Monad.Except (MonadError(..))
+import Control.Monad.Trans.Class (lift)
 import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
 import Gargantext.API.Auth.PolicyCheck ( BoolExpr, AccessCheck, AccessPolicyManager(..), AccessResult(..))
 import Gargantext.API.Errors.Types ( BackendInternalError(..) )

src/Gargantext/API/GraphQL/Team.hs

@@ -25,7 +25,7 @@ import Gargantext.Core.Config (HasJWTSettings)
 import Gargantext.Core.Types (NodeId(..), unNodeId)
 import Gargantext.Core.Types.Individu qualified as Individu
 import Gargantext.Database.Action.Share (membersOf, deleteMemberShip)
-import Gargantext.Database.Prelude (IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.User (getUsersWithNodeHyperdata)
 import Gargantext.Database.Schema.Node (NodePoly(Node, _node_id), _node_user_id)
@@ -60,13 +60,14 @@ dbTeam :: (IsDBEnvExtra env) =>
           Int -> GqlM e env Team
 dbTeam nodeId = do
   let nId = UnsafeMkNodeId nodeId
-  res <- lift $ membersOf nId
-  teamNode <- lift $ getNode nId
-  userNodes <- lift $ getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode
-  let username = getUsername userNodes
-  pure $ Team { team_owner_username = username
-              , team_members = map toTeamMember res
-              }
+  lift $ runDBQuery $ do
+    res <- membersOf nId
+    teamNode <- getNode nId
+    userNodes <- getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode
+    let username = getUsername userNodes
+    pure $ Team { team_owner_username = username
+                , team_members = map toTeamMember res
+                }
   where
     toTeamMember :: (Text, NodeId) -> TeamMember
     toTeamMember (username, fId)= TeamMember {
@@ -81,18 +82,19 @@ dbTeam nodeId = do
 deleteTeamMembership :: (IsDBEnvExtra env, HasJWTSettings env) =>
                         TeamDeleteMArgs -> GqlM' e env [Int]
 deleteTeamMembership TeamDeleteMArgs { token, shared_folder_id, team_node_id } = do
-  teamNode <- lift $ getNode $ UnsafeMkNodeId team_node_id
-  userNodes <- lift (getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode)
+  userNodes <- lift $ runDBTx $ do
+    teamNode <- getNode $ UnsafeMkNodeId team_node_id
+    getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode
   case userNodes of
-    [] -> panicTrace $ "[deleteTeamMembership] User with id " <> T.pack (show $ uId teamNode) <> " doesn't exist."
+    [] -> panicTrace $ "[deleteTeamMembership] User with id " <> T.pack (show $ team_node_id) <> " doesn't exist."
     (( _, node_u):_) -> do
       testAuthUser <- lift $ authUser (nId node_u) token
-      lift $ case testAuthUser of
+      case testAuthUser of
         -- Invalid -> panicTrace "[deleteTeamMembership] failed to validate user"
         Invalid -> do
-          throwError $ InternalAuthenticationError $ UserNotAuthorized (uId node_u) "This user is not team owner"
+          lift $ throwError $ InternalAuthenticationError $ UserNotAuthorized (uId node_u) "This user is not team owner"
         Valid -> do
-          deleteMemberShip [(UnsafeMkNodeId shared_folder_id, UnsafeMkNodeId team_node_id)]
+          lift $ runDBTx $ deleteMemberShip [(UnsafeMkNodeId shared_folder_id, UnsafeMkNodeId team_node_id)]
   where
     uId Node { _node_user_id } = _node_user_id
     nId Node { _node_id } = _node_id

src/Gargantext/API/GraphQL/TreeFirstLevel.hs

@@ -25,7 +25,7 @@ import Gargantext.Core.Types.Main ( Tree(..), _tn_node, _tn_children, NodeTree(.
 import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Admin.Types.Node (allNodeTypes, NodeId(..), NodeType)
 import Gargantext.Database.Admin.Types.Node qualified as NN
-import Gargantext.Database.Prelude (IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Tree qualified as T
 import Gargantext.Database.Schema.Node (NodePoly(_node_parent_id))
@@ -77,10 +77,11 @@ dbTree :: (IsDBEnvExtra env) =>
           NN.UserId -> Int -> GqlM e env (TreeFirstLevel (GqlM e env))
 dbTree loggedInUserId root_id = do
   let rId = UnsafeMkNodeId root_id
-  t <- lift $ T.tree loggedInUserId T.TreeFirstLevel rId allNodeTypes
-  n <- lift $ getNode $ UnsafeMkNodeId root_id
-  let pId = toParentId n
-  pure $ toTree rId pId t
+  lift $ runDBQuery $ do
+    t <- T.tree loggedInUserId T.TreeFirstLevel rId allNodeTypes
+    n <- getNode $ UnsafeMkNodeId root_id
+    let pId = toParentId n
+    pure $ toTree rId pId t
   where
     toParentId N.Node { _node_parent_id } = _node_parent_id
 
@@ -100,7 +101,7 @@ childrenToTreeNodes (TreeN {_tn_node}, rId) = toTreeNode (Just rId) _tn_node
 
 resolveParent :: (IsDBEnvExtra env) => Maybe NodeId -> GqlM e env (Maybe TreeNode)
 resolveParent (Just pId) = do
-  node <- lift $ getNode pId
+  node <- lift $ runDBQuery $ getNode pId
   pure $ nodeToTreeNode node
 resolveParent Nothing = pure Nothing
 
@@ -133,6 +134,6 @@ convertDbTreeToTreeNode T.DbTreeNode { _dt_name, _dt_nodeId, _dt_typeId, _dt_par
 dbRecursiveParents :: (IsDBEnvExtra env) => Int -> GqlM e env BreadcrumbInfo
 dbRecursiveParents nodeId = do
   let nId = UnsafeMkNodeId nodeId
-  dbParents <- lift $ T.recursiveParents nId allNodeTypes
+  dbParents <- lift $ runDBQuery $ T.recursiveParents nId allNodeTypes
   let treeNodes = map convertDbTreeToTreeNode dbParents
   pure $ BreadcrumbInfo { parents = treeNodes }

src/Gargantext/API/GraphQL/User.hs

@@ -22,7 +22,7 @@ import Gargantext.API.GraphQL.Types (GqlM, GqlM')
 import Gargantext.Core.Types (NodeId(..), UserId)
 import Gargantext.Core.Types.Individu qualified as Individu
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..))
-import Gargantext.Database.Prelude (IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.User qualified as DBUser
 import Gargantext.Database.Schema.User (UserLight(..))
 import Gargantext.Prelude
@@ -72,7 +72,7 @@ resolveUsers autUser mgr UserArgs { user_id } = do
 -- | Inner function to fetch the user from DB.
 dbUsers :: (IsDBEnvExtra env)
         => Int -> GqlM e env [User (GqlM e env)]
-dbUsers user_id = lift (map toUser <$> DBUser.getUsersWithId (Individu.RootId $ UnsafeMkNodeId user_id))
+dbUsers user_id = lift (map toUser <$> runDBQuery (DBUser.getUsersWithId (Individu.RootId $ UnsafeMkNodeId user_id)))
 
 toUser
   :: (IsDBEnvExtra env)
@@ -85,25 +85,25 @@ toUser (UserLight { .. }) = User { u_email = userLight_email
 resolveHyperdata
   :: (IsDBEnvExtra env)
   => UserId -> GqlM e env (Maybe HyperdataUser)
-resolveHyperdata userid = lift (listToMaybe <$> DBUser.getUserHyperdata (Individu.UserDBId userid))
+resolveHyperdata userid = lift (listToMaybe <$> runDBQuery (DBUser.getUserHyperdata (Individu.UserDBId userid)))
 
 updateUserPubmedAPIKey :: ( IsDBEnvExtra env ) =>
                           UserPubmedAPIKeyMArgs -> GqlM' e env Int
 updateUserPubmedAPIKey UserPubmedAPIKeyMArgs { user_id, api_key } = do
-  _ <- lift $ DBUser.updateUserPubmedAPIKey (Individu.RootId $ UnsafeMkNodeId user_id) api_key
+  _ <- lift $ runDBTx $ DBUser.updateUserPubmedAPIKey (Individu.RootId $ UnsafeMkNodeId user_id) api_key
 
   pure 1
 
 updateUserEPOAPIUser :: ( IsDBEnvExtra env ) =>
                         UserEPOAPIUserMArgs -> GqlM' e env Int
 updateUserEPOAPIUser UserEPOAPIUserMArgs { user_id, api_user } = do
-  _ <- lift $ DBUser.updateUserEPOAPIUser (Individu.RootId $ UnsafeMkNodeId user_id) api_user
+  _ <- lift $ runDBTx $ DBUser.updateUserEPOAPIUser (Individu.RootId $ UnsafeMkNodeId user_id) api_user
 
   pure 1
 
 updateUserEPOAPIToken :: ( IsDBEnvExtra env ) =>
                          UserEPOAPITokenMArgs -> GqlM' e env Int
 updateUserEPOAPIToken UserEPOAPITokenMArgs { user_id, api_token } = do
-  _ <- lift $ DBUser.updateUserEPOAPIToken (Individu.RootId $ UnsafeMkNodeId user_id) api_token
+  _ <- lift $ runDBTx $ DBUser.updateUserEPOAPIToken (Individu.RootId $ UnsafeMkNodeId user_id) api_token
 
   pure 1

src/Gargantext/API/GraphQL/UserInfo.hs

@@ -49,7 +49,7 @@ import Gargantext.API.GraphQL.Utils (AuthStatus(Invalid, Valid), authUser)
 import Gargantext.Core.Config (HasJWTSettings)
 import Gargantext.Core.Types (UserId(..))
 import Gargantext.Core.Types.Individu qualified as Individu
-import Gargantext.Database.Prelude (IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Query.Table.User (getUsersWithHyperdata, getUsersWithNodeHyperdata, updateUserEmail)
 import Gargantext.Database.Schema.Node (node_id, node_hyperdata, NodePoly (Node, _node_id))
@@ -124,7 +124,7 @@ updateUserInfo
   => UserInfoMArgs -> GqlM' e env Int
 updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
   -- lift $ printDebug "[updateUserInfo] ui_id" ui_id
-  users <- lift (getUsersWithNodeHyperdata (Individu.UserDBId $ UnsafeMkUserId ui_id))
+  users <- lift $ runDBQuery $ getUsersWithNodeHyperdata (Individu.UserDBId $ UnsafeMkUserId ui_id)
   case users of
     [] -> panicTrace $ "[updateUserInfo] User with id " <> (T.pack $ show ui_id) <> " doesn't exist."
     ((UserLight { .. }, node_u):_) -> do
@@ -155,10 +155,11 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
           let u' = UserLight { userLight_email = fromMaybe userLight_email $ view ui_cwTouchMailL u_hyperdata'
                              , .. }
           -- lift $ printDebug "[updateUserInfo] with firstName" u_hyperdata'
-          _ <- lift $ updateHyperdata (node_u ^. node_id) u_hyperdata'
-          _ <- lift $ updateUserEmail u'
-          --let _newUser = toUser (u, u_hyperdata')
-          pure 1
+          lift $ runDBTx $ do
+            _ <- updateHyperdata (node_u ^. node_id) u_hyperdata'
+            _ <- updateUserEmail u'
+            --let _newUser = toUser (u, u_hyperdata')
+            pure 1
   where
     uh _ Nothing u_hyperdata = u_hyperdata
     uh lens' (Just val) u_hyperdata = u_hyperdata & lens' ?~ val
@@ -175,7 +176,7 @@ dbUsers user_id = do
 --  user <- getUsersWithId user_id
 --  hyperdata <- getUserHyperdata user_id
 --  lift (map toUser <$> zip user hyperdata)
-  lift (map toUser <$> getUsersWithHyperdata (Individu.UserDBId user_id))
+  lift (map toUser <$> runDBQuery (getUsersWithHyperdata (Individu.UserDBId user_id)))
 
 toUser :: (UserLight, HyperdataUser) -> UserInfo
 toUser (UserLight { .. }, u_hyperdata) =

src/Gargantext/API/HashedResponse.hs

@@ -19,6 +19,8 @@ import Gargantext.Prelude.Crypto.Hash qualified as Crypto (hash)
 data HashedResponse a = HashedResponse { hash :: Text, value :: a }
   deriving (Generic)
 
+instance NFData a => NFData (HashedResponse a) where
+
 instance ToSchema a => ToSchema (HashedResponse a)
 instance ToJSON a => ToJSON (HashedResponse a) where
   toJSON = genericToJSON defaultOptions

src/Gargantext/API/Job.hs

@@ -20,6 +20,7 @@ module Gargantext.API.Job (
   , jobLogFailTotalWithMessage
   , RemainingSteps(..)
   , addErrorEvent
+  , addWarningEvent
   ) where
 
 import Control.Lens (over, _Just)
@@ -49,6 +50,9 @@ addEvent level message (JobLog { _scst_events = mEvts, .. }) = JobLog { _scst_ev
 addErrorEvent :: ToHumanFriendlyError e => e -> JobLog -> JobLog
 addErrorEvent message = addEvent "ERROR" (mkHumanFriendly message)
 
+addWarningEvent :: ToHumanFriendlyError e => e -> JobLog -> JobLog
+addWarningEvent message = addEvent "WARNING" (mkHumanFriendly message)
+
 jobLogProgress :: Int -> JobLog -> JobLog
 jobLogProgress n jl = over (scst_succeeded . _Just) (+ n) $
                       over (scst_remaining . _Just) (\x -> max 0 (x - n)) jl

src/Gargantext/API/Members.hs

@@ -15,6 +15,7 @@ import Gargantext.API.Routes.Named.Private qualified as Named
 import Gargantext.Database.Action.Share (membersOf)
 import Gargantext.Database.Admin.Types.Node (NodeType(NodeTeam))
 import Gargantext.Database.Query.Table.Node (getNodesIdWithType)
+import Gargantext.Database.Prelude
 import Gargantext.Prelude
 import Servant.Server.Generic (AsServerT)
 
@@ -22,7 +23,7 @@ members :: IsGargServer err env m => Named.MembersAPI (AsServerT m)
 members = Named.MembersAPI getMembers
 
 getMembers :: IsGargServer err env m => m [Text]
-getMembers = do
+getMembers = runDBQuery $ do
   teamNodeIds <- getNodesIdWithType NodeTeam
   m <- concatMapM membersOf teamNodeIds
   pure $ map fst m

src/Gargantext/API/Ngrams/List/Types.hs

@@ -9,15 +9,13 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE TypeOperators     #-}
-
 module Gargantext.API.Ngrams.List.Types where
 
 import Data.Aeson
-import Data.ByteString.Lazy qualified as BSL
+-- import Data.ByteString.Lazy qualified as BSL
 import Data.Swagger (ToSchema, declareNamedSchema, genericDeclareNamedSchema)
 import Data.Text
-import Data.Text.Encoding qualified as E
+-- import Data.Text.Encoding qualified as E
 import Gargantext.API.Ngrams.Types (NgramsList)
 import Gargantext.API.Node.Corpus.New.Types (FileType(..))
 import Gargantext.Core.Utils.Aeson (jsonOptions)
@@ -46,16 +44,18 @@ instance ToSchema WithFile where
 ------------------------------------------------------------------------
 
 data WithJsonFile = WithJsonFile
-  { _wjf_data     :: !NgramsList
+  { -- _wjf_data     :: !NgramsList
+    _wjf_data     :: !Text
   , _wjf_name     :: !Text
   } deriving (Eq, Show, Generic)
 
 instance FromForm WithJsonFile where
   fromForm f = do
-    d' <- parseUnique "_wjf_data" f
-    d <- case eitherDecode' (BSL.fromStrict $ E.encodeUtf8 d') of
-      Left s -> Left $ pack s
-      Right v -> Right v
+    d <- parseUnique "_wjf_data" f
+    -- d' <- parseUnique "_wjf_data" f
+    -- d <- case eitherDecode' (BSL.fromStrict $ E.encodeUtf8 d') of
+    --   Left s -> Left $ pack s
+    --   Right v -> Right v
     n <- parseUnique "_wjf_name" f
     pure $ WithJsonFile { _wjf_data = d
                         , _wjf_name = n }

src/Gargantext/API/Ngrams/NgramsTree.hs

@@ -34,7 +34,7 @@ data NgramsTree = NgramsTree { mt_label :: Text
                              , mt_value :: Double
                              , mt_children :: [NgramsTree]
                              }
-    deriving (Generic, Show)
+    deriving (Generic, Show, Eq)
 
 toNgramsTree :: Tree (NgramsTerm,Double) -> NgramsTree
 toNgramsTree (Node (NgramsTerm l,v) xs) = NgramsTree l v (map toNgramsTree xs)