Merge branch 'dev' into 238-dev-async-job-worker

CHANGELOG.md

+## Version 0.0.7.2
+
+* [FRONT][FEAT][Graph Explorer Legend (#683)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/683)
+* [FRONT][FIX][[Graph explorer] Search and associated documents (#262)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/262)
+* [BACK][FIX][Terms are calculated over all documents, even those in trash (#385)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/385)
+* [BACK][FIX][Improve document search (and better error reporting) (#265)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/265)
+* [BACK][FEAT][Add websockets support (#341)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341)
+
 ## Version 0.0.7.1.16
 
 * [BACK][FI][API with Open Alex seems down (#379)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/379)

README.md

@@ -317,9 +317,21 @@ Maybe you need to restore the gargantua password
 $ ALTER ROLE gargantua PASSWORD 'yourPasswordIn_gargantext.ini'
 ```
 Maybe you need to change the port to 5433 for database connection in your gargantext.ini file.
+
+## `haskell-language-server`
+
+If you want to use `haskell-language-server` for GHC 9.4.7, install it
+with `ghcup`:
+```shell
+ghcup compile hls --version 2.7.0.0 --ghc 9.4.7
+```
+https://haskell-language-server.readthedocs.io/en/latest/installation.html
+
+
 # Async workers
 
 To run the worker, follow these steps:
 - run Redis with: `podman run --rm -it -p 6379:6379 redis:latest`
 - `"simple"` worker definition is in `gargantext-settings.toml`
 - run worker: `cabal v2-run gargantext-cli -- worker --name simple`
+

bench/Main.hs

-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications  #-}
+
 module Main where
 
 import Control.DeepSeq

bin/gargantext-central-exchange/Main.hs

+{-|
+Module      : Main.hs
+Description : Gargantext central exchange for async notifications
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+ -}
+
+{-# LANGUAGE Strict            #-}
+
+module Main where
+
+import Control.Concurrent (threadDelay)
+import Control.Monad (join, mapM_)
+import Data.ByteString.Char8 qualified as C
+import Data.Text qualified as T
+import Gargantext.Core.AsyncUpdates.CentralExchange (gServer)
+import Gargantext.Core.AsyncUpdates.Constants (ceBind, ceConnect)
+import Gargantext.Prelude
+import Nanomsg
+import Options.Applicative
+
+
+data Command =
+    CEServer
+  | SimpleServer
+  | WSServer
+  | Client
+
+
+parser :: Parser (IO ())
+parser = subparser
+    ( command "ce-server" (info (pure gServer) idm)
+   <> command "simple-server" (info (pure simpleServer) idm)
+   <> command "ws-server" (info (pure wsServer) idm)
+   <> command "client" (info (pure gClient) idm) )
+
+
+main :: IO ()
+main = join $ execParser (info parser idm)
+
+simpleServer :: IO ()
+simpleServer = do
+  withSocket Pull $ \s -> do
+    _ <- bind s ceBind
+    putText "[simpleServer] receiving"
+    forever $ do
+      mr <- recvMalloc s 1024
+      C.putStrLn mr
+      -- case mr of
+      --   Nothing -> pure ()
+      --   Just r -> C.putStrLn r
+      -- threadDelay 10000
+
+wsServer :: IO ()
+wsServer = do
+  withSocket Pull $ \ws -> do
+    _ <- bind ws "ws://*:5560"
+    forever $ do
+      putText "[wsServer] receiving"
+      r <- recv ws
+      C.putStrLn r
+    
+gClient :: IO ()
+gClient = do
+    withSocket Push $ \s -> do
+      _ <- connect s ceConnect
+      -- let str = C.unwords (take 10 $ repeat "hello")
+      let str = "{\"type\": \"update_tree_first_level\", \"node_id\": -1}"
+      C.putStrLn $ C.pack "sending: " <> str
+      send s str
+
+    withSocket Push $ \s -> do
+      _ <- connect s ceConnect
+      let str2 = "{\"type\": \"update_tree_first_level\", \"node_id\": -2}"
+      C.putStrLn $ C.pack "sending: " <> str2
+      send s str2
+

bin/gargantext-cli/CLI/Invitations.hs

@@ -23,6 +23,7 @@ import Gargantext.API.Errors.Types
 import Gargantext.API.Node () -- instances only
 import Gargantext.API.Node.Share qualified as Share
 import Gargantext.API.Node.Share.Types qualified as Share
+import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
 import Gargantext.Core.Config (readConfig)
 import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.Types
@@ -36,7 +37,10 @@ invitationsCLI :: InvitationsArgs -> IO ()
 invitationsCLI (InvitationsArgs iniPath settingsPath user node_id email) = do
   _cfg       <- readConfig         (_IniFile iniPath)
 
-  let invite :: (HasSettings env, CmdRandom env BackendInternalError m, HasNLPServer env) => m Int
+  let invite :: ( HasSettings env
+                , CmdRandom env BackendInternalError m
+                , HasNLPServer env
+                , CET.HasCentralExchangeNotification env ) => m Int
       invite = Share.api (UserName $ cs user) node_id (Share.ShareTeamParams $ cs email)
 
   withDevEnv iniPath settingsPath $ \env -> do

bin/gargantext-cli/CLI/Phylo/Common.hs

-{-# LANGUAGE OverloadedStrings #-}
 module CLI.Phylo.Common where
 
 import Control.Concurrent.Async (mapConcurrently)

bin/gargantext-cli/CLI/Phylo/Profile.hs

-{-# LANGUAGE OverloadedStrings #-}
 module CLI.Phylo.Profile where
 
 import CLI.Phylo.Common

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

@@ -18,6 +18,7 @@ import Options.Applicative
 import Prelude
 import Servant.API
 import Servant.API.Routes
+import Servant.API.WebSocket qualified as WS (WebSocketPending)
 import Servant.Auth qualified as Servant
 
 routesCmd :: Mod CommandFields CLI
@@ -42,6 +43,9 @@ export_p = CLIR_export <$>
 instance HasRoutes api => HasRoutes (Servant.Auth xs a :> api) where
   getRoutes = getRoutes @api
 
+instance HasRoutes WS.WebSocketPending where
+  getRoutes = []
+
 instance HasRoutes Raw where
   getRoutes = []
 

bin/install

@@ -4,5 +4,5 @@ echo "GarganText, build, install, test and documentation"
 nix-shell --run "cabal update                                     \\
                  && cabal v2-build --ghc-options=-O2              \\
                  && cabal --overwrite-policy=always install       \\
-                 && cabal v2-test --test-show-details=streaming   \\
+                 && cabal v2-test                               \\
                  && cabal haddock"

bin/track_haskell_deps.hs

@@ -12,11 +12,8 @@ stack exec ghc -- --make -O2 -threaded scripts/haskell/dependencies.hs
 -}
 
 {-# LANGUAGE BangPatterns        #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections       #-}
-{-# LANGUAGE NumericUnderscores  #-}
 {-# LANGUAGE ViewPatterns        #-}
 
 module Main where

bin/update-project-dependencies

@@ -18,8 +18,10 @@ fi
 # with the `sha256sum` result calculated on the `cabal.project` and
 # `cabal.project.freeze`. This ensures the files stay deterministic so that CI
 # cache can kick in.
-expected_cabal_project_hash="66d93bf833eaa39e8f06c3f3c79d87ad9418438b959a79ab5fc11551d67015a3"
-expected_cabal_project_freeze_hash="05ee74fc30b25edf135f4f9c53a2c134752184545b7a9e837f27e36d507a7a80"
+expected_cabal_project_hash="9c487a789f77d9a96b4ac6a4b6268a075a72b8a391d987ba12194a46d96f6ee8"
+expected_cabal_project_freeze_hash="50f3ccea242400c48bd9cec7286bd07c8223c87c043e09576dd5fef0949f982a"
+
+
 
 cabal --store-dir=$STORE_DIR v2-build --dry-run
 cabal2stack --system-ghc --allow-newer --resolver lts-21.17 --resolver-file devops/stack/lts-21.17.yaml -o stack.yaml

cabal.project

@@ -29,7 +29,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/opaleye-textsearch.git
-    tag: cb07b604bfb7a22aa21dd8918de5cb65c8a4bdf1
+    tag: 04b5c9044fef44393b66bffa258ca0b0f59c1087
 
 source-repository-package
     type: git
@@ -165,6 +165,16 @@ source-repository-package
     location: https://github.com/robstewart57/rdf4h.git
     tag: 4fd2edf30c141600ffad6d730cc4c1c08a6dbce4
 
+source-repository-package
+    type: git
+    location: https://github.com/garganscript/nanomsg-haskell
+    tag: 23be4130804d86979eaee5caffe323a1c7f2b0d6
+    
+-- source-repository-package
+--     type: git
+--     location: https://github.com/jimenezrick/nng-haskell
+--     tag: 31e52d7bc720e5fb9daf1c1e8bc1fd156d577af2
+        
 source-repository-package
     type: git
     location: https://github.com/adinapoli/http-reverse-proxy.git
@@ -183,8 +193,14 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/haskell-bee
-    tag: da1a7aaadddb5cfc940243c787ddb2575869f6c9
+    tag: d159ed580acde0bbdbd7b3b1c33fe1a7d5cff34f
+
+source-repository-package
+    type: git
+    location: https://gitlab.iscpif.fr/gargantext/haskell-throttle
+    tag: 02f5ed9ee2d6cce45161addf945b88bc6adf9059
 
+        
 allow-older: *
 allow-newer: *
 

cabal.project.freeze

@@ -167,6 +167,7 @@ constraints: any.Cabal ==3.8.1.0,
              any.data-time-segment ==0.1.0.0,
              any.dec ==0.0.5,
              any.deepseq ==1.4.8.0,
+             any.deferred-folds ==0.9.18.6,
              any.dense-linear-algebra ==0.1.0.0,
              any.deriving-aeson ==0.2.9,
              any.digest ==0.0.1.7,
@@ -205,8 +206,10 @@ constraints: any.Cabal ==3.8.1.0,
              any.filepath ==1.4.2.2,
              any.filepattern ==0.1.3,
              any.fmt ==0.6.3.0,
+             any.focus ==1.0.3.2,
              any.foldable1-classes-compat ==0.1,
              foldable1-classes-compat +tagged,
+             any.foldl ==1.4.15,
              any.formatting ==7.2.0,
              formatting +no-double-conversion,
              any.free ==5.1.10,
@@ -250,6 +253,7 @@ constraints: any.Cabal ==3.8.1.0,
              any.haskell-lexer ==1.1.1,
              any.haskell-src-exts ==1.23.1,
              any.haskell-src-meta ==0.8.12,
+             any.haskell-throttle ==0.1.0.0,
              any.hedgehog ==1.2,
              any.hgal ==2.0.0.2,
              any.hlcm ==0.2.2,
@@ -330,6 +334,7 @@ constraints: any.Cabal ==3.8.1.0,
              libyaml -no-unicode -system-libyaml,
              any.lifted-async ==0.10.2.4,
              any.lifted-base ==0.2.3.12,
+             any.list-t ==1.0.5.7,
              any.listsafe ==0.1.0.1,
              any.llvm-hs ==12.0.0,
              llvm-hs -debug -llvm-with-rtti +shared-llvm,
@@ -377,6 +382,7 @@ constraints: any.Cabal ==3.8.1.0,
              any.mtl-compat ==0.2.2,
              mtl-compat -two-point-one -two-point-two,
              any.mwc-random ==0.15.0.2,
+             any.nanomsg-haskell ==0.2.4,
              any.natural-transformation ==0.4,
              any.network ==3.1.4.0,
              network -devel,
@@ -387,7 +393,7 @@ constraints: any.Cabal ==3.8.1.0,
              any.old-locale ==1.0.0.7,
              any.old-time ==1.1.0.3,
              any.opaleye ==0.9.6.1,
-             any.opaleye-textsearch ==0.1.0.0,
+             any.opaleye-textsearch ==0.2.0.0,
              any.openalex ==0.1.0.0,
              any.optics-core ==0.4.1.1,
              optics-core -explicit-generic-labels,
@@ -432,6 +438,8 @@ constraints: any.Cabal ==3.8.1.0,
              prettyprinter -buildreadme +text,
              any.prettyprinter-ansi-terminal ==1.1.3,
              any.primitive ==0.8.0.0,
+             any.primitive-extras ==0.10.1.10,
+             any.primitive-unlifted ==2.1.0.0,
              any.probability ==0.2.8,
              probability +splitbase,
              any.process ==1.6.17.0,
@@ -509,6 +517,7 @@ constraints: any.Cabal ==3.8.1.0,
              any.servant-swagger ==1.2,
              any.servant-swagger-ui ==0.3.5.5.0.0,
              any.servant-swagger-ui-core ==0.3.5,
+             any.servant-websockets ==2.0.0,
              any.servant-xml-conduit ==0.1.0.4,
              any.shelly ==1.12.1,
              shelly -build-examples -lifted,
@@ -541,7 +550,9 @@ constraints: any.Cabal ==3.8.1.0,
              any.stemmer ==0.5.2,
              any.stm ==2.5.1.0,
              any.stm-chans ==3.0.0.9,
+             any.stm-containers ==1.2.0.3,
              any.stm-delay ==0.1.1.1,
+             any.stm-hamt ==1.2.0.14,
              any.storable-complex ==0.2.3.0,
              any.streaming-commons ==0.2.2.6,
              streaming-commons -use-bytestring-builder,

devops/docker/docker-compose.yaml

 version: '3'
 
 services:
+  caddy:
+    image: caddy:alpine
+    network: host
+    ports:
+      - 8108:8108
+    volumes:
+      - ./Caddyfile:/etc/caddy/Caddyfile:ro
+      - ../../purescript-gargantext:/srv/purescript-gargantext:ro
+
   #postgres11:
   #  #image: 'postgres:latest'
   #  image: 'postgres:11'
@@ -36,26 +45,35 @@ services:
       - ../dbs:/dbs
       - ../postgres/schema.sql:/docker-entrypoint-initdb.d/schema.sql:ro
 
-  pgadmin:
-    image: 'dpage/pgadmin4'
-    ports:
-      - 8081:80
-    environment:
-      PGADMIN_DEFAULT_EMAIL: admin@localhost.lan
-      PGADMIN_DEFAULT_PASSWORD: admin
+  # NOTE: Use dbeaver instead, it's nicer and remembers passwords
+  # (unlike pgadmin when you remove the docker volume)
+  # pgadmin:
+  #   image: 'dpage/pgadmin4'
+  #   ports:
+  #     - 8081:80
+  #   environment:
+  #     PGADMIN_DEFAULT_EMAIL: admin@localhost.lan
+  #     PGADMIN_DEFAULT_PASSWORD: admin
 
-    depends_on:
-      - postgres
-    links:
-      - postgres
-    volumes:
-      - pgadmin:/var/lib/pgadmin
+  #   depends_on:
+  #     - postgres
+  #   links:
+  #     - postgres
+  #   volumes:
+  #     - pgadmin:/var/lib/pgadmin
 
-  corenlp:
-    #image: 'cgenie/corenlp-garg:latest'
-    image: 'cgenie/corenlp-garg:4.5.4'
-    ports:
-      - 9000:9000
+  # corenlp:
+  #   #image: 'cgenie/corenlp-garg:latest'
+  #   image: 'cgenie/corenlp-garg:4.5.4'
+  #   ports:
+  #     - 9000:9000
+
+  # johnsnownlp:
+  #   image: 'johnsnowlabs/nlp-server:latest'
+  #   volumes:
+  #     - js-cache:/home/johnsnowlabs/cache_pretrained
+  #   ports:
+  #     - 5000:5000
 
 volumes:
   #garg-pgdata:

gargantext-settings.toml

@@ -15,6 +15,7 @@ allowed-origins = [
   , "https://msh.sub.gargantext.org"
   , "https://dev.sub.gargantext.org"
   , "http://localhost:8008"
+  , "http://localhost:8108"
   , "http://localhost:3000"
   ]
 

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 3.4
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.7.1.16
+version: 0.0.7.2
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -33,6 +33,7 @@ data-files:
     ekg-assets/chart_line_add.png
     ekg-assets/cross.png
     test-data/ngrams/GarganText_NgramsTerms-QuantumComputing.json
+    test-data/ngrams/GarganText_DocsList-nodeId-177.json
     test-data/ngrams/simple.json
     test-data/ngrams/simple.tsv
     test-data/phylo/bpa_phylo_test.json
@@ -67,6 +68,7 @@ common defaults
     MultiParamTypeClasses
     NamedFieldPuns
     NoImplicitPrelude
+    NumericUnderscores
     OverloadedStrings
     RankNTypes
     RecordWildCards
@@ -129,6 +131,7 @@ library
       Gargantext.API.Ngrams.Types
       Gargantext.API.Node
       Gargantext.API.Node.Corpus.New
+      Gargantext.API.Node.Corpus.New.Types
       Gargantext.API.Node.Corpus.Types
       Gargantext.API.Node.Corpus.Update
       Gargantext.API.Node.File
@@ -165,6 +168,15 @@ library
       Gargantext.API.Types
       Gargantext.API.Viz.Types
       Gargantext.Core
+      Gargantext.Core.AsyncUpdates
+      Gargantext.Core.AsyncUpdates.CentralExchange
+      Gargantext.Core.AsyncUpdates.CentralExchange.Types
+      Gargantext.Core.AsyncUpdates.Constants
+      Gargantext.Core.AsyncUpdates.Dispatcher
+      Gargantext.Core.AsyncUpdates.Dispatcher.Subscriptions
+      Gargantext.Core.AsyncUpdates.Dispatcher.Types
+      Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket
+      Gargantext.Core.AsyncUpdates.Nanomsg
       Gargantext.Core.Config
       Gargantext.Core.Config.Mail
       Gargantext.Core.Config.NLP
@@ -183,13 +195,14 @@ library
       Gargantext.Core.Text.Corpus.API.OpenAlex
       Gargantext.Core.Text.Corpus.API.Pubmed
       Gargantext.Core.Text.Corpus.Parsers
-      Gargantext.Core.Text.Corpus.Parsers.TSV
       Gargantext.Core.Text.Corpus.Parsers.Date
       Gargantext.Core.Text.Corpus.Parsers.Date.Parsec
+      Gargantext.Core.Text.Corpus.Parsers.TSV
       Gargantext.Core.Text.Corpus.Query
       Gargantext.Core.Text.List
-      Gargantext.Core.Text.List.Group.WithStem
       Gargantext.Core.Text.List.Formats.TSV
+      Gargantext.Core.Text.List.Group.WithStem
+      Gargantext.Core.Text.List.Social
       Gargantext.Core.Text.Metrics
       Gargantext.Core.Text.Metrics.CharByChar
       Gargantext.Core.Text.Metrics.Count
@@ -296,6 +309,7 @@ library
       Gargantext.API.GraphQL.Team
       Gargantext.API.GraphQL.TreeFirstLevel
       Gargantext.API.GraphQL.Types
+      Gargantext.API.GraphQL.UnPrefix
       Gargantext.API.GraphQL.User
       Gargantext.API.GraphQL.UserInfo
       Gargantext.API.GraphQL.Utils
@@ -309,7 +323,6 @@ library
       Gargantext.API.Node.Corpus.Export
       Gargantext.API.Node.Corpus.Export.Types
       Gargantext.API.Node.Corpus.New.File
-      Gargantext.API.Node.Corpus.New.Types
       Gargantext.API.Node.Corpus.Searx
       Gargantext.API.Node.Document.Export
       Gargantext.API.Node.Document.Export.Types
@@ -377,7 +390,6 @@ library
       Gargantext.Core.Text.List.Group.WithScores
       Gargantext.Core.Text.List.Learn
       Gargantext.Core.Text.List.Merge
-      Gargantext.Core.Text.List.Social
       Gargantext.Core.Text.List.Social.Find
       Gargantext.Core.Text.List.Social.Patch
       Gargantext.Core.Text.List.Social.Prelude
@@ -544,6 +556,7 @@ library
     , cryptohash ^>= 0.11.9
     , data-time-segment ^>= 0.1.0.0
     , deepseq ^>= 1.4.4.0
+    , deferred-folds >= 0.9.18 && < 0.10
     , directory ^>= 1.3.6.0
     , discrimination >= 0.5
     , ekg-core ^>= 0.1.1.7
@@ -566,6 +579,7 @@ library
     , hashable ^>= 1.3.0.0
     , haskell-bee
     , haskell-igraph ^>= 0.10.4
+    , haskell-throttle
     , hedis >= 0.15.2 && < 0.16
     , hlcm ^>= 0.2.2
     , hsinfomap ^>= 0.1
@@ -608,11 +622,12 @@ library
     , morpheus-graphql-subscriptions >= 0.17.0 && < 0.25
     , morpheus-graphql-tests >= 0.17.0 && < 0.25
     , mtl ^>= 2.2.2
+    , nanomsg-haskell >= 0.2.4 && < 0.3
     , natural-transformation ^>= 0.4
     , network >= 3.1.4.0
     , network-uri ^>= 2.6.4.1
     , opaleye ^>= 0.9.6.1
-    , opaleye-textsearch >= 0.1.0.0
+    , opaleye-textsearch >= 0.2.0.0
     , openalex
     , pandoc ^>= 2.14.0.3
     , parallel ^>= 3.2.2.0
@@ -663,6 +678,7 @@ library
     , servant-swagger >= 1.2
     , servant-swagger-ui ^>= 0.3.5.3.5.0
     , servant-swagger-ui-core >= 0.3.5
+    , servant-websockets >= 2.0.0 && < 2.1
     , servant-xml-conduit >= 0.1.0.4
     , simple-reflect ^>= 0.3.3
     , singletons ^>= 2.7
@@ -671,6 +687,7 @@ library
     , split ^>= 0.2.3.4
     , stemmer ^>= 0.5.2
     , stm ^>= 2.5.0.1
+    , stm-containers >= 1.2.1 && < 1.3
     , stringsearch >= 0.3.6.6
     , swagger2 ^>= 2.6
     , taggy-lens ^>= 0.1.2
@@ -761,6 +778,7 @@ executable gargantext-cli
     , servant
     , servant-auth
     , servant-routes < 0.2
+    , servant-websockets >= 2.0.0 && < 2.1
     , shelly
     , split ^>= 0.2.3.4
     , text ^>= 1.2.4.1
@@ -791,6 +809,27 @@ executable gargantext-server
     , text ^>= 1.2.4.1
     , unordered-containers ^>= 0.2.16.0
     , vector ^>= 0.7.3
+    
+executable gargantext-central-exchange
+  import:
+      defaults
+  main-is: Main.hs
+  other-modules:
+      Paths_gargantext
+  hs-source-dirs:
+      bin/gargantext-central-exchange
+  build-depends:
+      bytestring ^>= 0.10.12.0
+    , gargantext
+    , gargantext-prelude
+    , nanomsg-haskell >= 0.2.4 && < 0.3
+    -- , nng-haskell
+    , optparse-applicative >= 0.18.1.0 && < 0.19
+    , optparse-generic ^>= 1.4.7
+    , postgresql-simple ^>= 0.6.4
+    , text ^>= 1.2.4.1
+    , unordered-containers ^>= 0.2.16.0
+    , vector ^>= 0.7.3
 
 common testDependencies
   build-depends:
@@ -809,6 +848,7 @@ common testDependencies
     , crawlerArxiv
     , cryptohash
     , directory
+    , epo-api-client
     , extra ^>= 1.7.9
     , fast-logger ^>= 3.0.5
     , fmt
@@ -847,6 +887,7 @@ common testDependencies
     , servant-client-core
     , servant-job
     , servant-server
+    , servant-websockets >= 2.0.0 && < 2.1
     , shelly >= 1.9 && < 2
     , split
     , stm ^>= 2.5.0.1
@@ -871,6 +912,27 @@ common testDependencies
     , wai
     , wai-extra
     , warp
+    , servant-websockets >= 2.0.0 && < 2.1
+    , shelly >= 1.9 && < 2
+    , stm ^>= 2.5.0.1
+    , streaming-commons
+    , tasty ^>= 1.4.2.1
+    , tasty-hspec
+    , tasty-hunit
+    , tasty-quickcheck
+    , tasty-smallcheck
+    , template-haskell
+    , text ^>= 1.2.4.1
+    , time ^>= 1.9.3
+    , tmp-postgres >= 1.34.1 && < 1.35
+    , tree-diff
+    , unliftio
+    , unordered-containers ^>= 0.2.16.0
+    , validity ^>= 0.11.0.1
+    , wai
+    , wai-extra
+    , warp
+    , websockets
 
 test-suite garg-test-tasty
   import:
@@ -879,9 +941,14 @@ test-suite garg-test-tasty
   type: exitcode-stdio-1.0
   main-is: drivers/tasty/Main.hs
   other-modules:
-      Test.API.Routes
       CLI.Phylo.Common
+      Paths_gargantext
+      Test.Core.AsyncUpdates
+      Test.API.Private.Share
+      Test.API.Authentication
+      Test.API.Routes
       Test.API.Setup
+      Test.API.UpdateList
       Test.Core.Similarity
       Test.Core.Text
       Test.Core.Text.Corpus.Query
@@ -918,7 +985,6 @@ test-suite garg-test-tasty
       Test.Utils
       Test.Utils.Crypto
       Test.Utils.Jobs
-      Paths_gargantext
   hs-source-dirs:
       test bin/gargantext-cli
   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
@@ -935,6 +1001,7 @@ test-suite garg-test-hspec
       Test.API.Authentication
       Test.API.Errors
       Test.API.GraphQL
+      Test.API.Notifications
       Test.API.Private
       Test.API.Private.Share
       Test.API.Routes

nix/pkgs.nix

@@ -33,6 +33,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";
 
@@ -125,6 +129,8 @@ rec {
     igraph_0_10_4
     libpqxx
     libsodium
+    nanomsg
+    # nng180
     zeromq
     curl
   ] ++ ( lib.optionals stdenv.isDarwin [

shell.nix

@@ -2,8 +2,9 @@
 let
   myBuildInputs = [
     pkgs.pkgs.docker-compose
-    pkgs.pkgs.haskell-language-server
+    #pkgs.pkgs.haskell-language-server
     pkgs.pkgs.stack
+    pkgs.pkgs.websocat
   ];
 in
 pkgs.pkgs.mkShell {

src/Gargantext/API.hs

@@ -27,7 +27,6 @@ Pouillard (who mainly made it).
 -}
 
 {-# LANGUAGE BangPatterns         #-}
-{-# LANGUAGE NumericUnderscores   #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
@@ -54,7 +53,8 @@ import Gargantext.API.Middleware (logStdoutDevSanitised)
 import Gargantext.API.Routes.Named (API)
 import Gargantext.API.Routes.Named.EKG
 import Gargantext.API.Server.Named (server)
-import Gargantext.API.Server.Named.EKG
+-- import Gargantext.API.Server.Named.EKG
+import Gargantext.Core.AsyncUpdates.Constants qualified as AUConstants
 import Gargantext.Database.Prelude qualified as DB
 import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
 import Gargantext.Prelude hiding (putStrLn)
@@ -64,12 +64,12 @@ import Network.Wai
 import Network.Wai.Handler.Warp hiding (defaultSettings)
 import Network.Wai.Middleware.Cors
 import Network.Wai.Middleware.RequestLogger
-import Paths_gargantext (getDataDir)
+-- import Paths_gargantext (getDataDir)
 import Servant hiding (Header)
 import Servant.Client.Core.BaseUrl (showBaseUrl)
 import System.Clock qualified as Clock
 import System.Cron.Schedule qualified as Cron
-import System.FilePath
+-- import System.FilePath
 
 -- | startGargantext takes as parameters port number and Ini file.
 startGargantext :: Mode -> PortNumber -> IniFile -> SettingsFile -> IO ()
@@ -107,6 +107,9 @@ portRouteInfo mainPort proxyPort = do
   putStrLn $ " - Swagger UI (API documentation)...........: " <> "http://localhost:" <> toUrlPiece mainPort <> "/swagger-ui"
   putStrLn $ " - Playground GraphQL (API documentation)...: " <> "http://localhost:" <> toUrlPiece mainPort <> "/gql"
   putStrLn $ " - Microservices proxy .....................: " <> "http://localhost:" <> toUrlPiece proxyPort
+  putStrLn $ " - Central exchange.........................: " <> "nanomsg: " <> pack AUConstants.ceBind
+  putStrLn $ " - Dispatcher internal......................: " <> "nanomsg: " <> pack AUConstants.dispatcherBind
+  putStrLn $ " - WebSocket address........................: " <> "ws://localhost:" <> toUrlPiece mainPort <> "/ws"
   putStrLn   "=========================================================================================================="
 
 -- | Stops the gargantext server and cancels all the periodic actions
@@ -182,12 +185,13 @@ makeGargMiddleware crsSettings mode = do
 
 makeApp :: Env -> IO Application
 makeApp env = do
-  (ekgStore, ekgMid) <- newEkgStore api
-  ekgDir <- (</> "ekg-assets") <$> getDataDir
-  pure $ ekgMid $ serveWithContext apiWithEkg cfg
-    (WithEkg { ekgAPI     = ekgServer ekgDir ekgStore
-             , wrappedAPI = server env
-             })
+  pure $ serveWithContext api cfg (server env)
+  -- (ekgStore, ekgMid) <- newEkgStore api
+  -- ekgDir <- (</> "ekg-assets") <$> getDataDir
+  -- pure $ ekgMid $ serveWithContext apiWithEkg cfg
+    -- (WithEkg { ekgAPI     = ekgServer ekgDir ekgStore
+    --          , wrappedAPI = server env
+    --          })
   where
     cfg :: Servant.Context AuthContext
     cfg = env ^. settings . jwtSettings

src/Gargantext/API/Admin/EnvTypes.hs

@@ -15,6 +15,8 @@ module Gargantext.API.Admin.EnvTypes (
   , env_manager
   , env_settings
   , env_self_url
+  , env_central_exchange
+  , env_dispatcher
   , menv_firewall
   , dev_env_logger
 
@@ -40,6 +42,9 @@ import Gargantext.API.Admin.Types
 import Gargantext.API.Errors.Types
 import Gargantext.API.Job
 import Gargantext.API.Prelude (GargM, IsGargServer)
+import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
+import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
+import Gargantext.Core.AsyncUpdates.Dispatcher.Types (Dispatcher, HasDispatcher(..))
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
 import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
 import Gargantext.Core.NodeStory
@@ -48,6 +53,7 @@ import Gargantext.Prelude
 import Gargantext.Core.Config (GargConfig(..))
 import Gargantext.Core.Config.Mail (MailConfig)
 import Gargantext.System.Logging
+import Gargantext.Utils.Jobs.Internal (pollJob)
 import Gargantext.Utils.Jobs.Map (LoggerM, J(..), jTask, rjGetLog)
 import Gargantext.Utils.Jobs.Monad qualified as Jobs
 import Network.HTTP.Client (Manager)
@@ -55,6 +61,7 @@ import Servant.Client (BaseUrl)
 import Servant.Job.Async (HasJobEnv(..), Job)
 import Servant.Job.Async qualified as SJ
 import Servant.Job.Core qualified
+import Servant.Job.Types qualified as SJ
 import System.Log.FastLogger qualified as FL
 
 data Mode = Dev | Mock | Prod
@@ -172,6 +179,8 @@ data Env = Env
   , _env_config    :: ~GargConfig
   , _env_mail      :: ~MailConfig
   , _env_nlp       :: ~NLPServerMap
+  , _env_central_exchange :: ~ThreadId
+  , _env_dispatcher :: ~Dispatcher
   }
   deriving (Generic)
 
@@ -201,6 +210,9 @@ instance HasMail Env where
 instance HasNLPServer Env where
   nlpServer = env_nlp
 
+instance HasDispatcher Env where
+  hasDispatcher = env_dispatcher
+
 instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
   _env = env_scrapers . Servant.Job.Core._env
 
@@ -210,6 +222,9 @@ instance HasJobEnv Env JobLog JobLog where
 instance Jobs.MonadJob (GargM Env err) GargJob (Seq JobLog) JobLog where
   getJobEnv = asks (view env_jobs)
 
+instance CET.HasCentralExchangeNotification Env where
+  ce_notify m = liftBase $ CE.notify m
+    
 -- | The /concrete/ 'JobHandle' in use with our 'GargM' (production) monad. Its
 -- constructor it's not exported, to not leak internal details of its implementation.
 data ConcreteJobHandle err =
@@ -229,8 +244,19 @@ mkJobHandle jId = JobHandle jId
 -- | Updates the status of a 'JobHandle' by using the input 'updateJobStatus' function.
 updateJobProgress :: ConcreteJobHandle err -> (JobLog -> JobLog) -> GargM Env err ()
 updateJobProgress ConcreteNullHandle _ = pure ()
-updateJobProgress hdl@(JobHandle _ logStatus) updateJobStatus =
-  Jobs.getLatestJobStatus hdl >>= logStatus . updateJobStatus
+updateJobProgress hdl@(JobHandle jId logStatus) updateJobStatus = do
+  jobLog <- Jobs.getLatestJobStatus hdl
+  let jobLogNew = updateJobStatus jobLog
+  logStatus jobLogNew
+  mJb <- Jobs.findJob jId
+  case mJb of
+    Nothing -> pure ()
+    Just je -> do
+      -- We use the same endpoint as the one for polling jobs via
+      -- API. This way we can send the job status directly in the
+      -- notification
+      j <- pollJob (Just $ SJ.Limit 1) Nothing jId je
+      CET.ce_notify $ CET.UpdateJobProgress j
 
 instance Jobs.MonadJobStatus (GargM Env err) where
 
@@ -319,6 +345,9 @@ data DevEnv = DevEnv
 
 makeLenses ''DevEnv
 
+instance CET.HasCentralExchangeNotification DevEnv where
+  ce_notify m = liftBase $ CE.notify m
+
 -- | Our /mock/ job handle.
 data DevJobHandle = DevJobHandle
 

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

@@ -11,7 +11,7 @@ import Data.Morpheus.Types ( GQLType, typeOptions )
 import Data.Proxy
 import Data.Swagger hiding (URL, url, port)
 import GHC.Generics hiding (to)
-import Gargantext.API.GraphQL.Utils qualified as GQLU
+import Gargantext.API.GraphQL.UnPrefix qualified as GQLU
 import Gargantext.Core.Types (TODO(..))
 import Gargantext.Prelude
 import Servant
@@ -22,12 +22,6 @@ import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary
 
 ------------------------------------------------------------------------
-instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where
-  arbitrary = panicTrace "TODO"
-
-instance Arbitrary a => Arbitrary (JobOutput a) where
-  arbitrary = JobOutput <$> arbitrary
-
 -- | Main Types
 -- TODO IsidoreAuth
 data ExternalAPIs = OpenAlex

src/Gargantext/API/Admin/Settings.hs

@@ -14,7 +14,6 @@ TODO-SECURITY: Critical
 
 {-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell     #-}
 
 module Gargantext.API.Admin.Settings
     where
@@ -25,19 +24,22 @@ import Control.Monad.Logger (LogLevel(..))
 import Control.Monad.Reader
 import Data.ByteString.Lazy qualified as L
 import Data.Pool (Pool)
+import Data.Pool qualified as Pool
 import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Settings.TOML (GargTomlSettings(..), loadGargTomlSettings)
 import Gargantext.API.Admin.Types
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
+import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
+import Gargantext.Core.AsyncUpdates.Dispatcher qualified as D
+import Gargantext.Core.Config (gc_js_job_timeout, gc_js_id_timeout, readConfig)
+import Gargantext.Core.Config.Mail qualified as Mail
+import Gargantext.Core.Config.NLP qualified as NLP
 import Gargantext.Core.NLP (nlpServerMap)
 import Gargantext.Core.NodeStory
 import Gargantext.Database.Prelude (databaseParameters, hasConfig)
 import Gargantext.Prelude
-import Gargantext.Core.Config (gc_js_job_timeout, gc_js_id_timeout, readConfig)
-import Gargantext.Core.Config.Mail qualified as Mail
-import Gargantext.Core.Config.NLP qualified as NLP
 import Gargantext.System.Logging
 import Gargantext.Utils.Jobs qualified as Jobs
 import Gargantext.Utils.Jobs.Monad qualified as Jobs
@@ -50,7 +52,7 @@ import Servant.Job.Async (newJobEnv, defaultSettings)
 import System.Directory
 import System.IO (hClose)
 import System.IO.Temp (withTempFile)
-import qualified Data.Pool as Pool
+
 
 newtype JwkFile = JwkFile { _JwkFile :: FilePath }
   deriving (Show, Eq, IsString)
@@ -211,6 +213,9 @@ newEnv logger port (IniFile file) settingsFile = do
   !config_mail  <- Mail.readConfig file
   !nlp_env      <- nlpServerMap <$> NLP.readConfig file
 
+  !central_exchange <- forkIO CE.gServer
+  !dispatcher <- D.dispatcher
+
 {-  An 'Env' by default doesn't have strict fields, but when constructing one in production
   we want to force them to WHNF to avoid accumulating unnecessary thunks.
 -}
@@ -226,6 +231,8 @@ newEnv logger port (IniFile file) settingsFile = do
     , _env_config    = config_env
     , _env_mail      = config_mail
     , _env_nlp       = nlp_env
+    , _env_central_exchange = central_exchange
+    , _env_dispatcher = dispatcher
     }
 
 newPool :: ConnectInfo -> IO (Pool Connection)

src/Gargantext/API/Admin/Settings/CORS.hs

 {--| Support in Gargantext for CORS (Cross-origin resource sharing) --}
 
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE ViewPatterns      #-}
 module Gargantext.API.Admin.Settings.CORS where

src/Gargantext/API/Admin/Settings/MicroServices.hs

-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 module Gargantext.API.Admin.Settings.MicroServices where
 

src/Gargantext/API/Errors.hs

@@ -8,6 +8,7 @@ module Gargantext.API.Errors (
 
   -- * Types
   , GargErrorScheme(..)
+  , renderGargErrorScheme
 
   -- * Conversion functions
   , backendErrorToFrontendError
@@ -48,6 +49,11 @@ data GargErrorScheme
   --   https://spec.graphql.org/June2018/#sec-Errors
     deriving (Show, Eq)
 
+renderGargErrorScheme :: GargErrorScheme -> T.Text
+renderGargErrorScheme = \case
+  GES_old -> "old"
+  GES_new -> "new"
+
 -- | Transforms a backend internal error into something that the frontend
 -- can consume. This is the only representation we offer to the outside world,
 -- as we later encode this into a 'ServerError' in the main server handler.
@@ -105,12 +111,11 @@ frontendErrorToServerError fe@(FrontendError diag ty _) =
               }
 
 internalServerErrorToFrontendError :: ServerError -> FrontendError
-internalServerErrorToFrontendError = \case
-  ServerError{..}
-    | errHTTPCode == 405
-    -> mkFrontendErr' (T.pack errReasonPhrase) $ FE_not_allowed (TL.toStrict $ TE.decodeUtf8 $ errBody)
-    | otherwise
-    -> mkFrontendErr' (T.pack errReasonPhrase) $ FE_internal_server_error (TL.toStrict $ TE.decodeUtf8 $ errBody)
+internalServerErrorToFrontendError ServerError{..}
+  | errHTTPCode == 405
+  = mkFrontendErr' (T.pack errReasonPhrase) $ FE_not_allowed (TL.toStrict $ TE.decodeUtf8 $ errBody)
+  | otherwise
+  = mkFrontendErr' (T.pack errReasonPhrase) $ FE_internal_server_error (TL.toStrict $ TE.decodeUtf8 $ errBody)
 
 jobErrorToFrontendError :: JobError -> FrontendError
 jobErrorToFrontendError = \case

src/Gargantext/API/Errors/TH.hs

 {-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
+
 module Gargantext.API.Errors.TH (
     deriveHttpStatusCode
   , deriveIsFrontendErrorData

src/Gargantext/API/Errors/Types.hs

@@ -12,7 +12,6 @@ Portability : POSIX
 {-# LANGUAGE ConstraintKinds          #-}
 {-# LANGUAGE LambdaCase               #-}
 {-# LANGUAGE PolyKinds                #-}
-{-# LANGUAGE RecordWildCards          #-}
 {-# LANGUAGE ScopedTypeVariables      #-}
 {-# LANGUAGE StandaloneDeriving       #-}
 {-# LANGUAGE StandaloneKindSignatures #-}

src/Gargantext/API/GraphQL.hs

@@ -25,7 +25,7 @@ import Data.Morpheus ( App, deriveApp )
 import Data.Morpheus.Server ( httpPlayground )
 import Data.Morpheus.Subscriptions ( Event (..), httpPubApp )
 import Data.Morpheus.Types ( GQLRequest, GQLResponse, GQLType, RootResolver(..), Undefined, defaultRootResolver)
-import Data.Proxy
+-- import Data.Proxy
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog)
 import Gargantext.API.Admin.Types (HasSettings)
@@ -167,8 +167,8 @@ data GraphQLAPIEndpoints mode = GraphQLAPIEndpoints
   }
   deriving Generic
 
-gqapi :: Proxy (ToServantApi GraphQLAPI)
-gqapi = Proxy
+-- gqapi :: Proxy (ToServantApi GraphQLAPI)
+-- gqapi = Proxy
 
 -- | Implementation of our API.
 api

src/Gargantext/API/GraphQL/UnPrefix.hs

+{-|
+Module      : Gargantext.API.GraphQL.UnPrefix
+Description : Un-prefix for GraphQL API
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# OPTIONS_GHC -Wno-deprecations #-} -- FIXME(adn) GraphQL will need updating.
+
+module Gargantext.API.GraphQL.UnPrefix where
+
+import Data.Morpheus.Types (GQLTypeOptions, fieldLabelModifier)
+import Data.Text qualified as T
+import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
+import Gargantext.Prelude
+
+unPrefix :: T.Text -> GQLTypeOptions -> GQLTypeOptions
+unPrefix prefix options = options { fieldLabelModifier = nflm }
+  where
+    nflm label = unCapitalize $ dropPrefix (T.unpack prefix) $ ( fieldLabelModifier options ) label

src/Gargantext/API/GraphQL/Utils.hs

@@ -13,21 +13,13 @@ Portability : POSIX
 module Gargantext.API.GraphQL.Utils where
 
 import Control.Lens (view)
-import Data.Morpheus.Types (GQLTypeOptions, fieldLabelModifier)
-import Data.Text qualified as T
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser (..), auth_node_id)
 import Gargantext.API.Admin.Types (jwtSettings, HasSettings (settings))
-import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
 import Gargantext.Database.Admin.Types.Node (NodeId)
 import Gargantext.Database.Prelude (Cmd')
 import Gargantext.Prelude
 import Servant.Auth.Server (verifyJWT, JWTSettings)
 
-unPrefix :: T.Text -> GQLTypeOptions -> GQLTypeOptions
-unPrefix prefix options = options { fieldLabelModifier = nflm }
-  where
-    nflm label = unCapitalize $ dropPrefix (T.unpack prefix) $ ( fieldLabelModifier options ) label
-
 data AuthStatus = Valid | Invalid
 
 authUser :: (HasSettings env) => NodeId -> Text -> Cmd' env err AuthStatus

src/Gargantext/API/Middleware.hs

-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns      #-}
 
 {-| Edit 'sensitiveKeywords' to extend the list of redacted fields. -}

src/Gargantext/API/Node/New.hs

@@ -29,26 +29,34 @@ import Gargantext.API.Errors.Types
 import Gargantext.API.Node.New.Types
 import Gargantext.API.Prelude
 import Gargantext.API.Routes.Named.Node qualified as Named
+import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CE
+import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.Worker.Jobs qualified as Jobs
 import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
 import Gargantext.Database.Action.Node
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (CmdM)
+import Gargantext.Database.Prelude (CmdM, DBCmd')
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Prelude
 import Gargantext.Utils.Jobs (serveJobsAPI)
 import Servant.Server.Generic (AsServerT)
 
 ------------------------------------------------------------------------
-postNode :: (CmdM env err m, HasNodeError err, HasSettings env)
+-- postNode :: (CmdM env err m, HasNodeError err, HasSettings env)
+postNode :: ( HasMail env
+            , HasNLPServer env
+            , HasNodeError err
+            , HasSettings env
+            , CE.HasCentralExchangeNotification env)
          => AuthenticatedUser
          -- ^ The logged-in user
          -> NodeId
          -> PostNode
-         -> m [NodeId]
-postNode authenticatedUser pId pn = do
-  postNode' authenticatedUser pId pn
-
+         -- -> m [NodeId]
+         -> DBCmd' env err [NodeId]
+postNode authenticatedUser nId pn = do
+  postNode' authenticatedUser nId pn
 
 postNodeAsyncAPI
   :: AuthenticatedUser
@@ -64,15 +72,33 @@ postNodeAsyncAPI authenticatedUser nId = Named.PostNodeAsyncAPI $ AsyncJobs $
     -- postNodeAsync authenticatedUser nId p jHandle
 
 ------------------------------------------------------------------------
-postNode' :: (CmdM env err m, HasSettings env, HasNodeError err)
-          => AuthenticatedUser
-          -- ^ The logged-in user
-          -> NodeId
-          -> PostNode
-          -> m [NodeId]
-postNode' authenticatedUser pId (PostNode nodeName nt) = do
+-- postNode' :: (CmdM env err m, HasSettings env, HasNodeError err)
+--           => AuthenticatedUser
+--           -- ^ The logged-in user
+--           -> NodeId
+--           -> PostNode
+--           -> m [NodeId]
+-- postNode' authenticatedUser pId (PostNode nodeName nt) = do
+postNode' :: ( CmdM env err m
+             , HasMail env
+             , HasNLPServer env
+             , HasNodeError err
+             , HasSettings env
+             , CE.HasCentralExchangeNotification env)
+    => AuthenticatedUser
+    -- ^ The logged in user
+    -> NodeId
+    -> PostNode
+    -> m [NodeId]
+postNode' authenticatedUser nId (PostNode nodeName tn) = do
+
   let userId = authenticatedUser ^. auth_user_id
-  mkNodeWithParent nt (Just pId) userId nodeName
+  nodeIds <- mkNodeWithParent tn (Just nId) userId nodeName
+
+  -- mapM_ (CE.ce_notify . CE.UpdateTreeFirstLevel) nodeIds
+  CE.ce_notify $ CE.UpdateTreeFirstLevel nId
+
+  return nodeIds
 
 
 -- postNodeAsync :: (FlowCmdM env err m, MonadJobStatus m, HasSettings env)

src/Gargantext/API/Node/Share.hs

@@ -20,6 +20,7 @@ import Data.Text qualified as Text
 import Gargantext.API.Node.Share.Types
 import Gargantext.API.Prelude
 import Gargantext.API.Routes.Named.Share qualified as Named
+import Gargantext.Core.AsyncUpdates.CentralExchange.Types (HasCentralExchangeNotification)
 import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.Types.Individu (User(..), arbitraryUsername)
 import Gargantext.Database.Action.Share (ShareNodeWith(..))
@@ -38,7 +39,11 @@ import Gargantext.API.Admin.Types (HasSettings)
 -- TODO permission
 -- TODO refactor userId which is used twice
 -- TODO change return type for better warning/info/success/error handling on the front
-api :: (HasNodeError err, HasNLPServer env, CmdRandom env err m, HasSettings env)
+api :: ( HasNodeError err
+       , HasNLPServer env
+       , CmdRandom env err m
+       , HasSettings env
+       , HasCentralExchangeNotification env )
     => User
     -> NodeId
     -> ShareNodeParams

src/Gargantext/API/Node/Types.hs

@@ -29,7 +29,6 @@ import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
 import Gargantext.Database.GargDB qualified as GargDB
 import Gargantext.Prelude
 import Servant.Job.Utils (jsonOptions)
-import Test.QuickCheck
 import Web.FormUrlEncoded          (FromForm, ToForm)
 
 -------------------------------------------------------
@@ -104,25 +103,12 @@ instance ToJSON WithQuery where
 instance ToSchema WithQuery where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wq_")
 
-instance Arbitrary WithQuery where
-  arbitrary = WithQuery <$> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-
 ------------------------------------------------------------------------
 data RenameNode = RenameNode { r_name :: Text }
   deriving (Generic)
 
 $(deriveJSON (unPrefix "r_"       ) ''RenameNode )
 instance ToSchema  RenameNode
-instance Arbitrary RenameNode where
-  arbitrary = elements [RenameNode "test"]
 
 data NodesToScore = NodesToScore { nts_nodesId :: [NodeId]
                                  , nts_score :: Int

src/Gargantext/API/Prelude.hs

@@ -26,6 +26,7 @@ import Gargantext.API.Admin.Auth.Types (AuthenticationError)
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Admin.Types
 import Gargantext.API.Errors.Class
+import Gargantext.Core.AsyncUpdates.CentralExchange.Types (HasCentralExchangeNotification)
 import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.NodeStory
@@ -53,6 +54,7 @@ type EnvC env =
   , HasNodeStoryEnv   env
   , HasMail           env
   , HasNLPServer      env
+  , HasCentralExchangeNotification env
   )
 
 type ErrC err =

src/Gargantext/API/Routes.hs

@@ -12,9 +12,9 @@ Portability : POSIX
 {-# LANGUAGE ConstraintKinds      #-}
 {-# LANGUAGE KindSignatures       #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
-{-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance HasSwagger (WithCustomErrorScheme GargAPI)
 

src/Gargantext/API/Routes/Named.hs

 
 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Gargantext.API.Routes.Named (
@@ -28,6 +27,7 @@ import Gargantext.API.GraphQL
 import Gargantext.API.Routes.Named.Private
 import Gargantext.API.Routes.Named.Public
 import Gargantext.API.Routes.Types
+import Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket qualified as Dispatcher
 import Servant.API ((:>), (:-), JSON, ReqBody, Post, Get, QueryParam)
 import Servant.API.Description (Summary)
 import Servant.API.NamedRoutes
@@ -42,7 +42,9 @@ newtype API mode = API
 data NamedAPI mode = NamedAPI
   { swaggerAPI  :: mode :- SwaggerSchemaUI "swagger-ui" "swagger.json"
   , backendAPI  :: mode :- NamedRoutes BackEndAPI
-  , graphqlAPI  :: mode :- NamedRoutes GraphQLAPI -- FIXME(adn) convert to named!
+  , graphqlAPI  :: mode :- NamedRoutes GraphQLAPI
+  , wsAPI       :: mode :- NamedRoutes Dispatcher.WSAPI
+  -- NOTE: FrontEndAPI is Raw and is a catch-all so needs to be at the end!
   , frontendAPI :: mode :- FrontEndAPI
   } deriving Generic
 

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
+
 module Gargantext.API.Routes.Named.Annuaire (
   -- * Routes types
     AddAnnuaireWithForm(..)

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
+
 module Gargantext.API.Routes.Named.Contact (
   -- * Routes types
     ContactAPI(..)

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
 
 module Gargantext.API.Routes.Named.Context (
   -- * Routes types

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
+
 module Gargantext.API.Routes.Named.Corpus (
   -- * Routes types
     CorpusExportAPI(..)

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
+
 module Gargantext.API.Routes.Named.Count (
   -- * Routes types
     CountAPI(..)

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

-{-# LANGUAGE DeriveGeneric   #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeOperators   #-}
+
 module Gargantext.API.Routes.Named.Document (
   -- * Routes types
     DocumentsFromWriteNodesAPI(..)

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
+
 module Gargantext.API.Routes.Named.EKG (
   -- * Routes types
   EkgAPI(..)

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

-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TypeOperators #-}
+
 module Gargantext.API.Routes.Named.File (
   -- * Routes types
     FileAPI(..)

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
 
 module Gargantext.API.Routes.Named.FrameCalc (
   -- * Routes types

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
+
 module Gargantext.API.Routes.Named.List (
   -- * Routes types
     GETAPI(..)

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
+
 module Gargantext.API.Routes.Named.Metrics (
   -- * Routes types
 

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
+
 module Gargantext.API.Routes.Named.Node (
   -- * Routes types
     NodeAPI(..)

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

 
 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -87,7 +86,7 @@ data GargPrivateAPI' mode = GargPrivateAPI'
                                       :> Capture "tree_id" NodeId
                                       :> NamedRoutes TreeFlatAPI
   , membersAPI     :: mode :- "members" :> Summary "Team node members" :> NamedRoutes MembersAPI
-  , addWithFormEp  :: mode :- NamedRoutes AddWithForm
+  , addWithFormAPI :: mode :- NamedRoutes AddWithForm
   , addWithQueryEp :: mode :- NamedRoutes AddWithQuery
   , listGetAPI     :: mode :- NamedRoutes List.GETAPI
   , listJsonAPI    :: mode :- NamedRoutes List.JSONAPI

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

-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TypeOperators #-}
+
 module Gargantext.API.Routes.Named.Public (
   -- * Routes types
     GargPublicAPI(..)

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
+
 module Gargantext.API.Routes.Named.Search (
   -- * Routes types
     SearchAPI(..)

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Gargantext.API.Routes.Named.Share (

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

-{-# LANGUAGE DeriveGeneric   #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeOperators   #-}
 

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
 
 module Gargantext.API.Routes.Named.Tree (
   -- * Routes types

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

 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveGeneric #-}
 
 module Gargantext.API.Routes.Named.Viz (
   -- * Routes types
@@ -53,11 +52,12 @@ newtype PostPhylo mode = PostPhylo
 -- | There is no Delete specific API for Graph since it can be deleted
 -- as simple Node.
 data GraphAPI mode = GraphAPI
-  { getGraphEp       :: mode :- Get '[JSON] HyperdataGraphAPI
-  , getGraphAsyncEp  :: mode :- "async" :> NamedRoutes GraphAsyncAPI
-  , cloneGraphEp     :: mode :- "clone" :> ReqBody '[JSON] HyperdataGraphAPI :> Post '[JSON] NodeId
-  , gexfEp           :: mode :- "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
-  , graphVersionsAPI :: mode :- "versions" :> NamedRoutes GraphVersionsAPI
+  { getGraphEp          :: mode :- Get '[JSON] HyperdataGraphAPI
+  , getGraphAsyncEp     :: mode :- "async" :> NamedRoutes GraphAsyncAPI
+  , cloneGraphEp        :: mode :- "clone" :> ReqBody '[JSON] HyperdataGraphAPI :> Post '[JSON] NodeId
+  , gexfEp              :: mode :- "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
+  , graphVersionsAPI    :: mode :- "versions" :> NamedRoutes GraphVersionsAPI
+  , updateGraphLegendEp :: mode :- "legend" :> ReqBody '[JSON] GraphLegendAPI :> Post '[JSON] NodeId
   } deriving Generic
 
 

src/Gargantext/API/Routes/Types.hs

@@ -5,6 +5,7 @@ module Gargantext.API.Routes.Types where
 
 import Control.Lens
 import Data.ByteString (ByteString)
+import Data.CaseInsensitive qualified as CI
 import Data.List qualified as L
 import Data.Proxy
 import Data.Set qualified as Set
@@ -12,16 +13,21 @@ import Gargantext.API.Errors
 import Network.Wai hiding (responseHeaders)
 import Prelude
 import Servant.API.Routes
+import Servant.API.Routes.Internal.Response (unResponses)
+import Servant.API.Routes.Route
 import Servant.Client hiding (responseHeaders)
+import Servant.Client.Core.Request (addHeader)
 import Servant.Ekg
 import Servant.Server
 import Servant.Server.Internal.Delayed
 import Servant.Server.Internal.DelayedIO
-import Servant.API.Routes.Route
-import Servant.API.Routes.Internal.Response (unResponses)
+import Network.HTTP.Types (HeaderName)
 
 data WithCustomErrorScheme a
 
+xGargErrorScheme :: HeaderName
+xGargErrorScheme = CI.mk "X-Garg-Error-Scheme"
+
 instance (HasServer subApi ctx) => HasServer (WithCustomErrorScheme subApi) ctx where
   type ServerT (WithCustomErrorScheme subApi) m = GargErrorScheme -> ServerT subApi m
   hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy subApi) pc nt . s
@@ -30,7 +36,7 @@ instance (HasServer subApi ctx) => HasServer (WithCustomErrorScheme subApi) ctx
       getErrorScheme :: DelayedIO GargErrorScheme
       getErrorScheme = withRequest $ \rq -> do
         let hdrs = requestHeaders rq
-            in case L.lookup "X-Garg-Error-Scheme" hdrs of
+            in case L.lookup xGargErrorScheme hdrs of
                  Nothing     -> pure GES_old
                  Just "new"  -> pure GES_new
                  Just _      -> pure GES_old
@@ -41,7 +47,9 @@ instance HasEndpoint sub => HasEndpoint (WithCustomErrorScheme sub) where
 
 instance HasClient m sub => HasClient m (WithCustomErrorScheme sub) where
   type Client m (WithCustomErrorScheme sub) = GargErrorScheme -> Client m sub
-  clientWithRoute m _ req _mgr = clientWithRoute m (Proxy :: Proxy sub) req
+  clientWithRoute m _ req0 _mgr =
+    let req = addHeader xGargErrorScheme (renderGargErrorScheme $ GES_new) req0
+    in clientWithRoute m (Proxy :: Proxy sub) req
 
   hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt . cl
 
@@ -49,5 +57,5 @@ instance (HasRoutes subApi) => HasRoutes (WithCustomErrorScheme subApi) where
   getRoutes =
     let apiRoutes = getRoutes @subApi
         errHeader = mkHeaderRep @"X-Garg-Error-Scheme" @ByteString
-        addHeader rt = rt & routeResponse . unResponses . traversed . responseHeaders %~ Set.insert errHeader
-    in  addHeader <$> apiRoutes
+        addHeader' rt = rt & routeResponse . unResponses . traversed . responseHeaders %~ Set.insert errHeader
+    in  addHeader' <$> apiRoutes

src/Gargantext/API/Server/Named.hs

@@ -22,6 +22,7 @@ import Gargantext.API.Server.Named.Public (serverPublicGargAPI)
 import Gargantext.API.Routes.Named
 import Gargantext.API.Swagger (swaggerDoc)
 import Gargantext.API.ThrowAll (serverPrivateGargAPI)
+import Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket qualified as Dispatcher
 import Gargantext.Database.Prelude (hasConfig)
 import Gargantext.Prelude hiding (Handler, catch)
 import Gargantext.Core.Config (gc_url_backend_api)
@@ -60,6 +61,11 @@ server env =
                       (Proxy :: Proxy AuthContext)
                       (transformJSONGQL errScheme)
                       GraphQL.api
+     , wsAPI       = hoistServer
+                       (Proxy :: Proxy (NamedRoutes Dispatcher.WSAPI))
+                       -- (Proxy :: Proxy AuthContext)
+                       (transformJSON errScheme)
+                       Dispatcher.wsServer
      , frontendAPI = frontEndServer
      }
   where

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

@@ -58,7 +58,7 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
        , treeAPI           = Tree.treeAPI authenticatedUser
        , treeFlatAPI       = Tree.treeFlatAPI authenticatedUser
        , membersAPI        = members
-       , addWithFormEp     = addCorpusWithForm (RootId userNodeId)
+       , addWithFormAPI    = addCorpusWithForm (RootId userNodeId)
        , addWithQueryEp    = addCorpusWithQuery (RootId userNodeId)
        , listGetAPI        = List.getAPI
        , listJsonAPI       = List.jsonAPI

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

@@ -19,11 +19,12 @@ import Servant.Server.Generic (AsServerT)
 
 graphAPI :: AuthenticatedUser -> UserId -> NodeId -> Named.GraphAPI (AsServerT (GargM Env BackendInternalError))
 graphAPI authenticatedUser userId n = withNamedAccess authenticatedUser (PathNode n) $ Named.GraphAPI
-  { getGraphEp       = getGraph n
-  , getGraphAsyncEp  = graphAsync n
-  , cloneGraphEp     = graphClone userId n
-  , gexfEp           = getGraphGexf      n
-  , graphVersionsAPI = graphVersionsAPI  userId n
+  { getGraphEp          = getGraph n
+  , getGraphAsyncEp     = graphAsync n
+  , cloneGraphEp        = graphClone userId n
+  , gexfEp              = getGraphGexf      n
+  , graphVersionsAPI    = graphVersionsAPI  userId n
+  , updateGraphLegendEp = updateGraphLegend n
   }
 
 

src/Gargantext/Core/AsyncUpdates.hs

+{-|
+Module      : Gargantext.Core.AsyncUpdates
+Description : Asynchronous updates to the frontend
+Copyright   : (c) CNRS, 2024-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# OPTIONS_GHC -Wno-deprecations #-} -- FIXME(cgenie) undefined remains in code
+
+module Gargantext.Core.AsyncUpdates
+where
+
+import Gargantext.Core.Types (NodeId, UserId)
+import Protolude
+
+
+{-
+
+Please note that we have 2 different notification mechanisms:
+- external (i.e. WebSocket or SSE connection to the frontend)
+- internal (e.g. job workers would like to report either progress or
+  that some node changed in the tree)
+    
+I imagine the workflow as follows (this is a mix of internal and
+external communication):
+- somewhere in the code (or in the async job worker) we decide to send
+  an update message to all interested users
+- such an action (UserAction) can be associated with the triggering
+  user (but doesn't have to be)
+- we compute interested users for given notification
+- we broadcast (using our broker) these notifications to all
+  interested users 
+- the broadcast message is either simple (meaning: hey, we have new
+  data, if you want you can send an update request) or we could send
+  the changed data already
+
+On the client side it looks more or less like this (external
+communication):
+- specific components decide to subscribe to specific
+  UserNotifications: task component is interested in running tasks (for
+  given node id), tree component is interested in the tree and its
+  first-level children (same for the children components)
+- the components react to events accordingly (usually by pulling in
+  new data)
+
+Thus, for example, the triple (user_id, node_id, "update_tree")
+defines a "update tree for given user and given node" subscription to
+this event, both for server and client. This triple is then the
+"touching point" between client and server. Through that point, update
+messages are sent from server.
+
+Subscription to topics is important IMHO because it allows to target
+clients directly rather than broadcasting messages to everyone. This
+reduces latency and is more secure. At the same time it is a bit more
+complicated because we need to agree on the topic schema both on
+server and client.
+
+As for internal communication, we don't need topics: we always want to
+get all notifications and process them accordingly (send messages to
+connected users, ignore any messages that would be sent to
+non-connected users).
+
+-}
+    
+-------------------------
+-- EXTERNAL COMMUNICATION
+-------------------------
+
+    
+-- | Various topics that users can subscribe to
+data Topic =
+  -- | Update given Servant Job (we currently send a request every
+  -- | second to get job status).
+  --  UpdateJob JobID
+  -- | Given parent node id, trigger update of the node and its
+  --   children (e.g. list is automatically created in a corpus)
+  UpdateTree NodeId
+  deriving (Eq, Show)
+
+
+-- TODO: I'm not sure if UserAction/UserSource is needed. I initially
+-- created that to mark who initiated the action, but I think we don't
+-- need it.
+--
+-- Suppose we send an 'UpdateTree node_id' message: from the DB we can
+-- infer all users that are associated with that node (I do keep in
+-- mind that we can share nodes to other users).
+data UserSource =
+    USUser UserId
+  | USSystem
+  deriving (Eq, Show)
+    
+-- | Action possibly associated with user who triggered it (there can
+--   be system actions as well)
+data UserAction =
+  UserAction UserSource Topic
+  deriving (Eq, Show)
+
+  
+-- | Represents a notification that goes to a given user. This is
+--   directly sent via WebSockets.
+--
+-- NOTE: Do we need public notifications? I.e. sent out to non-logged
+-- in users?
+data UserNotification =
+  UserNotification UserId UserAction
+  deriving (Eq, Show)
+
+-- | What we want now is, given a UserAction action, generate all
+--   interested users to which the notification will be sent.
+--   This function lives in a monad because we have to fetch users
+--   from DB.
+notificationsForUserAction :: UserAction -> m [ UserNotification ]
+notificationsForUserAction = undefined
+
+
+-- | A connected user can be either associated with his UserId or
+--   don't have it, since he's not logged in (for public messages).
+data ConnectedUser =
+    CUUser UserId
+  | CUPublic
+  deriving (Eq, Show)
+    
+-- | Stores connection type associated with given user, subscribed to
+-- | a given topic.
+--
+--   We probably should set conn = Servant.API.WebSocket.Connection
+data Subscription conn =
+  Subscription ConnectedUser conn Topic
+
+
+-- | Given a UserNotification and all subscriptions, send it to all
+--   matching ones. Possibly we could make this function as part of a
+--   typeclass so that we can decide how to send the notification
+--   based on whether we choose pure WebSockets, NATS or something
+--   else.
+sendNotification :: UserNotification -> [ Subscription conn ] -> m ()
+sendNotification = undefined
+
+

src/Gargantext/Core/AsyncUpdates/CentralExchange.hs

+{-|
+Module      : Gargantext.Core.AsyncUpdates.CentralExchange
+Description : Central exchange (asynchronous notifications)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
+
+Docs:
+https://dev.sub.gargantext.org/#/share/Notes/187918
+    
+-}
+
+module Gargantext.Core.AsyncUpdates.CentralExchange where
+
+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 Gargantext.Core.AsyncUpdates.CentralExchange.Types
+import Gargantext.Core.AsyncUpdates.Constants (ceBind, ceConnect, dispatcherConnect)
+import Gargantext.Prelude
+import Gargantext.System.Logging (LogLevel(DEBUG), withLogger, logMsg)
+import Nanomsg (Pull(..), Push(..), bind, connect, recvMalloc, send, withSocket)
+    
+{-
+
+Central exchange is a service, which gathers messages from various
+places and informs the Dispatcher (which will then inform users about
+various events).
+
+The primary goal is to be able to read as many messages as possible
+and then send them to the Dispatcher. Although nanomsg does some
+message buffering, we don't want these messages to pile up, especially
+with many users having updates.
+    
+-}
+
+gServer :: IO ()
+gServer = do
+  withSocket Pull $ \s -> do
+    withSocket Push $ \s_dispatcher -> do
+      _ <- bind s ceBind
+      _ <- connect s_dispatcher dispatcherConnect
+
+      tChan <- TChan.newTChanIO
+
+      -- | We have 2 threads: one that listens for nanomsg messages
+      -- | and puts them on the 'tChan' and the second one that reads
+      -- | the 'tChan' and calls Dispatcher accordingly. This is to
+      -- | make reading nanomsg as fast as possible.
+      void $ Async.concurrently (worker s_dispatcher tChan) $ do
+        forever $ do
+          -- putText "[central_exchange] receiving"
+          r <- recvMalloc s 1024
+          -- C.putStrLn $ "[central_exchange] " <> r
+          atomically $ TChan.writeTChan tChan r
+  where
+    worker s_dispatcher tChan = do
+      withLogger () $ \ioLogger -> do
+        forever $ do
+          r <- atomically $ TChan.readTChan tChan
+          case Aeson.decode (BSL.fromStrict r) of
+            Just _ujp@(UpdateJobProgress _s) -> do
+              -- logMsg ioLogger DEBUG $ "[central_exchange] " <> show ujp
+              -- send the same message that we received
+              send s_dispatcher r
+            Just (UpdateTreeFirstLevel node_id) -> do
+              logMsg ioLogger DEBUG $ "[central_exchange] update tree: " <> show node_id
+              -- putText $ "[central_exchange] sending that to the dispatcher: " <> show node_id
+              -- To make this more robust, use withAsync so we don't
+              -- block the main thread (send is blocking)
+              
+              -- NOTE: If we're flooded with messages, and send is
+              -- slow, we might be spawning many threads...
+    
+              -- NOTE: Currently we just forward the message that we
+              -- got. So in theory central exchange isn't needed (we
+              -- could ping dispatcher directly). However, I think
+              -- it's better to have this as a separate
+              -- component. Currently I built this inside
+              -- gargantext-server but maybe it can be a separate
+              -- process, independent of the server.
+              -- send the same message that we received
+              send s_dispatcher r
+            _ -> logMsg ioLogger DEBUG $ "[central_exchange] unknown message"
+      
+
+notify :: CEMessage -> IO ()
+notify ceMessage = do
+  Async.withAsync (pure ()) $ \_ -> do
+    withSocket Push $ \s -> do
+      _ <- connect s ceConnect
+      let str = Aeson.encode ceMessage
+      send s $ BSL.toStrict str

src/Gargantext/Core/AsyncUpdates/CentralExchange/Types.hs

+{-|
+Module      : Gargantext.Core.AsyncUpdates.CentralExchange.Types
+Description : Types for asynchronous notifications (central exchange)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
+
+Docs:
+https://dev.sub.gargantext.org/#/share/Notes/187918    
+-}
+
+module Gargantext.Core.AsyncUpdates.CentralExchange.Types where
+
+import Codec.Binary.UTF8.String qualified as CBUTF8
+import Data.Aeson ((.:), (.=), object, withObject)
+import Data.Aeson qualified as Aeson
+import Data.Aeson.Types (prependFailure, typeMismatch)
+import Data.ByteString.Lazy qualified as BSL
+import Gargantext.API.Admin.Orchestrator.Types (JobLog)
+import Gargantext.Core.Types (NodeId)
+import Gargantext.Prelude
+import Prelude qualified
+import Servant.Job.Core (Safety(Safe))
+import Servant.Job.Types (JobStatus)
+    
+{-
+
+Central exchange is a service, which gathers messages from various
+places and informs the Dispatcher (which will then inform users about
+various events).
+    
+-}
+
+-- INTERNAL MESSAGES
+data CEMessage =
+    UpdateJobProgress (JobStatus 'Safe JobLog)
+  | UpdateTreeFirstLevel NodeId
+instance Prelude.Show CEMessage where
+  show (UpdateJobProgress js) = "UpdateJobProgress " <> (CBUTF8.decode $ BSL.unpack $ Aeson.encode js)
+  show (UpdateTreeFirstLevel nodeId) = "UpdateTreeFirstLevel " <> show nodeId
+instance FromJSON CEMessage where
+  parseJSON = withObject "CEMessage" $ \o -> do
+    type_ <- o .: "type"
+    case type_ of
+      "update_job_progress" -> do
+        js <- o .: "js"
+        pure $ UpdateJobProgress js
+      "update_tree_first_level" -> do
+        node_id <- o .: "node_id"
+        pure $ UpdateTreeFirstLevel node_id
+      s -> prependFailure "parsing type failed, " (typeMismatch "type" s)
+instance ToJSON CEMessage where
+  toJSON (UpdateJobProgress js) = object [
+        "type" .= toJSON ("update_job_progress" :: Text)
+      , "js"   .= toJSON js
+    ]
+  toJSON (UpdateTreeFirstLevel node_id) = object [
+      "type"    .= toJSON ("update_tree_first_level" :: Text)
+    , "node_id" .= toJSON node_id
+    ]
+
+
+class HasCentralExchangeNotification env where
+  ce_notify :: (MonadReader env m, MonadBase IO m) => CEMessage -> m ()

src/Gargantext/Core/AsyncUpdates/Constants.hs

+{-|
+Module      : Gargantext.Core.AsyncUpdates.Constants
+Description : Various constants
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
+
+Docs:
+https://dev.sub.gargantext.org/#/share/Notes/187918
+    
+-}
+
+module Gargantext.Core.AsyncUpdates.Constants where
+
+import Prelude qualified
+
+-- NOTE IDP is fast and we're on local network so it shouldn't be a
+-- problem with dropping packets. Otherwise, use TCP
+-- https://nanomsg.org
+
+-- | Bind address for central exchange (for tcp: tcp://*:5560)
+ceBind :: Prelude.String
+ceBind = "ipc:///tmp/central-exchange.ipc"
+-- ceBind = "tcp://*:5560"
+-- | Connect address for central exchange (for tcp: tcp://localhost:5560)
+ceConnect :: Prelude.String
+ceConnect = "ipc:///tmp/central-exchange.ipc"
+-- ceConnect = "tcp://localhost:5560"
+    
+-- | Bind address for dispatcher (for tcp: tcp://*:5561)
+dispatcherBind :: Prelude.String
+dispatcherBind = "ipc:///tmp/dispatcher.ipc"
+-- dispatcherBind = "tcp://*:5561"
+-- | Connect address for dispatcher (for tcp: tcp://localhost:5561)
+dispatcherConnect :: Prelude.String
+dispatcherConnect = "ipc:///tmp/dispatcher.ipc"
+-- dispatcherConnect = "tcp://localhost:5561"

src/Gargantext/Core/AsyncUpdates/Dispatcher.hs

+{-|
+Module      : Gargantext.Core.AsyncUpdates.Dispatcher
+Description : Dispatcher (handles websocket connections, accepts message from central exchange)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
+
+Docs:
+https://dev.sub.gargantext.org/#/share/Notes/187918
+    
+-}
+
+{-# LANGUAGE TypeOperators #-}
+    
+module Gargantext.Core.AsyncUpdates.Dispatcher where
+
+import Control.Concurrent.Async qualified as Async
+import Control.Concurrent.STM.TChan qualified as TChan
+import Control.Concurrent.Throttle (throttle)
+import Data.Aeson qualified as Aeson
+import Data.ByteString.Lazy qualified as BSL
+import DeferredFolds.UnfoldlM qualified as UnfoldlM
+import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CETypes
+import Gargantext.Core.AsyncUpdates.Constants as AUConstants
+import Gargantext.Core.AsyncUpdates.Dispatcher.Types
+import Gargantext.Prelude
+import Gargantext.System.Logging (LogLevel(DEBUG), withLogger, logMsg)
+import Nanomsg (Pull(..), bind, recvMalloc, withSocket)
+import Network.WebSockets qualified as WS
+import Servant.Job.Types (JobStatus(_job_id))
+import StmContainers.Set qualified as SSet
+
+{-
+
+Dispatcher is a service, which provides couple of functionalities:
+- handles WebSocket connections and manages them
+- accepts messages from central exchange
+- dispatches these messages to connected users
+    
+-}
+    
+
+dispatcher :: IO Dispatcher
+dispatcher = do
+  subscriptions <- SSet.newIO
+
+  -- let server = wsServer authSettings subscriptions
+
+  d_ce_listener <- forkIO (dispatcherListener subscriptions)
+
+  pure $ Dispatcher { d_subscriptions = subscriptions
+                    -- , d_ws_server     = server
+                    , d_ce_listener   = d_ce_listener }
+
+
+    
+-- | 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 :: SSet.Set Subscription -> IO ()
+dispatcherListener subscriptions = do
+  withSocket Pull $ \s -> do
+    _ <- bind s AUConstants.dispatcherBind
+
+    tChan <- TChan.newTChanIO
+
+    throttleTChan <- TChan.newTChanIO
+
+    -- 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
+      void $ Async.concurrently (Async.replicateConcurrently 5 $ worker tChan throttleTChan) $ do
+        forever $ do
+          -- putText "[dispatcher_listener] receiving"
+          r <- recvMalloc s 1024
+          -- C.putStrLn $ "[dispatcher_listener] " <> r
+          atomically $ TChan.writeTChan tChan r
+  where
+    worker tChan throttleTChan = do
+      -- tId <- myThreadId
+      
+      forever $ do
+        r <- atomically $ TChan.readTChan tChan
+        -- putText $ "[" <> show tId <> "] received a message: " <> decodeUtf8 r
+        
+        case Aeson.decode (BSL.fromStrict r) of
+          Nothing -> withLogger () $ \ioL ->
+                       logMsg ioL DEBUG "[dispatcher_listener] unknown message from central exchange"
+          Just ceMessage -> do
+            -- putText $ "[dispatcher_listener] received message: " <> show ceMessage
+            -- subs <- atomically $ readTVar subscriptions
+            filteredSubs <- atomically $ do
+              let subs' = UnfoldlM.filter (pure . ceMessageSubPred ceMessage) $ SSet.unfoldlM subscriptions
+              UnfoldlM.foldlM' (\acc sub -> pure $ acc <> [sub]) [] subs'
+            -- NOTE This isn't safe: we atomically fetch subscriptions,
+            -- then send notifications one by one. In the meantime, a
+            -- subscription could end or new ones could appear (but is
+            -- this really a problem? I new subscription comes up, then
+            -- probably they already fetch new tree anyways, and if old
+            -- one drops in the meantime, it won't listen to what we
+            -- send...)
+            -- let filteredSubs = filterCEMessageSubs ceMessage subs
+            mapM_ (sendNotification throttleTChan ceMessage) filteredSubs
+
+-- | When processing tasks such as Flow, we can generate quite a few
+-- notifications in a short time. We want to limit this with throttle
+-- tchan.
+sendNotification :: TChan.TChan ((ByteString, Topic), (WS.Connection, WS.DataMessage))
+                 -> CETypes.CEMessage
+                 -> Subscription
+                 -> IO ()
+sendNotification throttleTChan ceMessage sub = do
+  let ws = s_ws_key_connection sub
+  let topic = s_topic sub
+  notification <-
+        case ceMessage of
+          CETypes.UpdateJobProgress jobStatus -> do
+            pure $ Notification topic (MJobProgress jobStatus)
+          CETypes.UpdateTreeFirstLevel _nodeId -> pure $ Notification topic MEmpty
+
+  let id' = (wsKey ws, topic)
+  atomically $ TChan.writeTChan throttleTChan (id', (wsConn ws, WS.Text (Aeson.encode notification) Nothing))
+
+sendDataMessageThrottled :: (WS.Connection, WS.DataMessage) -> IO ()
+sendDataMessageThrottled (conn, msg) =
+  WS.sendDataMessage conn msg
+
+
+-- Custom filtering of list of Subscriptions based on
+-- CETypes.CEMessage.
+-- For example, we can add CEMessage.Broadcast to propagate a
+-- notification to all connections.
+filterCEMessageSubs :: CETypes.CEMessage -> [Subscription] -> [Subscription]
+filterCEMessageSubs ceMessage subscriptions = filter (ceMessageSubPred ceMessage) subscriptions
+
+ceMessageSubPred :: CETypes.CEMessage -> Subscription -> Bool
+ceMessageSubPred (CETypes.UpdateJobProgress js) (Subscription { s_topic }) =
+  s_topic == (UpdateJobProgress $ _job_id js)
+ceMessageSubPred (CETypes.UpdateTreeFirstLevel node_id) (Subscription { s_topic }) =
+  s_topic == UpdateTree node_id

src/Gargantext/Core/AsyncUpdates/Dispatcher/Subscriptions.hs

+{-|
+Module      : Gargantext.Core.AsyncUpdates.Dispatcher.Subscriptions
+Description : Dispatcher (manage websocket subscriptions)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
+
+Docs:
+https://dev.sub.gargantext.org/#/share/Notes/187918
+    
+-}
+
+    
+module Gargantext.Core.AsyncUpdates.Dispatcher.Subscriptions where
+
+import DeferredFolds.UnfoldlM qualified as UnfoldlM
+import Gargantext.Core.AsyncUpdates.Dispatcher.Types
+import Gargantext.Prelude
+import StmContainers.Set as SSet
+
+
+-- | TODO Allow only 1 topic subscription per connection. It doesn't
+-- | make sense to send multiple notifications of the same type to the
+-- | same connection.
+insertSubscription :: SSet.Set Subscription -> Subscription -> IO ()
+insertSubscription subscriptions sub = do
+  atomically $ SSet.insert sub subscriptions
+    -- s <- readTVar subscriptions
+    -- let ss = nubBy eqSub $ s <> [sub]
+    -- writeTVar subscriptions ss
+    -- -- pure ss
+    -- pure ()
+     
+removeSubscription :: SSet.Set Subscription -> Subscription -> IO ()
+removeSubscription subscriptions sub = do
+  atomically $ SSet.delete sub subscriptions
+    -- s <- readTVar subscriptions
+    -- let ss = filter (\sub' -> not $ sub `eqSub` sub') s
+    -- writeTVar subscriptions ss
+    -- pure ss
+   
+removeSubscriptionsForWSKey :: SSet.Set Subscription -> WSKeyConnection -> IO ()
+removeSubscriptionsForWSKey subscriptions ws = do
+  atomically $ do
+    let toDelete = UnfoldlM.filter (\sub -> return $ subKey sub == wsKey ws) $ SSet.unfoldlM subscriptions
+    UnfoldlM.mapM_ (\sub -> SSet.delete sub subscriptions) toDelete
+  -- atomically $ do
+  --   s <- readTVar subscriptions
+  --   let ss = filter (\sub -> subKey sub /= wsKey ws) s
+  --   writeTVar subscriptions ss
+  --   pure ss

src/Gargantext/Core/AsyncUpdates/Dispatcher/Types.hs

+{-|
+Module      : Gargantext.Core.AsyncUpdates.Dispatcher.Types
+Description : Dispatcher (handles websocket connections, accepts message from central exchange)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
+
+Docs:
+https://dev.sub.gargantext.org/#/share/Notes/187918
+    
+-}
+
+{-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-unused-imports #-}
+    
+module Gargantext.Core.AsyncUpdates.Dispatcher.Types where
+
+import Codec.Binary.UTF8.String qualified as CBUTF8
+import Control.Concurrent.Async qualified as Async
+import Control.Lens (Getter, view)
+import Data.Aeson ((.:), (.=))
+import Data.Aeson qualified as Aeson
+import Data.Aeson.Types (prependFailure, typeMismatch)
+import Data.ByteString.Char8 qualified as C
+import Data.ByteString.Lazy qualified as BSL
+import Data.List (nubBy)
+import DeferredFolds.UnfoldlM qualified as UnfoldlM
+import Data.UUID.V4 as UUID
+import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(_auth_user_id))
+import Gargantext.API.Admin.Orchestrator.Types (JobLog)
+import Gargantext.API.Admin.Types (jwtSettings, Settings, jwtSettings)
+import Gargantext.API.Prelude (IsGargServer)
+import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CETypes
+import Gargantext.Core.AsyncUpdates.Constants as AUConstants
+import Gargantext.Core.Types (NodeId, UserId)
+import Gargantext.Prelude
+import GHC.Conc (TVar, newTVarIO, readTVar, writeTVar)
+import Nanomsg
+import Network.WebSockets qualified as WS
+import Prelude qualified
+import Protolude.Base (Show(showsPrec))
+import Servant
+-- import Servant.API.NamedRoutes ((:-))
+import Servant.API.WebSocket qualified as WS
+import Servant.Auth.Server (verifyJWT)
+import Servant.Job.Core (Safety(Safe))
+import Servant.Job.Types (JobID, JobStatus(_job_id))
+import Servant.Server.Generic (AsServer, AsServerT)
+import StmContainers.Set as SSet
+
+
+
+-- | A topic is sent, when a client wants to subscribe to specific
+-- | types of notifications
+data Topic =
+  -- | Update given Servant Job (we currently send a request every
+  -- | second to get job status).
+   UpdateJobProgress (JobID 'Safe)
+  -- | Given parent node id, trigger update of the node and its
+  --   children (e.g. list is automatically created in a corpus)
+  | UpdateTree NodeId
+  deriving (Eq, Ord)
+instance Prelude.Show Topic where
+  show (UpdateJobProgress jId) = "UpdateJobProgress " <> (CBUTF8.decode $ BSL.unpack $ Aeson.encode jId)
+  show (UpdateTree nodeId) = "UpdateTree " <> show nodeId
+instance Hashable Topic where
+  hashWithSalt salt (UpdateJobProgress jId) = hashWithSalt salt ("update-job-progress" :: Text, Aeson.encode jId)
+  hashWithSalt salt (UpdateTree nodeId) = hashWithSalt salt ("update-tree" :: Text, nodeId)
+instance FromJSON Topic where
+  parseJSON = Aeson.withObject "Topic" $ \o -> do
+    type_ <- o .: "type"
+    case type_ of
+      "update_job_progress" -> do
+        jId <- o .: "j_id"
+        pure $ UpdateJobProgress jId
+      "update_tree" -> do
+        node_id <- o .: "node_id"
+        pure $ UpdateTree node_id
+      s -> prependFailure "parsing type failed, " (typeMismatch "type" s)
+instance ToJSON Topic where
+  toJSON (UpdateJobProgress jId) = Aeson.object [
+      "type" .= toJSON ("update_job_progress" :: Text)
+    , "j_id" .= toJSON jId
+    ]
+  toJSON (UpdateTree node_id) = Aeson.object [
+      "type" .= toJSON ("update_tree" :: Text)
+    , "node_id" .= toJSON node_id
+    ]
+
+-- | A message to  be sent inside a Notification
+data Message =
+    MJobProgress (JobStatus 'Safe JobLog)
+  | MEmpty
+-- | For tests
+instance Eq Message where
+  (==) (MJobProgress js1) (MJobProgress js2) = _job_id js1 == _job_id js2
+  (==) MEmpty MEmpty = True
+  (==) _ _ = False
+instance Prelude.Show Message where
+  show (MJobProgress jobStatus) = "MJobProgress " <> (CBUTF8.decode $ BSL.unpack $ Aeson.encode jobStatus)
+  show MEmpty = "MEmpty"
+instance ToJSON Message where
+  toJSON (MJobProgress jobStatus) = Aeson.object [
+      "type" .= toJSON ("MJobProgress" :: Text)
+    , "job_status" .= toJSON jobStatus
+    ]
+  toJSON MEmpty = Aeson.object [
+      "type" .= toJSON ("MEmpty" :: Text)  
+    ]
+instance FromJSON Message where
+  parseJSON = Aeson.withObject "Message" $ \o -> do
+    type_ <- o .: "type"
+    case type_ of
+      "MJobProgress" -> do
+        job_status <- o .: "job_status"
+        pure $ MJobProgress job_status
+      "MEmpty" -> pure MEmpty
+      s -> prependFailure "parsing type failed, " (typeMismatch "type" s)
+
+    
+data ConnectedUser =
+    CUUser UserId
+  | CUPublic
+  deriving (Eq, Show)
+instance Hashable ConnectedUser where
+  hashWithSalt salt (CUUser userId) = hashWithSalt salt ("cuuser" :: Text, userId)
+  hashWithSalt salt CUPublic = hashWithSalt salt ("cupublic" :: Text)
+  
+newtype WSKeyConnection = WSKeyConnection (ByteString, WS.Connection)
+instance Hashable WSKeyConnection where
+  hashWithSalt salt (WSKeyConnection (key, _conn)) = hashWithSalt salt key
+instance Eq WSKeyConnection where
+  (==) (WSKeyConnection (key1, _conn1)) (WSKeyConnection (key2, _conn2)) = key1 == key2
+instance Show WSKeyConnection where
+  showsPrec d (WSKeyConnection (key, _conn)) = showsPrec d $ "WSKeyConnection " <> key
+showWSKeyConnection :: WSKeyConnection -> Text
+showWSKeyConnection ws = "WSKeyConnection " <> show (wsKey ws)
+wsKey :: WSKeyConnection -> ByteString
+wsKey (WSKeyConnection (key, _conn)) = key
+wsConn :: WSKeyConnection -> WS.Connection
+wsConn (WSKeyConnection (_key, conn)) = conn
+    
+data Subscription =
+  Subscription {
+      s_connected_user    :: ConnectedUser
+    , s_ws_key_connection :: WSKeyConnection
+    , s_topic             :: Topic }
+    deriving (Eq, Show)
+instance Hashable Subscription where
+  hashWithSalt salt (Subscription { .. }) =
+    hashWithSalt salt ( s_connected_user, s_ws_key_connection, s_topic )
+subKey :: Subscription -> ByteString
+subKey sub = wsKey $ s_ws_key_connection sub
+
+
+type Token = Text
+
+    
+{-
+We accept requests for subscription/unsubscription via websocket.
+
+We could instead handle 1 websocket connection per every topic
+subscription (e.g. parse headers in WS.PendingConnection. However, WS
+by default can handle 65k concurrent connections. With multiple users
+having multiple components open, we could exhaust that limit quickly.
+
+Hence, we architect this to have 1 websocket connection per web
+browser.
+-}
+data WSRequest =
+    WSSubscribe Topic
+  | WSUnsubscribe Topic
+  | WSAuthorize Token
+  | WSDeauthorize
+  deriving (Eq, Show)
+instance FromJSON WSRequest where
+  parseJSON = Aeson.withObject "WSRequest" $ \o -> do
+    request <- o .: "request"
+    case request of
+      "subscribe" -> do
+        topic <- o .: "topic"
+        pure $ WSSubscribe topic
+      "unsubscribe" -> do
+        topic <- o .: "topic"
+        pure $ WSUnsubscribe topic
+      "authorize" -> do
+         token <- o .: "token"
+         pure $ WSAuthorize token
+      "deauthorize" -> pure $ WSDeauthorize
+      s -> prependFailure "parsing request type failed, " (typeMismatch "request" s)
+-- | For tests mainly
+instance ToJSON WSRequest where
+  toJSON (WSSubscribe topic) = Aeson.object [ "request" .= ( "subscribe":: Text )
+                                            , "topic" .= topic ]
+  toJSON (WSUnsubscribe topic) = Aeson.object [ "request" .= ( "unsubscribe" :: Text )
+                                              , "topic" .= topic ]
+  toJSON (WSAuthorize token) = Aeson.object [ "request" .= ( "authorize" :: Text )
+                                            , "token" .= token ]
+  toJSON WSDeauthorize = Aeson.object [ "request" .= ( "deauthorize" :: Text ) ]
+    
+data Dispatcher =
+ Dispatcher { d_subscriptions :: SSet.Set Subscription
+            -- , d_ws_server     :: WSAPI AsServer
+            , d_ce_listener   :: ThreadId
+            }
+
+
+class HasDispatcher env where
+  hasDispatcher :: Getter env Dispatcher
+
+
+-- | A notification is sent to clients who subscribed to specific topics
+data Notification =
+   Notification Topic Message
+  deriving (Show)
+
+instance ToJSON Notification where
+  toJSON (Notification topic message) = Aeson.object [
+      "notification" .= toJSON (Aeson.object [
+         "topic" .= toJSON topic
+       , "message" .= toJSON message
+       ])
+    ]
+    

src/Gargantext/Core/AsyncUpdates/Dispatcher/WebSocket.hs

+{-|
+Module      : Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket
+Description : Dispatcher websocket server
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
+
+Docs:
+https://dev.sub.gargantext.org/#/share/Notes/187918
+    
+-}
+
+{-# LANGUAGE TypeOperators #-}
+    
+module Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket where
+
+import Control.Concurrent.Async qualified as Async
+import Control.Lens (view)
+import Data.Aeson qualified as Aeson
+import Data.UUID.V4 as UUID
+import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(_auth_user_id))
+import Gargantext.API.Admin.Types (HasSettings(settings), Settings, jwtSettings)
+import Gargantext.API.Prelude (IsGargServer)
+import Gargantext.Core.AsyncUpdates.Dispatcher.Subscriptions
+import Gargantext.Core.AsyncUpdates.Dispatcher.Types
+import Gargantext.Prelude
+import Gargantext.System.Logging (LogLevel(DEBUG), logMsg, withLogger)
+import Network.WebSockets qualified as WS
+import Servant
+import Servant.API.WebSocket qualified as WS (WebSocketPending)
+import Servant.Auth.Server (verifyJWT)
+import Servant.Server.Generic (AsServerT)
+import StmContainers.Set as SSet
+
+    
+newtype WSAPI mode = WSAPI {
+    wsAPIServer :: mode :- "ws" :> Summary "WebSocket endpoint" :> WS.WebSocketPending
+  } deriving Generic
+
+
+wsServer :: ( IsGargServer env err m, HasDispatcher env, HasSettings env ) => WSAPI (AsServerT m)
+wsServer = WSAPI { wsAPIServer = streamData }
+  where
+    streamData :: ( IsGargServer env err m, HasDispatcher env, HasSettings env )
+               => WS.PendingConnection -> m ()
+    streamData pc = do
+      authSettings <- view settings
+      d <- view hasDispatcher
+      let subscriptions = d_subscriptions d
+      key <- getWSKey pc
+      c <- liftBase $ WS.acceptRequest pc
+      let ws = WSKeyConnection (key, c)
+      _ <- liftBase $ Async.concurrently (wsLoop authSettings subscriptions ws) (pingLoop ws)
+      -- _ <- liftIO $ Async.withAsync (pure ()) (\_ -> wsLoop ws)
+      pure ()
+
+  
+-- | Send a ping control frame periodically, otherwise the
+-- | connection is dropped. NOTE that 'onPing' message is not
+-- | supported in the JS API: either the browser supports this or
+-- | not:
+-- | https://stackoverflow.com/questions/10585355/sending-websocket-ping-pong-frame-from-browser
+pingLoop :: WSKeyConnection -> IO ()
+pingLoop ws = do
+  forever $ do
+    -- WS.sendDataMessage (wsConn ws) (WS.Text (Aeson.encode Ping) Nothing)
+    WS.sendPing (wsConn ws) ("" :: Text)
+    threadDelay $ 10 * 1000000
+
+      
+wsLoop :: Settings -> SSet.Set Subscription -> WSKeyConnection -> IO a
+wsLoop authSettings subscriptions ws = flip finally disconnect $ do
+  withLogger () $ \ioLogger -> do
+    logMsg ioLogger DEBUG "[wsLoop] connecting"
+    wsLoop' CUPublic ioLogger
+
+  where
+    wsLoop' user ioLogger = do
+      dm <- WS.receiveDataMessage (wsConn ws)
+      
+      newUser <- case dm of
+        WS.Text dm' _ -> do
+          case Aeson.decode dm' of
+            Nothing -> do
+              logMsg ioLogger DEBUG $ "[wsLoop] unknown message: " <> show dm'
+              return user
+            Just (WSSubscribe topic) -> do
+              -- TODO Fix s_connected_user based on header
+              let sub = Subscription { s_connected_user = user
+                                     , s_ws_key_connection = ws
+                                     , s_topic = topic }
+              _ss <- insertSubscription subscriptions sub
+              -- putText $ "[wsLoop] subscriptions: " <> show (showSub <$> ss)
+              return user
+            Just (WSUnsubscribe topic) -> do
+              let sub = Subscription { s_connected_user = user
+                                     , s_ws_key_connection = ws
+                                     , s_topic = topic }
+              _ss <- removeSubscription subscriptions sub
+              -- putText $ "[wsLoop] subscriptions: " <> show (showSub <$> ss)
+              return user
+            Just (WSAuthorize token) -> do
+              let jwtS = authSettings ^. jwtSettings
+              mUser <- liftBase $ verifyJWT jwtS (encodeUtf8 token)
+
+              logMsg ioLogger DEBUG $ "[wsLoop] authorized user: " <> show mUser
+
+              -- TODO Update my subscriptions!
+
+              return $ fromMaybe user (CUUser . _auth_user_id <$> mUser)
+            Just WSDeauthorize -> do
+              -- TODO Update my subscriptions!
+              pure CUPublic
+        _ -> do
+          logMsg ioLogger DEBUG "[wsLoop] binary ws messages not supported"
+          return user
+        
+      wsLoop' newUser ioLogger
+
+    disconnect = do
+      withLogger () $ \ioLogger -> do
+        logMsg ioLogger DEBUG "[wsLoop] disconnecting..."
+        _ss <- removeSubscriptionsForWSKey subscriptions ws
+        -- putText $ "[wsLoop] subscriptions: " <> show (show <$> ss)
+        return ()
+
+    
+        
+getWSKey :: MonadBase IO m => WS.PendingConnection -> m ByteString
+getWSKey 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).
+  let mKey = head $ filter (\(k, _) -> k == "Sec-WebSocket-Key") $ WS.requestHeaders reqHead
+  let key' = snd $ fromMaybe (panicTrace "Sec-WebSocket-Key not found!") mKey
+  -- Unfortunately, a single browsers sends the same
+  -- Sec-WebSocket-Key so we want to make that even more unique.
+  uuid <- liftBase $ UUID.nextRandom
+  let key = key' <> "-" <> show uuid
+  liftBase $ putText $ "[getWSKey] request headers: " <> (show $ WS.requestHeaders reqHead)
+
+  pure key

src/Gargantext/Core/AsyncUpdates/Nanomsg.hs

+{-|
+Module      : Gargantext.Core.AsyncUpdates.Nanomsg
+Description : Nanomsg utils
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
+
+Docs:
+https://dev.sub.gargantext.org/#/share/Notes/187918
+    
+-}
+
+module Gargantext.Core.AsyncUpdates.Nanomsg where
+
+import Gargantext.Prelude
+import Nanomsg
+
+
+
+withSafeSocket :: SocketType a => Text -> a -> (Socket a -> IO c) -> IO c
+withSafeSocket socketName t =
+  bracket onOpen onClose
+  where
+    onOpen = do
+      s <- socket t
+      setRcvBuf s 1
+      setSndBuf s 1
+      rcvBufInt <- rcvBuf s
+      sndBufInt <- sndBuf s
+      putText $ "[" <> socketName <> "] rcvBuf: " <> show rcvBufInt <> ", sndBuf: " <> show sndBufInt
+      pure s
+    onClose s = do
+      close s
+      panicTrace $ "[withSafeSocket] " <> socketName <> " closed"

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

@@ -85,7 +85,6 @@ where $n_{ij}$ is the cooccurrence between term $i$ and term $j$
 {-# LANGUAGE TypeOperators       #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns        #-}
-{-# LANGUAGE GADTs               #-}
 
 module Gargantext.Core.Methods.Similarities.Accelerate.Distributional
   where

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

@@ -11,8 +11,6 @@ Thx to Alp Well Typed for the first version.
 
 -}
 
-{-# LANGUAGE OverloadedStrings #-}
-
 module Gargantext.Core.Text.Corpus.Parsers.Wikidata.Crawler
   where
 

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

 {-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE ViewPatterns       #-}
+
 module Gargantext.Core.Text.Corpus.Query (
     Query -- * opaque
   , RawQuery(..)

src/Gargantext/Core/Text/List/Social.hs

@@ -83,6 +83,7 @@ instance ToSchema FlowSocialListWith where
 instance FromHttpApiData FlowSocialListWith
   where
     parseUrlPiece "My lists first"    = pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
+    parseUrlPiece "MySelfFirst"       = pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
     parseUrlPiece "Others lists first" = pure $ FlowSocialListWithPriority { fslw_priority = OthersFirst }
     parseUrlPiece "NoList"          = pure $ NoList True
     parseUrlPiece x                 = panicTrace $ "[G.C.T.L.Social] TODO FromHttpApiData FlowSocialListWith error: " <> (show x)

src/Gargantext/Core/Text/Prepare.hs

@@ -15,8 +15,6 @@ that could be the incarnation of the mythic Gargantua.
 
 -}
 
-{-# LANGUAGE OverloadedStrings #-}
-
 module Gargantext.Core.Text.Prepare
   where
 

src/Gargantext/Core/Text/Terms/Mono/Stem/Internal/Lancaster.hs

-{-# LANGUAGE OverloadedStrings #-}
 
 module Gargantext.Core.Text.Terms.Mono.Stem.Internal.Lancaster
   ( stem

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

@@ -36,7 +36,7 @@ multiterms nsc l txt = do
   let txt' = cleanTextForNLP txt
   if txt' == ""
      then do
-       printDebug "[G.C.T.Terms.Multi] becomes empty after cleanTextForNLP" txt
+       -- printDebug "[G.C.T.Terms.Multi] becomes empty after cleanTextForNLP" txt
        pure []
      else do
        ret <- multiterms' tokenTag2terms l txt'

src/Gargantext/Core/Types.hs

@@ -14,8 +14,8 @@ commentary with @some markup@.
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
 
 ------------------------------------------------------------------------
-{-# LANGUAGE TemplateHaskell      #-}
 {-# LANGUAGE DerivingStrategies   #-}
+{-# LANGUAGE TemplateHaskell      #-}
 
 module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
                              , module Gargantext.Database.Admin.Types.Node

src/Gargantext/Core/Types/Main.hs

@@ -19,6 +19,7 @@ module Gargantext.Core.Types.Main where
 ------------------------------------------------------------------------
 
 import Data.Bimap (Bimap)
+import Data.Bimap qualified as Bimap
 import Data.Swagger ( ToSchema(..), ToParamSchema, genericDeclareNamedSchema )
 import Data.Text (unpack, pack)
 import Data.TreeDiff
@@ -29,7 +30,6 @@ import Gargantext.Prelude
 import Servant.API (FromHttpApiData(..), ToHttpApiData(..))
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-import qualified Data.Bimap as Bimap
 
 type CorpusName = Text
 ------------------------------------------------------------------------

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

@@ -297,3 +297,18 @@ getGraphGexf :: HasNodeStory env err m
 getGraphGexf nId = do
   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph nId
   pure $ addHeader "attachment; filename=graph.gexf" graph
+
+------------------------------------------------------------
+updateGraphLegend :: HasNodeError err
+                  => NodeId
+                  -> GraphLegendAPI
+                  -> DBCmd err NodeId
+updateGraphLegend nId (GraphLegendAPI lg ) = do
+  nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
+  let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+  case graph of
+    Nothing -> pure nId
+    Just g -> do
+      let graph' = set (graph_metadata . _Just . gm_legend) lg g
+      _ <- updateHyperdata nId (HyperdataGraph (Just graph') (nodeGraph ^. node_hyperdata . hyperdataCamera))
+      pure nId

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

@@ -241,6 +241,20 @@ instance FromField HyperdataGraphAPI
     fromField = fromField'
 
 
+-----------------------------------------------------------
+
+data GraphLegendAPI = GraphLegendAPI [LegendField]
+  deriving (Show, Generic)
+$(deriveJSON (unPrefix "_graphAPI") ''GraphLegendAPI)
+instance ToSchema GraphLegendAPI where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graphAPI")
+
+makeLenses ''GraphLegendAPI
+
+instance FromField GraphLegendAPI
+  where
+    fromField = fromField'
+
 
 
 ---------------------- defaults

src/Gargantext/Core/Viz/Types.hs

-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE TemplateHaskell   #-}
 
 module Gargantext.Core.Viz.Types where
@@ -10,13 +5,12 @@ module Gargantext.Core.Viz.Types where
 import Data.Aeson.TH (deriveJSON)
 import Data.Swagger
 import Data.Vector (Vector)
-import qualified Data.Vector as V
+import Data.Vector qualified as V
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Protolude
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
-
 ---------------
 -- | Chart | --
 ---------------

src/Gargantext/Core/Worker/TOML.hs

@@ -53,7 +53,7 @@ workerSettingsCodec = WorkerSettings
 workerDefinitionCodec :: TomlCodec WorkerDefinition
 workerDefinitionCodec = WorkerDefinition
   <$> Toml.text "name" .= _wdName
-  <*> Toml.string "queue" .= _wdQueue
+  <*> (Broker.Queue <$> Toml.text "queue") .= (Broker._Queue <$> _wdQueue)
   <*> Toml.table workerBrokerCodec "broker.redis" .= _wdBroker
 
 workerBrokerCodec :: TomlCodec WorkerBroker

src/Gargantext/Database/Action/Delete.hs

@@ -20,6 +20,7 @@ module Gargantext.Database.Action.Delete
 import Control.Lens (view)
 import Data.Text (unpack)
 import Gargantext.Core (HasDBid(..))
+import Gargantext.Core.AsyncUpdates.CentralExchange.Types (ce_notify, CEMessage(..))
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Action.Share (delFolderTeam)
 import Gargantext.Database.Action.User (getUserId)
@@ -43,7 +44,7 @@ deleteNode :: (CmdCommon env, HasNodeError err)
            -> Cmd' env err Int
 deleteNode u nodeId = do
   node' <- N.getNode nodeId
-  case (view node_typename node') of
+  num <- case (view node_typename node') of
     nt | nt == toDBid NodeUser -> panicTrace "[G.D.A.D.deleteNode] Not allowed to delete NodeUser (yet)"
     nt | nt == toDBid NodeTeam -> do
       uId   <- getUserId u
@@ -57,6 +58,14 @@ deleteNode u nodeId = do
       N.deleteNode nodeId
     _                             -> N.deleteNode nodeId
 
+  -- | Node was deleted, refresh its parent (if exists)
+  -- mapM_ (CE.ce_notify . CE.UpdateTreeFirstLevel) nodeIds
+  case view node_parent_id node' of
+    Nothing -> return ()
+    Just pId -> ce_notify $ UpdateTreeFirstLevel pId
+    
+  return num
+
   -- if hasNodeType node' NodeUser
   --    then panic "Not allowed to delete NodeUser (yet)"
   --    else if hasNodeType node' NodeTeam

src/Gargantext/Database/Action/Flow.hs

@@ -65,6 +65,7 @@ import Data.Text qualified as T
 import EPO.API.Client.Types qualified as EPO
 import Gargantext.API.Ngrams.Tools (getTermsWith)
 import Gargantext.Core (Lang(..), NLPServerConfig, withDefaultLanguage)
+import Gargantext.Core.AsyncUpdates.CentralExchange.Types (HasCentralExchangeNotification(ce_notify), CEMessage(..))
 import Gargantext.Core.Ext.IMTUser (readFile_Annuaire)
 import Gargantext.Core.NLP (HasNLPServer, nlpServerGet)
 import Gargantext.Core.NodeStory.Types (HasNodeStory)
@@ -167,6 +168,7 @@ flowDataText :: forall env err m.
                 , HasValidationError err
                 , MonadJobStatus m
                 , HasSettings env
+                , HasCentralExchangeNotification env
                 )
                 => User
                 -> DataText
@@ -197,7 +199,7 @@ flowAnnuaire :: ( DbCmd' env err m
                 , HasValidationError err
                 , MonadJobStatus m
                 , HasSettings env
-                )
+                , HasCentralExchangeNotification env )
              => MkCorpusUser
              -> TermType Lang
              -> FilePath
@@ -217,7 +219,7 @@ flowCorpusFile :: ( DbCmd' env err m
                   , HasValidationError err
                   , MonadJobStatus m
                   , HasSettings env
-                  )
+                  , HasCentralExchangeNotification env )
            => MkCorpusUser
            -> Limit -- Limit the number of docs (for dev purpose)
            -> TermType Lang
@@ -248,7 +250,7 @@ flowCorpus :: ( DbCmd' env err m
               , FlowCorpus a
               , MonadJobStatus m
               , HasSettings env
-              )
+              , HasCentralExchangeNotification env )
            => MkCorpusUser
            -> TermType Lang
            -> Maybe FlowSocialListWith
@@ -269,6 +271,7 @@ flow :: forall env err m a c.
         , MkCorpus c
         , MonadJobStatus m
         , HasSettings env
+        , HasCentralExchangeNotification env
         )
         => Maybe c
         -> MkCorpusUser
@@ -282,7 +285,7 @@ flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do
   -- TODO if public insertMasterDocs else insertUserDocs
   nlpServer <- view $ nlpServerGet (_tt_lang la)
   runConduit $ zipSources (yieldMany ([1..] :: [Int])) docsC
-    .| CList.chunksOf 100
+    .| CList.chunksOf 2
     .| mapM_C (addDocumentsWithProgress nlpServer userCorpusId)
     .| sinkNull
 
@@ -321,6 +324,7 @@ addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do
 ------------------------------------------------------------------------
 createNodes :: ( DbCmd' env err m, HasNodeError err, HasSettings env
                , MkCorpus c
+               , HasCentralExchangeNotification env
                )
             => MkCorpusUser
             -> Maybe c
@@ -339,6 +343,9 @@ createNodes mkCorpusUser ctype = do
   _ <- insertDefaultNodeIfNotExists NodeGraph     userCorpusId userId
   -- _ <- insertDefaultNodeIfNotExists NodeDashboard userCorpusId userId
 
+  ce_notify $ UpdateTreeFirstLevel listId
+  ce_notify $ UpdateTreeFirstLevel userCorpusId
+
   pure (userId, userCorpusId, listId)
 
 

src/Gargantext/Database/Action/Metrics/NgramsByContext.hs

@@ -127,7 +127,8 @@ getOccByNgramsOnlyFast cId lId nt = do
                 WITH cnnv AS
                 ( SELECT DISTINCT context_node_ngrams.context_id,
                     context_node_ngrams.ngrams_id,
-                    nodes_contexts.node_id
+                    nodes_contexts.node_id,
+                    nodes_contexts.category
                   FROM nodes_contexts
                   JOIN context_node_ngrams ON context_node_ngrams.context_id = nodes_contexts.context_id
                 ),
@@ -135,7 +136,7 @@ getOccByNgramsOnlyFast cId lId nt = do
                   (SELECT context_id, ngrams_id, terms
                   FROM cnnv
                   JOIN ngrams ON cnnv.ngrams_id = ngrams.id
-                  WHERE node_id = ?
+                  WHERE node_id = ? AND cnnv.category > 0
                   ),
                 ncids_agg AS
                   (SELECT ngrams_id, terms, array_agg(DISTINCT context_id) AS agg

src/Gargantext/Database/Action/Metrics/TFICF.hs

@@ -70,8 +70,8 @@ getTficf_withSample cId mId nt = do
                      <$> getOccByNgramsOnlyFast_withSample mId countGlobal nt
                             (HM.keys mapTextDoubleLocal)
 
-  printDebug "[getTficf_withSample] mapTextDoubleLocal: " mapTextDoubleLocal
-  printDebug "[getTficf_withSample] mapTextDoubleGlobal: " mapTextDoubleGlobal
+  -- printDebug "[getTficf_withSample] mapTextDoubleLocal: " mapTextDoubleLocal
+  -- printDebug "[getTficf_withSample] mapTextDoubleGlobal: " mapTextDoubleGlobal
 
   --printDebug "getTficf_withSample" (mapTextDoubleLocal, mapTextDoubleGlobal, countLocal, countGlobal)
   pure $ HM.mapWithKey (\t n ->

src/Gargantext/Database/Action/Search.hs

@@ -61,7 +61,9 @@ import Opaleye.TextSearch
 --
 
 queryToTsSearch :: API.Query -> Field SqlTSQuery
-queryToTsSearch q = sqlToTSQuery $ T.unpack $ API.interpretQuery q transformAST
+queryToTsSearch q =
+  let (dictionary, transformed) = API.interpretQuery q transformAST
+  in sqlToTSQuery dictionary (T.unpack transformed)
   where
 
     -- It's important to understand how things work under the hood: When we perform
@@ -97,29 +99,45 @@ queryToTsSearch q = sqlToTSQuery $ T.unpack $ API.interpretQuery q transformAST
       API.QT_partial_match (Term term)
         -> stem EN GargPorterAlgorithm term <> ":*"
 
-    transformAST :: BoolExpr [API.QueryTerm] -> T.Text
+    -- Transforms the input query terms and returns the full SQL query to feed Postgres AND
+    -- the dictionary to use, see: https://www.postgresql.org/docs/current/textsearch-dictionaries.html
+    -- In a nutshell, if we have a partial match operator in our query, we use the \"simple\" dictionary
+    -- under the hood, which won't filter stop words, which are sometimes useful, see issue #265.
+    transformAST :: BoolExpr [API.QueryTerm] -> (Maybe Dictionary, T.Text)
     transformAST ast = case ast of
       BAnd sub1 sub2
-        -> " (" <> transformAST sub1 <> " & " <> transformAST sub2 <> ") "
+        -> let (d1, sub1Expr) = transformAST sub1
+               (d2, sub2Expr) = transformAST sub2
+           in (d1 <|> d2, " (" <> sub1Expr <> " & " <> sub2Expr <> ") ")
       BOr sub1 sub2
-        -> " (" <> transformAST sub1 <> " | " <> transformAST sub2 <> ") "
+        -> let (d1, sub1Expr) = transformAST sub1
+               (d2, sub2Expr) = transformAST sub2
+           in (d1 <|> d2, " (" <> sub1Expr <> " | " <> sub2Expr <> ") ")
       BNot (BConst (Negative term))
         -> transformAST (BConst (Positive term)) -- double negation
       BNot sub
-        -> "!" <> transformAST sub
+        -> second (\e -> "!" <> e) $ transformAST sub
       -- BTrue cannot happen is the query parser doesn't support parsing 'TRUE' alone.
       BTrue
-        -> T.empty
+        -> (Nothing, T.empty)
       -- BTrue cannot happen is the query parser doesn't support parsing 'FALSE' alone.
       BFalse
-        -> T.empty
+        -> (Nothing, T.empty)
       BConst (Positive queryTerms)
-        -> renderQueryTerms queryTerms
+        -> (pickDictionary queryTerms,  renderQueryTerms queryTerms)
       -- We can handle negatives via `ANDNOT` with itself.
       BConst (Negative queryTerms)
-        -> "!" <> renderQueryTerms queryTerms
+        -> (pickDictionary queryTerms, "!" <> renderQueryTerms queryTerms)
 
 
+pickDictionary :: [API.QueryTerm] -> Maybe Dictionary
+pickDictionary qs = if any isPartialMatch qs then Just (Dictionary "simple") else Nothing
+  where
+    isPartialMatch :: API.QueryTerm -> Bool
+    isPartialMatch = \case
+      API.QT_partial_match{} -> True
+      _                      -> False
+
 ------------------------------------------------------------------------
 searchDocInDatabase :: HasDBid NodeType
                     => ParentId

src/Gargantext/Database/Admin/Types/Hyperdata/Any.hs

@@ -9,13 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
 module Gargantext.Database.Admin.Types.Hyperdata.Any

src/Gargantext/Database/Admin/Types/Hyperdata/Contact.hs

@@ -12,13 +12,7 @@ Portability : POSIX
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
 
 {-# LANGUAGE DeriveAnyClass             #-}
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FunctionalDependencies     #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
 
@@ -27,7 +21,7 @@ module Gargantext.Database.Admin.Types.Hyperdata.Contact
 
 import Data.Morpheus.Types (GQLType(..))
 import Data.Time.Segment (jour)
-import Gargantext.API.GraphQL.Utils qualified as GAGU
+import Gargantext.API.GraphQL.UnPrefix qualified as GAGU
 import Gargantext.Core.Text (HasText(..))
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
 import Gargantext.Prelude

src/Gargantext/Database/Admin/Types/Hyperdata/Corpus.hs

@@ -9,13 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
 module Gargantext.Database.Admin.Types.Hyperdata.Corpus

src/Gargantext/Database/Admin/Types/Hyperdata/CorpusField.hs

@@ -9,10 +9,7 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TemplateHaskell            #-}
-
 module Gargantext.Database.Admin.Types.Hyperdata.CorpusField
 where
 

src/Gargantext/Database/Admin/Types/Hyperdata/Dashboard.hs

@@ -9,12 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TemplateHaskell            #-}
 

src/Gargantext/Database/Admin/Types/Hyperdata/Default.hs

@@ -9,13 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
 module Gargantext.Database.Admin.Types.Hyperdata.Default

src/Gargantext/Database/Admin/Types/Hyperdata/Document.hs

@@ -9,13 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
 module Gargantext.Database.Admin.Types.Hyperdata.Document where

src/Gargantext/Database/Admin/Types/Hyperdata/File.hs

@@ -9,13 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
 module Gargantext.Database.Admin.Types.Hyperdata.File

src/Gargantext/Database/Admin/Types/Hyperdata/Folder.hs

@@ -9,13 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
 module Gargantext.Database.Admin.Types.Hyperdata.Folder

src/Gargantext/Database/Admin/Types/Hyperdata/List.hs

@@ -9,13 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
 module Gargantext.Database.Admin.Types.Hyperdata.List

src/Gargantext/Database/Admin/Types/Hyperdata/Model.hs

@@ -9,13 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
 module Gargantext.Database.Admin.Types.Hyperdata.Model

src/Gargantext/Database/Admin/Types/Hyperdata/Phylo.hs

@@ -9,13 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
 module Gargantext.Database.Admin.Types.Hyperdata.Phylo

src/Gargantext/Database/Admin/Types/Hyperdata/Texts.hs

@@ -9,13 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
 module Gargantext.Database.Admin.Types.Hyperdata.Texts