Merge branch 'dev' into 433-dev-ignore-tsv-errors

.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.4.8
+image: adinapoli/gargantext:v3.5
 
 variables:
   STACK_ROOT: "${CI_PROJECT_DIR}/.stack-root"
   STACK_OPTS: "--system-ghc"
-  CABAL_STORE_DIR: "${CI_PROJECT_DIR}/.cabal"
+  STORE_DIR: "${CI_PROJECT_DIR}/.cabal"
+  CABAL_DIR: "${CI_PROJECT_DIR}/.cabal"
   CORENLP: "4.5.4"
   FF_USE_FASTZIP: "true"
   ARTIFACT_COMPRESSION_LEVEL: "fast"
   CACHE_COMPRESSION_LEVEL: "fast"
+  XDG_CACHE_HOME: "/builds/gargantext/.cache"
 
 stages:
   - cabal
@@ -26,6 +28,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 +42,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 +57,55 @@ 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 && 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'\""
+      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'\""
+
       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.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/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/Server.hs

@@ -12,31 +12,39 @@ Portability : POSIX
 
 module CLI.Server where
 
-import Data.Version (showVersion)
 import CLI.Parsers (settings_p)
 import CLI.Types
 import CLI.Worker (runAllWorkers)
-import GHC.IO.Encoding (setLocaleEncoding, utf8)
-import Gargantext.API (startGargantext)
+import Control.Monad.IO.Class
+import Data.Version (showVersion)
 import Gargantext.API.Admin.EnvTypes (Mode(..))
+import Gargantext.API (startGargantext)
+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 GHC.IO.Encoding (setLocaleEncoding, utf8)
 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
+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 +66,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 +89,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/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)
@@ -67,8 +67,9 @@ workerCLI (CLIW_run (WorkerArgs { .. })) = do
           withPGMQWorkerCtrlC env wd $ \a _state -> do
             -- _ <- runReaderT (sendJob Ping) env
             wait a
-workerCLI (CLIW_runAll (WorkerAllArgs { .. })) = withLogger () $ \ioLogger -> do
-  runAllWorkers ioLogger worker_toml
+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)
 

bin/install-cabal2stack

@@ -19,7 +19,7 @@ then
     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
+    cabal --store-dir=$STORE_DIR v2-install --allow-newer --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

@@ -23,7 +23,7 @@ expected_cabal_project_freeze_hash="32310c4d4e7b4679dcb90dcfcd0d6d1b175dbf885a77
 
 
 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
@@ -104,7 +77,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/openalex.git
-    tag: a80e0ea57379d23f5e18a412606a71471b8ef681
+    tag: c86412b5b8713b2bdd63b2bed2a2259c5d143a88
 
 source-repository-package
     type: git
@@ -114,12 +87,14 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/gargantext-graph.git
-    tag: 588e104fe7593210956610cab0041fd16584a4ce
+    tag: a08ceed71b297a811f90cb86c3c61dc0b153036b
+    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
@@ -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
@@ -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/docker/Dockerfile

@@ -3,18 +3,25 @@ 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 GHC=9.6.6
 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 ./nix/pinned-25.05.nix                            /builds/gargantext/nix/pinned-25.05.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 \
@@ -47,32 +54,22 @@ RUN apt-get update && \
       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
 
-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
+SHELL ["/bin/bash", "-o", "pipefail", "-c"]
 
-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" && \
+RUN cd /root/devops/coreNLP; ./build.sh && \
+    set -o pipefail && \
+    bash <(curl -L https://releases.nixos.org/nix/nix-2.26.2/install) --no-daemon && \
+    locale-gen en_US.UTF-8 && 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`
-
-ENV PATH=/root/.nix-profile/bin:$PATH
-
-RUN . $HOME/.bashrc && nix-env --version
-
-ENV PATH=/root/.local/bin:$PATH
+    echo `which nix-env` && \
+    . $HOME/.bashrc && nix-env --version && \
+    cd /builds/gargantext && nix-shell --run "./bin/install-cabal2stack"
 
-RUN cd /builds/gargantext && nix-shell --run "./bin/install-cabal2stack"
 WORKDIR "/builds/gargantext/"
 

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"
 
 

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/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"
+      component: "gargantext:exe:gargantext"
 
     - 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"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-server/Paths_gargantext.hs"
-      component: "gargantext:exe:gargantext-server"
+      component: "gargantext:exe:gargantext"
 
     - path: "./test"
       component: "gargantext:test:garg-test-tasty"

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;
+  ghc966 = pkgs.haskell.compiler.ghc966;
+  cabal_install = pkgs.haskell.lib.compose.justStaticExecutables pkgs.haskell.packages.ghc966.cabal-install;
   graphviz_dev = pkgs.graphviz.overrideAttrs (finalAttrs: previousAttrs: {
     version = "11.0.0~dev";
     src = pkgs.fetchFromGitLab {
@@ -33,14 +25,10 @@ rec {
                           ];
                 });
 
-  # nng180 = pkgs.nng.overrideAttrs (new: old: rec {
-  #   version = "1.8.0";
-  # });
-  
   igraph_0_10_4 = pkgs.igraph.overrideAttrs (finalAttrs: previousAttrs: {
     version = "0.10.4";
 
-    nativeBuildInputs = previousAttrs.nativeBuildInputs or [] ++ [ pkgs.clang_12 ];
+    nativeBuildInputs = previousAttrs.nativeBuildInputs;
 
     src = pkgs.fetchFromGitHub {
       owner = "igraph";
@@ -53,7 +41,7 @@ rec {
       echo "0.10.4" > IGRAPH_VERSION
     '';
 
-    outputs = [ "out" "doc" ];
+    outputs = [ "dev" "out" "doc" ];
 
     buildInputs = [
       pkgs.arpack
@@ -64,7 +52,6 @@ rec {
       pkgs.libxml2
       pkgs.nanomsg
       pkgs.plfit
-    ] ++ pkgs.lib.optionals pkgs.stdenv.cc.isClang [
       pkgs.llvmPackages.openmp
     ];
 
@@ -81,23 +68,29 @@ rec {
       "-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 "$out/include/igraph" && cp *.h ../
+      cd "$dev/include/igraph" && cp *.h ../
       cd $CUR_DIR
     '';
 
   });
   hsBuildInputs = [
-    ghc948
-    cabal_install_3_10_2_1
+    ghc966
+    cabal_install
     pkgs.haskellPackages.alex
     pkgs.haskellPackages.happy
     pkgs.haskellPackages.pretty-show
@@ -113,25 +106,22 @@ rec {
     hlint
     libffi
     lapack
-    lzma
+    xz
     pcre
     pkg-config
     postgresql
     xz
     zlib
     blas
-    gfortran7
+    gfortran
     expat
     icu
     graphviz
-    clang_12
-    llvm_12
-    gcc12
+    gcc13
     igraph_0_10_4
     libpqxx
     libsodium
     nanomsg
-    # nng180
     zeromq
     curl
   ] ++ ( lib.optionals stdenv.isDarwin [
@@ -139,8 +129,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,14 +48,14 @@ 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)
@@ -70,21 +70,20 @@ import System.Cron.Schedule qualified as Cron
 
 -- | 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) = withLoggerIO mode $ \logger -> 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
+  withNotifications config $ \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
+    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
@@ -94,23 +93,24 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mod
           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 +121,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/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
 
@@ -43,14 +43,14 @@ 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 (GargConfig(..), gc_mail_config, gc_nlp_config, HasJWTSettings(..), HasConfig(..), HasManager(..), gc_logging, lc_log_level)
+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
@@ -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',
@@ -142,7 +120,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 }
 
@@ -176,6 +157,7 @@ instance HasLogger (GargM DevEnv BackendInternalError) where
 
 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
@@ -186,7 +168,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
@@ -234,8 +216,34 @@ instance HasNodeArchiveStoryImmediateSaver DevEnv where
 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
+  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
+    cfg <- view hasConfig
+    let minLvl = cfg ^. gc_logging . lc_log_level
+    when (lvl >= minLvl) $ 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)
+
+instance MonadLogger (GargM Env BackendInternalError) where
+  getLogger = asks _env_logger

src/Gargantext/API/Admin/Settings.hs

@@ -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

src/Gargantext/API/Auth/PolicyCheck.hs

@@ -33,6 +33,7 @@ module Gargantext.API.Auth.PolicyCheck (
   , nodePublishedEdit
   , moveChecks
   , publishChecks
+  , remoteExportChecks
   , userMe
   , alwaysAllow
   , alwaysDeny
@@ -211,7 +212,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
@@ -274,6 +275,11 @@ 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/Dev.hs

@@ -14,24 +14,25 @@ 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 Data.Pool (withResource)
 import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) )
 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.Types (SettingsFile(..))
+import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
 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
+withDevEnv settingsFile k = withLoggerIO Dev $ \logger -> do
   env <- newDevEnv logger
   k env -- `finally` cleanEnv env
 
@@ -41,8 +42,10 @@ withDevEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
       --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
       pool    <- newPool (_gc_database_config cfg)
       nodeStory_env <- fromDBNodeStoryEnv pool
+      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

@@ -176,6 +176,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
@@ -121,6 +123,12 @@ data BackendInternalError
 
 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 +266,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 +286,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 +526,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 +749,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/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/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/Ngrams.hs

@@ -21,6 +21,7 @@ add get
 {-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE IncoherentInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeFamilies      #-}
 {-# LANGUAGE TypeOperators     #-}
 
@@ -84,13 +85,13 @@ module Gargantext.API.Ngrams
 import Control.Lens (view, (^..), (+~), (%~), msumOf, at, ix, _Just, Each(..), (%%~), ifolded, to, withIndex, over)
 import Data.Aeson.Text qualified as DAT
 import Data.List qualified as List
-import Data.Map.Strict qualified as Map
 import Data.Map.Strict.Patch qualified as PM
+import Data.Map.Strict qualified as Map
 import Data.Patch.Class (Action(act), Transformable(..), ours)
 import Data.Set qualified as Set
 import Data.Text (isInfixOf, toLower, unpack)
 import Data.Text.Lazy.IO as DTL ( writeFile )
-import Formatting (hprint, int, (%))
+import Formatting (sformat, int, (%))
 import Gargantext.API.Ngrams.Tools (getNodeStory)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory (ArchiveList, HasNodeStory, HasNodeArchiveStoryImmediateSaver(..), HasNodeStoryImmediateSaver(..), NgramsStatePatch', a_history, a_state, a_version, currentVersion)
@@ -99,8 +100,9 @@ import Gargantext.Core.Types (ListType(..), NodeId, ListId, TODO, assertValid, H
 import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
 import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast)
 import Gargantext.Database.Query.Table.Ngrams ( text2ngrams, insertNgrams )
-import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
 import Gargantext.Prelude.Clock (hasTime, getTime)
+import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
+import Gargantext.System.Logging
 import Text.Collate qualified as Unicode
 
 
@@ -517,7 +519,9 @@ unicodeDUCETSorter :: Text -> Text -> Ordering
 unicodeDUCETSorter = Unicode.collate Unicode.rootCollator
 
 getTableNgrams :: forall env err m.
-                  ( HasNodeStory env err m )
+                  ( HasNodeStory env err m
+                  , MonadLogger m
+                  )
                => NodeId
                -> ListId
                -> TabType
@@ -531,7 +535,9 @@ getTableNgrams nodeId listId tabType searchQuery = do
 
 -- | Helper function to get the ngrams table with scores.
 getNgramsTable' :: forall env err m.
-                   ( HasNodeStory env err m )
+                   ( HasNodeStory env err m
+                   , MonadLogger m
+                   )
                 => NodeId
                 -> ListId
                 -> NgramsType
@@ -544,7 +550,9 @@ getNgramsTable' nId listId ngramsType = do
 -- | Helper function to set scores on an `NgramsTable`.
 setNgramsTableScores :: forall env err m t.
                         ( Each t t NgramsElement NgramsElement
-                        , HasNodeStory env err m )
+                        , HasNodeStory env err m
+                        , MonadLogger m
+                        )
                      => NodeId
                      -> ListId
                      -> NgramsType
@@ -555,12 +563,9 @@ setNgramsTableScores nId listId ngramsType table = do
   occurrences <- getOccByNgramsOnlyFast nId listId ngramsType
   --printDebug "[setNgramsTableScores] occurrences" occurrences
   t2 <- getTime
-  liftBase $ do
-    let ngrams_terms = table ^.. each . ne_ngrams
-    -- printDebug "ngrams_terms" ngrams_terms
-    hprint stderr
-      ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n")
-      (length ngrams_terms) t1 t2
+  let ngrams_terms = table ^.. each . ne_ngrams
+  $(logLocM) DEBUG $ "ngrams_terms: " <> show ngrams_terms
+  $(logLocM) DEBUG $ sformat ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n") (length ngrams_terms) t1 t2
   let
     setOcc ne = ne & ne_occurrences .~ Set.fromList (msumOf (ix (ne ^. ne_ngrams)) occurrences)
 
@@ -580,7 +585,7 @@ needsScores (Just ScoreAsc)  = True
 needsScores (Just ScoreDesc) = True
 needsScores _ = False
 
-getTableNgramsCorpus :: ( HasNodeStory env err m )
+getTableNgramsCorpus :: ( HasNodeStory env err m, MonadLogger m )
                      => NodeId
                      -> TabType
                      -> ListId

src/Gargantext/API/Ngrams/List.hs

@@ -10,6 +10,7 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE ViewPatterns        #-}
 
@@ -20,17 +21,17 @@ import Data.ByteString.Lazy qualified as BSL
 import Data.Csv qualified as Tsv
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
-import Data.Map.Strict (toList)
 import Data.Map.Strict qualified as Map
+import Data.Map.Strict (toList)
 import Data.Set qualified as Set
 import Data.Text (concat, pack, splitOn)
-import Data.Vector (Vector)
 import Data.Vector qualified as Vec
+import Data.Vector (Vector)
 import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Errors.Types (BackendInternalError(InternalServerError))
-import Gargantext.API.Ngrams (setListNgrams)
 import Gargantext.API.Ngrams.List.Types (_wjf_data, _wtf_data)
 import Gargantext.API.Ngrams.Prelude (getNgramsList)
+import Gargantext.API.Ngrams (setListNgrams)
 import Gargantext.API.Ngrams.Types
 import Gargantext.API.Prelude (GargM, serverError, HasServerError)
 import Gargantext.API.Routes.Named.List qualified as Named
@@ -46,11 +47,13 @@ import Gargantext.Database.Schema.Ngrams ( text2ngrams, NgramsId )
 import Gargantext.Database.Schema.Node (_node_parent_id)
 import Gargantext.Database.Types (Indexed(..))
 import Gargantext.Prelude hiding (concat, toList)
+import Gargantext.System.Logging (logLocM, MonadLogger)
 import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
 import Prelude qualified
 import Protolude qualified as P
 import Servant
 import Servant.Server.Generic (AsServerT)
+import Gargantext.System.Logging (LogLevel(..))
 
 
 getAPI :: Named.GETAPI (AsServerT (GargM Env BackendInternalError))
@@ -114,7 +117,7 @@ jsonPostAsync = Named.JSONAPI {
   }
 
 ------------------------------------------------------------------------
-postAsyncJSON :: (HasNodeStory env err m, MonadJobStatus m)
+postAsyncJSON :: (HasNodeStory env err m, MonadJobStatus m, MonadLogger m)
               => ListId
               -> NgramsList
               -> JobHandle m
@@ -123,13 +126,17 @@ postAsyncJSON l ngramsList jobHandle = do
 
   markStarted 2 jobHandle
 
+  $(logLocM) DEBUG "[postAsyncJSON] Setting the Ngrams list ..."
   setList
+  $(logLocM) DEBUG "[postAsyncJSON] Done."
 
   markProgress 1 jobHandle
 
   corpus_node <- getNode l -- (Proxy :: Proxy HyperdataList)
   let corpus_id = fromMaybe (panicTrace "no parent_id") (_node_parent_id corpus_node)
+  $(logLocM) DEBUG "[postAsyncJSON] Executing re-indexing..."
   _ <- reIndexWith corpus_id l NgramsTerms (Set.fromList [MapTerm, CandidateTerm])
+  $(logLocM) DEBUG "[postAsyncJSON] Re-indexing done."
 
   markComplete jobHandle
 
@@ -206,7 +213,7 @@ tsvToNgramsTableMap record = case Vec.toList record of
 
 
 -- | This is for debugging the TSV parser in the REPL
-importTsvFile :: forall env err m. (HasNodeStory env err m, HasServerError err, MonadJobStatus m)
+importTsvFile :: forall env err m. (HasNodeStory env err m, HasServerError err, MonadJobStatus m, MonadLogger m)
               => ListId -> P.FilePath -> m ()
 importTsvFile lId fp = do
   contents <- liftBase $ P.readFile fp

src/Gargantext/API/Ngrams/Types.hs

@@ -16,6 +16,7 @@ Portability : POSIX
 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# OPTIONS -fno-warn-orphans     #-}  -- some instances are orphaned here
+{-# LANGUAGE StandaloneDeriving #-}
 
 module Gargantext.API.Ngrams.Types where
 
@@ -98,6 +99,8 @@ newtype MSet a = MSet (Map a ())
   deriving newtype (Semigroup, Monoid)
   deriving anyclass (ToExpr)
 
+instance NFData a => NFData (MSet a) where
+
 instance ToJSON a => ToJSON (MSet a) where
   toJSON     (MSet m) = toJSON     (Map.keys m)
   toEncoding (MSet m) = toEncoding (Map.keys m)
@@ -171,6 +174,7 @@ instance FromField NgramsRepoElement where
   fromField = fromJSONField
 instance ToField NgramsRepoElement where
   toField = toJSONField
+instance NFData NgramsRepoElement where
 
 data NgramsElement =
      NgramsElement { _ne_ngrams      :: NgramsTerm
@@ -201,6 +205,7 @@ newNgramsElement mayList ngrams =
 
 instance ToSchema NgramsElement where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
+instance NFData NgramsElement where
 
 ------------------------------------------------------------------------
 newtype NgramsTable = NgramsTable [NgramsElement]
@@ -209,6 +214,7 @@ newtype NgramsTable = NgramsTable [NgramsElement]
   deriving anyclass (ToExpr)
 
 -- type NgramsList = NgramsTable
+instance NFData NgramsTable where
 
 makePrisms ''NgramsTable
 
@@ -379,6 +385,10 @@ newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
   deriving stock (Eq, Show, Generic)
   deriving newtype (Validity, Semigroup, Monoid, Group, Transformable, Composable)
 
+deriving anyclass instance (NFData k, NFData v) => NFData (PatchMap k v)
+deriving anyclass instance NFData a => NFData (Replace a)
+instance NFData a => NFData (PatchMSet a) where
+
 unPatchMSet :: PatchMSet a -> PatchMap a AddRem
 unPatchMSet (PatchMSet a) = a
 
@@ -441,6 +451,8 @@ data NgramsPatch
                    }
       deriving (Eq, Show, Generic)
 
+instance NFData NgramsPatch where
+
 -- The JSON encoding is untagged, this is OK since the field names are disjoints and thus the encoding is unambiguous.
 -- TODO: the empty object should be accepted and treated as mempty.
 deriveJSON (unPrefixUntagged "_") ''NgramsPatch
@@ -532,6 +544,8 @@ newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
   deriving stock (Eq, Show, Generic)
   deriving newtype (ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
 
+instance NFData NgramsTablePatch
+
 mkNgramsTablePatch :: Map NgramsTerm NgramsPatch -> NgramsTablePatch
 mkNgramsTablePatch = NgramsTablePatch . PM.fromMap
 
@@ -683,6 +697,8 @@ deriveJSON (unPrefix "_v_") ''Versioned
 makeLenses ''Versioned
 instance (Typeable a, ToSchema a) => ToSchema (Versioned a) where
   declareNamedSchema = wellNamedSchema "_v_"
+instance NFData a => NFData (Versioned a) where
+instance Serialise a => Serialise (Versioned a) where
 ------------------------------------------------------------------------
 type Count = Int
 
@@ -697,6 +713,7 @@ deriveJSON (unPrefix "_vc_") ''VersionedWithCount
 makeLenses ''VersionedWithCount
 instance (Typeable a, ToSchema a) => ToSchema (VersionedWithCount a) where
   declareNamedSchema = wellNamedSchema "_vc_"
+instance NFData a => NFData (VersionedWithCount a) where
 
 toVersionedWithCount :: Count -> Versioned a -> VersionedWithCount a
 toVersionedWithCount count (Versioned version data_) = VersionedWithCount version count data_

src/Gargantext/API/Node.hs

@@ -28,15 +28,15 @@ Node API
 module Gargantext.API.Node
   where
 
-import Gargantext.API.Admin.Auth (withNamedAccess, withNamedPolicyT, withPolicy, withPolicy)
 import Gargantext.API.Admin.Auth.Types (PathId(..), AuthenticatedUser (..), auth_node_id, auth_user_id)
+import Gargantext.API.Admin.Auth (withNamedAccess, withNamedPolicyT, withPolicy, withPolicy)
 import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Auth.PolicyCheck ( nodeReadChecks, nodeWriteChecks, moveChecks, AccessPolicyManager, publishChecks )
 import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Metrics
 import Gargantext.API.Ngrams.Types (TabType(..))
-import Gargantext.API.Node.DocumentUpload qualified as DocumentUpload
 import Gargantext.API.Node.DocumentsFromWriteNodes qualified as DFWN
+import Gargantext.API.Node.DocumentUpload qualified as DocumentUpload
 import Gargantext.API.Node.File ( fileApi, fileAsyncApi )
 import Gargantext.API.Node.FrameCalcUpload qualified as FrameCalcUpload
 import Gargantext.API.Node.New ( postNode, postNodeAsyncAPI )
@@ -49,8 +49,11 @@ import Gargantext.API.Routes.Named.Node qualified as Named
 import Gargantext.API.Routes.Named.Private qualified as Named
 import Gargantext.API.Routes.Named.Publish qualified as Named
 import Gargantext.API.Routes.Named.Share qualified as Named
+import Gargantext.API.Routes.Named.Tree qualified as Named
 import Gargantext.API.Search qualified as Search
 import Gargantext.API.Server.Named.Ngrams (apiNgramsTableCorpus)
+import Gargantext.API.Server.Named.Remote qualified as Named
+import Gargantext.API.Server.Named.Remote qualified as Remote
 import Gargantext.API.Table ( tableApi, getPair )
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Viz.Phylo.API (phyloAPI)
@@ -62,17 +65,16 @@ import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (DBCmdExtra, JSONB)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Children (getChildren)
-import Gargantext.Database.Query.Table.Node.Update (Update(..), update)
-import Gargantext.Database.Query.Table.Node.Update qualified as U (update, Update(..), publish)
-import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Query.Table.NodeContext (nodeContextsCategory, nodeContextsScore)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.NodeNode
+import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
+import Gargantext.Database.Query.Table.Node.Update qualified as U (update, Update(..), publish)
+import Gargantext.Database.Query.Table.Node.Update (Update(..), update)
 import Gargantext.Database.Query.Tree (tree, tree_flat, TreeMode(..))
 import Gargantext.Prelude
 import Servant
 import Servant.Server.Generic (AsServerT)
-import Gargantext.API.Routes.Named.Tree qualified as Named
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 
 
 -- | Delete Nodes
@@ -216,8 +218,12 @@ corpusNodeAPI authenticatedUser = Named.CorpusAPIEndpoint $ \targetNode ->
 ------------------------------------------------------------------------
 nodeAPI :: AuthenticatedUser
         -> Named.NodeAPIEndpoint (AsServerT (GargM Env BackendInternalError))
-nodeAPI authenticatedUser = Named.NodeAPIEndpoint $ \targetNode ->
-  withNamedAccess authenticatedUser (PathNode targetNode) (concreteAPI targetNode)
+nodeAPI authenticatedUser = Named.NodeAPIEndpoint
+  { nodeEndpointAPI = \targetNode ->
+      withNamedAccess authenticatedUser (PathNode targetNode) (concreteAPI targetNode)
+  , nodeRemoteImportAPI = Named.remoteImportAPI authenticatedUser
+  }
+
   where
     concreteAPI = genericNodeAPI' (Proxy :: Proxy HyperdataAny) authenticatedUser
 
@@ -269,6 +275,7 @@ genericNodeAPI' _ authenticatedUser targetNode =  Named.NodeAPI
   , fileAsyncAPI       = fileAsyncApi authenticatedUser targetNode
   , dfwnAPI            = DFWN.api authenticatedUser targetNode
   , documentUploadAPI  = DocumentUpload.api targetNode
+  , remoteExportAPI    = Remote.remoteExportAPI targetNode authenticatedUser
   }
   where
     userRootId     = RootId $ authenticatedUser ^. auth_node_id

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

@@ -25,8 +25,8 @@ import Control.Lens ( view, non )
 import Data.ByteString.Base64 qualified as BSB64
 import Data.Conduit.Internal (zipSources)
 import Data.Swagger ( ToSchema(..) )
-import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
+import Data.Text qualified as T
 import Gargantext.API.Admin.Orchestrator.Types qualified as API
 import Gargantext.API.Ngrams (commitStatePatch, Versioned(..))
 import Gargantext.API.Node.Corpus.New.Types ( FileFormat(..), FileType(..) )
@@ -34,14 +34,14 @@ import Gargantext.API.Node.Corpus.Searx ( triggerSearxSearch )
 import Gargantext.API.Node.Corpus.Types ( Datafield(Web), datafield2origin )
 import Gargantext.API.Node.Corpus.Update (addLanguageToCorpus)
 import Gargantext.API.Node.Types
-import Gargantext.Core (withDefaultLanguage, defaultLanguage)
 import Gargantext.Core.Config (gc_jobs, hasConfig)
 import Gargantext.Core.Config.Types (jc_max_docs_parsers)
-import Gargantext.Core.NodeStory (HasNodeStoryImmediateSaver, HasNodeArchiveStoryImmediateSaver, currentVersion, NgramsStatePatch')
+import Gargantext.Core.NodeStory (HasNodeStoryImmediateSaver, HasNodeArchiveStoryImmediateSaver, currentVersion, NgramsStatePatch', HasNodeStoryEnv)
 import Gargantext.Core.Text.Corpus.Parsers qualified as Parser (FileType(..), parseFormatC, _ParseFormatError)
 import Gargantext.Core.Text.Corpus.Query qualified as API
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core (withDefaultLanguage, defaultLanguage)
 import Gargantext.Database.Action.Flow (flowCorpus, getDataText, flowDataText, TermType(..){-, allDataOrigins-})
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Action.Mail (sendMail)
@@ -51,6 +51,8 @@ import Gargantext.Database.Admin.Types.Hyperdata.Document ( ToHyperdataDocument(
 import Gargantext.Database.Admin.Types.Hyperdata.File ( HyperdataFile(..) )
 import Gargantext.Database.Admin.Types.Node (CorpusId, NodeType(..), ParentId)
 import Gargantext.Database.GargDB qualified as GargDB
+import Gargantext.Database.Prelude (IsDBCmd)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node (getNodeWith, getOrMkList)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpusIds))
@@ -359,11 +361,15 @@ addToCorpusWithFile user cid nwf@(NewWithFile _d (withDefaultLanguage -> l) fNam
 
 --- UTILITIES
 
-commitCorpus :: ( FlowCmdM env err m
+commitCorpus :: ( IsDBCmd env err m
+                , HasNodeStoryEnv env
+                , HasNodeError err
                 , HasNodeArchiveStoryImmediateSaver env
                 , HasNodeStoryImmediateSaver env )
-             => ParentId -> User -> m (Versioned NgramsStatePatch')
-commitCorpus cid user = do  
+             => ParentId
+             -> User
+             -> m (Versioned NgramsStatePatch')
+commitCorpus cid user = do
   userId <- getUserId user
   listId <- getOrMkList cid userId
   v <- currentVersion listId

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

 module Gargantext.API.Node.Corpus.Subcorpus where
 
+import Data.Validity (Validation(..), ValidationChain(..))
 import Gargantext.Prelude
-
-import Gargantext.API.Errors.Types (BackendInternalError)
+import Gargantext.API.Errors.Types (BackendInternalError(..))
 import Gargantext.API.Routes.Named.Corpus (MakeSubcorpusAPI(..), SubcorpusParams(..))
 import Gargantext.Core.NodeStory.Types (HasNodeStoryEnv)
 import Gargantext.Core.NLP (HasNLPServer)
@@ -21,12 +21,14 @@ makeSubcorpus :: ( HasNodeStoryEnv env
   => UserId
   -> MakeSubcorpusAPI (AsServerT m)
 makeSubcorpus user = MakeSubcorpusAPI $ \corpusId params -> do
-  case parseQuery (RawQuery $ _subcorpusParams_query params) of
-    Left _  -> return False
-    Right q -> do
-      _ <- makeSubcorpusFromQuery
+  let queryText = _subcorpusParams_query params
+  case parseQuery (RawQuery queryText) of
+    Left msg -> throwError $ InternalValidationError $ Validation [Violated $
+                  "Failed to parse the query " <> show queryText <> ": " <> msg]
+    Right q  -> do
+      subcorpusId <- makeSubcorpusFromQuery
              (UserDBId user)
              corpusId
              q
              (_subcorpusParams_reuseParentList params)
-      return True
+      return subcorpusId

src/Gargantext/API/Node/Document/Export.hs

@@ -9,6 +9,10 @@ Portability : POSIX
 -}
 
 module Gargantext.API.Node.Document.Export
+  ( documentExportAPI
+  -- * Internals
+  , get_document_json
+  )
   where
 
 import Control.Lens (view)
@@ -20,7 +24,7 @@ import Data.Time.Clock.System (getSystemTime, systemSeconds)
 import Data.Time.LocalTime (getCurrentTimeZone, TimeZone (timeZoneMinutes))
 import Data.Version (showVersion)
 import Gargantext.API.Node.Document.Export.Types
-import Gargantext.API.Prelude (GargNoServer, IsGargServer)
+import Gargantext.API.Prelude (IsGargServer)
 import Gargantext.API.Routes.Named.Document qualified as Named
 import Gargantext.Core (toDBid)
 import Gargantext.Database.Admin.Types.Node (DocId, NodeId, NodeType(..))
@@ -46,21 +50,26 @@ documentExportAPI userNodeId dId = Named.DocumentExportAPI $ Named.DocumentExpor
 
 --------------------------------------------------
 -- | Hashes are ordered by Set
-getDocumentsJSON :: NodeId
+getDocumentsJSON :: IsGargServer env err m
+                 => NodeId
                  -- ^ The ID of the target user
                  -> DocId
-                 -> GargNoServer (Headers '[Header "Content-Disposition" T.Text] DocumentExport)
+                 -> m (Headers '[Header "Content-Disposition" T.Text] DocumentExport)
 getDocumentsJSON nodeUserId pId = do
-  uId <- view node_user_id <$> getNodeUser nodeUserId
-  mcId <- getClosestParentIdByType pId NodeCorpus
-  let cId = maybe (panicTrace "[G.A.N.D.Export] Node has no parent") identity mcId
-  docs <- runViewDocuments cId False Nothing Nothing Nothing Nothing Nothing
-  let dexp = DocumentExport { _de_documents = mapFacetDoc uId <$> docs
-                            , _de_garg_version = T.pack $ showVersion PG.version }
+  dexp <- get_document_json nodeUserId pId
   pure $ addHeader (T.concat [ "attachment; filename="
                              , "GarganText_DocsList-"
                              , T.pack (show pId)
                              , ".json" ]) dexp
+
+get_document_json :: IsGargServer err env m => NodeId -> DocId -> m DocumentExport
+get_document_json nodeUserId pId = do
+  uId <- view node_user_id <$> getNodeUser nodeUserId
+  mcId <- getClosestParentIdByType pId NodeCorpus
+  let cId = maybe (panicTrace "[G.A.N.D.Export] Node has no parent") identity mcId
+  docs <- runViewDocuments cId False Nothing Nothing Nothing Nothing Nothing
+  pure DocumentExport { _de_documents = mapFacetDoc uId <$> docs
+                      , _de_garg_version = T.pack $ showVersion PG.version }
   where
     mapFacetDoc uId (FacetDoc { .. }) =
       Document { _d_document =
@@ -80,10 +89,11 @@ getDocumentsJSON nodeUserId pId = do
                                                 , _ng_hash = "" }
                          , _d_hash     = ""}
 
-getDocumentsJSONZip :: NodeId
+getDocumentsJSONZip :: IsGargServer env err m
+                    => NodeId
                     -- ^ The Node ID of the target user
                     -> DocId
-                    -> GargNoServer (Headers '[Header "Content-Disposition" T.Text] DocumentExportZIP) -- [Document]
+                    -> m (Headers '[Header "Content-Disposition" T.Text] DocumentExportZIP) -- [Document]
 getDocumentsJSONZip userNodeId pId = do
   dJSON <- getDocumentsJSON userNodeId pId
   systime <- liftBase getSystemTime
@@ -98,10 +108,11 @@ getDocumentsJSONZip userNodeId pId = do
                              , dezFileName dexpz
                              , ".zip" ]) dexpz
 
-getDocumentsTSV :: NodeId
+getDocumentsTSV :: IsGargServer err env m
+                => NodeId
                 -- ^ The Node ID of the target user
                 -> DocId
-                -> GargNoServer (Headers '[Header "Content-Disposition" T.Text] T.Text) -- [Document]
+                -> m (Headers '[Header "Content-Disposition" T.Text] T.Text) -- [Document]
 getDocumentsTSV userNodeId pId = do
   dJSON <- getDocumentsJSON userNodeId pId
   let DocumentExport { _de_documents } = getResponse dJSON

src/Gargantext/API/Node/Document/Export/Types.hs

@@ -13,12 +13,13 @@ Portability : POSIX
 
 module Gargantext.API.Node.Document.Export.Types where
 
+import Codec.Serialise.Class hiding (encode)
 import Data.Aeson (encode)
 import Data.Aeson.TH (deriveJSON)
 import Data.Csv (DefaultOrdered(..), ToNamedRecord(..), (.=), header, namedRecord)
 import Data.Swagger ( genericDeclareNamedSchema, ToParamSchema(..), ToSchema(..) )
-import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
+import Data.Text qualified as T
 import Gargantext.Core.Types ( Node, TODO )
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..) )
@@ -28,27 +29,37 @@ import Gargantext.Utils.Servant (ZIP)
 import Gargantext.Utils.Zip (zipContentsPureWithLastModified)
 import Protolude
 import Servant (MimeRender(..), MimeUnrender(..))
+import Prelude (show)
 
 
 -- | Document Export
 data DocumentExport =
   DocumentExport { _de_documents    :: [Document]
                  , _de_garg_version :: Text
-                 } deriving (Generic)
+                 } deriving (Generic, Show, Eq)
+
+instance Serialise DocumentExport where
 
 -- | This is to represent a zipped document export. We want to have doc_id in zipped file name.
 data DocumentExportZIP =
   DocumentExportZIP { _dez_dexp          :: DocumentExport
                     , _dez_doc_id        :: DocId
                     , _dez_last_modified :: Integer } deriving (Generic)
-    
-    
+
+
 data Document =
   Document { _d_document :: Node HyperdataDocument
            , _d_ngrams   :: Ngrams
            , _d_hash     :: Hash
            } deriving (Generic)
 
+instance Eq Document where
+  (Document _ _ h1) == (Document _ _ h2) = h1 == h2 -- compare by their hashes
+
+instance Show Document where
+  show (Document _ _ h1) = "Document " <> Prelude.show h1
+
+instance Serialise Document where
 --instance Read Document where
 --  read "" = panic "not implemented"
 instance DefaultOrdered Document where
@@ -102,6 +113,8 @@ instance ToParamSchema Document where
 instance ToParamSchema Ngrams where
   toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
 
+instance Serialise Ngrams where
+
 $(deriveJSON (unPrefix "_ng_") ''Ngrams)
 $(deriveJSON (unPrefix "_d_") ''Document)
 $(deriveJSON (unPrefix "_de_") ''DocumentExport)
@@ -113,7 +126,7 @@ $(deriveJSON (unPrefix "_de_") ''DocumentExport)
 -- Needs to be here because of deriveJSON TH above
 
 dezFileName :: DocumentExportZIP -> Text
-dezFileName (DocumentExportZIP { .. }) = "GarganText_DocsList-" <> show _dez_doc_id <> ".json"
+dezFileName (DocumentExportZIP { .. }) = "GarganText_DocsList-" <> Protolude.show _dez_doc_id <> ".json"
     
 instance MimeRender ZIP DocumentExportZIP where
   mimeRender _ dexpz@(DocumentExportZIP { .. }) =

src/Gargantext/API/Node/DocumentUpload.hs

@@ -11,33 +11,43 @@ Portability : POSIX
 
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE MonoLocalBinds      #-}
+{-# LANGUAGE TemplateHaskell     #-}
 
 module Gargantext.API.Node.DocumentUpload where
 
 import Control.Lens (view)
 import Data.Text qualified as T
+import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(..))
 import Gargantext.API.Admin.EnvTypes (Env)
-import Gargantext.API.Errors.Types ( BackendInternalError )
+import Gargantext.API.Errors.Types ( BackendInternalError (..) )
+import Gargantext.API.Node.Corpus.New (commitCorpus)
+import Gargantext.API.Node.Document.Export.Types ( Document(..))
 import Gargantext.API.Node.DocumentUpload.Types
 import Gargantext.API.Prelude ( GargM )
 import Gargantext.API.Routes.Named.Document qualified as Named
 import Gargantext.API.Worker (serveWorkerAPI)
 import Gargantext.Core (Lang(..))
-import Gargantext.Core.NLP (nlpServerGet)
+import Gargantext.Core.NLP (nlpServerGet, HasNLPServer)
+import Gargantext.Core.NodeStory.Types (HasNodeStoryEnv, HasNodeArchiveStoryImmediateSaver)
 import Gargantext.Core.Text.Corpus.Parsers.Date (mDateSplit)
 import Gargantext.Core.Text.Terms (TermType(..))
+import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
+import Gargantext.Core.Worker.Jobs.Types (WorkSplit(..))
 import Gargantext.Database.Action.Flow (addDocumentsToHyperCorpus)
 import Gargantext.Database.Action.Flow.Types ( FlowCmdM )
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( HyperdataCorpus )
 import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
-import Gargantext.Database.Admin.Types.Node ( DocId, NodeId, NodeType(NodeCorpus) )
+import Gargantext.Database.Admin.Types.Node ( DocId, NodeId, NodeType(NodeCorpus), ParentId )
+import Gargantext.Database.Prelude (IsDBCmd)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType')
+import Gargantext.Database.Schema.Node (_node_hyperdata)
 import Gargantext.Prelude
+import Gargantext.System.Logging (logLocM, LogLevel(..), MonadLogger)
 import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
 import Servant.Server.Generic (AsServerT)
 
-
 api :: NodeId -> Named.DocumentUploadAPI (AsServerT (GargM Env BackendInternalError))
 api nId = Named.DocumentUploadAPI {
     uploadDocAsyncEp = serveWorkerAPI $ \p ->
@@ -91,3 +101,30 @@ documentUpload nId doc = do
   let lang = EN
   ncs <- view $ nlpServerGet lang
   addDocumentsToHyperCorpus ncs (Nothing :: Maybe HyperdataCorpus) (Multi lang) cId [hd]
+
+-- | Imports the documents contained into this 'DocumentExport' into this (local) version
+-- of the running node.
+-- /NOTE(adn)/: We should compare the gargantext version and ensure that we are importing
+-- only compatible versions.
+remoteImportDocuments :: ( HasNodeError err
+                         , HasNLPServer env
+                         , HasNodeArchiveStoryImmediateSaver env
+                         , HasNodeStoryEnv env
+                         , IsDBCmd env err m
+                         , MonadLogger m
+                         , MonadIO m)
+                      => AuthenticatedUser
+                      -> ParentId
+                      -> NodeId
+                      -> WorkSplit
+                      -> [Document]
+                      -- ^ Total docs
+                      -> m [NodeId]
+remoteImportDocuments loggedInUser corpusId nodeId WorkSplit{..} documents = do
+  let la = Multi EN
+  nlpServerConfig <- view $ nlpServerGet (_tt_lang la)
+  $(logLocM) INFO $ "Importing " <> T.pack (show _ws_current) <> "/" <> T.pack (show _ws_total) <> " documents for corpus node " <> T.pack (show nodeId)
+  docs <- addDocumentsToHyperCorpus nlpServerConfig (Nothing :: Maybe HyperdataCorpus) la corpusId (map (_node_hyperdata . _d_document) documents)
+  _versioned <- commitCorpus corpusId (RootId $ _auth_node_id loggedInUser)
+  $(logLocM) INFO $ "Done importing " <> T.pack (show _ws_current) <> "/" <> T.pack (show _ws_total) <> " documents for corpus node " <> T.pack (show nodeId)
+  pure docs

src/Gargantext/API/Node/Share.hs

@@ -55,25 +55,21 @@ api userInviting nId (ShareTeamParams user') = do
           pure u
         Left _err -> do
           username' <- getUsername userInviting
-          if username' `List.elem` arbitraryUsername
-            then do
-              -- printDebug "[G.A.N.Share.api]" ("Demo users are not allowed to invite" :: Text)
-              pure ()
-            else do
-              -- TODO better analysis of the composition of what is shared
-              children <- findNodesWithType nId [NodeList] [ NodeFolderShared
-                                                           , NodeTeam
-                                                           , NodeFolder
-                                                           , NodeCorpus
-                                                           ]
-              _ <- if List.null children
-                then do
-                  -- printDebug "[G.A.N.Share.api]" ("Invitation is enabled if you share a corpus at least" :: Text)
-                  pure $ UnsafeMkUserId 0
-                else do
-                  -- printDebug "[G.A.N.Share.api]" ("Your invitation is sent to: " <> user'')
-                  newUser user''
-              pure ()
+          unless (username' `List.elem` arbitraryUsername) $ do
+            -- TODO better analysis of the composition of what is shared
+            children <- findNodesWithType nId [NodeList] [ NodeFolderShared
+                                                         , NodeTeam
+                                                         , NodeFolder
+                                                         , NodeCorpus
+                                                         ]
+            _ <- if List.null children
+              then do
+                -- printDebug "[G.A.N.Share.api]" ("Invitation is enabled if you share a corpus at least" :: Text)
+                pure $ UnsafeMkUserId 0
+              else do
+                -- printDebug "[G.A.N.Share.api]" ("Your invitation is sent to: " <> user'')
+                newUser user''
+            pure ()
           pure u
 
   fromIntegral <$> DB.shareNodeWith (ShareNodeWith_User NodeFolderShared (UserName user)) nId

src/Gargantext/API/Node/Update.hs

@@ -10,7 +10,6 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators    #-}
 
 module Gargantext.API.Node.Update
       where
@@ -67,6 +66,7 @@ updateNode nId (UpdateNodeParamsGraph
                     (UpdateNodeConfigGraph metric partitionMethod bridgeMethod strength nt1 nt2)) jobHandle = do
 
   markStarted 2 jobHandle
+  markProgress 1 jobHandle
   -- printDebug "Computing graph: " method
   _ <- recomputeGraph nId partitionMethod bridgeMethod (Just metric) (Just strength) nt1 nt2 True
   -- printDebug "Graph computed: " method
@@ -74,6 +74,7 @@ updateNode nId (UpdateNodeParamsGraph
 
 updateNode nid1 (LinkNodeReq nt nid2) jobHandle = do
   markStarted 2 jobHandle
+  markProgress 1 jobHandle
   _ <- case nt of
     NodeAnnuaire -> pairing nid2 nid1 Nothing -- defaultList
     NodeCorpus   -> pairing nid1 nid2 Nothing -- defaultList
@@ -84,7 +85,7 @@ updateNode nid1 (LinkNodeReq nt nid2) jobHandle = do
 
 -- | `Advanced` to update graphs
 updateNode lId (UpdateNodeParamsList Advanced) jobHandle = do
-  markStarted 3 jobHandle
+  markStarted 4 jobHandle
   corpusId <- view node_parent_id <$> getNode lId
 
   markProgress 1 jobHandle
@@ -92,7 +93,9 @@ updateNode lId (UpdateNodeParamsList Advanced) jobHandle = do
   _ <- case corpusId of
     Just cId -> do
       _ <- Metrics.updatePie cId (Just lId) NgramsTypes.Authors Nothing
+      markProgress 1 jobHandle
       _ <- Metrics.updateTree cId (Just lId) NgramsTypes.Institutes MapTerm
+      markProgress 1 jobHandle
       _ <- Metrics.updatePie cId (Just lId) NgramsTypes.Sources Nothing
       pure ()
     Nothing  -> pure ()
@@ -108,6 +111,7 @@ updateNode lId (UpdateNodeParamsList _mode) jobHandle = do
   _ <- case corpusId of
     Just cId -> do
       _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
+      markProgress 1 jobHandle
       _ <- updateNgramsOccurrences cId lId
       pure ()
     Nothing  -> pure ()
@@ -124,7 +128,7 @@ updateNode phyloId (UpdateNodePhylo config) jobHandle = do
   let corpusId = fromMaybe (panicTrace "no corpus id") corpusId'
 
   phy <- timeMeasured "updateNode.flowPhyloAPI" $ flowPhyloAPI (subConfigAPI2config config) mbComputeHistory corpusId
-  markProgress 2 jobHandle
+  markProgress 1 jobHandle
 
 {-
   logStatus JobLog { _scst_succeeded = Just 2
@@ -140,12 +144,12 @@ updateNode phyloId (UpdateNodePhylo config) jobHandle = do
   markComplete jobHandle
 
 updateNode tId (UpdateNodeParamsTexts _mode) jobHandle = do
-  markStarted 3 jobHandle
+  markStarted 2 jobHandle
   corpusId <- view node_parent_id <$> getNode tId
   markProgress 1 jobHandle
 
   _ <- case corpusId of
-    Just cId -> updateDocs cId
+    Just cId -> updateDocs cId jobHandle
     Nothing  -> do
       _ <- panicTrace "[G.A.N.Update] updateNode/UpdateNodeParamsText: no corpus Id given"
       pure ()
@@ -155,7 +159,7 @@ updateNode tId (UpdateNodeParamsTexts _mode) jobHandle = do
 updateNode tId
     (UpdateNodeParamsCorpus methodGraph methodPhylo methodTexts methodList)
     jobHandle = do
-  markStarted 3 jobHandle
+  markStarted 5 jobHandle
   markProgress 1 jobHandle
 
   _ <- getNode tId
@@ -165,8 +169,11 @@ updateNode tId
   childNodeLists <- getChildrenByType tId NodeList
 
   mapM_ (\cId -> updateNode cId (UpdateNodeParamsTexts methodTexts) jobHandle) childTexts
+  markProgress 1 jobHandle
   mapM_ (\cId -> updateNode cId (UpdateNodeParamsGraph methodGraph) jobHandle) childGraphs
+  markProgress 1 jobHandle
   mapM_ (\cId -> updateNode cId (UpdateNodePhylo methodPhylo) jobHandle) childPhylos
+  markProgress 1 jobHandle
   mapM_ (\cId -> updateNode cId (UpdateNodeParamsList methodList) jobHandle) childNodeLists
 
   markComplete jobHandle
@@ -175,14 +182,23 @@ updateNode _nId _p jobHandle = do
   simuLogs jobHandle 10
 ------------------------------------------------------------------------
 
-updateDocs :: (HasNodeStory env err m)
-            => NodeId -> m ()
-updateDocs cId = do
+updateDocs :: ( HasNodeStory env err m
+              , MonadJobStatus m
+              , MonadLogger m )
+           => NodeId
+           -> JobHandle m
+           -> m ()
+updateDocs cId jobHandle = do
+  markStarted 4 jobHandle
   lId <- defaultList cId
   _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
+  markProgress 1 jobHandle
   _ <- updateNgramsOccurrences cId lId
+  markProgress 1 jobHandle
   _ <- updateContextScore      cId lId
+  markProgress 1 jobHandle
   _ <- Metrics.updateChart'    cId lId NgramsTypes.Docs Nothing
+  markProgress 1 jobHandle
   -- printDebug "updateContextsScore" (cId, lId, u)
   pure ()
 

src/Gargantext/API/Prelude.hs

@@ -17,13 +17,14 @@ module Gargantext.API.Prelude
   , HasServerError(..)
   , serverError ) where
 
+import Control.Exception.Safe qualified as Safe
 import Control.Lens ((#))
 import Control.Monad.Random (MonadRandom)
 import Gargantext.API.Admin.Auth.Types (AuthenticationError)
 import Gargantext.API.Errors.Class (HasAuthenticationError, _AuthenticationError)
-import Gargantext.API.Errors.Types (HasServerError(..), serverError)
+import Gargantext.API.Errors.Types (HasServerError(..), serverError, HasBackendInternalError)
 import Gargantext.Core.Notifications.CentralExchange.Types (HasCentralExchangeNotification)
-import Gargantext.Core.Config (HasConfig)
+import Gargantext.Core.Config (HasConfig, HasManager)
 import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.NodeStory (HasNodeStory, HasNodeStoryEnv)
@@ -45,6 +46,7 @@ type EnvC env =
   , HasNodeStoryEnv   env
   , HasMail           env
   , HasNLPServer      env
+  , HasManager        env
   , HasCentralExchangeNotification env
   )
 
@@ -53,6 +55,7 @@ type ErrC err =
   , HasValidationError     err
   , HasTreeError           err
   , HasServerError         err
+  , HasBackendInternalError err
   , HasAuthenticationError err
 --  , ToJSON               err -- TODO this is arguable
   , Exception              err
@@ -62,6 +65,7 @@ type GargServerC env err m =
   ( HasNodeStory env err m
   , HasMail      env
   , MonadRandom          m
+  , Safe.MonadCatch m
   , EnvC         env
   , ErrC             err
   , ToJSON           err

src/Gargantext/API/Routes/Client.hs

+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Gargantext.API.Routes.Client where
+
+import Conduit qualified as C
+import Data.Proxy
+import Data.Text.Encoding qualified as TE
+import Gargantext.API.Admin.Auth.Types qualified as Auth
+import Gargantext.API.Errors (GargErrorScheme(..))
+import Gargantext.API.Routes.Named
+import Gargantext.API.Routes.Named.Node
+import Gargantext.API.Routes.Named.Private
+import Gargantext.API.Routes.Named.Remote qualified as Named
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Prelude
+import Network.HTTP.Types qualified as H
+import Servant.API.WebSocket qualified as WS
+import Servant.Auth.Client qualified as S
+import Servant.Client.Core
+import Servant.Client.Generic (genericClient)
+import Servant.Client.Streaming
+import Servant.Conduit ()
+
+instance RunClient m => HasClient m WS.WebSocketPending where
+  type Client m WS.WebSocketPending = H.Method ->  m ()
+
+  clientWithRoute :: Proxy m -> Proxy WS.WebSocketPending -> Request -> Client m WS.WebSocketPending
+  clientWithRoute _pm Proxy _req _httpMethod = do
+    panicTrace "[WebSocket client] this is not implemented!"
+
+  hoistClientMonad _ _ f cl = \meth -> f (cl meth)
+
+-- | The client for the full API. It also serves as a \"proof\" that our
+-- whole API has all the required instances to be used in a client.
+clientRoutes :: API (AsClientT ClientM)
+clientRoutes = genericClient
+
+remoteImportClient :: Auth.Token
+                   -> C.ConduitT () Named.RemoteBinaryData IO ()
+                   -> ClientM [NodeId]
+remoteImportClient (S.Token . TE.encodeUtf8 -> token) c =
+  clientRoutes & apiWithCustomErrorScheme
+               & ($ GES_new)
+               & backendAPI
+               & backendAPI'
+               & mkBackEndAPI
+               & gargAPIVersion
+               & gargPrivateAPI
+               & mkPrivateAPI
+               & ($ token)
+               & nodeEp
+               & nodeRemoteImportAPI
+               & Named.remoteImportEp
+               & ($ c)
+
+remoteExportClient :: Auth.Token
+                   -> NodeId
+                   -> Named.RemoteExportRequest
+                   -> ClientM [NodeId]
+remoteExportClient (S.Token . TE.encodeUtf8 -> token) nodeId r =
+  clientRoutes & apiWithCustomErrorScheme
+               & ($ GES_new)
+               & backendAPI
+               & backendAPI'
+               & mkBackEndAPI
+               & gargAPIVersion
+               & gargPrivateAPI
+               & mkPrivateAPI
+               & ($ token)
+               & nodeEp
+               & nodeEndpointAPI
+               & ($ nodeId)
+               & remoteExportAPI
+               & Named.remoteExportEp
+               & ($ r)

src/Gargantext/API/Routes/Named/Corpus.hs

@@ -30,7 +30,7 @@ import Gargantext.API.Node.Types (NewWithForm, WithQuery)
 import Gargantext.API.Worker (WorkerAPI)
 import Gargantext.Core.Text.Ngrams (NgramsType(..))
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
-import Gargantext.Database.Admin.Types.Node (CorpusId, ListId)
+import Gargantext.Database.Admin.Types.Node (CorpusId, ListId, NodeId)
 import Gargantext.Prelude (Bool)
 import Servant
 
@@ -67,7 +67,7 @@ newtype MakeSubcorpusAPI mode = MakeSubcorpusAPI
                      :> Capture "corpus_id" CorpusId
                      :> "subcorpus"
                      :> ReqBody '[JSON] SubcorpusParams
-                     :> Post '[JSON] Bool -- was request successful
+                     :> Post '[JSON] NodeId -- new subcorpus ID
   } deriving Generic
 
 data SubcorpusParams = SubcorpusParams

src/Gargantext/API/Routes/Named/Node.hs

@@ -50,6 +50,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.User ( HyperdataUser )
 import Gargantext.Database.Query.Facet.Types ( FacetDoc, OrderBy(..) )
 import Prelude
 import Servant
+import Gargantext.API.Routes.Named.Remote (RemoteExportAPI)
 
 -------------------------------------------------------------------
 -- | Node API Types management
@@ -99,6 +100,7 @@ data NodeAPI a mode = NodeAPI
   , fileAsyncAPI       :: mode :- "async"     :> NamedRoutes FileAsyncAPI
   , dfwnAPI            :: mode :- "documents-from-write-nodes" :> NamedRoutes DocumentsFromWriteNodesAPI
   , documentUploadAPI  :: mode :- NamedRoutes DocumentUploadAPI
+  , remoteExportAPI    :: mode :- NamedRoutes RemoteExportAPI
   } deriving Generic
 
 

src/Gargantext/API/Routes/Named/Private.hs

@@ -26,23 +26,24 @@ module Gargantext.API.Routes.Named.Private (
 
 
 import Data.Text (Text)
-import GHC.Generics (Generic)
-import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
-import Gargantext.API.Auth.PolicyCheck (PolicyChecked)
-import Gargantext.API.Routes.Named.Contact (ContactAPI)
-import Gargantext.API.Routes.Named.Context (ContextAPI)
-import Gargantext.API.Routes.Named.Corpus (AddWithForm, AddWithQuery, CorpusExportAPI, MakeSubcorpusAPI)
-import Gargantext.API.Routes.Named.Count (CountAPI, Query)
-import Gargantext.API.Routes.Named.Document (DocumentExportAPI)
+import Gargantext.API.Admin.Auth.Types
+import Gargantext.API.Auth.PolicyCheck
+import Gargantext.API.Routes.Named.Contact
+import Gargantext.API.Routes.Named.Context
+import Gargantext.API.Routes.Named.Corpus
+import Gargantext.API.Routes.Named.Count
+import Gargantext.API.Routes.Named.Document
 import Gargantext.API.Routes.Named.List (GETAPI, JSONAPI, TSVAPI)
-import Gargantext.API.Routes.Named.Node (NodeAPI, NodesAPI, NodeNodeAPI, Roots)
-import Gargantext.API.Routes.Named.Share (ShareURL)
-import Gargantext.API.Routes.Named.Table (TableNgramsAPI)
-import Gargantext.API.Routes.Named.Tree (NodeTreeAPI, TreeFlatAPI)
-import Gargantext.API.Routes.Named.Viz (GraphAPI, PhyloExportAPI)
-import Gargantext.Database.Admin.Types.Hyperdata.Any (HyperdataAny)
-import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataAnnuaire, HyperdataCorpus)
-import Gargantext.Database.Admin.Types.Node (ContextId, CorpusId, DocId, NodeId)
+import Gargantext.API.Routes.Named.Node
+import Gargantext.API.Routes.Named.Remote
+import Gargantext.API.Routes.Named.Share
+import Gargantext.API.Routes.Named.Table
+import Gargantext.API.Routes.Named.Tree
+import Gargantext.API.Routes.Named.Viz
+import Gargantext.Database.Admin.Types.Hyperdata.Any
+import Gargantext.Database.Admin.Types.Hyperdata.Corpus
+import Gargantext.Database.Admin.Types.Node
+import GHC.Generics
 import Servant.API
 import Servant.Auth qualified as SA
 
@@ -120,6 +121,7 @@ data NodeAPIEndpoint mode = NodeAPIEndpoint
                             :> Summary "Node endpoint"
                             :> Capture "node_id" NodeId
                             :> NamedRoutes (NodeAPI HyperdataAny)
+  , nodeRemoteImportAPI :: mode :- "node" :> "remote" :> NamedRoutes RemoteImportAPI
   } deriving Generic
 
 newtype AnnuaireAPIEndpoint mode = AnnuaireAPIEndpoint

src/Gargantext/API/Routes/Named/Remote.hs

+
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DerivingStrategies #-}
+module Gargantext.API.Routes.Named.Remote (
+  -- * Routes types
+    RemoteExportAPI(..)
+  , RemoteImportAPI(..)
+  , RemoteExportRequest(..)
+  , RemoteBinaryData(..)
+  ) where
+
+import Conduit qualified as C
+import Data.Aeson as JSON
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString qualified as BS
+import Data.Proxy
+import Data.Swagger hiding (Http)
+import Gargantext.API.Admin.Auth.Types (Token)
+import Gargantext.API.Auth.PolicyCheck (PolicyChecked)
+import Gargantext.Database.Admin.Types.Node ( NodeId (..) )
+import GHC.Generics
+import Prelude
+import Servant.API
+import Servant.Client.Core.BaseUrl
+import Test.QuickCheck
+
+
+data RemoteExportAPI mode = RemoteExportAPI
+  { remoteExportEp :: mode :- "remote" :> ReqBody '[JSON] RemoteExportRequest :> PolicyChecked (Post '[JSON] [NodeId])
+  } deriving Generic
+
+data RemoteImportAPI mode = RemoteImportAPI
+  { remoteImportEp :: mode :- "import" :> StreamBody NoFraming OctetStream (C.ConduitT () RemoteBinaryData IO ())
+                                       :> Post '[JSON] [NodeId]
+  } deriving Generic
+
+data RemoteExportRequest =
+  RemoteExportRequest
+  { -- | The URL of the instance we want to copy data to.
+    _rer_instance_url  :: BaseUrl
+    -- | The JWT token to use for authentication purposes.
+  , _rer_instance_auth :: Token
+  } deriving (Show, Eq, Generic)
+
+instance Arbitrary RemoteExportRequest where
+  arbitrary = RemoteExportRequest <$> (pure (BaseUrl Http "dev.sub.gargantext.org" 8008 "")) <*> arbitrary
+
+instance ToJSON RemoteExportRequest where
+  toJSON RemoteExportRequest{..}
+    = JSON.object [ "instance_url"  .= toJSON _rer_instance_url
+                  , "instance_auth" .= toJSON _rer_instance_auth
+                  ]
+
+instance FromJSON RemoteExportRequest where
+  parseJSON = withObject "RemoteExportRequest" $ \o -> do
+    _rer_instance_url  <- maybe (fail "RemoteExportRequest invalid URL") pure =<< (parseBaseUrl <$> o .: "instance_url")
+    _rer_instance_auth <- o .: "instance_auth"
+    pure RemoteExportRequest{..}
+
+instance ToSchema RemoteExportRequest where
+  declareNamedSchema _ =
+    let exampleSchema = RemoteExportRequest (BaseUrl Http "dev.sub.gargantext.org" 8008 "") ("abcdef")
+    in pure $ NamedSchema (Just "RemoteExportRequest") $ sketchStrictSchema exampleSchema
+
+newtype RemoteBinaryData = RemoteBinaryData { getRemoteBinaryData :: BS.ByteString }
+  deriving (Show, Eq, Ord)
+
+instance Accept RemoteBinaryData where
+  contentType _ = contentType (Proxy :: Proxy OctetStream)
+
+instance MimeRender OctetStream RemoteBinaryData where
+    mimeRender _ (RemoteBinaryData bs) = BL.fromStrict bs
+
+instance MimeUnrender OctetStream RemoteBinaryData where
+    mimeUnrender _ bs = Right (RemoteBinaryData $ BS.toStrict bs)
+
+instance ToSchema RemoteBinaryData where
+  declareNamedSchema _ = pure $ NamedSchema (Just "RemoteExportRequest") binarySchema

src/Gargantext/API/Routes/Named/Share.hs

@@ -13,14 +13,14 @@ module Gargantext.API.Routes.Named.Share (
   , ShareNodeParams(..)
   ) where
 
-import Data.Aeson (FromJSON(..), ToJSON(..), withText)
+import Data.Aeson (withText)
 import Data.Swagger (ToSchema, declareNamedSchema)
 import Data.Text qualified as T
-import GHC.Generics (Generic)
 import Gargantext.API.Node.Share.Types ( ShareNodeParams (..) )
-import Gargantext.Database.Admin.Types.Node (NodeId, NodeType)
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Prelude
 import Network.URI (parseURI)
-import Prelude
+import Prelude (fail)
 import Servant
 
 -- | A shareable link.
@@ -31,6 +31,8 @@ import Servant
 newtype ShareLink = ShareLink { getShareLink :: URI }
   deriving (Show, Eq, Ord, Generic)
 
+instance NFData ShareLink where
+
 renderShareLink :: ShareLink -> T.Text
 renderShareLink = T.pack . show . getShareLink
 

src/Gargantext/API/Server/Named/Ngrams.hs

@@ -9,8 +9,8 @@ module Gargantext.API.Server.Named.Ngrams (
 import Control.Lens ((%%~))
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
-import Gargantext.API.Admin.Auth (withNamedAccess)
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser, PathId (..))
+import Gargantext.API.Admin.Auth (withNamedAccess)
 import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Metrics qualified as Metrics
@@ -25,11 +25,12 @@ import Gargantext.Core.Types.Query (Limit(..), Offset(..))
 import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
 import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Query.Table.Ngrams ( selectNgramsByDoc )
-import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.Node.Select ( selectNodesWithUsername )
 import Gargantext.Database.Schema.Node (node_id, node_parent_id, node_user_id)
 import Gargantext.Prelude
+import Gargantext.System.Logging
 import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..), markFailedNoErr)
 import Servant.Server.Generic (AsServerT)
 
@@ -150,7 +151,7 @@ tableNgramsPostChartsAsync utn jobHandle = do
   -}
 
 scoresRecomputeTableNgrams :: forall env err m.
-                              ( HasNodeStory env err m, HasNodeError err )
+                              ( HasNodeStory env err m, HasNodeError err, MonadLogger m )
                            => NodeId -> TabType -> ListId -> m Int
 scoresRecomputeTableNgrams nId tabType listId = do
   tableMap <- getNgramsTableMap listId ngramsType
@@ -163,7 +164,9 @@ scoresRecomputeTableNgrams nId tabType listId = do
 
 -- | Text search is deactivated for now for ngrams by doc only
 getTableNgramsDoc :: ( HasNodeStory env err m
-                     , HasNodeError err )
+                     , HasNodeError err
+                     , MonadLogger m
+                     )
                   => DocId -> TabType
                   -> ListId -> Limit -> Maybe Offset
                   -> Maybe ListType

src/Gargantext/API/Server/Named/Private.hs

@@ -10,17 +10,17 @@ import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Members (members)
 import Gargantext.API.Ngrams.List qualified as List
 import Gargantext.API.Node (annuaireNodeAPI, corpusNodeAPI, nodeAPI, nodeNodeAPI, nodesAPI, roots)
-import Gargantext.API.Node qualified as Tree
 import Gargantext.API.Node.Contact as Contact
 import Gargantext.API.Node.Corpus.Export qualified as CorpusExport
 import Gargantext.API.Node.Corpus.Subcorpus qualified as Subcorpus
 import Gargantext.API.Node.Document.Export (documentExportAPI)
 import Gargantext.API.Node.Phylo.Export qualified as PhyloExport
+import Gargantext.API.Node qualified as Tree
 import Gargantext.API.Node.ShareURL ( shareURL )
 import Gargantext.API.Prelude (GargM)
 import Gargantext.API.Routes (addCorpusWithForm, addCorpusWithQuery)
 import Gargantext.API.Routes.Named.Private qualified as Named
-import Gargantext.API.Server.Named.Ngrams (apiNgramsTableDoc)
+import Gargantext.API.Server.Named.Ngrams
 import Gargantext.API.Server.Named.Viz qualified as Viz
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny)
@@ -61,7 +61,7 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
        , membersAPI        = members
        , addWithFormAPI    = addCorpusWithForm (RootId userNodeId)
        , addWithQueryEp    = addCorpusWithQuery (RootId userNodeId)
-       , makeSubcorpusAPI      = Subcorpus.makeSubcorpus userId
+       , makeSubcorpusAPI  = Subcorpus.makeSubcorpus userId
        , listGetAPI        = List.getAPI
        , listJsonAPI       = List.jsonAPI
        , listTsvAPI        = List.tsvAPI

src/Gargantext/API/ThrowAll.hs

@@ -30,6 +30,7 @@ import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Prelude (GargM, _ServerError)
 import Gargantext.API.Routes.Named.Private qualified as Named
+import Gargantext.API.Routes.Named.Remote () -- instance MimeUnrenderer
 import Gargantext.API.Server.Named.Private qualified as Named
 import Gargantext.Database.Admin.Types.Node (UserId (..))
 import Gargantext.Prelude hiding (Handler)
@@ -37,6 +38,7 @@ import Network.HTTP.Types.Status (Status(..))
 import Network.Wai (responseLBS)
 import Servant
 import Servant.Auth.Server (AuthResult(..))
+import Servant.Conduit ()
 import Servant.Server.Generic (AsServerT)
 
 -- | Slightly more general version of the 'ThrowAll' typeclass from Servant,

src/Gargantext/API/Worker.hs

@@ -36,7 +36,7 @@ serveWorkerAPI f = WorkerAPI { workerAPIPost }
   where
     workerAPIPost i = do
       let job = f i
-      logM DDEBUG $ "[serveWorkerAPI] sending job " <> show job
+      logM DEBUG $ "[serveWorkerAPI] sending job " <> show job
       mId <- sendJob job
       pure $ JobInfo { _ji_message_id = mId
                      , _ji_mNode_id = getWorkerMNodeId job }
@@ -54,4 +54,4 @@ serveWorkerAPIEJob f = WorkerAPI { workerAPIPost }
           mId <- sendJob job
           pure $ JobInfo { _ji_message_id = mId
                          , _ji_mNode_id = getWorkerMNodeId job }
-    
+

src/Gargantext/Core.hs

@@ -57,6 +57,8 @@ data Lang = DE
           | ZH
   deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, GQLType)
 
+instance NFData Lang where
+
 -- | Defaults to 'EN' in all those places where a language is mandatory,
 -- but an optional one has been passed.
 withDefaultLanguage :: Maybe Lang -> Lang

src/Gargantext/Core/Config.hs

@@ -12,10 +12,12 @@ Configuration for the gargantext server
 -}
 
 {-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE LambdaCase          #-}
 
 module Gargantext.Core.Config (
     -- * Types
     GargConfig(..)
+  , LogConfig(..)
 
     -- * Lenses
   , gc_datafilepath
@@ -29,32 +31,55 @@ module Gargantext.Core.Config (
   , gc_secrets
   , gc_apis
   , gc_worker
-  , gc_log_level
+  , gc_logging
+  , lc_log_level
+  , lc_log_file
 
   , mkProxyUrl
 
   , HasJWTSettings(..)
   , HasConfig(..)
+  , HasManager(..)
   ) where
 
 import Control.Lens (Getter)
-import Control.Monad.Logger (LogLevel(LevelDebug))
-import Data.Text as T
+import Gargantext.System.Logging.Types (LogLevel, parseLogLevel)
 import Database.PostgreSQL.Simple qualified as PSQL
+import Data.Text as T
 import Gargantext.Core.Config.Mail (MailConfig)
 import Gargantext.Core.Config.NLP (NLPConfig)
-import Gargantext.Core.Config.Worker (WorkerSettings)
 import Gargantext.Core.Config.Types
+import Gargantext.Core.Config.Worker (WorkerSettings)
 import Gargantext.Prelude
+import Network.HTTP.Client qualified as HTTP
 import Servant.Auth.Server (JWTSettings)
 import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl)
 import Toml.Schema
+import Toml.Schema.FromValue (typeError)
 
 
 -- | strip a given character from end of string
 -- stripRight :: Char -> T.Text -> T.Text
 -- stripRight c s = if T.last s == c then stripRight c (T.take (T.length s - 1) s) else s
 
+data LogConfig = LogConfig
+  { _lc_log_file  :: Maybe FilePath
+  , _lc_log_level :: !LogLevel
+  } deriving Show
+
+instance FromValue LogConfig where
+  fromValue = parseTableFromValue $ do
+    _lc_log_file  <- optKey "log_file"
+    _lc_log_level <- reqKeyOf "log_level" parse_log_level
+    pure LogConfig{..}
+
+parse_log_level :: Value' l -> Matcher l LogLevel
+parse_log_level = \case
+  Text' a txt -> case parseLogLevel txt of
+    Left err  -> typeError (T.unpack err) (Text' a txt)
+    Right ll  -> pure ll
+  xs          -> typeError "parse_log_level" xs
+
 -- Non-strict data so that we can use it in tests
 data GargConfig = GargConfig { _gc_datafilepath         :: ~FilePath
                              -- , _gc_repofilepath      :: ~FilePath
@@ -68,12 +93,10 @@ data GargConfig = GargConfig { _gc_datafilepath         :: ~FilePath
                              , _gc_secrets              :: ~SecretsConfig
                              , _gc_apis                 :: ~APIsConfig
                              , _gc_worker               :: ~WorkerSettings
-                             , _gc_log_level            :: ~LogLevel
+                             , _gc_logging              :: ~LogConfig
                              }
   deriving (Generic, Show)
 
-makeLenses ''GargConfig
-
 instance FromValue GargConfig where
   fromValue = parseTableFromValue $ do
     _gc_frontend_config <- reqKey "frontend"
@@ -87,7 +110,7 @@ instance FromValue GargConfig where
     _gc_apis <- reqKey "apis"
     _gc_notifications_config <- reqKey "notifications"
     _gc_worker <- reqKey "worker"
-    let _gc_log_level = LevelDebug
+    _gc_logging <- reqKey "logs"
     return $ GargConfig { _gc_datafilepath
                         , _gc_jobs
                         , _gc_apis
@@ -99,7 +122,7 @@ instance FromValue GargConfig where
                         , _gc_frames
                         , _gc_secrets
                         , _gc_worker
-                        , _gc_log_level }
+                        , _gc_logging }
 instance ToValue GargConfig where
   toValue = defaultTableToValue
 instance ToTable GargConfig where
@@ -134,3 +157,14 @@ instance HasConfig GargConfig where
 
 class HasJWTSettings env where
   jwtSettings :: Getter env JWTSettings
+
+class HasManager env where
+  gargHttpManager :: Getter env HTTP.Manager
+
+--
+-- Lenses
+--
+
+makeLenses ''LogConfig
+makeLenses ''GargConfig
+

src/Gargantext/Core/LinearAlgebra.hs

+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-|
+Module      : Gargantext.Core.LinearAlgebra
+Description : Linear Algebra utility functions
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Linear algebra utility functions to be used across all the Gargantext modules requiring it.
+-}
+
+module Gargantext.Core.LinearAlgebra (
+  -- * Handy re-exports
+    module Gargantext.Core.LinearAlgebra.Operations
+  , module Gargantext.Core.LinearAlgebra.Distributional
+  ) where
+
+import Gargantext.Core.LinearAlgebra.Operations
+import Gargantext.Core.LinearAlgebra.Distributional

src/Gargantext/Core/LinearAlgebra/Distributional.hs

+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-|
+Module      : Gargantext.Core.LinearAlgebra.Distributional
+Description : The "distributional" algorithm, fast and slow implementations
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+module Gargantext.Core.LinearAlgebra.Distributional (
+    distributional
+  , logDistributional2
+
+  -- * Internals for testing
+  , distributionalReferenceImplementation
+  ) where
+
+import Data.Massiv.Array (D, Matrix, Vector, Array, Ix3, U, Ix2 (..), IxN (..))
+import Data.Massiv.Array qualified as A
+import Gargantext.Core.LinearAlgebra.Operations
+import Prelude
+
+-- | `distributional m` returns the distributional distance between each
+-- pair of terms as a matrix.  The argument m is the matrix $[n_{ij}]_{i,j}$
+-- where $n_{ij}$ is the coocccurrence between term $i$ and term $j$.
+--
+-- ## Basic example with Matrix of size 3: 
+--
+-- >>> theMatrixInt 3
+-- Matrix (Z :. 3 :. 3)
+--   [ 7, 4, 0,
+--     4, 5, 3,
+--     0, 3, 4]
+--
+-- >>> distributional $ theMatrixInt 3
+-- Matrix (Z :. 3 :. 3)
+--   [ 1.0, 0.0, 0.9843749999999999,
+--     0.0, 1.0,                0.0,
+--     1.0, 0.0,                1.0]
+--
+-- ## Basic example with Matrix of size 4: 
+--
+-- >>> theMatrixInt 4
+-- Matrix (Z :. 4 :. 4)
+--   [ 4, 1, 2, 1,
+--     1, 4, 0, 0,
+--     2, 0, 3, 3,
+--     1, 0, 3, 3]
+--
+-- >>> distributional $ theMatrixInt 4
+-- Matrix (Z :. 4 :. 4)
+--   [                  1.0,                   0.0, 0.5714285714285715, 0.8421052631578947,
+--                      0.0,                   1.0,                1.0,                1.0,
+--     8.333333333333333e-2,             4.6875e-2,                1.0,               0.25,
+--       0.3333333333333333, 5.7692307692307696e-2,                1.0,                1.0]
+--
+-- /IMPORTANT/: As this function computes the diagonal matrix in order to carry on the computation
+-- the input has to be a square matrix, or this function will fail at runtime.
+distributional :: forall r e. ( A.Manifest r e
+                              , A.Manifest r Int
+                              , A.Unbox e
+                              , A.Source r Int
+                              , A.Size r
+                              , Ord e
+                              , Fractional e
+                              , Num e
+                              )
+                              => Matrix r Int
+                              -> Matrix U e
+distributional m' = A.computeP result
+ where
+    mD :: Matrix D e
+    mD = A.map fromIntegral m'
+
+    m :: Matrix A.U e
+    m = A.compute mD
+
+    n :: Int
+    n = dim m'
+
+    diag_m :: Vector A.U e
+    diag_m = diag m
+
+    d_1 :: Matrix A.D e
+    d_1 = A.backpermute' (A.Sz2 n n) (\(_ A.:. i) -> i) diag_m
+
+    d_2 :: Matrix A.D e
+    d_2 = A.backpermute' (A.Sz2 n n) (\(i A.:. _) -> i) diag_m
+
+    a :: Matrix D e
+    a = termDivNanD mD d_1
+
+    b :: Matrix D e
+    b = termDivNanD mD d_2
+
+    miDelayed :: Matrix D e
+    miDelayed = a `mulD` b
+
+    miMemo :: Matrix D e
+    miMemo = A.delay (A.compute @U miDelayed)
+
+    w_1 :: Array D Ix3 e
+    w_1 = A.backpermute' (A.Sz3 n n n) (\(x A.:> _y A.:. z) -> x A.:. z) miMemo
+
+    w_2 :: Array D Ix3 e
+    w_2 = A.backpermute' (A.Sz3 n n n) (\(_x A.:> y A.:. z) -> y A.:. z) miMemo
+
+    w' :: Array D Ix3 e
+    w' = A.zipWith min w_1 w_2
+
+    z_1 :: Matrix A.D e
+    z_1 = A.ifoldlWithin' 1 ( \(i :> j :. k) acc w'_val ->
+      let ii_val = if k /= i && k /= j then 1 else 0
+          z1_val = w'_val * ii_val
+      in acc + z1_val
+      ) 0 w'
+
+    z_2 :: Matrix A.D e
+    z_2 = A.ifoldlWithin' 1 ( \(i :> j :. k) acc w1_val ->
+      let ii_val = if k /= i && k /= j then 1 else 0
+          z2_val = w1_val * ii_val
+      in acc + z2_val
+      ) 0 w_1
+
+    result :: Matrix A.D e
+    result = termDivNanD z_1 z_2
+
+-- | A reference implementation for \"distributional\" which is slower but
+-- it's more declarative and can be used to assess the correctness of the
+-- optimised version.
+-- Same proviso about the shape of the matri applies for this function.
+distributionalReferenceImplementation :: forall r e.
+                                      ( A.Manifest r e
+                                      , A.Unbox e
+                                      , A.Source r Int
+                                      , A.Size r
+                                      , Ord e
+                                      , Fractional e
+                                      , Num e
+                                      )
+                                      => Matrix r Int
+                                      -> Matrix r e
+distributionalReferenceImplementation m' = result
+ where
+    mD :: Matrix D e
+    mD = A.map fromIntegral m'
+
+    m :: Matrix A.U e
+    m = A.compute mD
+
+    n :: Int
+    n = dim m'
+
+    -- Computes the diagonal matrix of the input ..
+    diag_m :: Vector A.U e
+    diag_m = diag m
+
+    -- Then we create a matrix that contains the same elements of diag_m
+    -- for the rows and columns, to make it square again.
+    d_1 :: Matrix A.D e
+    d_1 = A.backpermute' (A.Sz2 n n) (\(_ A.:. i) -> i) diag_m
+
+    d_2 :: Matrix A.D e
+    d_2 = A.backpermute' (A.Sz2 n n) (\(i A.:. _) -> i) diag_m
+
+    a :: Matrix D e
+    a = termDivNanD mD d_1
+
+    b :: Matrix D e
+    b = termDivNanD mD d_2
+
+    miDelayed :: Matrix D e
+    miDelayed = a `mulD` b
+
+    miMemo :: Matrix D e
+    miMemo = A.delay (A.compute @U miDelayed)
+
+    -- The matrix permutations is taken care of below by directly replicating
+    -- the matrix mi, making the matrix w unneccessary and saving one step.
+    -- replicate (constant (Z :. All :. n :. All)) mi
+    w_1 :: Array D Ix3 e
+    w_1 = A.backpermute' (A.Sz3 n n n) (\(x A.:> _y A.:. z) -> x A.:. z) miMemo
+
+    -- replicate (constant (Z :. n :. All :. All)) mi
+    w_2 :: Array D Ix3 e
+    w_2 = A.backpermute' (A.Sz3 n n n) (\(_x A.:> y A.:. z) -> y A.:. z) miMemo
+
+    w' :: Array D Ix3 e
+    w' = A.zipWith min w_1 w_2
+
+    -- The matrix ii = [r_{i,j,k}]_{i,j,k} has r_(i,j,k) = 0 if k = i OR k = j
+    -- and r_(i,j,k) = 1 otherwise (i.e. k /= i AND k /= j).
+    -- generate (constant (Z :. n :. n :. n)) (lift1 (\( i A.:. j A.:. k) -> cond ((&&) ((/=) k i) ((/=) k j)) 1 0))
+    ii :: Array A.D Ix3 e
+    ii = A.makeArrayR A.D A.Seq (A.Sz3 n n n) $ \(i A.:> j A.:. k) -> if k /= i && k /= j then 1 else 0
+
+    z_1 :: Matrix A.D e
+    z_1 = sumRowsD (w' `mulD` ii)
+
+    z_2 :: Matrix A.D e
+    z_2 = sumRowsD (w_1 `mulD` ii)
+
+    result = A.computeP (termDivNanD z_1 z_2)
+
+
+logDistributional2 :: (A.Manifest r e
+                      , A.Unbox e
+                      , A.Source r Int
+                      , A.Shape r Ix2
+                      , Num e
+                      , Ord e
+                      , A.Source r e
+                      , Fractional e
+                      , Floating e
+                      )
+                   => Matrix r Int
+                   -> Matrix r e
+logDistributional2 m = A.computeP
+                     $ diagNull n
+                     $ matMaxMini
+                     $ logDistributional' n m
+  where
+    n = dim m
+
+logDistributional' :: forall r e.
+                   ( A.Manifest r e
+                   , A.Unbox e
+                   , A.Source r Int
+                   , A.Shape r Ix2
+                   , Num e
+                   , Ord e
+                   , A.Source r e
+                   , Fractional e
+                   , Floating e
+                   )
+                   => Int
+                   -> Matrix r Int
+                   -> Matrix r e
+logDistributional' n m' = result
+ where
+    m :: Matrix A.U e
+    m = A.compute $ A.map fromIntegral m'
+
+    -- Scalar. Sum of all elements of m.
+    to :: e
+    to = A.sum m
+
+    -- Diagonal matrix with the diagonal of m.
+    d_m :: Matrix A.D e
+    d_m = m `mulD` (matrixIdentity n)
+
+    -- Size n vector. s = [s_i]_i
+    s :: Vector A.U e
+    s = A.compute $ sumRowsD (m `subD` d_m)
+
+    -- Matrix nxn. Vector s replicated as rows.
+    s_1 :: Matrix D e
+    s_1 = A.backpermute' (A.Sz2 n n) (\(x :. _y) -> x) s
+
+    -- Matrix nxn. Vector s replicated as columns.
+    s_2 :: Matrix D e
+    s_2 = A.backpermute' (A.Sz2 n n) (\(_x :. y) -> y) s
+
+    -- Matrix nxn. ss = [s_i * s_j]_{i,j}. Outer product of s with itself.
+    ss :: Matrix A.D e
+    ss = s_1 `mulD` s_2
+
+    mi_divvy :: Matrix A.D e
+    mi_divvy = A.zipWith (\m_val ss_val ->
+      let x  = m_val `safeDiv` ss_val
+          x' = x * to
+      in if (x' < 1) then 0 else log x') m ss
+
+    -- Matrix nxn. mi = [m_{i,j}]_{i,j} where
+    -- m_{i,j} = 0 if n_{i,j} = 0 or i = j,
+    -- m_{i,j} = log(to * n_{i,j} / s_{i,j}) otherwise.
+    mi :: Matrix A.U e
+    mi = A.computeP $ mulD (matrixEye n) (mi_divvy)
+
+    sumMin :: Matrix A.U e
+    sumMin = sumMin_go n mi
+
+    sumM :: Matrix A.U e
+    sumM = sumM_go n mi
+
+    result :: Matrix r e
+    result = termDivNan sumMin sumM

src/Gargantext/Core/LinearAlgebra/Operations.hs

+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-|
+Module      : Gargantext.Core.LinearAlgebra.Operations
+Description : Operations on matrixes using massiv
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+module Gargantext.Core.LinearAlgebra.Operations (
+  -- * Convertion functions
+    accelerate2MassivMatrix
+  , accelerate2Massiv3DMatrix
+  , massiv2AccelerateMatrix
+  , massiv2AccelerateVector
+
+  -- * Operations on matrixes
+  , (.*)
+  , (.-)
+  , diag
+  , termDivNan
+  , sumRows
+  , dim
+  , matrixEye
+  , matrixIdentity
+  , diagNull
+
+  -- * Operations on delayed arrays
+  , diagD
+  , subD
+  , mulD
+  , termDivNanD
+  , sumRowsD
+  , safeDiv
+
+  -- * Internals for testing
+  , sumRowsReferenceImplementation
+  , matMaxMini
+  , sumM_go
+  , sumMin_go
+  ) where
+
+import Data.Array.Accelerate qualified as Acc
+import Data.List.Split qualified as Split
+import Data.Massiv.Array (D, Matrix, Vector, Array)
+import Data.Massiv.Array qualified as A
+import Prelude
+import Protolude.Safe (headMay)
+import Data.Monoid
+
+-- | Converts an accelerate matrix into a Massiv matrix.
+accelerate2MassivMatrix :: (A.Unbox a, Acc.Elt a) => Acc.Matrix a -> Matrix A.U a
+accelerate2MassivMatrix m =
+  let (Acc.Z Acc.:. _r Acc.:. c) = Acc.arrayShape m
+  in A.fromLists' @A.U A.Par $ Split.chunksOf c (Acc.toList m)
+
+-- | Converts a massiv matrix into an accelerate matrix.
+massiv2AccelerateMatrix :: (Acc.Elt a, A.Source r a) => Matrix r a -> Acc.Matrix a
+massiv2AccelerateMatrix m =
+  let m' = A.toLists2 m
+      r  = Prelude.length m'
+      c  = maybe 0 Prelude.length (headMay m')
+  in Acc.fromList (Acc.Z Acc.:. r Acc.:. c) (mconcat m')
+
+-- | Converts a massiv vector into an accelerate one.
+massiv2AccelerateVector :: (A.Source r a, Acc.Elt a) => A.Vector r a -> Acc.Vector a
+massiv2AccelerateVector m =
+  let m' = A.toList m
+      r  = Prelude.length m'
+  in Acc.fromList (Acc.Z Acc.:. r) m'
+
+accelerate2Massiv3DMatrix :: (A.Unbox e, Acc.Elt e, A.Manifest r e)
+                          => Acc.Array (Acc.Z Acc.:. Int Acc.:. Int Acc.:. Int) e
+                          -> A.Array r A.Ix3 e
+accelerate2Massiv3DMatrix m =
+  let (Acc.Z Acc.:. _r Acc.:. _c Acc.:. _z) = Acc.arrayShape m
+  in A.fromLists' A.Par $ map (Split.chunksOf $ _z) $ Split.chunksOf (_c*_z) (Acc.toList m)
+
+
+
+-- | Computes the diagnonal matrix of the input one.
+diag :: (A.Unbox e, A.Manifest r e, A.Source r e, Num e) => Matrix r e -> Vector A.U e
+diag matrix =
+  let (A.Sz2 rows _cols) = A.size matrix
+      newSize = A.Sz1 rows
+  in A.makeArrayR A.U A.Seq newSize $ (\(A.Ix1 i) -> matrix A.! (A.Ix2 i i))
+
+diagD :: (A.Source r e, A.Size r) => Matrix r e -> Vector A.D e
+diagD matrix =
+  let (A.Sz2 rows _cols) = A.size matrix
+      newSize = A.Sz1 rows
+  in A.backpermute' newSize (\i -> i A.:. i) matrix
+
+-- | Term by term division where divisions by 0 produce 0 rather than NaN.
+termDivNan :: (A.Manifest r3 a, A.Source r1 a, A.Source r2 a, Eq a, Fractional a)
+           => Matrix r1 a
+           -> Matrix r2 a
+           -> Matrix r3 a
+termDivNan m1 = A.compute . termDivNanD m1
+
+termDivNanD :: (A.Source r1 a, A.Source r2 a, Eq a, Fractional a)
+            => Matrix r1 a
+            -> Matrix r2 a
+            -> Matrix D a
+termDivNanD m1 m2 = A.zipWith safeDiv m1 m2
+
+safeDiv :: (Eq a, Fractional a) => a -> a -> a
+safeDiv i j = if j == 0 then 0 else i / j
+{-# INLINE safeDiv #-}
+
+sumRows :: ( A.Index (A.Lower ix)
+           , A.Index ix
+           , A.Source r e
+           , A.Manifest r e
+           , A.Strategy r
+           , A.Size r
+           , Num e
+           ) => Array r ix e
+             -> Array r (A.Lower ix) e
+sumRows = A.compute . sumRowsD
+
+sumRowsD :: ( A.Index (A.Lower ix)
+            , A.Index ix
+            , A.Source r e
+            , Num e
+            ) => Array r ix e
+              -> Array D (A.Lower ix) e
+sumRowsD matrix = A.map getSum $ A.foldlWithin' 1 (\(Sum s) n -> Sum $ s + n) mempty matrix
+
+sumRowsReferenceImplementation :: ( A.Load r A.Ix2 e
+                                  , A.Source r e
+                                  , A.Manifest r e
+                                  , A.Strategy r
+                                  , A.Size r
+                                  , Num e
+                                  ) => Array r A.Ix3 e
+                                    -> Array r A.Ix2 e
+sumRowsReferenceImplementation matrix =
+  let A.Sz3 rows cols z = A.size matrix
+  in A.makeArray (A.getComp matrix) (A.Sz2 rows cols) $ \(i A.:. j) ->
+       A.sum (A.backpermute' (A.Sz1 z) (\c -> i A.:> j A.:. c) matrix)
+
+-- | Matrix cell by cell multiplication
+(.*) :: (A.Manifest r3 a, A.Source r1 a, A.Source r2 a, A.Index ix, Num a)
+     => Array r1 ix a
+     -> Array r2 ix a
+     -> Array r3 ix a
+(.*) m1 = A.compute . mulD m1
+
+mulD :: (A.Source r1 a, A.Source r2 a, A.Index ix, Num a)
+     => Array r1 ix a
+     -> Array r2 ix a
+     -> Array D ix a
+mulD m1 m2 = A.zipWith (*) m1 m2
+
+-- | Matrix cell by cell substraction
+(.-) :: (A.Manifest r3 a, A.Source r1 a, A.Source r2 a, A.Index ix, Num a)
+     => Array r1 ix a
+     -> Array r2 ix a
+     -> Array r3 ix a
+(.-) m1 = A.compute . subD m1
+
+subD :: (A.Source r1 a, A.Source r2 a, A.Index ix, Num a)
+     => Array r1 ix a
+     -> Array r2 ix a
+     -> Array D ix a
+subD m1 m2 = A.zipWith (-) m1 m2
+
+
+-- | Get the dimensions of a /square/ matrix.
+dim :: A.Size r => Matrix r a -> Int
+dim m = n
+  where
+    (A.Sz2 _ n) = A.size m
+
+matMaxMini :: (A.Unbox a, A.Source r a, Ord a, Num a, A.Shape r A.Ix2) => Matrix r a -> Matrix A.U a
+matMaxMini m = A.compute $ A.map (\x -> if x > miniMax then x else 0) m
+  where
+    -- Convert the matrix to a list of rows, take the minimum of each row,
+    -- and then the maximum of those minima.
+    miniMax = maximum (map minimum (A.toLists m))
+
+sumM_go :: (A.Unbox a, A.Manifest r a, Num a, A.Load r A.Ix2 a) => Int -> Matrix r a -> Matrix A.U a
+sumM_go n mi = A.makeArrayR A.U A.Seq (A.Sz2 n n) $ \(i A.:. j) ->
+  Prelude.sum [ if k /= i && k /= j then mi A.! (i A.:. k) else 0 | k <- [0 .. n - 1] ]
+
+sumMin_go :: (A.Unbox a, A.Manifest r a, Num a, Ord a, A.Load r A.Ix2 a) => Int -> Matrix r a -> Matrix A.U a
+sumMin_go n mi = A.makeArrayR A.U A.Seq (A.Sz2 n n) $ \(i A.:. j) ->
+  Prelude.sum
+    [ if k /= i && k /= j
+        then min (mi A.! (i A.:. k)) (mi A.! (j A.:. k))
+        else 0
+    | k <- [0 .. n - 1]
+    ]
+
+matrixEye :: (A.Unbox e, Num e) => Int -> Matrix A.U e
+matrixEye n = A.makeArrayR A.U A.Seq (A.Sz2 n n) $ \(i A.:. j) -> if i == j then 0 else 1
+{-# INLINE matrixEye #-}
+{-# SPECIALIZE matrixEye :: Int -> Matrix A.U Double #-}
+
+matrixIdentity :: (A.Unbox e, Num e) => Int -> Matrix A.U e
+matrixIdentity n = A.makeArrayR A.U A.Seq (A.Sz2 n n) $ \(i A.:. j) -> if i == j then 1 else 0
+{-# INLINE matrixIdentity #-}
+{-# SPECIALIZE matrixIdentity :: Int -> Matrix A.U Double #-}
+
+diagNull :: (A.Unbox e, A.Source r e, Num e) => Int -> Matrix r e -> Matrix A.U e
+diagNull n m = A.compute $ A.zipWith (*) m (matrixEye n)

src/Gargantext/Core/Methods/Matrix/Accelerate/Utils.hs

@@ -38,8 +38,6 @@ import Data.Array.Accelerate
 import Data.Array.Accelerate.Interpreter (run)
 import qualified Gargantext.Prelude as P
 
-import Debug.Trace (trace)
-
 -- | Matrix cell by cell multiplication
 (.*) :: ( Shape ix
         , Slice ix
@@ -55,26 +53,28 @@ import Debug.Trace (trace)
 (./) :: ( Shape ix
         , Slice ix
         , Elt a
+        , Eq a
         , P.Num (Exp a)
         , P.Fractional (Exp a)
         )
      => Acc (Array ((ix :. Int) :. Int) a)
      -> Acc (Array ((ix :. Int) :. Int) a)
      -> Acc (Array ((ix :. Int) :. Int) a)
-(./) = zipWith (/)
+(./) = zipWith safeDivCond
 
 -- | Term by term division where divisions by 0 produce 0 rather than NaN. 
-termDivNan :: ( Shape ix
-        , Slice ix
-        , Elt a
-        , Eq a
-        , P.Num (Exp a)
-        , P.Fractional (Exp a)
-        )
-     => Acc (Array ((ix :. Int) :. Int) a)
-     -> Acc (Array ((ix :. Int) :. Int) a)
-     -> Acc (Array ((ix :. Int) :. Int) a)
-termDivNan = trace "termDivNan" $ zipWith (\i j -> cond ((==) j 0) 0 ((/) i j))
+termDivNan :: ( Elt a
+              , Eq a
+              , P.Num (Exp a)
+              , P.Fractional (Exp a)
+              )
+           => Acc (Matrix a)
+           -> Acc (Matrix a)
+           -> Acc (Matrix a)
+termDivNan = zipWith safeDivCond
+
+safeDivCond :: (Eq a, P.Num (Exp a), P.Fractional (Exp a)) => Exp a -> Exp a -> Exp a
+safeDivCond i j = cond ((==) j 0) 0 ((/) i j)
 
 (.-) :: ( Shape ix
         , Slice ix

src/Gargantext/Core/Methods/Similarities.hs

@@ -20,10 +20,11 @@ import Data.Swagger
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Gargantext.Core.Methods.Similarities.Accelerate.Conditional (measureConditional')
-import Gargantext.Core.Methods.Similarities.Accelerate.Distributional (logDistributional2)
+import Gargantext.Core.LinearAlgebra.Operations (accelerate2MassivMatrix, massiv2AccelerateMatrix)
+import Gargantext.Core.LinearAlgebra.Distributional (logDistributional2)
 -- import Gargantext.Core.Text.Metrics.Count (coocOn)
 -- import Gargantext.Core.Viz.Graph.Index
-import Gargantext.Prelude (Ord, Eq, Int, Double, Show, map)
+import Gargantext.Prelude (Ord, Eq, Int, Double, Show, map, ($), (.))
 import Prelude (Enum, Bounded, minBound, maxBound)
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary
@@ -36,7 +37,7 @@ data Similarity = Conditional | Distributional
 
 measure :: Similarity -> Matrix Int -> Matrix Double
 measure Conditional    x = measureConditional' x
-measure Distributional x = logDistributional2 x
+measure Distributional x = massiv2AccelerateMatrix . logDistributional2 . accelerate2MassivMatrix $ x
 
 ------------------------------------------------------------------------
 withMetric :: GraphMetric -> Similarity

src/Gargantext/Core/Methods/Similarities/Accelerate/Distributional.hs

@@ -89,18 +89,22 @@ where $n_{ij}$ is the cooccurrence between term $i$ and term $j$
 {-# LANGUAGE ViewPatterns        #-}
 
 module Gargantext.Core.Methods.Similarities.Accelerate.Distributional
+  ( distributional
+  , logDistributional2
+
+  -- internals for testing
+  , distributionalWith
+  , logDistributional2With
+  , sumMin_go
+  , sumM_go
+  )
   where
 
 -- import qualified Data.Foldable as P (foldl1)
 -- import Debug.Trace (trace)
 import Data.Array.Accelerate as A
--- import Data.Array.Accelerate.Interpreter (run)
-import Data.Array.Accelerate.LLVM.Native (run) -- TODO: try runQ?
+import Data.Array.Accelerate.Interpreter qualified as Naive
 import Gargantext.Core.Methods.Matrix.Accelerate.Utils
-import qualified Gargantext.Prelude as P
-
-import Debug.Trace
-import Prelude (show, mappend{- , String, (<>), fromIntegral, flip -})
 
 import qualified Prelude
 
@@ -138,8 +142,16 @@ import qualified Prelude
 --     8.333333333333333e-2,             4.6875e-2,                1.0,               0.25,
 --       0.3333333333333333, 5.7692307692307696e-2,                1.0,                1.0]
 --
+-- /IMPORTANT/: As this function computes the diagonal matrix in order to carry on the computation
+-- the input has to be a square matrix, or this function will fail at runtime.
 distributional :: Matrix Int -> Matrix Double
-distributional m' = run $ result
+distributional = distributionalWith Naive.run
+
+distributionalWith :: (Elt e, FromIntegral Int e, Eq e, Prelude.Fractional (Exp e), Ord e)
+                   => (forall a. Arrays a => Acc a -> a)
+                   -> Matrix Int
+                   -> Matrix e
+distributionalWith interpret m' = interpret $ result
  where
     m = map A.fromIntegral $ use m'
     n = dim m'
@@ -149,7 +161,7 @@ distributional m' = run $ result
     d_1 = replicate (constant (Z :. n :. All)) diag_m
     d_2 = replicate (constant (Z :. All :. n)) diag_m
 
-    mi    = (.*) ((./) m d_1) ((./) m d_2)
+    mi    = (.*) (termDivNan m d_1) (termDivNan m d_2)
 
     -- w = (.-) mi d_mi
     
@@ -170,15 +182,36 @@ distributional m' = run $ result
     result = termDivNan z_1 z_2
 
 logDistributional2 :: Matrix Int -> Matrix Double
-logDistributional2 m = trace ("logDistributional2, dim=" `mappend` show n) . run
+logDistributional2 m = logDistributional2With Naive.run m
+
+logDistributional2With :: ( Elt e
+                          , Prelude.Num (Exp e)
+                          , Ord e
+                          , Prelude.Num e
+                          , FromIntegral Int e
+                          , Prelude.Fractional (Exp e)
+                          , Prelude.Floating (Exp e)
+                          )
+                       => (forall a. Arrays a => Acc a -> a)
+                       -> Matrix Int -> Matrix e
+logDistributional2With interpreter m = interpreter
                      $ diagNull n
                      $ matMaxMini
                      $ logDistributional' n m
   where
     n = dim m
 
-logDistributional' :: Int -> Matrix Int -> Acc (Matrix Double)
-logDistributional' n m' = trace ("logDistributional'") result
+logDistributional' :: ( Elt e
+                      , Prelude.Num (Exp e)
+                      , FromIntegral Int e
+                      , Eq e
+                      , Ord e
+                      , Prelude.Fractional (Exp e)
+                      , Prelude.Floating (Exp e)
+                      )
+                   => Int -> Matrix Int
+                   -> Acc (Matrix e)
+logDistributional' n m' = result
  where
     -- From Matrix Int to Matrix Double, i.e :
     -- m :: Matrix Int -> Matrix Double
@@ -236,10 +269,10 @@ logDistributional' n m' = trace ("logDistributional'") result
     -- k_diff_i_and_j = lift1 (\(Z :. i :. j :. k) -> ((&&) ((/=) k i) ((/=) k j)))
 
     -- Matrix nxn. 
-    sumMin = trace "sumMin" $ sumMin_go n mi -- sum (condOrDefault k_diff_i_and_j 0 w')
+    sumMin = sumMin_go n mi -- sum (condOrDefault k_diff_i_and_j 0 w')
 
     -- Matrix nxn. All columns are the same.
-    sumM = trace "sumM" $ sumM_go n mi -- trace "sumM" $ sum (condOrDefault k_diff_i_and_j 0 w_1)
+    sumM = sumM_go n mi -- trace "sumM" $ sum (condOrDefault k_diff_i_and_j 0 w_1)
 
     result = termDivNan sumMin sumM
 
@@ -264,103 +297,6 @@ logDistributional' n m' = trace ("logDistributional'") result
 --            \[N_{m} = \sum_{i,i \neq i}^{m} \sum_{j, j \neq j}^{m} S_{ij}\]
 --
 
-logDistributional :: Matrix Int -> Matrix Double
-logDistributional m' = run $ diagNull n $ result
- where
-    m = map fromIntegral $ use m'
-    n = dim m'
-
-    -- Scalar. Sum of all elements of m.
-    to = the $ sum (flatten m)
-
-    -- Diagonal matrix with the diagonal of m.
-    d_m = (.*) m (matrixIdentity n)
-
-    -- Size n vector. s = [s_i]_i
-    s = sum ((.-) m d_m)
-
-    -- Matrix nxn. Vector s replicated as rows. 
-    s_1 = replicate (constant (Z :. All :. n)) s
-    -- Matrix nxn. Vector s replicated as columns. 
-    s_2 = replicate (constant (Z :. n :. All)) s
-
-    -- Matrix nxn. ss = [s_i * s_j]_{i,j}. Outer product of s with itself. 
-    ss = (.*) s_1 s_2
-
-    -- Matrix nxn. mi = [m_{i,j}]_{i,j} where 
-    -- m_{i,j} = 0 if n_{i,j} = 0 or i = j, 
-    -- m_{i,j} = log(to * n_{i,j} / s_{i,j}) otherwise.
-    mi = (.*) (matrixEye n) 
-        (map (lift1 (\x -> cond (x == 0) 0 (log (x * to)))) ((./) m ss))
-
-    -- Tensor nxnxn. Matrix mi replicated along the 2nd axis.
-    w_1 = replicate (constant (Z :. All :. n :. All)) mi
-
-    -- Tensor nxnxn. Matrix mi replicated along the 1st axis.
-    w_2 = replicate (constant (Z :. n :. All :. All)) mi
-
-    -- Tensor nxnxn.
-    w' = zipWith min w_1 w_2
-
-    -- A predicate that is true when the input (i, j, k) satisfy 
-    -- k /= i AND k /= j
-    k_diff_i_and_j = lift1 (\(Z :. i :. j :. k) -> ((&&) ((/=) k i) ((/=) k j)))
-
-    -- Matrix nxn. 
-    sumMin = sum (condOrDefault k_diff_i_and_j 0 w')
-
-    -- Matrix nxn. All columns are the same.
-    sumM = sum (condOrDefault k_diff_i_and_j 0 w_1)
-
-    result = termDivNan sumMin sumM
-
-
-
-
-distributional'' :: Matrix Int -> Matrix Double
-distributional'' m = -- run {- $ matMaxMini -}
-                   run  $ diagNull n
-                       $ rIJ n
-                       $ filterWith 0 100
-                       $ filter' 0
-                       $ s_mi
-                       $ map A.fromIntegral
-                          {- from Int to Double -}
-                       $ use m
-                          {- push matrix in Accelerate type -}
-  where
-
-    _ri :: Acc (Matrix Double) -> Acc (Matrix Double)
-    _ri mat = mat1 -- zipWith (/) mat1 mat2
-      where
-        mat1 = matSumCol n $ zipWith min (_myMin mat) (_myMin $ filterWith 0 100 $ diagNull n $ transpose mat)
-        _mat2 = total mat
-
-    _myMin :: Acc (Matrix Double) -> Acc (Matrix Double)
-    _myMin = replicate (constant (Z :. n :. All)) . minimum
-
-
-    -- TODO fix NaN
-    -- Quali TEST: OK
-    s_mi :: Acc (Matrix Double) -> Acc (Matrix Double)
-    s_mi m' = zipWith (\x y -> log (x / y)) (diagNull n m')
-            $ zipWith (/) (crossProduct n m') (total m')
-            -- crossProduct n m'
-
-
-    total :: Acc (Matrix Double) -> Acc (Matrix Double)
-    total = replicate (constant (Z :. n :. n)) . sum . sum
-
-    n :: Dim
-    n = dim m
-
-rIJ :: (Elt a, Ord a, P.Fractional (Exp a), P.Num a)
-    => Dim -> Acc (Matrix a) -> Acc (Matrix a)
-rIJ n m = matMaxMini $ divide a b
-  where
-    a = sumRowMin n m
-    b = sumColMin n m
-
 -- * For Tests (to be removed)
 -- | Test perfermance with this matrix
 -- TODO : add this in a benchmark folder
@@ -376,25 +312,6 @@ distriTest n = logDistributional m == distributional m
 -- compact repr of "extend along an axis" op?
 -- general sparse repr ?
 
-type Extended sh = sh :. Int
-
-data Ext where
-  Along1 :: Int -> Ext
-  Along2 :: Int -> Ext
-
-along1 :: Int -> Ext
-along1 = Along1
-
-along2 :: Int -> Ext
-along2 = Along2
-
-type Delayed sh a = Exp sh -> Exp a
-
-data ExtArr sh a = ExtArr
-  { extSh  :: Extended sh
-  , extFun :: Delayed (Extended sh) a
-  }
-
 {-
 w_1_{i, j, k} = mi_{i, k}
 w_2_{i, j, k} = mi_{j, k}

src/Gargantext/Core/Notifications.hs

@@ -12,14 +12,14 @@ Portability : POSIX
 module Gargantext.Core.Notifications
 where
 
-import Gargantext.Core.Config.Types (NotificationsConfig)
+import Gargantext.Core.Config (GargConfig)
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
 import Gargantext.Core.Notifications.Dispatcher qualified as D
 import Protolude
 
 
-withNotifications :: NotificationsConfig -> (D.Dispatcher -> IO a) -> IO a
-withNotifications nc cb =
-  D.withDispatcher nc $ \dispatcher -> do
-    withAsync (CE.gServer nc) $ \_ce -> do
+withNotifications :: GargConfig -> (D.Dispatcher -> IO a) -> IO a
+withNotifications gc cb =
+  D.withDispatcher gc $ \dispatcher -> do
+    withAsync (CE.gServer gc) $ \_ce -> do
       cb dispatcher

src/Gargantext/Core/Notifications/CentralExchange.hs

@@ -11,7 +11,7 @@ https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
 
 Docs:
 https://dev.sub.gargantext.org/#/share/Notes/187918
-    
+
 -}
 
 module Gargantext.Core.Notifications.CentralExchange (
@@ -23,15 +23,16 @@ import Control.Concurrent.Async qualified as Async
 import Control.Concurrent.STM.TChan qualified as TChan
 import Data.Aeson qualified as Aeson
 import Data.ByteString.Lazy qualified as BSL
-import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
+import Data.Text qualified as T
+import Gargantext.Core.Config (GargConfig, gc_notifications_config, gc_logging)
 import Gargantext.Core.Config.Types (NotificationsConfig(..))
 import Gargantext.Core.Notifications.CentralExchange.Types
 import Gargantext.Prelude
 import Gargantext.System.Logging (LogLevel(..), withLogger, logMsg)
 import Nanomsg (Pull(..), Push(..), bind, connect, recv, send, withSocket)
 import System.Timeout (timeout)
-    
+
 {-
 
 Central exchange is a service, which gathers messages from various
@@ -42,18 +43,18 @@ The primary goal is to be able to read as many messages as possible
 and then send them to the Dispatcher. Although nanomsg does some
 message buffering, we don't want these messages to pile up, especially
 with many users having updates.
-    
+
 -}
 
-gServer :: NotificationsConfig -> IO ()
-gServer (NotificationsConfig { .. }) = do
+gServer :: GargConfig -> IO ()
+gServer cfg = do
   withSocket Pull $ \s -> do
     withSocket Push $ \s_dispatcher -> do
-      withLogger () $ \ioLogger -> do
-        logMsg ioLogger DDEBUG $ "[central_exchange] binding to " <> T.unpack _nc_central_exchange_bind
+      withLogger log_cfg $ \ioLogger -> do
+        logMsg ioLogger DEBUG $ "[central_exchange] binding to " <> T.unpack _nc_central_exchange_bind
       _ <- bind s $ T.unpack _nc_central_exchange_bind
-      withLogger () $ \ioLogger -> do
-        logMsg ioLogger DDEBUG $ "[central_exchange] connecting to " <> T.unpack _nc_dispatcher_bind
+      withLogger log_cfg $ \ioLogger -> do
+        logMsg ioLogger DEBUG $ "[central_exchange] connecting to " <> T.unpack _nc_dispatcher_bind
       _ <- connect s_dispatcher $ T.unpack _nc_dispatcher_connect
 
       tChan <- TChan.newTChanIO
@@ -63,16 +64,18 @@ gServer (NotificationsConfig { .. }) = do
       -- | the 'tChan' and calls Dispatcher accordingly. This is to
       -- | make reading nanomsg as fast as possible.
       void $ Async.concurrently (worker s_dispatcher tChan) $ do
-        withLogger () $ \ioLogger -> do
+        withLogger log_cfg $ \ioLogger -> do
           forever $ do
             -- putText "[central_exchange] receiving"
             r <- recv s
-            logMsg ioLogger DDEBUG $ "[central_exchange] received: " <> show r
+            logMsg ioLogger DEBUG $ "[central_exchange] received: " <> show r
             -- C.putStrLn $ "[central_exchange] " <> r
             atomically $ TChan.writeTChan tChan r
   where
+    NotificationsConfig{..} = cfg ^. gc_notifications_config
+    log_cfg = cfg ^. gc_logging
     worker s_dispatcher tChan = do
-      withLogger () $ \ioLogger -> do
+      withLogger log_cfg $ \ioLogger -> do
         forever $ do
           r <- atomically $ TChan.readTChan tChan
           case Aeson.decode (BSL.fromStrict r) of
@@ -81,10 +84,10 @@ gServer (NotificationsConfig { .. }) = do
               -- putText $ "[central_exchange] sending that to the dispatcher: " <> show node_id
               -- To make this more robust, use withAsync so we don't
               -- block the main thread (send is blocking)
-              
+
               -- NOTE: If we're flooded with messages, and send is
               -- slow, we might be spawning many threads...
-    
+
               -- NOTE: Currently we just forward the message that we
               -- got. So in theory central exchange isn't needed (we
               -- could ping dispatcher directly). However, I think
@@ -102,16 +105,19 @@ gServer (NotificationsConfig { .. }) = do
               void $ timeout 100_000 $ send s_dispatcher r
             Nothing ->
               logMsg ioLogger ERROR $ "[central_exchange] cannot decode message: " <> show r
-      
 
-notify :: NotificationsConfig -> CEMessage -> IO ()
-notify (NotificationsConfig { _nc_central_exchange_connect }) ceMessage = do
+
+notify :: GargConfig -> CEMessage -> IO ()
+notify cfg ceMessage = do
   Async.withAsync (pure ()) $ \_ -> do
     withSocket Push $ \s -> do
       _ <- connect s $ T.unpack _nc_central_exchange_connect
       let str = Aeson.encode ceMessage
-      withLogger () $ \ioLogger ->
-        logMsg ioLogger DDEBUG $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str)
+      withLogger log_cfg $ \ioLogger ->
+        logMsg ioLogger DEBUG $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str)
       -- err <- sendNonblocking s $ BSL.toStrict str
       -- putText $ "[notify] err: " <> show err
       void $ timeout 100_000 $ send s $ BSL.toStrict str
+  where
+    NotificationsConfig { _nc_central_exchange_connect } = cfg ^. gc_notifications_config
+    log_cfg = cfg ^. gc_logging

src/Gargantext/Core/Notifications/Dispatcher.hs

@@ -11,7 +11,7 @@ https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
 
 Docs:
 https://dev.sub.gargantext.org/#/share/Notes/187918
-    
+
 -}
 
 module Gargantext.Core.Notifications.Dispatcher (
@@ -38,6 +38,7 @@ import Gargantext.System.Logging (LogLevel(..), withLogger, logMsg)
 import Nanomsg (Pull(..), bind, recv, withSocket)
 import Network.WebSockets qualified as WS
 import StmContainers.Set qualified as SSet
+import Gargantext.Core.Config
 
 {-
 
@@ -45,7 +46,7 @@ Dispatcher is a service, which provides couple of functionalities:
 - handles WebSocket connections and manages them
 - accepts messages from central exchange
 - dispatches these messages to connected users
-    
+
 -}
 
 data Dispatcher =
@@ -55,23 +56,23 @@ data Dispatcher =
 dispatcherSubscriptions :: Dispatcher -> SSet.Set Subscription
 dispatcherSubscriptions = d_subscriptions
 
-withDispatcher :: NotificationsConfig -> (Dispatcher -> IO a) -> IO a
-withDispatcher nc cb = do
+withDispatcher :: GargConfig -> (Dispatcher -> IO a) -> IO a
+withDispatcher cfg cb = do
   subscriptions <- SSet.newIO
 
-  Async.withAsync (dispatcherListener nc subscriptions) $ \_a -> do
+  Async.withAsync (dispatcherListener cfg subscriptions) $ \_a -> do
     let dispatcher = Dispatcher { d_subscriptions = subscriptions }
     cb dispatcher
 
-    
+
 -- | This is a nanomsg socket listener. We want to read the messages
 -- | as fast as possible and then process them gradually in a separate
 -- | thread.
-dispatcherListener :: NotificationsConfig -> SSet.Set Subscription -> IO ()
-dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions = do
+dispatcherListener :: GargConfig -> SSet.Set Subscription -> IO ()
+dispatcherListener config subscriptions = do
   withSocket Pull $ \s -> do
-    withLogger () $ \ioLogger -> do
-      logMsg ioLogger DDEBUG $ "[dispatcherListener] binding to " <> T.unpack _nc_dispatcher_bind
+    withLogger log_cfg $ \ioLogger -> do
+      logMsg ioLogger DEBUG $ "[dispatcherListener] binding to " <> T.unpack _nc_dispatcher_bind
     _ <- bind s $ T.unpack _nc_dispatcher_bind
 
     tChan <- TChan.newTChanIO
@@ -81,7 +82,7 @@ dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions =
     -- NOTE I'm not sure that we need more than 1 worker here, but in
     -- theory, the worker can perform things like user authentication,
     -- DB queries etc so it can be slow sometimes.
-    Async.withAsync (throttle 500_000 throttleTChan sendDataMessageThrottled) $ \_ -> do
+    Async.withAsync (throttle 500_000 throttleTChan (sendDataMessageThrottled log_cfg)) $ \_ -> do
       void $ Async.concurrently (Async.replicateConcurrently 5 $ worker tChan throttleTChan) $ do
         forever $ do
           -- putText "[dispatcher_listener] receiving"
@@ -89,20 +90,22 @@ dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions =
           -- C.putStrLn $ "[dispatcher_listener] " <> r
           atomically $ TChan.writeTChan tChan r
   where
+    NotificationsConfig { _nc_dispatcher_bind } = config ^. gc_notifications_config
+    log_cfg = config ^. gc_logging
     worker tChan throttleTChan = do
       -- tId <- myThreadId
-      
+
       forever $ do
         r <- atomically $ TChan.readTChan tChan
         -- putText $ "[" <> show tId <> "] received a message: " <> decodeUtf8 r
-        
+
         case Aeson.decode (BSL.fromStrict r) of
           Nothing ->
-            withLogger () $ \ioL ->
+            withLogger log_cfg $ \ioL ->
               logMsg ioL DEBUG "[dispatcher_listener] unknown message from central exchange"
           Just ceMessage -> do
-            withLogger () $ \ioL ->
-              logMsg ioL DDEBUG $ "[dispatcher_listener] received " <> show ceMessage
+            withLogger log_cfg $ \ioL ->
+              logMsg ioL DEBUG $ "[dispatcher_listener] received " <> show ceMessage
             -- subs <- atomically $ readTVar subscriptions
             filteredSubs <- atomically $ do
               let subs' = UnfoldlM.filter (pure . ceMessageSubPred ceMessage) $ SSet.unfoldlM subscriptions
@@ -161,10 +164,10 @@ sendNotification throttleTChan ceMessage sub = do
 
 -- | The "true" message sending to websocket. After it was withheld
 -- for a while (for throttling), it is finally sent here
-sendDataMessageThrottled :: (WS.Connection, WS.DataMessage) -> IO ()
-sendDataMessageThrottled (conn, msg) = do
-  withLogger () $ \ioL ->
-    logMsg ioL DDEBUG $ "[sendDataMessageThrottled] dispatching notification: " <> show msg
+sendDataMessageThrottled :: LogConfig -> (WS.Connection, WS.DataMessage) -> IO ()
+sendDataMessageThrottled log_cfg (conn, msg) = do
+  withLogger log_cfg $ \ioL ->
+    logMsg ioL DEBUG $ "[sendDataMessageThrottled] dispatching notification: " <> show msg
   WS.sendDataMessage conn msg
 
 

src/Gargantext/Core/Text/Ngrams.hs

@@ -88,6 +88,7 @@ data Ngrams = UnsafeNgrams { _ngramsTerms :: Text
   deriving (Generic, Show, Eq, Ord)
 
 instance Hashable Ngrams
+instance Serialise Ngrams where
 
 makeLenses ''Ngrams
 instance PGS.ToRow Ngrams where

src/Gargantext/Core/Types.hs

@@ -188,6 +188,8 @@ $(deriveJSON (unPrefix "tr_") ''TableResult)
 instance (Typeable a, ToSchema a) => ToSchema (TableResult a) where
   declareNamedSchema = wellNamedSchema "tr_"
 
+instance NFData a => NFData (TableResult a) where
+
 ----------------------------------------------------------------------------
 data Typed a b =
   Typed { _withType :: a

src/Gargantext/Core/Types/Individu.hs

@@ -57,7 +57,9 @@ instance Prelude.Show GargPassword where
 instance ToJSON GargPassword
 instance FromJSON GargPassword
 
-instance ToSchema GargPassword
+instance ToSchema GargPassword where
+  declareNamedSchema _ = pure $ NamedSchema (Just "GargPassword") passwordSchema
+
 type Email          = Text
 type UsernameMaster = Username
 type UsernameSimple = Username

src/Gargantext/Core/Viz/Graph/GEXF.hs

@@ -51,19 +51,30 @@ graphToXML (G.Graph { .. }) = root _graph_nodes _graph_edges
         desc = XML.tag "description" mempty $ XML.content "Gargantext gexf file"
 
     graph :: (Monad m) => [G.Node] -> [G.Edge] -> ConduitT i XML.Event m ()
-    graph gn ge = XML.tag "graph" params $ (nodes gn) <> (edges ge)
+    graph gn ge = XML.tag "graph" params $ graphAttributes <> (nodes gn) <> (edges ge)
       where
         params = XML.attr "mode" "static"
               <> XML.attr "defaultedgetype" "directed"
 
+    graphAttributes :: (Monad m) => ConduitT i XML.Event m ()
+    graphAttributes = XML.tag "attributes" graphAttributesParams $ graphAttributeWeight
+      where
+        graphAttributesParams = XML.attr "class" "node"
+        graphAttributeWeight = XML.tag "attribute" attrWeightParams $ XML.content ""
+        attrWeightParams = XML.attr "id" "0"
+                        <> XML.attr "title" "weight"
+                        <> XML.attr "type" "integer"
+
     nodes :: (Monad m) => [G.Node] -> ConduitT i XML.Event m ()
     nodes gn = XML.tag "nodes" mempty (yieldMany gn .| awaitForever node')
     node' :: (Monad m) => G.Node -> ConduitT i XML.Event m ()
-    node' (G.Node { .. }) = XML.tag "node" params (XML.tag "viz:size" sizeParams $ XML.content "")
+    -- node' (G.Node { .. }) = XML.tag "node" params (XML.tag "viz:size" sizeParams $ XML.content "")
+    node' (G.Node { .. }) = XML.tag "node" params $ XML.tag "attvalues" mempty $ XML.tag "attvalue" sizeParams mempty
       where
         params = XML.attr "id" node_id
               <> XML.attr "label" node_label
-        sizeParams = XML.attr "value" (show node_size)
+        sizeParams = XML.attr "for" "0"
+                  <> XML.attr "value" (show node_size)
 
     edges :: (Monad m) => [G.Edge] -> ConduitT i XML.Event m ()
     edges ge = XML.tag "edges" mempty (yieldMany ge .| awaitForever edge')