Merge branch 'dev' into 444-dev-temporary-file-storage

.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.5
+
+* [BACK][FIX][Error when uploading a specific TSV file (#433)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/433)
+
+## Version 0.0.7.4.4
+
+* [BACK][FIX][Order 1 advanced distance (#445)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/445)
+* [FRONT][FIX][Frontend for bridgeness method choice (#730)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/730)
+* [FRONT][FIX][Unify CSS files to a single syntax format (#712)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/712)
+* [FRONT][FIX][Upgrade sigma.js (#705)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/705)
+* [FRONT][FIX][Subcorpus frontend (#718)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/718)
+* [FRONT][FIX][[Corpus upload] Fix an error on form select "NoList" option (#729)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/729)
+* [FRONT][FIX][Basic feature flag hook (#721)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/721)
+
+## Version 0.0.7.4.3
+
+* [BACK][UPGRADE][Remove obsolete GHC option (#388)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/388)
+* [BACK][REFACT][Error in corpus upload / construction are not reflected in the overall JobStatus (#390)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/390)
+* [BACK][FIX][Write test(s) for "ngrams scores do not account for trashed documents" (#391)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/391)
+
 ## Version 0.0.7.4.2
 
 * [BACK][FIX][Let users create a Subcorpus (#384)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/384)

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

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)
@@ -37,18 +37,20 @@ import Prelude qualified
 
 
 workerCLI :: CLIWorker -> IO ()
-workerCLI (CLIW_run (WorkerArgs { .. })) = withLogger () $ \ioLogger -> do
+workerCLI (CLIW_run (WorkerArgs { .. })) = do
   let ___ = putStrLn ((List.concat
                        $ List.take 72
                        $ List.cycle ["_"]) :: Prelude.String)
 
+  withWorkerEnv worker_toml $ \env -> do
+    let log_cfg = env ^. hasConfig . gc_logging
+    withLogger log_cfg $ \ioLogger -> do
       ___
       logMsg ioLogger INFO "GarganText worker"
       logMsg ioLogger INFO $ "worker_name: " <> T.unpack worker_name
       logMsg ioLogger INFO $ "worker toml: " <> _SettingsFile worker_toml
       ___
       
-  withWorkerEnv worker_toml $ \env -> do
       let ws = env ^. hasConfig . gc_worker
       case findDefinitionByName ws worker_name of
         Nothing -> do
@@ -67,8 +69,9 @@ workerCLI (CLIW_run (WorkerArgs { .. })) = withLogger () $ \ioLogger -> 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="bf98c4373747e16acdba3e143ad67c978b53587918ee
 
 
 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:
     ./
@@ -26,11 +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/alpmestan/accelerate-arithmetic.git
-    tag: a110807651036ca2228a76507ee35bbf7aedf87a
-
 source-repository-package
     type: git
     location: https://github.com/alpmestan/hmatrix.git
@@ -43,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
@@ -58,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
@@ -101,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
@@ -128,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
@@ -177,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

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"
 
 

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 3.4
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.7.4.2
+version: 0.0.7.4.5
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -98,7 +98,7 @@ flag test-crypto
 -- debug output for the phylo code, so that it doesn't
 -- hinder its performance.
 flag no-phylo-debug-logs
-  default: False
+  default: True
   manual: True
 
 flag enable-benchmarks
@@ -309,6 +309,7 @@ library
       Gargantext.Orphans.Accelerate
       Gargantext.Orphans.OpenAPI
       Gargantext.System.Logging
+      Gargantext.System.Logging.Types
       Gargantext.Utils.Dict
       Gargantext.Utils.Jobs.Error
       Gargantext.Utils.Jobs.Monad
@@ -536,7 +537,7 @@ library
     , fmt
     , formatting ^>= 7.2.0
     , fullstop ^>= 0.1.4
-    , gargantext-graph >=0.1.0.0
+    , gargantext-graph-core >= 0.2.0.0
     , gargantext-prelude
     , graphviz ^>= 2999.20.1.0
     , haskell-bee
@@ -550,7 +551,7 @@ library
     , hstatistics ^>= 0.3.1
     , http-api-data >= 0.5 && < 0.6
     , http-client ^>= 0.7.14
-    , http-client-tls == 0.3.6.1
+    , http-client-tls >= 0.3.6.1 && < 0.4
     , http-conduit >= 2.3.8 && < 2.3.9
     , http-media ^>= 0.8.0.0
     , http-types ^>= 0.12.3
@@ -571,7 +572,7 @@ library
     , morpheus-graphql-app >= 0.24.3 && < 0.28.1
     , morpheus-graphql-server >= 0.24.3 && < 0.28.1
     , morpheus-graphql-subscriptions >= 0.24.3 && < 0.28.1
-    , mtl ^>= 2.2.2
+    , mtl >= 2.2.2 && < 2.4
     , nanomsg-haskell >= 0.2.4 && < 0.3
     , network >= 3.1.4.0
     , network-uri ^>= 2.6.4.1
@@ -598,9 +599,9 @@ library
     , scientific < 0.4
     , serialise ^>= 0.2.4.0
     , servant >= 0.20.1 && < 0.21
-    , servant-auth ^>= 0.4.0.0
+    , servant-auth >= 0.4.0.0 && < 0.5
     , servant-auth-client
-    , servant-auth-server ^>=0.4.6.0
+    , servant-auth-server >=0.4.6.0 && < 0.5
     , servant-auth-swagger ^>= 0.2.10.1
     , servant-blaze ^>= 0.9.1
     , servant-client >= 0.20 && < 0.21
@@ -617,7 +618,7 @@ library
     , servant-xml-conduit ^>= 0.1.0.4
     , shelly >= 1.9 && < 2
     , singletons ^>= 3.0.2
-    , singletons-th >= 3.1 && < 3.2
+    , singletons-th >= 3.1 && < 3.3
     , smtp-mail >= 0.3.0.0
     , split >= 0.2.3.4
     , stemmer == 0.5.2
@@ -626,11 +627,12 @@ library
     , stringsearch >= 0.3.6.6
     , swagger2 ^>= 2.8.7
     , tagsoup ^>= 0.14.8
-    , template-haskell ^>= 2.19.0.0
+    , template-haskell >= 2.19.0.0 && < 2.21
     , temporary ^>= 1.3
     , text ^>= 2.0.2
     , text-metrics ^>= 0.3.2
     , time ^>= 1.12.2
+    , transformers
     , transformers-base ^>= 0.4.6
     , tree-diff
     , toml-parser >= 2.0.1.0 && < 3
@@ -649,7 +651,7 @@ library
     , wai-extra ^>= 3.1.8
     , wai-util >= 0.8
     , warp ^>= 3.3.20
-    , websockets ^>= 0.12.7.3
+    , websockets >= 0.12.7.3 && < 0.14
     , wreq ^>= 0.5.3.3
     , xml-conduit ^>= 1.9.1.3
     , xml-types ^>= 0.3.8
@@ -695,7 +697,6 @@ executable gargantext
     , gargantext-prelude
     , haskell-bee
     , MonadRandom ^>= 0.6
-    , monad-logger ^>= 0.3.36
     , optparse-applicative
     , postgresql-simple >= 0.6.4 && <= 0.7.0.0
     , servant >= 0.20.1 && < 0.21
@@ -739,12 +740,11 @@ common commonTestDependencies
     , hspec-wai
     , hspec-wai-json
     , http-client ^>= 0.7.14
-    -- important: 0.3.6.1 uses cryptonite, while > uses crypton
-    , http-client-tls == 0.3.6.1
+    , http-client-tls >= 0.3.6.1 && < 0.4
     , http-types
     , lens >= 5.2.2 && < 5.3
     , monad-control >= 1.0.3 && < 1.1
-    , mtl ^>= 2.2.2
+    , mtl >= 2.2.2 && < 2.4
     , network-uri
     , parsec ^>= 3.1.16.1
     , patches-class ^>= 0.1.0.1
@@ -866,7 +866,9 @@ test-suite garg-test-hspec
     , commonTestDependencies
   type: exitcode-stdio-1.0
   main-is: drivers/hspec/Main.hs
-  build-depends: process ^>= 1.6.18.0
+  build-depends:
+      process ^>= 1.6.18.0
+    , unix >= 2.7.3 && < 2.9
   other-modules:
       Paths_gargantext
       Test.API

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,17 +70,16 @@ 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
@@ -106,11 +105,12 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mod
             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/EnvTypes.hs

@@ -43,7 +43,7 @@ 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(..))
+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
@@ -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,7 @@ 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
@@ -190,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
@@ -244,5 +222,28 @@ instance HasManager DevEnv where
 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/Dev.hs

@@ -26,13 +26,13 @@ import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
 import Gargantext.Database.Prelude (Cmd, CmdRandom, connPool, runCmd)
 import Gargantext.Prelude
-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
 

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/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
+  $(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/Node/Update.hs

@@ -63,12 +63,12 @@ updateNode :: (HasNodeStory env err m
            -> JobHandle m
            -> m ()
 updateNode nId (UpdateNodeParamsGraph
-                    (UpdateNodeConfigGraph metric partitionMethod bridgeMethod strength nt1 nt2)) jobHandle = do
+                    (UpdateNodeConfigGraph metric 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
+  _ <- recomputeGraph nId bridgeMethod (Just metric) (Just strength) nt1 nt2 True
   -- printDebug "Graph computed: " method
   markComplete jobHandle
 

src/Gargantext/API/Node/Update/Types.hs

@@ -5,8 +5,7 @@ import Data.Aeson
 import Data.Swagger ( ToSchema )
 import Gargantext.Core.Methods.Similarities (GraphMetric(..))
 import Gargantext.Core.Text.Ngrams (NgramsType)
-import Gargantext.Core.Viz.Graph.Tools (PartitionMethod(..), BridgenessMethod(..))
-import Gargantext.Core.Viz.Graph.Types (Strength)
+import Gargantext.Core.Viz.Graph.Types (BridgenessMethod, Strength)
 import Gargantext.Core.Viz.Phylo (PhyloSubConfigAPI(..))
 import Gargantext.Database.Admin.Types.Node ( NodeId, NodeType )
 import Gargantext.Prelude
@@ -46,7 +45,6 @@ data Charts = Sources | Authors | Institutes | Ngrams | All
 
 ------------------------------------------------------------------------
 data UpdateNodeConfigGraph = UpdateNodeConfigGraph { methodGraphMetric        :: !GraphMetric
-                                                   , methodGraphClustering    :: !PartitionMethod
                                                    , methodGraphBridgeness    :: !BridgenessMethod
                                                    , methodGraphEdgesStrength :: !Strength
                                                    , methodGraphNodeType1     :: !NgramsType

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/Worker.hs

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

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,7 +31,9 @@ module Gargantext.Core.Config (
   , gc_secrets
   , gc_apis
   , gc_worker
-  , gc_log_level
+  , gc_logging
+  , lc_log_level
+  , lc_log_file
 
   , mkProxyUrl
 
@@ -39,24 +43,43 @@ module Gargantext.Core.Config (
   ) 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
@@ -70,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"
@@ -89,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
@@ -101,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
@@ -139,3 +160,11 @@ class HasJWTSettings env where
 
 class HasManager env where
   gargHttpManager :: Getter env HTTP.Manager
+
+--
+-- Lenses
+--
+
+makeLenses ''LogConfig
+makeLenses ''GargConfig
+

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

@@ -23,8 +23,9 @@ 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
@@ -45,15 +46,15 @@ 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
@@ -104,14 +107,17 @@ gServer (NotificationsConfig { .. }) = do
               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

@@ -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
 
 {-
 
@@ -55,11 +56,11 @@ 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
 
@@ -67,11 +68,11 @@ withDispatcher nc cb = do
 -- | 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,6 +90,8 @@ 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
 
@@ -98,11 +101,11 @@ dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions =
 
         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/Notifications/Dispatcher/WebSocket.hs

@@ -17,7 +17,12 @@ https://dev.sub.gargantext.org/#/share/Notes/187918
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators #-}
 
-module Gargantext.Core.Notifications.Dispatcher.WebSocket where
+module Gargantext.Core.Notifications.Dispatcher.WebSocket (
+  -- * Types
+    WSAPI(..)
+  -- * Functions
+  , wsServer
+  ) where
 
 import Control.Concurrent.Async qualified as Async
 import Control.Exception.Safe qualified as Exc
@@ -29,7 +34,7 @@ import Gargantext.API.Prelude (IsGargServer)
 import Gargantext.Core.Notifications.Dispatcher.Subscriptions
 import Gargantext.Core.Notifications.Dispatcher.Types
 import Gargantext.Core.Notifications.Dispatcher (Dispatcher, dispatcherSubscriptions)
-import Gargantext.Core.Config (HasJWTSettings(jwtSettings))
+import Gargantext.Core.Config (HasJWTSettings(jwtSettings), HasConfig (..), LogConfig, gc_logging)
 import Gargantext.Prelude
 import Gargantext.System.Logging (LogLevel(..), logMsg, withLogger, logM)
 import Network.WebSockets qualified as WS
@@ -55,12 +60,13 @@ wsServer = WSAPI { wsAPIServer = streamData }
                => WS.PendingConnection -> m ()
     streamData pc = Exc.catches (do
       jwtS <- view jwtSettings
+      log_cfg  <- view (hasConfig . gc_logging)
       d <- view hasDispatcher
       let subscriptions = dispatcherSubscriptions d
-      key <- getWSKey pc
+      key <- getWSKey log_cfg pc
       c <- liftBase $ WS.acceptRequest pc
       let ws = WSKeyConnection (key, c)
-      _ <- liftBase $ Async.concurrently (wsLoop jwtS subscriptions ws) (pingLoop ws)
+      _ <- liftBase $ Async.concurrently (wsLoop log_cfg jwtS subscriptions ws) (pingLoop ws)
       -- _ <- liftIO $ Async.withAsync (pure ()) (\_ -> wsLoop ws)
       pure ()
       ) [ Exc.Handler $ \(err :: WS.ConnectionException) ->
@@ -85,9 +91,9 @@ pingLoop ws = do
     threadDelay $ 10 * 1000000
 
 
-wsLoop :: JWTSettings -> SSet.Set Subscription -> WSKeyConnection -> IO a
-wsLoop jwtS subscriptions ws = flip finally disconnect $ do
-  withLogger () $ \ioLogger -> do
+wsLoop :: LogConfig -> JWTSettings -> SSet.Set Subscription -> WSKeyConnection -> IO a
+wsLoop log_cfg jwtS subscriptions ws = flip finally disconnect $ do
+  withLogger log_cfg $ \ioLogger -> do
     logMsg ioLogger DEBUG "[wsLoop] connecting"
     wsLoop' CUPublic ioLogger
 
@@ -136,7 +142,7 @@ wsLoop jwtS subscriptions ws = flip finally disconnect $ do
       wsLoop' newUser ioLogger
 
     disconnect = do
-      withLogger () $ \ioLogger -> do
+      withLogger log_cfg $ \ioLogger -> do
         logMsg ioLogger DEBUG "[wsLoop] disconnecting..."
         _ss <- removeSubscriptionsForWSKey subscriptions ws
         -- putText $ "[wsLoop] subscriptions: " <> show (show <$> ss)
@@ -144,13 +150,13 @@ wsLoop jwtS subscriptions ws = flip finally disconnect $ do
 
 
 
-getWSKey :: MonadBase IO m => WS.PendingConnection -> m ByteString
-getWSKey pc = do
+getWSKey :: MonadBase IO m => LogConfig -> WS.PendingConnection -> m ByteString
+getWSKey log_cfg pc = do
   let reqHead = WS.pendingRequest pc
   -- WebSocket specification says that a pending request should send
   -- some unique, Sec-WebSocket-Key string. We use this to compare
   -- connections (WS.Connection doesn't implement an Eq instance).
-  liftBase $ withLogger () $ \ioLogger -> do
+  liftBase $ withLogger log_cfg $ \ioLogger -> do
     logMsg ioLogger DEBUG $ "[wsLoop, getWSKey] headers: " <> show (WS.requestHeaders reqHead)
   let mKey = head $ filter (\(k, _) -> k == "Sec-WebSocket-Key") $ WS.requestHeaders reqHead
   let key' = snd $ fromMaybe (panicTrace "Sec-WebSocket-Key not found!") mKey

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

@@ -71,10 +71,9 @@ getGraph nId = do
   case graph of
     Nothing     -> do
         let defaultMetric          = Order1
-        let defaultPartitionMethod = Spinglass
         let defaultEdgesStrength   = Strong
-        let defaultBridgenessMethod = BridgenessMethod_Basic
-        graph' <- computeGraph cId defaultPartitionMethod defaultBridgenessMethod (withMetric defaultMetric) defaultEdgesStrength (NgramsTerms, NgramsTerms) repo
+        let defaultBridgenessMethod = BridgenessBasic
+        graph' <- computeGraph cId defaultBridgenessMethod (withMetric defaultMetric) defaultEdgesStrength (NgramsTerms, NgramsTerms) repo
         mt     <- defaultGraphMetadata cId listId "Title" repo defaultMetric defaultEdgesStrength
         let mt' = set gm_legend (generateLegend graph') mt
         let
@@ -91,7 +90,6 @@ getGraph nId = do
 --recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
 recomputeGraph :: HasNodeStory env err m
                => NodeId
-               -> PartitionMethod
                -> BridgenessMethod
                -> Maybe GraphMetric
                -> Maybe Strength
@@ -99,7 +97,7 @@ recomputeGraph :: HasNodeStory env err m
                -> NgramsType
                -> Bool
                -> m Graph
-recomputeGraph nId partitionMethod bridgeMethod maybeSimilarity maybeStrength nt1 nt2 force' = do
+recomputeGraph nId bridgeMethod maybeSimilarity maybeStrength nt1 nt2 force' = do
   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
   let
     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
@@ -127,7 +125,7 @@ recomputeGraph nId partitionMethod bridgeMethod maybeSimilarity maybeStrength nt
   let v   = repo ^. unNodeStory . at listId . _Just . a_version
 
   let computeG mt = do
-        !g <- computeGraph cId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo
+        !g <- computeGraph cId bridgeMethod similarity strength (nt1,nt2) repo
         let mt' = set gm_legend (generateLegend g) mt
         let g' = set graph_metadata (Just mt') g
         _nentries <- updateHyperdata nId (HyperdataGraph (Just g') camera)
@@ -154,14 +152,13 @@ recomputeGraph nId partitionMethod bridgeMethod maybeSimilarity maybeStrength nt
 -- TODO remove repo
 computeGraph :: HasNodeError err
              => CorpusId
-             -> PartitionMethod
              -> BridgenessMethod
              -> Similarity
              -> Strength
              -> (NgramsType, NgramsType)
              -> NodeListStory
              -> DBCmd err Graph
-computeGraph corpusId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo = do
+computeGraph corpusId bridgeMethod similarity strength (nt1,nt2) repo = do
   -- Getting the Node parameters
   lId  <- defaultList corpusId
   lIds <- selectNodesWithUsername NodeList userMaster
@@ -190,7 +187,7 @@ computeGraph corpusId partitionMethod bridgeMethod similarity strength (nt1,nt2)
 
   -- TODO MultiPartite Here
   liftBase
-        $ cooc2graphWith partitionMethod bridgeMethod (MultiPartite (Partite (HashMap.keysSet m1) nt1)
+        $ cooc2graphWith bridgeMethod (MultiPartite (Partite (HashMap.keysSet m1) nt1)
                                               (Partite (HashMap.keysSet m2) nt2)
                                               )
                                 similarity 0 strength myCooc
@@ -239,7 +236,7 @@ graphRecompute ::  (HasNodeStory env err m, MonadJobStatus m)
                -> m ()
 graphRecompute n jobHandle = do
   markStarted 1 jobHandle
-  _g <- recomputeGraph n Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
+  _g <- recomputeGraph n BridgenessBasic Nothing Nothing NgramsTerms NgramsTerms False
   markComplete jobHandle
 
 graphVersions :: (HasNodeStory env err m)
@@ -274,7 +271,7 @@ graphVersions u nId = do
 recomputeVersions :: HasNodeStory env err m
                   => NodeId
                   -> m Graph
-recomputeVersions nId = recomputeGraph nId Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
+recomputeVersions nId = recomputeGraph nId BridgenessBasic Nothing Nothing NgramsTerms NgramsTerms False
 
 ------------------------------------------------------------
 graphClone :: (HasNodeError err)

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

@@ -20,8 +20,6 @@ TODO use Map LouvainNodeId (Map LouvainNodeId)
 
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
 
-{-# LANGUAGE BangPatterns #-}
-
 module Gargantext.Core.Viz.Graph.Bridgeness -- (bridgeness)
   where
 
@@ -31,8 +29,8 @@ import Data.Map.Strict (fromListWith, lookup, toList, mapWithKey, elems)
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
 import Data.Tuple.Extra qualified as Tuple
-import Gargantext.Core.Methods.Similarities (Similarity(..))
-import Gargantext.Prelude hiding (toList)
+import Gargantext.Core.Viz.Graph.Types (BridgenessMethod(..))
+import Gargantext.Prelude hiding (toList, filter)
 import Graph.Types (ClusterNode(..))
 ----------------------------------------------------------------------
 
@@ -66,51 +64,21 @@ clusterNodes2sets = Dico.elems
                   . Dico.fromListWith (<>)
                   . (map ((Tuple.second Set.singleton) . swap . nodeId2comId))
 
-----------------------------------------------------------------------
-data Bridgeness = Bridgeness_Basic { bridgeness_partitions :: [ClusterNode]
-                                   , bridgeness_filter     :: Double
-                                   }
-                | Bridgeness_Advanced { bridgeness_similarity :: Similarity
-                                      , bridgness_confluence  :: Confluence
-                                      }
-                | Bridgeness_Recursive { br_partitions :: [[Set NodeId]]
-                                       , br_filter     :: Double
-                                       , br_similarity :: Similarity
-                                       }
-
-
-type Confluence = Map (NodeId, NodeId) Double
-
--- Filter Links between the Clusters
--- Links: Map (NodeId, NodeId) Double
--- List of Clusters: [Set NodeId]
-bridgeness :: Bridgeness
-            -> Map (NodeId, NodeId) Double
-            -> Map (NodeId, NodeId) Double
-bridgeness (Bridgeness_Recursive sn f sim) m =
-  Map.unions $ [linksBetween] <> map (\s -> bridgeness (Bridgeness_Basic (setNodes2clusterNodes s) (if sim == Conditional then pi*f else f)) m') sn
-    where
-      (linksBetween, m') = Map.partitionWithKey (\(n1,n2) _v -> Map.lookup n1 mapNodeIdClusterId
-                                                             /= Map.lookup n2 mapNodeIdClusterId
-                                                ) $ bridgeness (Bridgeness_Basic clusters f) m
-      clusters = setNodes2clusterNodes (map Set.unions sn)
-      mapNodeIdClusterId = clusterNodes2map clusters
-
-
-bridgeness (Bridgeness_Advanced sim c) m = Map.fromList
-                $ List.filter (\x -> if sim == Conditional then snd x > 0.2 else snd x > 0.02)
-                $ map (\(ks, (v1,_v2)) -> (ks,v1))
-                $ Map.toList
-                $ Map.intersectionWithKey
-                      (\k v1 v2 -> trace ("intersectionWithKey " <> (show (k, v1, v2)) :: Text) (v1, v2)) m c
-
-
-bridgeness (Bridgeness_Basic ns b) m = Map.fromList
-                                     $ List.concat
-                                     $ Map.elems
-                                     $ filterComs (round b)
-                                     $ groupEdges (Map.fromList $ map nodeId2comId ns) m
-
+-- | Filter the edges of a graph based on the computed clustering
+bridgeness :: [ClusterNode]               -- ^ Clustering
+           -> BridgenessMethod            -- ^ basic/advanced flag
+           -> Double                      -- ^ Bridgeness threshold
+           -> Map (NodeId, NodeId) Double -- ^ Input graph
+           -> Map (NodeId, NodeId) Double -- ^ Output graph
+bridgeness partitions method filterThreshold graph =
+  Map.fromList $
+  List.concat  $
+  Map.elems    $
+  (case method of
+     BridgenessBasic    -> filterComs (round filterThreshold)
+     BridgenessAdvanced -> filterComsAdvanced
+  )            $
+  groupEdges (Map.fromList $ map nodeId2comId partitions) graph
 
 groupEdges :: (Ord comId, Ord nodeId)
            => Map nodeId comId
@@ -130,7 +98,7 @@ filterComs :: (Ord n1, Eq n2)
            => Int
            -> Map (n2, n2) [(a3, n1)]
            -> Map (n2, n2) [(a3, n1)]
-filterComs b m = Map.filter (\n -> length n > 0) $ mapWithKey filter' m
+filterComs b m = Map.filter (not . null) $ mapWithKey filter' m
   where
     filter' (c1,c2) a
       | c1 == c2  = a
@@ -143,40 +111,14 @@ filterComs b m = Map.filter (\n -> length n > 0) $ mapWithKey filter' m
             t :: Double
             t = fromIntegral $ length $ List.concat $ elems m
 
---------------------------------------------------------------
--- Utils
-{--
-map2intMap :: Map (Int, Int) a -> IntMap (IntMap a)
-map2intMap m = IntMap.fromListWith (<>)
-             $ map (\((k1,k2), v) -> if k1 < k2
-                                   then (k1, IntMap.singleton k2 v)
-                                   else (k2, IntMap.singleton k1 v)
-                    )
-             $ Map.toList m
-
-look :: (Int,Int) -> IntMap (IntMap a) -> Maybe a
-look (k1,k2) m = if k1 < k2
-                    then case (IntMap.lookup k1 m) of
-                           Just m' -> IntMap.lookup k2 m'
-                           _       -> Nothing
-                    else look (k2,k1) m
-
-
-{-
-Compute the median of a list
-From:  https://hackage.haskell.org/package/dsp-0.2.5.1/docs/src/Numeric.Statistics.Median.html
-Compute the center of the list in a more lazy manner
-and thus halves memory requirement.
--}
-
-median :: (Ord a, Fractional a) => [a] -> a
-median [] = panic "medianFast: empty list has no median"
-median zs =
-   let recurse (x0:_)    (_:[])   = x0
-       recurse (x0:x1:_) (_:_:[]) = (x0+x1)/2
-       recurse (_:xs)    (_:_:ys) = recurse xs ys
-       recurse _ _  =
-          panic "median: this error cannot occur in the way 'recurse' is called"
-   in  recurse zs zs
-
--}
+-- Weak links are often due to noise in the data and decrease the readability of the graph. 
+-- This function prunes the links between the clusters when their weight is under a given 'threshold'.  
+filterComsAdvanced :: (Ord a1, Fractional a1, Eq a2)
+                   => Map (a2, a2) [(a3, a1)]
+                   -> Map (a2, a2) [(a3, a1)]
+filterComsAdvanced m = Map.filter (not . null) $ mapWithKey filter' m
+  where
+    threshold = 0.03 -- TODO make this threshold configurable
+    filter' (c1,c2) xs
+      | c1 == c2  = xs
+      | otherwise = List.filter (\(_nn,v) -> v >= threshold) xs

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

@@ -23,18 +23,16 @@ import Data.HashSet qualified as HashSet
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
-import Data.Swagger ( ToSchema )
 import Data.Text qualified as Text
 import Data.Vector.Storable qualified as Vec
 import Gargantext.API.Ngrams.Types (NgramsTerm(..))
 import Gargantext.Core.Methods.Similarities (Similarity(..), measure)
 import Gargantext.Core.Statistics ( pcaReduceTo, Dimension(Dimension) )
 import Gargantext.Core.Text.Ngrams (NgramsType(..))
-import Gargantext.Core.Viz.Graph.Bridgeness (bridgeness, Bridgeness(..), Partitions, nodeId2comId, setNodes2clusterNodes)
+import Gargantext.Core.Viz.Graph.Bridgeness (bridgeness, nodeId2comId, setNodes2clusterNodes)
 import Gargantext.Core.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map, Index, MatrixShape(..))
 import Gargantext.Core.Viz.Graph.Tools.IGraph (mkGraphUfromEdges, spinglass, spinglass')
-import Gargantext.Core.Viz.Graph.Tools.Infomap (infomap)
-import Gargantext.Core.Viz.Graph.Types (Attributes(..), Edge(..), Graph(..), MultiPartite(..), Node(..), Partite(..), Strength(..), LegendField(..))
+import Gargantext.Core.Viz.Graph.Types (Attributes(..), BridgenessMethod, Edge(..), Graph(..), MultiPartite(..), Node(..), Partite(..), Strength(..), LegendField(..))
 import Gargantext.Core.Viz.Graph.Utils (edgesFilter, nodesFilter)
 import Gargantext.Prelude
 import Graph.BAC.ProxemyOptim qualified as BAC
@@ -42,24 +40,6 @@ import Graph.Types (ClusterNode(..))
 import IGraph qualified as Igraph
 import IGraph.Algorithms.Layout qualified as Layout
 import IGraph.Random ( Gen ) -- (Gen(..))
-import Test.QuickCheck (elements)
-import Test.QuickCheck.Arbitrary ( Arbitrary(arbitrary) )
-
-data PartitionMethod = Spinglass | Confluence | Infomap
-    deriving (Generic, Eq, Ord, Enum, Bounded, Show)
-instance FromJSON  PartitionMethod
-instance ToJSON    PartitionMethod
-instance ToSchema  PartitionMethod
-instance Arbitrary PartitionMethod where
-  arbitrary = elements [ minBound .. maxBound ]
-
-data BridgenessMethod = BridgenessMethod_Basic | BridgenessMethod_Advanced
-    deriving (Generic, Eq, Ord, Enum, Bounded, Show)
-instance FromJSON  BridgenessMethod
-instance ToJSON    BridgenessMethod
-instance ToSchema  BridgenessMethod
-instance Arbitrary BridgenessMethod where
-  arbitrary = elements [ minBound .. maxBound ]
 
 
 -------------------------------------------------------------
@@ -90,33 +70,18 @@ cooc2graph' distance threshold myCooc
 
 
 -- coocurrences graph computation
-cooc2graphWith :: PartitionMethod
-               -> BridgenessMethod
+cooc2graphWith :: BridgenessMethod
                -> MultiPartite
                -> Similarity
                -> Threshold
                -> Strength
                -> HashMap (NgramsTerm, NgramsTerm) Int
                -> IO Graph
-cooc2graphWith Spinglass = cooc2graphWith' (spinglass 1)
-cooc2graphWith Confluence= cooc2graphWith' (\x -> pure $ BAC.defaultClustering x)
-cooc2graphWith Infomap   = cooc2graphWith' (infomap "-v -N2")
---cooc2graphWith Infomap   = cooc2graphWith' (infomap "--silent --two-level -N2")
-                        -- TODO: change these options, or make them configurable in UI?
-
-cooc2graphWith' :: Partitions
-                -> BridgenessMethod
-                -> MultiPartite
-                -> Similarity
-                -> Threshold
-                -> Strength
-                -> HashMap (NgramsTerm, NgramsTerm) Int
-                -> IO Graph
-cooc2graphWith' _doPartitions _bridgenessMethod multi similarity threshold strength myCooc = do
+cooc2graphWith bridgenessMethod multi similarity threshold strength myCooc = do
   let (distanceMap, diag, ti) = doSimilarityMap similarity threshold strength myCooc
   distanceMap `seq` diag `seq` ti `seq` pure ()
 
-  partitions <- if (Map.size distanceMap > 0)
+  partitions <- if Map.size distanceMap > 0
       then spinglass' 1 distanceMap
       else panic $ Text.unwords [ "I can not compute the graph you request"
                                 , "because either the quantity of documents"
@@ -130,13 +95,13 @@ cooc2graphWith' _doPartitions _bridgenessMethod multi similarity threshold stren
 
   let
     !confluence' = BAC.computeConfluences 3 (Map.keys distanceMap) True
-    !bridgeness' = bridgeness
-      (Bridgeness_Basic (partitionsToClusterNodes partitions) 1.0)
+    !bridgeness' = bridgeness (partitionsToClusterNodes partitions)
+                              bridgenessMethod
+                              1.0
                               distanceMap
 
   pure $ data2graph multi ti diag bridgeness' confluence' (setNodes2clusterNodes partitions)
 
-
 -- | A converter from the partition type returned by `spinglass'`
 -- to the partition type required by `bridgeness`
 partitionsToClusterNodes :: [Set Int] -> [ClusterNode]
@@ -154,7 +119,6 @@ partitionsToClusterNodes setlist =
   -- Turn pairs into `ClusterNode`s
   fmap (\(clusterId, nodeId) -> ClusterNode nodeId clusterId)
 
-
 type Reverse = Bool
 
 doSimilarityMap :: Similarity

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

@@ -40,6 +40,16 @@ instance ToJSON TypeNode
 instance FromJSON TypeNode
 instance ToSchema TypeNode
 
+
+data BridgenessMethod = BridgenessBasic | BridgenessAdvanced
+    deriving (Generic, Eq, Ord, Enum, Bounded, Show)
+instance FromJSON  BridgenessMethod
+instance ToJSON    BridgenessMethod
+instance ToSchema  BridgenessMethod
+instance Arbitrary BridgenessMethod where
+  arbitrary = elements [ minBound .. maxBound ]
+
+
 data Attributes = Attributes { clust_default :: Int }
   deriving (Show, Generic)
 $(deriveJSON (unPrefix "") ''Attributes)

src/Gargantext/Core/Worker.hs

@@ -42,7 +42,7 @@ import Gargantext.API.Node.Types (_wtf_file_oid)
 import Gargantext.API.Node.Update.Types (UpdateNodeParams(..), Granularity (..))
 import Gargantext.API.Node.Update (updateNode)
 import Gargantext.API.Server.Named.Ngrams (tableNgramsPostChartsAsync)
-import Gargantext.Core.Config (hasConfig, gc_database_config, gc_jobs, gc_notifications_config, gc_worker)
+import Gargantext.Core.Config (hasConfig, gc_database_config, gc_jobs, gc_worker, gc_logging)
 import Gargantext.Core.Config.Types (jc_max_docs_scrapers)
 import Gargantext.Core.Config.Worker (WorkerDefinition(..))
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
@@ -89,7 +89,7 @@ notifyJobStarted env (W.State { name }) bm = do
   let mId = messageId bm
   let j = toA $ getMessage bm
   let job = W.job j
-  withLogger () $ \ioL ->
+  withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
     logMsg ioL DEBUG $ "[notifyJobStarted] [" <> name <> " :: " <> show mId <> "] starting job: " <> show j
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
@@ -105,7 +105,7 @@ notifyJobFinished env (W.State { name }) bm = do
   let mId = messageId bm
   let j = toA $ getMessage bm
   let job = W.job j
-  withLogger () $ \ioL ->
+  withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
     logMsg ioL DEBUG $ "[notifyJobFinished] [" <> name <> " :: " <> show mId <> "] finished job: " <> show j
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
@@ -121,7 +121,7 @@ notifyJobTimeout env (W.State { name }) bm = do
   let mId = messageId bm
   let j = toA $ getMessage bm
   let job = W.job j
-  withLogger () $ \ioL ->
+  withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
     logMsg ioL ERROR $ "[notifyJobTimeout] [" <> name <> " :: " <> show mId <> "] job timed out: " <> show j
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
@@ -138,7 +138,7 @@ notifyJobFailed env (W.State { name }) bm exc = do
   let mId = messageId bm
   let j = toA $ getMessage bm
   let job = W.job j
-  withLogger () $ \ioL ->
+  withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
     logMsg ioL ERROR $ "[notifyJobFailed] [" <> name <> " :: " <> show mId <> "] failed job: " <> show j <> "   --- ERROR: " <> show exc
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
@@ -154,7 +154,7 @@ notifyJobKilled _ _ Nothing = pure ()
 notifyJobKilled env (W.State { name }) (Just bm) = do
   let j = toA $ getMessage bm
   let job = W.job j
-  withLogger () $ \ioL ->
+  withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
     logMsg ioL ERROR $ "[notifyJobKilled] [" <> name <> "] failed job: " <> show j
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
@@ -223,7 +223,7 @@ performAction env _state bm = do
   case job of
     Ping -> runWorkerMonad env $ do
       $(logLocM) DEBUG "[performAction] ping"
-      liftIO $ CE.notify (env ^. (to _w_env_config) . gc_notifications_config) CET.Ping
+      liftIO $ CE.notify (env ^. (to _w_env_config)) CET.Ping
 
     -- | flow action for a single contact
     AddContact { .. } -> runWorkerMonad env $ do

src/Gargantext/Core/Worker/Env.hs

@@ -10,6 +10,7 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans      #-}  -- orphan HasNodeError IOException
 
@@ -20,6 +21,7 @@ module Gargantext.Core.Worker.Env where
 import Control.Concurrent.STM.TVar (TVar, modifyTVar, newTVarIO, readTVarIO)
 import Control.Exception.Safe qualified as CES
 import Control.Lens (prism', to, view)
+import Control.Lens.TH
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Maybe (fromJust)
 import Data.Pool qualified as Pool
@@ -31,7 +33,7 @@ import Gargantext.API.Job (RemainingSteps(..), jobLogStart, jobLogProgress, jobL
 import Gargantext.API.Prelude (GargM)
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
 import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
-import Gargantext.Core.Config (GargConfig(..), HasConfig(..))
+import Gargantext.Core.Config (GargConfig(..), HasConfig(..), gc_logging)
 import Gargantext.Core.Config.Mail qualified as Mail
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.Config.Types (SettingsFile(..))
@@ -44,7 +46,7 @@ import Gargantext.Database.Prelude (HasConnectionPool(..))
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Database.Query.Tree.Error (HasTreeError(..))
 import Gargantext.Prelude hiding (to)
-import Gargantext.System.Logging (HasLogger(..), Logger, LogLevel(..), MonadLogger(..), withLogger, logMsg, withLoggerHoisted)
+import Gargantext.System.Logging (HasLogger(..), Logger, LogLevel(..), MonadLogger(..), withLogger, logMsg, withLoggerIO)
 import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
 import GHC.IO.Exception (IOException(..), IOErrorType(OtherError))
 import Prelude qualified
@@ -69,7 +71,7 @@ data WorkerJobState = WorkerJobState
 
 
 withWorkerEnv :: SettingsFile -> (WorkerEnv -> IO a) -> IO a
-withWorkerEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
+withWorkerEnv settingsFile k = withLoggerIO Dev $ \logger -> do
   env <- newWorkerEnv logger
   k env -- `finally` cleanEnv env
 
@@ -138,9 +140,9 @@ instance CET.HasCentralExchangeNotification WorkerEnv where
   ce_notify m = do
     c <- asks (view $ to _w_env_config)
     liftBase $ do
-      withLogger () $ \ioL ->
-        logMsg ioL DDEBUG $ "[ce_notify]: " <> show (_gc_notifications_config c) <> " :: " <> show m
-      CE.notify (_gc_notifications_config c) m
+      withLogger (c ^. gc_logging) $ \ioL ->
+        logMsg ioL DEBUG $ "[ce_notify]: " <> show (_gc_notifications_config c) <> " :: " <> show m
+      CE.notify c m
 
 ---------
 instance HasValidationError IOException where
@@ -269,3 +271,5 @@ updateJobProgress (WorkerJobHandle (ji@JobInfo { _ji_message_id })) f = do
       Just (WorkerJobState { _wjs_job_info = ji
                            , _wjs_job_log = f initJobLog })
 
+
+makeLenses ''WorkerEnv

src/Gargantext/Core/Worker/Jobs.hs

@@ -15,7 +15,7 @@ module Gargantext.Core.Worker.Jobs where
 
 import Async.Worker qualified as W
 import Control.Lens (view)
-import Gargantext.Core.Config (gc_database_config, gc_worker, HasConfig(..), GargConfig)
+import Gargantext.Core.Config (gc_database_config, gc_worker, HasConfig(..), GargConfig, gc_logging)
 import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..))
 import Gargantext.Core.Worker.Broker (initBrokerWithDBCreate)
 import Gargantext.Core.Worker.Jobs.Types (Job(..))
@@ -44,7 +44,7 @@ sendJobWithCfg gcConfig job = do
       b <- initBrokerWithDBCreate (gcConfig ^. gc_database_config) ws
       let queueName = _wdQueue wd
       let job' = (updateJobData job $ W.mkDefaultSendJob' b queueName job) { W.delay = _wsDefaultDelay }
-      withLogger () $ \ioL ->
+      withLogger (gcConfig ^. gc_logging) $ \ioL ->
         logMsg ioL DEBUG $ "[sendJob] sending job " <> show job <> " (delay " <> show (W.delay job') <> ")"
       W.sendJob' job'
 

src/Gargantext/Database/Types.hs

@@ -32,6 +32,9 @@ data Indexed i a =
 
 makeLenses ''Indexed
 
+instance Functor (Indexed i) where
+  fmap f (Indexed i a) = Indexed i (f a)
+
 instance Bifunctor Indexed where
   first  f (Indexed i a) = Indexed (f i) a
   second g (Indexed i a) = Indexed i (g a)

src/Gargantext/System/Logging.hs

 {-# LANGUAGE TemplateHaskell      #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeApplications     #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Gargantext.System.Logging (
-    LogLevel(..)
-  , HasLogger(..)
-  , MonadLogger(..)
+    module Gargantext.System.Logging.Types
   , logM
   , logLocM
   , logLoc
   , withLogger
-  , withLoggerHoisted
+  , withLoggerIO
   ) where
 
+import Gargantext.System.Logging.Types
 import Control.Exception.Safe (MonadMask, bracket)
 import Control.Monad (when)
+import Gargantext.Core.Config (LogConfig(..))
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Control
-import Data.Kind (Type)
 import Data.Text qualified as T
 import Data.Time.Clock (getCurrentTime)
 import Language.Haskell.TH hiding (Type)
 import Language.Haskell.TH.Syntax qualified as TH
 import Prelude
 import System.Environment (lookupEnv)
-import Text.Read (readMaybe)
 
 
-data LogLevel =
-  -- | Detailed debug messages
-  DDEBUG
-  -- | Debug messages
-  | DEBUG
-  -- | Information
-  | INFO
-  -- | Normal runtime conditions
-  | NOTICE
-  -- | General Warnings
-  | WARNING
-  -- | General Errors
-  | ERROR
-  -- | Severe situations
-  | CRITICAL
-  -- | Take immediate action
-  | ALERT
-  -- | System is unusable
-  | EMERGENCY
-  deriving (Show, Eq, Ord, Enum, Bounded, Read)
-
--- | This is a barebore logging interface which we
--- can extend to plug a proper logging library, without
--- the details of the logger cropping up everywhere in
--- the rest of the codebase.
-class HasLogger m where
-  data family Logger m        :: Type
-  type family LogInitParams m :: Type
-  type family LogPayload m    :: Type
-  initLogger    :: LogInitParams m -> (forall m1. MonadIO m1 => m1 (Logger m))
-  destroyLogger :: Logger m        -> (forall m1. MonadIO m1 => m1 ())
-  logMsg        :: Logger m        -> LogLevel -> LogPayload m -> m ()
-  logTxt        :: Logger m        -> LogLevel -> T.Text -> m ()
-
--- | Separate typeclass to get hold of a 'Logger' from within a monad.
--- We keey 'HasLogger' and 'MonadLogger' separate to enforce compositionality,
--- i.e. we can still give instances to 'HasLogger' for things like 'IO' without
--- having to force actually acquiring a logger for those monads.
-class HasLogger m => MonadLogger m where
-  getLogger :: m (Logger m)
-
 -- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
 logM :: (Monad m, MonadLogger m) => LogLevel -> T.Text -> m ()
 logM level msg = do
@@ -119,26 +77,29 @@ withLogger params = bracket (initLogger params) destroyLogger
 
 -- | Like 'withLogger', but it allows creating a 'Logger' that can run in
 -- a different monad from within an 'IO' action.
-withLoggerHoisted :: (MonadBaseControl IO m, HasLogger m)
+withLoggerIO :: (MonadBaseControl IO m, HasLogger m)
              => LogInitParams m
              -> (Logger m -> IO a)
              -> IO a
-withLoggerHoisted params act = bracket (initLogger params) destroyLogger act
+withLoggerIO params act = bracket (initLogger params) destroyLogger act
 
 -- | A plain logger in the IO monad, waiting for more serious logging solutions like
 -- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229
 instance HasLogger IO where
   data instance Logger IO        = IOLogger LogLevel
-  type instance LogInitParams IO = ()
+  type instance LogInitParams IO = LogConfig
   type instance LogPayload IO    = String
-  initLogger () = do
-    mLvl <- liftIO $ lookupEnv "LOG_LEVEL"
-    let lvl = case mLvl of
-          Nothing      -> INFO
+  initLogger LogConfig{..} = do
+    -- let the env var take precedence over the LogConfig one.
+    mLvl <- liftIO $ lookupEnv "GGTX_LOG_LEVEL"
+    lvl <- case mLvl of
+          Nothing      -> pure _lc_log_level
           Just s       ->
-            case readMaybe s of
-              Nothing -> error $ "unknown log level " <> s
-              Just lvl' -> lvl'
+            case parseLogLevel (T.pack s) of
+              Left err   -> do
+                liftIO $ putStrLn $ "unknown log level " <> s <> ": " <> T.unpack err <> " , ignoring GGTX_LOG_LEVEL"
+                pure $ _lc_log_level
+              Right lvl' -> pure lvl'
     pure $ IOLogger lvl
   destroyLogger _ = pure ()
   logMsg (IOLogger minLvl) lvl msg = do

src/Gargantext/System/Logging/Types.hs

+{-# LANGUAGE TypeFamilies  #-}
+{-# LANGUAGE LambdaCase    #-}
+
+module Gargantext.System.Logging.Types (
+    LogLevel(..)
+  , HasLogger(..)
+  , MonadLogger(..)
+  , parseLogLevel
+  , renderLogLevel
+  , prop_loglevel_roundtrip
+  ) where
+
+import Control.Monad.IO.Class
+import Data.Kind (Type)
+import Data.Text qualified as T
+import Prelude
+
+
+data LogLevel =
+  -- | Debug messages
+    DEBUG
+  -- | Information
+  | INFO
+  -- | Normal runtime conditions
+  | WARNING
+  -- | General Errors
+  | ERROR
+  deriving (Show, Eq, Ord, Enum, Bounded, Read)
+
+renderLogLevel :: LogLevel -> T.Text
+renderLogLevel = \case
+  DEBUG   -> "debug"
+  INFO    -> "info"
+  WARNING -> "warning"
+  ERROR   -> "error"
+
+parseLogLevel :: T.Text -> Either T.Text LogLevel
+parseLogLevel = \case
+  "debug"   -> Right DEBUG
+  "info"    -> Right INFO
+  "warning" -> Right WARNING
+  "warn"    -> Right WARNING
+  "error"   -> Right ERROR
+  xs -> Left ("Invalid log level found: " <> xs)
+
+prop_loglevel_roundtrip :: LogLevel -> Bool
+prop_loglevel_roundtrip ll = (parseLogLevel . renderLogLevel $ ll) == Right ll
+
+-- | This is a barebore logging interface which we
+-- can extend to plug a proper logging library, without
+-- the details of the logger cropping up everywhere in
+-- the rest of the codebase.
+class HasLogger m where
+  data family Logger m        :: Type
+  type family LogInitParams m :: Type
+  type family LogPayload m    :: Type
+  initLogger    :: LogInitParams m -> (forall m1. MonadIO m1 => m1 (Logger m))
+  destroyLogger :: Logger m        -> (forall m1. MonadIO m1 => m1 ())
+  logMsg        :: Logger m        -> LogLevel -> LogPayload m -> m ()
+  logTxt        :: Logger m        -> LogLevel -> T.Text -> m ()
+
+-- | Separate typeclass to get hold of a 'Logger' from within a monad.
+-- We keey 'HasLogger' and 'MonadLogger' separate to enforce compositionality,
+-- i.e. we can still give instances to 'HasLogger' for things like 'IO' without
+-- having to force actually acquiring a logger for those monads.
+class HasLogger m => MonadLogger m where
+  getLogger :: m (Logger m)

stack.yaml

 "allow-newer": true
 "extra-deps":
-- "JuicyPixels-3.3.9"
 - "KMP-0.2.0.0"
-- "OneTuple-0.4.2"
-- "aeson-pretty-0.8.10"
-- "alex-3.5.1.0"
-- "ansi-terminal-1.0.2"
-- "assoc-1.1.1"
-- "atomic-primops-0.8.8"
+- "alex-3.5.2.0"
+- "ansi-wl-pprint-0.6.9"
 - "barbies-2.1.1.0"
-- "base-compat-0.13.1"
-- "base-compat-batteries-0.13.1"
-- "base-orphans-0.9.2"
+- "base-orphans-0.9.3"
 - "base64-1.0"
-- "bifunctors-5.6.2"
-- "binary-orphans-1.0.5"
-- "blaze-html-0.9.2.0"
-- "boring-0.2.2"
-- "bytestring-lexing-0.5.0.14"
-- "bzlib-conduit-0.3.0.3"
-- "cabal-doctest-1.0.10"
-- "cassava-0.5.3.2"
-- "cassava-conduit-0.6.6"
-- "concurrent-output-1.10.21"
-- "conduit-1.3.6"
-- "criterion-measurement-0.2.2.0"
-- "cron-0.7.1"
-- "crypton-1.0.0"
-- "crypton-x509-1.7.7"
-- "data-fix-0.3.4"
-- "dec-0.0.6"
-- "digest-0.0.2.1"
-- "double-conversion-2.0.5.0"
-- "extra-1.7.16"
-- "fast-logger-3.2.3"
-- "fgl-5.8.2.0"
-- "file-embed-0.0.16.0"
+- "bytes-0.17.4"
+- "bytestring-lexing-0.5.0.15"
+- "bzlib-conduit-0.3.0.4"
+- "charset-0.3.11"
+- "comonad-5.0.9"
+- "conduit-extra-1.3.7"
+- "cron-0.7.2"
+- "crypton-1.0.1"
+- "crypton-connection-0.4.3"
+- "data-default-0.8.0.0"
+- "data-default-class-0.2.0.0"
+- "deferred-folds-0.9.18.7"
+- "entropy-0.4.1.11"
 - "file-embed-lzma-0.1"
-- "foldl-1.4.17"
-- "free-5.2"
+- "foldl-1.4.18"
 - "fullstop-0.1.4"
-- "hashable-1.4.4.0"
-- "haskell-src-meta-0.8.14"
+- "graphviz-2999.20.2.1"
+- "half-0.3.2"
+- "happy-2.1.5"
+- "happy-lib-2.1.5"
+- "hashtables-1.4.2"
+- "haskell-src-meta-0.8.15"
 - "hedgehog-1.5"
-- "hslogger-1.3.1.1"
-- "hsparql-0.3.8"
-- "hspec-2.11.9"
-- "hspec-api-2.11.9"
-- "hspec-core-2.11.9"
-- "hspec-discover-2.11.9"
-- "hspec-expectations-0.8.4"
-- "html-entities-1.1.4.7"
+- "hsparql-0.3.9"
 - "http-accept-0.2"
-- "http-api-data-0.5.1"
 - "http-client-0.7.14"
 - "http-conduit-2.3.8.3"
-- "http2-5.0.1"
-- "indexed-traversable-0.1.4"
-- "invariant-0.6.3"
-- "iproute-1.7.14"
-- "json-stream-0.4.6.0"
-- "kan-extensions-5.2.6"
-- "language-c-0.9.3"
-- "libyaml-0.1.4"
-- "libyaml-clib-0.2.5"
+- "integer-logarithms-1.0.4"
+- "invariant-0.6.4"
+- "jose-0.10.0.1"
+- "language-c-0.10.0"
 - "linear-1.23"
-- "logict-0.8.1.0"
-- "lzma-0.0.1.1"
-- "math-functions-0.3.4.4"
-- "megaparsec-9.6.1"
-- "microlens-th-0.4.3.15"
-- "mono-traversable-1.0.17.0"
-- "monoid-extras-0.6.3"
+- "massiv-1.0.4.1"
+- "megaparsec-9.7.0"
+- "microlens-th-0.4.3.16"
+- "monad-logger-0.3.41"
+- "mono-traversable-1.0.21.0"
+- "monoid-extras-0.6.4"
 - "morpheus-graphql-0.28.0"
 - "morpheus-graphql-app-0.28.0"
 - "morpheus-graphql-client-0.28.1"
@@ -80,81 +52,55 @@
 - "morpheus-graphql-core-0.28.1"
 - "morpheus-graphql-server-0.28.0"
 - "morpheus-graphql-subscriptions-0.28.0"
-- "mwc-random-0.15.1.0"
-- "network-control-0.0.2"
+- "mwc-random-0.15.2.0"
 - "opaleye-0.10.3.1"
-- "ordered-containers-0.2.4"
-- "os-string-2.0.6"
-- "password-3.0.4.0"
-- "postgres-options-0.2.2.0"
+- "password-3.1.0.1"
 - "postgresql-libpq-0.10.2.0"
 - "postgresql-libpq-configure-0.10.0.1"
-- "postgresql-simple-0.7.0.0"
-- "primitive-0.7.4.0"
-- "primitive-extras-0.10.2"
-- "primitive-unlifted-2.1.0.0"
-- "protolude-0.3.4"
+- "pretty-simple-4.1.3.0"
+- "primitive-extras-0.10.2.2"
+- "primitive-unlifted-2.2.0.0"
+- "psqueues-0.2.8.1"
 - "rake-0.0.1"
-- "random-1.2.1.2"
+- "random-1.2.1.3"
 - "random-strings-0.1.1.0"
 - "rdf4h-5.1.0"
-- "reflection-2.1.8"
-- "resourcet-1.3.0"
-- "safe-0.3.21"
-- "selective-0.7.0.1"
-- "servant-0.20.2"
-- "servant-auth-0.4.2.0"
-- "servant-auth-client-0.4.2.0"
-- "servant-auth-server-0.4.9.0"
-- "servant-auth-swagger-0.2.11.0"
-- "servant-client-0.20.2"
-- "servant-client-core-0.20.2"
-- "servant-conduit-0.16.1"
+- "reflection-2.1.9"
+- "req-3.13.4"
+- "scheduler-2.0.1.0"
 - "servant-ekg-0.3.1"
-- "servant-server-0.20.2"
-- "servant-swagger-1.2.1"
 - "servant-swagger-ui-0.3.5.5.0.1"
-- "singleton-bool-0.1.8"
-- "singletons-3.0.3"
-- "some-1.0.6"
-- "split-0.2.5"
+- "singletons-3.0.4"
+- "smtp-mail-0.5.0.0"
+- "splitmix-0.1.1"
+- "statistics-0.16.3.0"
 - "stemmer-0.5.2"
-- "stm-containers-1.2.1"
-- "stm-hamt-1.2.1"
-- "swagger2-2.8.9"
-- "tagged-0.8.8"
+- "stm-containers-1.2.1.1"
+- "stm-hamt-1.2.1.1"
+- "streaming-commons-0.2.3.0"
+- "tagged-0.8.9"
 - "taggy-0.2.1"
 - "taggy-lens-0.1.2"
-- "tasty-1.5"
-- "tasty-hspec-1.2.0.4"
-- "tasty-hunit-0.10.2"
-- "tasty-quickcheck-0.11"
-- "text-short-0.1.6"
-- "th-compat-0.1.5"
-- "these-1.2.1"
-- "time-compat-1.9.7"
+- "tasty-1.5.3"
+- "tasty-quickcheck-0.11.1"
+- "th-compat-0.1.6"
+- "th-expand-syns-0.4.12.0"
+- "th-lift-0.8.6"
+- "th-orphans-0.13.16"
+- "time-compat-1.9.8"
+- "tls-2.1.7"
+- "tmp-postgres-1.34.1.0"
 - "toml-parser-2.0.1.0"
-- "type-equality-1.0.1"
-- "typed-process-0.2.12.0"
-- "unicode-collation-0.1.3.6"
-- "units-2.4.1.5"
-- "unix-compat-0.7.2"
-- "unix-time-0.4.15"
-- "unordered-containers-0.2.20"
-- "utility-ht-0.0.17.2"
+- "uri-bytestring-0.4.0.0"
 - "uuid-1.3.16"
 - "uuid-types-1.0.6"
-- "validity-0.12.1.0"
-- "vector-algorithms-0.9.0.2"
-- "vector-stream-0.1.0.1"
-- "wai-app-static-3.1.9"
-- "wai-extra-3.1.15"
-- "wai-logger-2.4.1"
+- "vector-algorithms-0.9.1.0"
+- "vector-space-0.19"
+- "wai-extra-3.1.17"
+- "wai-logger-2.5.0"
 - "wai-util-0.8"
-- "warp-3.3.31"
-- "wreq-0.5.4.3"
-- "zip-2.0.1"
-- "zip-archive-0.4.3.2"
+- "websockets-0.13.0.0"
+- "wuss-2.0.2.2"
 - "zlib-0.7.1.0"
 - commit: 334d05519436bb7f20f9926ec76418f5b8afa359
   git: "https://github.com/AccelerateHS/accelerate.git"
@@ -164,10 +110,6 @@
   git: "https://github.com/adinapoli/http-reverse-proxy.git"
   subdirs:
   - .
-- commit: a110807651036ca2228a76507ee35bbf7aedf87a
-  git: "https://github.com/alpmestan/accelerate-arithmetic.git"
-  subdirs:
-  - .
 - commit: b9fca8beee0f23c17a6b2001ec834d071709e6e7
   git: "https://github.com/alpmestan/hmatrix.git"
   subdirs:
@@ -180,10 +122,6 @@
   git: "https://github.com/boolexpr/boolexpr.git"
   subdirs:
   - .
-- commit: 1790fdf9138970dde0dbabf8b270698145a4a88c
-  git: "https://github.com/chessai/eigen.git"
-  subdirs:
-  - .
 - commit: 10a416b9f6c443866b36479c3441ebb3bcdeb7ef
   git: "https://github.com/delanoe/data-time-segment.git"
   subdirs:
@@ -204,10 +142,6 @@
   git: "https://github.com/haskell-github-trust/ekg-json"
   subdirs:
   - .
-- commit: a3875fe652d3bb5acb522674c22c6c814c1b4ad0
-  git: "https://gitlab.iscpif.fr/amestanogullari/accelerate-utility.git"
-  subdirs:
-  - .
 - commit: eb130c71fa17adaceed6ff66beefbccb13df51ba
   git: "https://gitlab.iscpif.fr/gargantext/crawlers/arxiv-api.git"
   subdirs:
@@ -236,10 +170,10 @@
   git: "https://gitlab.iscpif.fr/gargantext/crawlers/pubmed.git"
   subdirs:
   - .
-- commit: 588e104fe7593210956610cab0041fd16584a4ce
+- commit: a08ceed71b297a811f90cb86c3c61dc0b153036b
   git: "https://gitlab.iscpif.fr/gargantext/gargantext-graph.git"
   subdirs:
-  - .
+  - "gargantext-graph-core"
 - commit: 4a9c709613554eed0189b486de2126c18797088c
   git: "https://gitlab.iscpif.fr/gargantext/haskell-bee"
   subdirs:
@@ -252,7 +186,7 @@
   git: "https://gitlab.iscpif.fr/gargantext/haskell-bee"
   subdirs:
   - "haskell-bee/"
-- commit: bb15d828d5ef36eeaa84cccb00598b585048c88e
+- commit: 214b31a2db46de5a2cac24231a3c07a1c4c3fab9
   git: "https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude"
   subdirs:
   - .
@@ -284,7 +218,7 @@
   git: "https://gitlab.iscpif.fr/gargantext/opaleye-textsearch.git"
   subdirs:
   - .
-- commit: 3668d28607867a88b2dfc62158139b3cfd629ddb
+- commit: a591716220cfcabffa24eb29cbaa2517023642af
   git: "https://gitlab.iscpif.fr/gargantext/patches-class.git"
   subdirs:
   - .
@@ -343,6 +277,8 @@ flags:
     tagged: true
   "bytestring-builder":
     bytestring_has_builder: true
+  "bzlib-conduit":
+    "system-bzip2": true
   c2hs:
     base3: true
     regression: false
@@ -352,8 +288,6 @@ flags:
     "optimize-gmp": true
   cereal:
     "bytestring-builder": false
-  "cipher-aes":
-    support_aesni: true
   clock:
     llvm: false
   cmdargs:
@@ -416,13 +350,11 @@ flags:
     donotgetentropy: false
   fgl:
     containers042: true
-  "foldable1-classes-compat":
-    tagged: true
   formatting:
     "no-double-conversion": false
   gargantext:
     "enable-benchmarks": false
-    "no-phylo-debug-logs": false
+    "no-phylo-debug-logs": true
     "test-crypto": false
   graphviz:
     "test-parsing": false
@@ -465,7 +397,6 @@ flags:
   "json-stream":
     conduit: false
   "language-c":
-    allwarnings: false
     iecfpextension: true
     usebytestrings: true
   lens:
@@ -585,6 +516,8 @@ flags:
     "newtype-unsafe": true
   splitmix:
     "optimised-mixer": false
+  statistics:
+    benchpapi: false
   "streaming-commons":
     "use-bytestring-builder": false
   stringsearch:
@@ -606,9 +539,7 @@ flags:
   "time-locale-compat":
     "old-locale": false
   tls:
-    compat: true
-    hans: false
-    network: true
+    devel: false
   "transformers-base":
     orphaninstances: true
   "transformers-compat":
@@ -641,7 +572,6 @@ flags:
     boundschecks: true
     internalchecks: false
     llvm: false
-    properties: true
     unsafechecks: false
   void:
     safe: false
@@ -686,5 +616,5 @@ flags:
     standalone: true
 packages:
 - .
-resolver: "lts-21.25"
+resolver: "lts-22.43"
 "system-ghc": true

test-data/test_config.toml

@@ -52,6 +52,10 @@ user = "gargantua"
 pass = "gargantua_test"
 name = "gargandb_test"
 
+[logs]
+log_file = "/var/log/gargantext/backend.log"
+log_level = "warn"
+
 [mail]
 port = 25
 host = "localhost"

test/Test/API/Notifications.hs

@@ -19,19 +19,19 @@ module Test.API.Notifications (
     tests
   ) where
 
-import Control.Concurrent (threadDelay)
 import Control.Concurrent.STM.TChan
 import Control.Concurrent.STM.TSem (newTSem, signalTSem, TSem)
+import Control.Concurrent (threadDelay)
 import Control.Lens ((^.))
 import Control.Monad (void)
 import Control.Monad.STM (atomically)
 import Data.Aeson qualified as Aeson
 import Data.ByteString qualified as BS
-import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
+import Data.Text qualified as T
 import Fmt ((+|), (|+))
 import Gargantext.API.Admin.Auth.Types (AuthResponse, authRes_token, authRes_tree_id)
-import Gargantext.Core.Config (gc_notifications_config)
+import Gargantext.Core.Config (gc_logging, LogConfig)
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
 import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
 import Gargantext.Core.Notifications.Dispatcher.Types qualified as DT
@@ -47,9 +47,11 @@ import Test.Database.Types (test_config)
 import Test.Hspec
 import Test.Hspec.Wai.Internal (withApplication)
 import Test.Instances ()
-import Text.RawString.QQ (r)
-import Test.Utils (protected, waitForTChanValue, waitForTSem, withValidLoginA)
+import Test.Utils (waitForTChanValue, waitForTSem)
 import Test.Utils.Notifications (withAsyncWSConnection)
+import Test.Utils (protected, withValidLoginA)
+import Text.RawString.QQ (r)
+
 
 
 
@@ -57,7 +59,8 @@ tests :: Spec
 tests = sequential $ around withTestDBAndPort $ do
   describe "Notifications" $ do
     it "ping WS notification works" $ \(SpecContext testEnv port _app _) -> do
-      let nc = (test_config testEnv) ^. gc_notifications_config
+      let cfg     = test_config testEnv
+      let log_cfg = (test_config testEnv) ^. gc_logging
       -- withLogger () $ \ioL -> do
       --   logMsg ioL DEBUG $ "[ping WS notification works] nc: " <> show nc
 
@@ -68,18 +71,19 @@ tests = sequential $ around withTestDBAndPort $ do
       wsTSem <- atomically $ newTSem 0
       tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
 
-      withAsyncWSConnection ("127.0.0.1", port) (wsConnection topic wsTSem tchan) $ \_a -> do
+      withAsyncWSConnection ("127.0.0.1", port) (wsConnection log_cfg topic wsTSem tchan) $ \_a -> do
         -- wait for ws process to inform us about topic subscription
         waitForTSem wsTSem 500
 
         threadDelay 300_000
-        CE.notify nc $ CET.Ping
+        CE.notify cfg $ CET.Ping
 
         -- the ping value that should come from the notification
         waitForTChanValue tchan (Just DT.NPing) 1_000
 
     it "ping WS unsubscribe works" $ \(SpecContext testEnv port _app _) -> do
-      let nc = (test_config testEnv) ^. gc_notifications_config      
+      let cfg     = test_config testEnv
+      let log_cfg = (test_config testEnv) ^. gc_logging
       let topic = DT.Ping
 
       -- Setup a WS client connection. Subscribe to a topic and
@@ -90,7 +94,7 @@ tests = sequential $ around withTestDBAndPort $ do
       tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
 
       -- setup a websocket connection
-      let wsConnect conn = withLogger () $ \_ioL -> do
+      let wsConnect conn = withLogger log_cfg $ \_ioL -> do
             -- logMsg ioL DEBUG $ "[wsConnect] subscribing topic: " <> show topic
             WS.sendTextData conn $ Aeson.encode (DT.WSSubscribe topic)
             -- inform the test process that we sent the subscription request
@@ -122,7 +126,7 @@ tests = sequential $ around withTestDBAndPort $ do
         waitForTSem wsTSem 500
 
         threadDelay 300_000
-        CE.notify nc $ CET.Ping
+        CE.notify cfg $ CET.Ping
 
         -- the ping value that should come from the notification
         waitForTChanValue tchan (Just DT.NPing) 1_000
@@ -130,23 +134,21 @@ tests = sequential $ around withTestDBAndPort $ do
         -- wait for lock from ws (it should have unsubscribed by now)
         waitForTSem wsTSem 500
         -- send the notification (which the client shouldn't receive)
-        CE.notify nc $ CET.Ping
+        CE.notify cfg $ CET.Ping
         -- wait for the value
         waitForTChanValue tchan Nothing 1_000
 
     describe "Update tree notifications" $ do
       it "simple WS notification works" $ \(SpecContext testEnv port _app _) -> do
-        let nc = (test_config testEnv) ^. gc_notifications_config
-        
         let topic = DT.UpdateTree 0
         wsTSem <- atomically $ newTSem 0  -- initially locked
         tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
 
-        withAsyncWSConnection ("127.0.0.1", port) (wsConnection topic wsTSem tchan) $ \_a -> do
+        withAsyncWSConnection ("127.0.0.1", port) (wsConnection (test_config testEnv ^. gc_logging) topic wsTSem tchan) $ \_a -> do
           waitForTSem wsTSem 500
 
           let nodeId = 0
-          CE.notify nc $ CET.UpdateTreeFirstLevel nodeId
+          CE.notify (test_config testEnv) $ CET.UpdateTreeFirstLevel nodeId
 
           waitForTChanValue tchan (Just $ DT.NUpdateTree nodeId) 1_000
 
@@ -193,7 +195,7 @@ tests = sequential $ around withTestDBAndPort $ do
 checkNotification :: SpecContext a
                   -> (AuthResponse -> IO ())
                   -> IO ()
-checkNotification ctx@(SpecContext _testEnv port _app _) act = do
+checkNotification ctx@(SpecContext testEnv port _app _) act = do
   _ <- dbEnvSetup ctx
 
   withValidLoginA port "alice" (GargPassword "alice") $ \_clientEnv authRes -> do
@@ -204,21 +206,23 @@ checkNotification ctx@(SpecContext _testEnv port _app _) act = do
     wsTSem <- atomically $ newTSem 0  -- initially locked
     tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
 
-    withAsyncWSConnection ("127.0.0.1", port) (wsConnection topic wsTSem tchan) $ \_a -> do
+    withAsyncWSConnection ("127.0.0.1", port) (wsConnection log_cfg topic wsTSem tchan) $ \_a -> do
       waitForTSem wsTSem 500
 
       act authRes
 
       waitForTChanValue tchan (Just $ DT.NUpdateTree treeId) 1_000
+  where
+    log_cfg = (test_config testEnv) ^. gc_logging
 
 
-
-wsConnection :: DT.Topic
+wsConnection :: LogConfig
+             -> DT.Topic
              -> TSem
              -> TChan (Maybe DT.Notification)
              -> WS.Connection
              -> IO ()
-wsConnection topic wsTSem tchan conn = withLogger () $ \_ioL -> do
+wsConnection log_cfg topic wsTSem tchan conn = withLogger log_cfg $ \_ioL -> do
   -- logMsg ioL DEBUG $ "[wsConnect] subscribing topic: " <> show topic
   WS.sendTextData conn $ Aeson.encode (DT.WSSubscribe topic)
   -- inform the test process that we sent the subscription request

test/Test/API/Private/Remote.hs

@@ -32,10 +32,10 @@ withTwoServerInstances :: (SpecContext (TestEnv,Wai.Application,Warp.Port) -> IO
 withTwoServerInstances action =
   withTestDB $ \testEnv1 -> do
     withTestDB $ \testEnv2 -> do
-      garg1App <- withLoggerHoisted Mock $ \ioLogger -> do
+      garg1App <- withLoggerIO Mock $ \ioLogger -> do
                    env <- newTestEnv testEnv1 ioLogger server1Port
                    makeApp env
-      garg2App <- withLoggerHoisted Mock $ \ioLogger -> do
+      garg2App <- withLoggerIO Mock $ \ioLogger -> do
                    env <- newTestEnv testEnv2 ioLogger server2Port
                    makeApp env
 

test/Test/API/Setup.hs

@@ -20,13 +20,15 @@ import Control.Monad.Reader
 import Data.ByteString.Lazy.Char8 qualified as C8L
 import Data.Cache qualified as InMemory
 import Data.Streaming.Network (bindPortTCP)
-import Gargantext.API (makeApp)
 import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..), env_dispatcher)
 import Gargantext.API.Errors.Types
+import Gargantext.API (makeApp)
 import Gargantext.API.Prelude
-import Gargantext.Core.Notifications (withNotifications)
+import Gargantext.Core.Config (gc_logging)
+import Gargantext.Core.Config (gc_notifications_config)
 import Gargantext.Core.Config (_gc_secrets, gc_frontend_config)
 import Gargantext.Core.Config.Types (NotificationsConfig(..), fc_appPort, jwtSettings)
+import Gargantext.Core.Notifications (withNotifications)
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Action.Flow
 import Gargantext.Database.Action.User.New
@@ -44,10 +46,10 @@ import Network.HTTP.Client.TLS (newTlsManager)
 import Network.HTTP.Types
 import Network.Wai (Application, responseLBS)
 import Network.Wai.Handler.Warp.Internal
-import Network.WebSockets qualified as WS
 import Network.Wai.Handler.Warp qualified as Warp
 import Network.Wai.Handler.Warp (runSettingsSocket)
 import Network.Wai qualified as Wai
+import Network.WebSockets qualified as WS
 import Prelude hiding (show)
 import Servant.Auth.Client ()
 import Test.Database.Setup (withTestDB)
@@ -108,9 +110,9 @@ nc = NotificationsConfig { _nc_central_exchange_bind = "tcp://*:15560"
 -- | Run the gargantext server on a random port, picked by Warp, which allows
 -- for concurrent tests to be executed in parallel, if we need to.
 withTestDBAndPort :: (SpecContext () -> IO ()) -> IO ()
-withTestDBAndPort action = withNotifications nc $ \dispatcher -> do
-  withTestDB $ \testEnv -> do    
-    withLoggerHoisted Mock $ \ioLogger -> do
+withTestDBAndPort action = withTestDB $ \testEnv -> do
+  withNotifications (cfg testEnv) $ \dispatcher -> do
+    withLoggerIO Mock $ \ioLogger -> do
       env <- newTestEnv testEnv ioLogger 8080
              <&> env_dispatcher .~ dispatcher
       app <- makeApp env
@@ -124,30 +126,32 @@ withTestDBAndPort action = withNotifications nc $ \dispatcher -> do
         [ Handler $ \(err :: WS.ConnectionException) ->
             case err of
               WS.CloseRequest _ _ ->
-                withLogger () $ \ioLogger' ->
+                withLogger (log_cfg testEnv) $ \ioLogger' ->
                   logTxt ioLogger' DEBUG "[withTestDBAndPort] CloseRequest caught"
               WS.ConnectionClosed ->
-                withLogger () $ \ioLogger' ->
+                withLogger (log_cfg testEnv) $ \ioLogger' ->
                   logTxt ioLogger' DEBUG "[withTestDBAndPort] ConnectionClosed caught"
               _ -> do
-                withLogger () $ \ioLogger' ->
+                withLogger (log_cfg testEnv) $ \ioLogger' ->
                   logTxt ioLogger' ERROR $ "[withTestDBAndPort] unknown exception: " <> show err
                 throw err
 
         -- re-throw any other exceptions
         , Handler $ \(err :: SomeException) -> throw err ]
-        
+  where
+    cfg te     = (test_config te) & gc_notifications_config .~ nc
+    log_cfg te = (cfg te) ^. gc_logging
 
 -- | Starts the backend server /and/ the microservices proxy, the former at
 -- a random port, the latter at a predictable port.
 withBackendServerAndProxy :: (((TestEnv, Warp.Port, Warp.Port)) -> IO ()) -> IO ()
 withBackendServerAndProxy action =
   withTestDB $ \testEnv -> do
-    gargApp <- withLoggerHoisted Mock $ \ioLogger -> do
+    gargApp <- withLoggerIO Mock $ \ioLogger -> do
                  env <- newTestEnv testEnv ioLogger 8080
                  makeApp env
     proxyCache <- InMemory.newCache Nothing
-    proxyApp <- withLoggerHoisted Mock $ \ioLogger -> do
+    proxyApp <- withLoggerIO Mock $ \ioLogger -> do
                   env <- newTestEnv testEnv ioLogger 8080
                   pure $ microServicesProxyApp proxyCache env
 

test/Test/API/UpdateList.hs

@@ -29,18 +29,18 @@ import Control.Lens (mapped, over)
 import Control.Monad.Fail (fail)
 import Data.Aeson qualified as JSON
 import Data.Aeson.QQ
-import Data.Map.Strict qualified as Map
 import Data.Map.Strict.Patch qualified as PM
+import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
-import Data.Text qualified as T
 import Data.Text.IO qualified as TIO
+import Data.Text qualified as T
 import Fmt
 import Gargantext.API.Admin.Auth.Types (Token)
 import Gargantext.API.Errors
 import Gargantext.API.HashedResponse
-import Gargantext.API.Ngrams qualified as APINgrams
 import Gargantext.API.Ngrams.List ( ngramsListFromTSVData )
 import Gargantext.API.Ngrams.List.Types (WithJsonFile(..), WithTextFile(..))
+import Gargantext.API.Ngrams qualified as APINgrams
 import Gargantext.API.Ngrams.Types
 import Gargantext.API.Node.Corpus.New.Types qualified as FType
 import Gargantext.API.Node.Types
@@ -49,6 +49,7 @@ import Gargantext.API.Routes.Named.Corpus (addWithTempFileEp)
 import Gargantext.API.Routes.Named.Node
 import Gargantext.API.Routes.Named.Private
 import Gargantext.API.Worker (workerAPIPost)
+import Gargantext.Core.Config
 import Gargantext.Core qualified as Lang
 import Gargantext.Core.Text.Corpus.Query (RawQuery(..))
 import Gargantext.Core.Text.List.Social
@@ -61,6 +62,7 @@ import Gargantext.Database.Query.Facet qualified as Facet
 import Gargantext.Prelude hiding (get)
 import Network.Wai.Handler.Warp qualified as Wai
 import Paths_gargantext (getDataFileName)
+import qualified Prelude
 import Servant.Client.Streaming
 import System.FilePath
 import Test.API.Prelude (checkEither, newCorpusForUser, newPrivateFolderForUser)
@@ -73,16 +75,16 @@ import Test.Hspec.Wai.JSON (json)
 import Test.Types (JobPollHandle(..))
 import Test.Utils (pollUntilWorkFinished, protectedJSON, withValidLogin)
 import Text.Printf (printf)
-import qualified Prelude
 
 
-uploadJSONList :: Wai.Port
+uploadJSONList :: LogConfig
+               -> Wai.Port
                -> Token
                -> CorpusId
                -> FilePath
                -> ClientEnv
                -> WaiSession () ListId
-uploadJSONList port token cId pathToNgrams clientEnv = do
+uploadJSONList log_cfg port token cId pathToNgrams clientEnv = do
   ([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeList","pn_name":"Testing"}|]
   -- Upload the JSON doc
   simpleNgrams' <- liftIO (TIO.readFile =<< getDataFileName pathToNgrams)
@@ -99,7 +101,7 @@ uploadJSONList port token cId pathToNgrams clientEnv = do
   -- j' <- pollUntilFinished token port mkPollUrl j
   ji <- checkEither $ liftIO $ runClientM (add_form_to_list token listId params) clientEnv
   -- liftIO (_jph_status j' `shouldBe` "IsFinished")
-  ji' <- pollUntilWorkFinished port ji
+  ji' <- pollUntilWorkFinished log_cfg port ji
   liftIO $ ji' `shouldBe` ji
   
   pure listId
@@ -114,9 +116,10 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
 
       it "allows uploading a JSON ngrams file" $ \(SpecContext testEnv port app _) -> do
         cId <- newCorpusForUser testEnv "alice"
+        let log_cfg = (test_config testEnv) ^. gc_logging
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
-            listId <- uploadJSONList port token cId "test-data/ngrams/simple.json" clientEnv
+            listId <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
 
             -- Now check that we can retrieve the ngrams
             liftIO $ do
@@ -138,6 +141,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
 
       it "does not create duplicates when uploading JSON (#313)" $ \(SpecContext testEnv port app _) -> do
         cId <- newCorpusForUser testEnv "alice"
+        let log_cfg = (test_config testEnv) ^. gc_logging
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
             -- this term is imported from the .json file
@@ -145,7 +149,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
             -- this is the new term, under which importedTerm will be grouped
             let newTerm = NgramsTerm "new abelian group"
 
-            listId <- uploadJSONList port token cId "test-data/ngrams/simple.json" clientEnv
+            listId <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
 
             let checkNgrams expected = do
                   eng <- liftIO $ runClientM (get_table_ngrams token cId APINgrams.Terms listId 10 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
@@ -186,7 +190,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
             -- finally, upload the list again, the group should be as
             -- it was before (the bug in #313 was that "abelian group"
             -- was created again as a term with no parent)
-            _ <- uploadJSONList port token cId "test-data/ngrams/simple.json" clientEnv
+            _ <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
 
             -- old (imported) term shouldn't become parentless
             -- (#313 error was that we had [newTerm, importedTerm] instead)
@@ -215,6 +219,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
 
       it "allows uploading a CSV ngrams file" $ \(SpecContext testEnv port app _) -> do
         cId <- newCorpusForUser testEnv "alice"
+        let log_cfg = (test_config testEnv) ^. gc_logging
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
             ([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeList","pn_name":"Testing"}|]
@@ -224,7 +229,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
                                       , _wtf_data = simpleNgrams
                                       , _wtf_name = "simple.tsv" }
             ji <- checkEither $ liftIO $ runClientM (add_tsv_to_list token listId params) clientEnv
-            _ <- pollUntilWorkFinished port ji
+            _ <- pollUntilWorkFinished log_cfg port ji
 
             -- Now check that we can retrieve the ngrams
             liftIO $ do
@@ -262,6 +267,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
             void $ createFortranDocsList testEnv port clientEnv token
 
       it "doesn't use trashed documents for score calculation (#385)" $ \(SpecContext testEnv port app _) -> do
+        let log_cfg = (test_config testEnv) ^. gc_logging
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
             corpusId <- createFortranDocsList testEnv port clientEnv token
@@ -280,7 +286,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
               pure tr1
 
 
-            termsNodeId <- uploadJSONList port token corpusId "test-data/ngrams/GarganText_NgramsTerms-nodeId-177.json" clientEnv
+            termsNodeId <- uploadJSONList log_cfg port token corpusId "test-data/ngrams/GarganText_NgramsTerms-nodeId-177.json" clientEnv
 
             liftIO $ do
               -- Now let's check the score for the \"fortran\" ngram.
@@ -348,19 +354,26 @@ createDocsList testDataPath testEnv port clientEnv token = do
   simpleDocs <- liftIO (TIO.readFile =<< getDataFileName testDataPath)
   let newWithForm = mkNewWithForm simpleDocs (T.pack $ takeBaseName testDataPath)
   ji <- checkEither $ liftIO $ runClientM (add_file_async token corpusId newWithForm) clientEnv
-  ji' <- pollUntilWorkFinished port ji
+  ji' <- pollUntilWorkFinished log_cfg port ji
   liftIO $ ji' `shouldBe` ji
   pure corpusId
+  where
+    log_cfg = (test_config testEnv) ^. gc_logging
 
 createFortranDocsList :: TestEnv -> Int -> ClientEnv -> Token -> WaiSession () CorpusId
 createFortranDocsList testEnv port =
   createDocsList "test-data/ngrams/GarganText_DocsList-nodeId-177.json" testEnv port
 
-updateNode :: Int -> ClientEnv -> Token -> NodeId -> WaiSession () ()
-updateNode port clientEnv token nodeId = do
+updateNode :: LogConfig
+           -> Int
+           -> ClientEnv
+           -> Token
+           -> NodeId
+           -> WaiSession () ()
+updateNode log_cfg port clientEnv token nodeId = do
   let params = UpdateNodeParamsTexts Both
   ji <- checkEither $ liftIO $ runClientM (update_node token nodeId params) clientEnv
-  ji' <- pollUntilWorkFinished port ji
+  ji' <- pollUntilWorkFinished log_cfg port ji
   liftIO $ ji' `shouldBe` ji
 
 mkNewWithForm :: T.Text -> T.Text -> NewWithForm

test/Test/Database/Operations.hs

@@ -10,7 +10,6 @@ module Test.Database.Operations (
    , nodeStoryTests
   ) where
 
-import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE

test/Test/Database/Setup.hs

@@ -2,7 +2,7 @@
 
 module Test.Database.Setup (
     withTestDB
-  , fakeTomlPath
+  , testTomlPath
   , testEnvToPgConnectionInfo
   ) where
 
@@ -28,7 +28,7 @@ import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
 import Gargantext.Core.Worker (initWorkerState)
 import Gargantext.Core.Worker.Env (WorkerEnv(..))
 import Gargantext.Prelude
-import Gargantext.System.Logging (withLoggerHoisted)
+import Gargantext.System.Logging (withLoggerIO)
 import Paths_gargantext
 import Prelude qualified
 import Shelly hiding (FilePath, run)
@@ -43,8 +43,8 @@ dbUser = "gargantua"
 dbPassword = "gargantua_test"
 dbName = "gargandb_test"
 
-fakeTomlPath :: IO SettingsFile
-fakeTomlPath = SettingsFile <$> getDataFileName "test-data/test_config.toml"
+testTomlPath :: IO SettingsFile
+testTomlPath = SettingsFile <$> getDataFileName "test-data/test_config.toml"
 
 gargDBSchema :: IO FilePath
 gargDBSchema = getDataFileName "devops/postgres/schema.sql"
@@ -81,7 +81,7 @@ setup = do
     Left err -> Prelude.fail $ show err
     Right db -> do
       let connInfo = tmpDBToConnInfo db
-      gargConfig <- fakeTomlPath >>= readConfig
+      gargConfig <- testTomlPath >>= readConfig
                     -- fix db since we're using tmp-postgres
                     <&> (gc_database_config .~ connInfo)
                     -- <&> (gc_worker . wsDatabase .~ connInfo)
@@ -98,7 +98,7 @@ setup = do
       bootstrapDB db pool gargConfig
       ugen <- emptyCounter
       test_nodeStory <- fromDBNodeStoryEnv pool
-      withLoggerHoisted Mock $ \logger -> do
+      withLoggerIO Mock $ \logger -> do
 
         let wPoolConfig = defaultPoolConfig (PG.connectPostgreSQL (Tmp.toConnectionString db))
                                             PG.close
@@ -107,7 +107,7 @@ setup = do
         wPool <- newPool (setNumStripes (Just 4) wPoolConfig)
         wNodeStory <- fromDBNodeStoryEnv wPool
         _w_env_job_state <- newTVarIO Nothing
-        withLoggerHoisted Mock $ \wioLogger -> do
+        withLoggerIO Mock $ \wioLogger -> do
           let wEnv = WorkerEnv { _w_env_config = gargConfig
                                , _w_env_logger = wioLogger
                                , _w_env_pool = wPool

test/Test/Database/Types.hs

@@ -144,6 +144,9 @@ instance HasLogger (GargM TestEnv BackendInternalError) where
     pure $ GargTestLogger mode test_logger_set
   destroyLogger GargTestLogger{..} = liftIO $ FL.rmLoggerSet test_logger_set
   logMsg (GargTestLogger 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

test/Test/Utils.hs

@@ -35,19 +35,20 @@ import Control.Concurrent.STM.TSem (TSem, waitTSem)
 import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVarIO)
 import Control.Exception.Safe ()
 import Control.Monad ()
-import Data.Aeson qualified as JSON
 import Data.Aeson.KeyMap qualified as KM
+import Data.Aeson qualified as JSON
 import Data.ByteString.Char8 qualified as B
 import Data.ByteString.Lazy qualified as L
 import Data.Map.Strict qualified as Map
-import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
-import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.Encoding qualified as TLE
+import Data.Text.Lazy qualified as TL
+import Data.Text qualified as T
 import Data.TreeDiff
 import Gargantext.API.Admin.Auth.Types (AuthRequest(..), AuthResponse, Token, authRes_token)
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Routes.Types (xGargErrorScheme)
+import Gargantext.Core.Config (LogConfig)
 import Gargantext.Core.Notifications.Dispatcher.Types qualified as DT
 import Gargantext.Core.Types.Individu (Username, GargPassword)
 import Gargantext.Core.Worker.Types (JobInfo(..))
@@ -55,21 +56,21 @@ import Gargantext.Prelude
 import Gargantext.System.Logging (withLogger, logMsg, LogLevel(..))
 import Network.HTTP.Client (defaultManagerSettings, newManager)
 import Network.HTTP.Client qualified as HTTP
-import Network.HTTP.Types (Header, Method, status200)
 import Network.HTTP.Types.Header (hAccept, hAuthorization, hContentType)
+import Network.HTTP.Types (Header, Method, status200)
 import Network.Wai.Handler.Warp (Port)
 import Network.Wai.Test (SResponse(..))
 import Network.WebSockets qualified as WS
 import Prelude qualified
-import Servant.Client.Streaming (ClientEnv, baseUrlPort, mkClientEnv, parseBaseUrl, runClientM, makeClientRequest, defaultMakeClientRequest)
 import Servant.Client.Core (BaseUrl)
 import Servant.Client.Core.Request qualified as Client
+import Servant.Client.Streaming (ClientEnv, baseUrlPort, mkClientEnv, parseBaseUrl, runClientM, makeClientRequest, defaultMakeClientRequest)
 import System.Environment (lookupEnv)
 import System.Timeout qualified as Timeout
 import Test.API.Routes (auth_api)
 import Test.Hspec.Expectations
-import Test.Hspec.Wai (MatchBody(..), WaiExpectation, WaiSession, request)
 import Test.Hspec.Wai.JSON (FromValue(..))
+import Test.Hspec.Wai (MatchBody(..), WaiExpectation, WaiSession, request)
 import Test.Hspec.Wai.Matcher (MatchHeader(..), ResponseMatcher(..), bodyEquals, formatHeader, match)
 import Test.Tasty.HUnit (Assertion, assertBool)
 import Test.Utils.Notifications (withWSConnection, millisecond)
@@ -252,10 +253,11 @@ gargMkRequest traceEnabled bu clientRq = do
 
 
 pollUntilWorkFinished :: HasCallStack
-                      => Port
+                      => LogConfig
+                      -> Port
                       -> JobInfo
                       -> WaiSession () JobInfo
-pollUntilWorkFinished port ji = do
+pollUntilWorkFinished log_cfg port ji = do
   let waitSecs = 60
   isFinishedTVar <- liftIO $ newTVarIO False
   let wsConnect =
@@ -271,11 +273,11 @@ pollUntilWorkFinished port ji = do
             case dec of
               Nothing -> pure ()
               Just (DT.NUpdateWorkerProgress ji' jl) -> do
-                withLogger () $ \ioL ->
+                withLogger log_cfg $ \ioL ->
                   logMsg ioL DEBUG $ "[pollUntilWorkFinished] received " <> show ji' <> ", " <> show jl
                 if ji' == ji && isFinished jl
                 then do
-                  withLogger () $ \ioL ->
+                  withLogger log_cfg $ \ioL ->
                     logMsg ioL DEBUG $ "[pollUntilWorkFinished] FINISHED! " <> show ji'
                   atomically $ writeTVar isFinishedTVar True
                 else
@@ -288,7 +290,7 @@ pollUntilWorkFinished port ji = do
             finished <- readTVarIO isFinishedTVar
             if finished
               then do
-                withLogger () $ \ioL ->
+                withLogger log_cfg $ \ioL ->
                   logMsg ioL DEBUG $ "[pollUntilWorkFinished] JOB FINISHED: " <> show ji
                 return True
               else do

test/drivers/hspec/Main.hs

@@ -6,9 +6,10 @@ import Control.Monad
 import Data.Text (isInfixOf)
 import Data.Text qualified as T
 import Gargantext.Prelude hiding (isInfixOf)
-import Shelly hiding (FilePath)
 import System.IO
 import System.Process
+import System.Posix.Process
+import System.Posix.Signals
 import Test.API qualified as API
 import Test.Database.Operations qualified as DB
 import Test.Hspec
@@ -21,7 +22,13 @@ startCoreNLPServer = do
   devNull <- openFile "/dev/null" WriteMode
   let p = proc "./startServer.sh" []
   (_, _, _, hdl) <- (createProcess $ p { cwd = Just "devops/coreNLP/stanford-corenlp-current"
-                    , delegate_ctlc = True
+                    -- NOTE(adn) Issue #451, this one has to stay disabled, because if we
+                    -- turn it on, despite the confusing documentation on the `process` library
+                    -- it will cause the Haskell RTS to completely ignore the Ctrl^c and instead
+                    -- delegate it exclusively to the process here, which means that our CoreNLP
+                    -- server will shut down correctly, but the test running will stop responding
+                    -- to Ctrl^C requests.
+                    , delegate_ctlc = False
                     , create_group = True
                     , std_out = UseHandle devNull
                     , std_err = UseHandle devNull
@@ -34,12 +41,14 @@ startCoreNLPServer = do
                                              | otherwise -> throwIO e
   pure hdl
 
-stopCoreNLPServer :: ProcessHandle -> IO ()
-stopCoreNLPServer ph = do
-  putText "calling stop core nlp"
-  interruptProcessGroupOf ph
-  putText "calling stop core nlp - done"
-
+killProcessTree :: ProcessHandle -> IO ()
+killProcessTree ph = do
+  pid <- getPid ph
+  case pid of
+    Nothing -> putText "Process already terminated"
+    Just p -> do
+      pgid <- getProcessGroupIDOf p
+      signalProcessGroup keyboardSignal pgid
 
 -- It's especially important to use Hspec for DB tests, because,
 -- unlike 'tasty', 'Hspec' has explicit control over parallelism,
@@ -55,9 +64,9 @@ stopCoreNLPServer ph = do
 main :: IO ()
 main = do
   hSetBuffering stdout NoBuffering
-  -- TODO Ideally remove start/stop notifications and use
-  -- Test/API/Setup to initialize this in env
-  bracket startCoreNLPServer stopCoreNLPServer $ \_ -> hspec $ sequential $ do
+  bracket startCoreNLPServer killProcessTree (const run_tests)
+  where
+    run_tests = hspec $ sequential $ do
       API.tests
       ReverseProxy.tests
       DB.tests