resolve the conflict

.clippy.dhall

+let Rule : Type = { match : Text, print : Text }
+let Config : Type = { rules : List Rule }
+
+let rule = \(match: Text) -> \(replace: Text) ->
+  { match = match, print = replace } : Rule
+
+in {
+  rules =
+    [
+      rule "(>>[ICS]>)|(<[ICS]<<)|(>[ICS]>)|(<[ICS]<)" ""
+    , rule "Couldn't match type"                  "Couldn't match"
+    , rule "               with"                  "          with"
+    , rule "Expected type:"                       "Expected:"
+    , rule "  Actual type:"                       "     Got:"
+    , rule "Couldn't match expected type ‘(.*?)’" "Expected: $1"
+    , rule "            with actual type ‘(.*?)’" "     Got: $1"
+    , rule "Couldn't match expected type ‘(.*)’ with actual type ‘(.*)’"
+           ''
+           Expected: $1
+                Got: $2
+           ''
+    -- , rule "(?s)>>C>.*?<C<<"                    ""
+    , rule "(?s)In a stmt of a 'do' block:.*?<(C|S)<<" "<$1<<"
+    , rule "(?s)In the \\w+ argument of.*?<(C|S)<<" "<$1<<"
+    , rule "(?s)In the expression.*?<(C|S)<<"       "<$1<<"
+    , rule "\\(bound at ([^)]*)\\)"             " -- $1"
+    , rule
+        "Ambiguous type variable (‘\\w+’) arising from a use of (‘\\w+’)"
+        "Type variable $1 is ambiguous in $2."
+    , rule
+        "prevents the constraint (‘.+’) from being solved.*"
+        "Can't pick an instance for $1."
+    , rule
+        "(Probable|Possible) fix:"
+        ''
+        ---
+        Maybe-fix:''
+    , rule
+        "use a type annotation to specify what.*"
+        "add type annotations to disambiguate."
+    , rule
+        "No instance for (.*?) arising from (a|the)( use of)? (.*)"
+        "Need a $1 instance for usage of $4"
+    , rule
+        "(?s)the type signature for:\n  "
+        "\n"
+    , rule
+        "(?s)These potential instances .*? -fprint-potential-instances to see them all\\)"
+        "More info: compile with -fprint-potential-instances."
+    , rule
+        "Relevant bindings include"
+        "Known types:\n"
+    ] : List Rule
+} : Config

.gitlab-ci.yml

@@ -2,8 +2,7 @@
 # https://vadosware.io/post/zero-to-continuous-integrated-testing-a-haskell-project-with-gitlab/
 #
 #
-image: cgenie/stack-build:lts-18.18-garg
-#image: cgenie/nixos-stack:latest
+image: adinapoli/gargantext:v1
 
 variables:
   STACK_ROOT: "${CI_PROJECT_DIR}/.stack-root"
@@ -15,49 +14,70 @@ variables:
 
 stages:
   - deps
-  - docs
   - test
+  - docs
+  - cabal
 
 deps:
+  stage: deps
   cache:
     # cache per branch name
     # key: ${CI_COMMIT_REF_SLUG}
     paths:
-      - .stack
       - .stack-root/
       - .stack-work/
       - target
   script:
-    - stack build --no-terminal --haddock --no-haddock-deps --only-dependencies --fast
+    - echo "Building the project from '$CI_PROJECT_DIR'"
+    - hpack
+    - nix-shell --run "LC_ALL=C.UTF-8 stack build --no-terminal --haddock --no-haddock-deps --only-dependencies --fast"
 
 docs:
+  stage: docs
   cache:
     # cache per branch name
     # key: ${CI_COMMIT_REF_SLUG}
     paths:
-      - .stack
       - .stack-root/
       - .stack-work/
       - target
   script:
-    - stack build --no-terminal --haddock --no-haddock-deps --fast
+    - hpack
+    - nix-shell --run "LC_ALL=C.UTF-8 stack build --no-terminal --haddock --no-haddock-deps --fast"
     - cp -R "$(stack path --local-install-root)"/doc ./output
   artifacts:
     paths:
       - ./output
     expire_in: 1 week
+  allow_failure: true
 
 test:
+  stage: test
   cache:
     # cache per branch name
     # key: ${CI_COMMIT_REF_SLUG}
     paths:
-      - .stack
       - .stack-root/
       - .stack-work/
       - target
   script:
-    - stack test --no-terminal --fast
+    - hpack
+    - nix-shell --run "LC_ALL=C.UTF-8 stack test --no-terminal --fast"
 
       # TOOO
 
+cabal:
+  stage: cabal
+  cache:
+    # cache per branch name
+    # key: ${CI_COMMIT_REF_SLUG}
+    paths:
+      - .stack-root/
+      - .stack-work/
+      - dist-newstyle/
+      - target
+  script:
+    - hpack
+    - nix-shell --run "LC_ALL=C.UTF-8 cabal v2-update 'hackage.haskell.org,2023-04-07T08:35:43Z' && cabal v2-build --dry-run"
+  allow_failure: true
+

README.md

@@ -74,8 +74,12 @@ nix-env (Nix) 2.11.0
 
 > **NOTE INFO (upgrade/downgrade if needed)**
 > Gargantext works with Nix 2.11.0 (older version than current 2.13.2). To downgrade your Nix version:
+> 
 > `nix-channel --update; nix-env -iA nixpkgs.nixVersions.nix_2_11 nixpkgs.cacert; systemctl daemon-reload; systemctl restart nix-daemon`
+> 
 > Upgrading Nix: https://nixos.org/manual/nix/unstable/installation/upgrading.html
+> 
+> **Then, don't forget to exit Terminal and reload to take into account the version change**
 
 
 #### 3. Build Core Code

bin/gargantext-import/Main.hs

@@ -23,12 +23,14 @@ import System.Environment (getArgs)
 import qualified Data.Text as Text
 import Text.Read (readMaybe)
 
-import Gargantext.API.Dev (withDevEnv, runCmdDev)
-import Gargantext.API.Admin.EnvTypes (DevEnv(..))
+import Gargantext.API.Dev (withDevEnv, runCmdGargDev)
+import Gargantext.API.Admin.EnvTypes (DevEnv(..), DevJobHandle(..))
+import Gargantext.API.Admin.Orchestrator.Types (JobLog)
 import Gargantext.API.Node () -- instances
 import Gargantext.API.Prelude (GargError)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Core.Types.Query (Limit)
 import Gargantext.Database.Action.Flow (flowCorpusFile, flowAnnuaire, TermType(..))
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Admin.Types.Hyperdata (toHyperdataDocument)
@@ -36,6 +38,7 @@ import Gargantext.Database.Admin.Types.Node (CorpusId)
 import Gargantext.Database.Prelude (Cmd)
 import Gargantext.Prelude
 import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..))
+import Gargantext.Utils.Jobs (MonadJobStatus, JobHandle)
 
 main :: IO ()
 main = do
@@ -47,17 +50,17 @@ main = do
     --tt = (Unsupervised EN 6 0 Nothing)
     tt = (Multi EN)
     format = CsvGargV3 -- CsvHal --WOS
-    limit' = case (readMaybe limit :: Maybe Int) of
+    limit' = case (readMaybe limit :: Maybe Limit) of
       Nothing -> panic $ "Cannot read limit: " <> (Text.pack limit)
       Just l  -> l
-    corpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
-    corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) limit' tt  format Plain corpusPath Nothing (\_ -> pure ())
+    corpus :: forall m. (FlowCmdM DevEnv GargError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
+    corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) limit' tt  format Plain corpusPath Nothing DevJobHandle
 
-    corpusCsvHal :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
-    corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) limit' tt CsvHal Plain corpusPath Nothing (\_ -> pure ())
+    corpusCsvHal :: forall m. (FlowCmdM DevEnv GargError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
+    corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) limit' tt CsvHal Plain corpusPath Nothing DevJobHandle
 
-    annuaire :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
-    annuaire = flowAnnuaire (UserName $ cs user) (Left "Annuaire") (Multi EN) corpusPath (\_ -> pure ())
+    annuaire :: forall m. (FlowCmdM DevEnv GargError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
+    annuaire = flowAnnuaire (UserName $ cs user) (Left "Annuaire") (Multi EN) corpusPath DevJobHandle
 
   {-
   let debatCorpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
@@ -72,15 +75,15 @@ main = do
 
   withDevEnv iniPath $ \env -> do
     _ <- if fun == "corpus"
-          then runCmdDev env corpus
+          then runCmdGargDev env corpus
           else pure 0 --(cs "false")
 
     _ <- if fun == "corpusCsvHal"
-          then runCmdDev env corpusCsvHal
+          then runCmdGargDev env corpusCsvHal
           else pure 0 --(cs "false")
 
     _ <- if fun == "annuaire"
-            then runCmdDev env annuaire
+            then runCmdGargDev env annuaire
             else pure 0
     {-
     _ <- if corpusType == "csv"

bin/gargantext-invitations/Main.hs

@@ -14,25 +14,17 @@ Portability : POSIX
 
 module Main where
 
-import Data.Either (Either(..))
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Node () -- instances only
 import Gargantext.API.Prelude (GargError)
-import Gargantext.Core.Types.Individu (User(..), arbitraryNewUsers, NewUser(..), arbitraryUsername, GargPassword(..))
-import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMk_RootWithCorpus)
-import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
-import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
-import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
+import Gargantext.Core.NLP (HasNLPServer)
+import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (CmdR)
-import Gargantext.Database.Query.Table.Node (getOrMkList)
-import Gargantext.Database.Query.Table.User (insertNewUsers, )
+import Gargantext.Database.Prelude (CmdRandom)
 import Gargantext.Prelude
-import Gargantext.Prelude.Config (GargConfig(..), readConfig)
-import Prelude (getLine, read)
+import Gargantext.Prelude.Config (readConfig)
+import Prelude (read)
 import System.Environment (getArgs)
-import Gargantext.Database.Action.User.New (newUsers)
-import Gargantext.Core.Types.Individu (User(..))
 import qualified Gargantext.API.Node.Share as Share
 
 main :: IO ()
@@ -43,9 +35,9 @@ main = do
       then panic "USAGE: ./gargantext-init gargantext.ini username node_id student@university.edu"
       else pure ()
 
-  cfg       <- readConfig         iniPath
+  _cfg       <- readConfig         iniPath
 
-  let invite :: CmdR GargError Int
+  let invite :: (CmdRandom env GargError m, HasNLPServer env) => m Int
       invite = Share.api (UserName $ cs user) (NodeId $ (read node_id :: Int)) (Share.ShareTeamParams $ cs email)
 
   withDevEnv iniPath $ \env -> do

bin/gargantext-phylo/Main.hs

@@ -278,7 +278,7 @@ main = do
 
             printIOComment (show (length $ nub $ concat $ map text corpus) <> " Size ngs_coterms")
 
-            printIOComment (show (length mapList) <> " Size ngs_terms List Map Ngrams")            
+            printIOComment (show (length mapList) <> " Size ngs_terms List Map Ngrams")
 
             printIOMsg "Reconstruct the phylo"
 

bin/gargantext-server/Main.hs

@@ -11,29 +11,29 @@ Script to start gargantext with different modes (Dev, Prod, Mock).
 
 -}
 
+{-# LANGUAGE QuasiQuotes          #-}
 {-# LANGUAGE StandaloneDeriving   #-}
-{-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE Strict               #-}
+{-# LANGUAGE TypeOperators        #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
+
 module Main where
 
-import Data.Version (showVersion)
+
+import Data.Maybe (fromMaybe)
 import Data.Text (unpack)
-import qualified Paths_gargantext as PG -- cabal magic build module
+import Data.Version (showVersion)
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import GHC.IO.Exception (IOException)
+import Gargantext.API (startGargantext, Mode(..)) -- , startGargantextMock)
+import Gargantext.API.Admin.EnvTypes (DevEnv)
+import Gargantext.API.Dev (withDevEnv, runCmdDev)
+import Gargantext.Prelude
 import Options.Generic
 import System.Exit (exitSuccess)
+import qualified Paths_gargantext as PG -- cabal magic build module
 
-import Gargantext.Prelude
-import Gargantext.API (startGargantext, Mode(..)) -- , startGargantextMock)
-
---------------------------------------------------------
--- Graph Tests
---import qualified Gargantext.Graph.Utils                    as U
---import qualified Gargantext.Graph.Distances.Conditional    as C
---import qualified Gargantext.Graph.Distances.Distributional as D
---import qualified Gargantext.Graph.Distances.Matrice        as M
---------------------------------------------------------
 
 instance ParseRecord Mode
 instance ParseField  Mode
@@ -59,24 +59,25 @@ main :: IO ()
 main = do
   MyOptions myMode myPort myIniFile myVersion  <- unwrapRecord
           "Gargantext server"
-
+  ---------------------------------------------------------------
   if myVersion then do
     putStrLn $ "Version: " <> showVersion PG.version
     System.Exit.exitSuccess
   else
     return ()
-
+  ---------------------------------------------------------------
   let myPort' = case myPort of
         Just p  -> p
         Nothing -> 8008
 
+      myIniFile' = case myIniFile of
+          Nothing -> panic "[ERROR] gargantext.ini needed"
+          Just i  -> i
+
+  ---------------------------------------------------------------
   let start = case myMode of
         Mock -> panic "[ERROR] Mock mode unsupported"
         _ -> startGargantext myMode myPort' (unpack myIniFile')
-            where
-              myIniFile' = case myIniFile of
-                  Nothing -> panic "[ERROR] gargantext.ini needed"
-                  Just i  -> i
-
   putStrLn $ "Starting with " <> show myMode <> " mode."
   start
+  ---------------------------------------------------------------

bin/gargantext_tmux

@@ -4,4 +4,4 @@ tmux new -d -s gargantext './server' \; \
             split-window -h -d 'cd ./purescript-gargantext ; ./server' \; \
             select-pane -t 1 \; \
             split-window -d    'cd deps/nlp/CoreNLP ; ./startServer.sh' \; \
-            split-window -d    'cd deps/nlp/spacy-server ; source env/bin/activate ; ./server' \; \
+            split-window -d    'cd deps/nlp/spacy-server ; docker-compose up' \; \

devops/docker/Dockerfile

-FROM fpco/stack-build:lts-18.18
+FROM ubuntu:jammy
 
-#RUN apt-key adv --keyserver hkp://pool.sks-keyservers.net:80 --recv-keys 8B1DA6120C2BF624
+ARG DEBIAN_FRONTEND=noninteractive
+ARG GHC=8.10.7
+ARG STACK=2.7.3
+ARG CABAL=3.10.1.0
+COPY ./shell.nix            /builds/gargantext/shell.nix
+COPY ./nix/pkgs.nix         /builds/gargantext/nix/pkgs.nix
+COPY ./nix/pinned-22.05.nix /builds/gargantext/nix/pinned-22.05.nix
+
+ENV TZ=Europe/Rome
 RUN apt-get update && \
-    apt-get install -y ca-certificates git libigraph0-dev && \
-    rm -rf /var/lib/apt/lists/*
+    apt-get install --no-install-recommends -y \
+      apt-transport-https \
+      autoconf \
+      automake \
+      build-essential \
+      ca-certificates \
+      curl \
+      gcc \
+      git \
+      gnupg2 \
+      libffi-dev \
+      libffi7 \
+      libgmp-dev \
+      libgmp10 \
+      libncurses-dev \
+      libncurses5 \
+      libnuma-dev \
+      libtinfo5 \
+      locales \
+      lsb-release \
+      software-properties-common \
+      strace \
+      sudo \
+      wget \
+      vim \
+      xz-utils \
+      zlib1g-dev && \
+    apt-get clean && rm -rf /var/lib/apt/lists/* && \
+    mkdir -m 0755 /nix && groupadd -r nixbld && chown root /nix && \
+    for n in $(seq 1 10); do useradd -c "Nix build user $n" -d /var/empty -g nixbld -G nixbld -M -N -r -s "$(command -v nologin)" "nixbld$n"; done
+
+RUN gpg --batch --keyserver keys.openpgp.org     --recv-keys 7D1E8AFD1D4A16D71FADA2F2CCC85C0E40C06A8C && \
+    gpg --batch --keyserver keyserver.ubuntu.com --recv-keys FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01
+SHELL ["/bin/bash", "-o", "pipefail", "-c"]
+
+RUN set -o pipefail && \
+    bash <(curl -L https://releases.nixos.org/nix/nix-2.15.0/install) --no-daemon && \
+    locale-gen en_US.UTF-8 && chown root -R /nix
+
+ENV LANG='en_US.UTF-8' LANGUAGE='en_US:en' LC_ALL='en_US.UTF-8'
+ENV USER=root
+ENV SHELL /bin/bash
+RUN . "$HOME/.nix-profile/etc/profile.d/nix.sh" && \
+    mkdir -p "/builds/gargantext/" && chmod 777 -R "/builds/gargantext" && \
+    echo "source $HOME/.nix-profile/etc/profile.d/nix.sh" >> "$HOME/.bashrc" && \
+    echo `which nix-env`
+
+ENV PATH=/root/.nix-profile/bin:$PATH
+
+RUN . $HOME/.bashrc && nix-env --version
+
+RUN \
+curl https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > /usr/bin/ghcup && \
+    chmod +x /usr/bin/ghcup && \
+    ghcup config set gpg-setting GPGLax && \
+    ghcup -v install ghc --force ${GHC} && \
+    ghcup -v install cabal --force ${CABAL} && \
+    ghcup -v install stack --force ${STACK}
+
+ENV PATH=/root/.ghcup/bin:$PATH
+ENV PATH=/root/.local/bin:$PATH
+
+
+RUN cd /builds/gargantext && nix-shell
+RUN ghcup set 8.10.7 && cabal v2-update && cabal v2-install hpack --overwrite-policy=always
 
+WORKDIR "/builds/gargantext/"

devops/docker/docker-compose.yaml

@@ -48,6 +48,8 @@ services:
       - postgres
     links:
       - postgres
+    volumes:
+      - pgadmin:/var/lib/pgadmin
 
   corenlp:
     image: 'cgenie/corenlp-garg'
@@ -65,3 +67,4 @@ volumes:
   #garg-pgdata:
   garg-pgdata14:
   js-cache:
+  pgadmin:

devops/postgres/schema.sql

@@ -335,3 +335,25 @@ CREATE OR REPLACE function node_pos(int, int) returns bigint
 
 --drop index node_by_pos;
 --create index node_by_pos on nodes using btree(node_pos(id,typename));
+
+-- Optimization for Ngrams Table View
+-- CREATE MATERIALIZED VIEW IF NOT EXISTS context_node_ngrams_view AS
+--   SELECT DISTINCT context_node_ngrams.context_id, ngrams_id, nodes_contexts.node_id
+--   FROM nodes_contexts
+--   JOIN context_node_ngrams
+--   ON context_node_ngrams.context_id = nodes_contexts.context_id;
+
+-- CREATE INDEX IF NOT EXISTS context_node_ngrams_view_context_id_idx
+--   ON context_node_ngrams_view(context_id);
+-- CREATE INDEX IF NOT EXISTS context_node_ngrams_view_ngrams_id_idx
+--   ON context_node_ngrams_view(ngrams_id);
+-- CREATE INDEX IF NOT EXISTS context_node_ngrams_view_node_id_idx
+--   ON context_node_ngrams_view(node_id);
+-- CREATE UNIQUE INDEX IF NOT EXISTS context_node_ngrams_view_context_ngrams_node_uniq_idx
+--   ON context_node_ngrams_view (context_id, ngrams_id, node_id);
+
+CREATE INDEX IF NOT EXISTS context_node_ngrams_context_id_ngrams_id_idx
+ON context_node_ngrams(context_id, ngrams_id);
+
+CREATE INDEX IF NOT EXISTS node_stories_ngrams_id_idx
+  ON node_stories(ngrams_id);

devops/postgres/upgrade/0.0.6.9.9.4.4.sql

+-- create materialized view if  not exists context_node_ngrams_view as
+-- select context_node_ngrams.context_id, ngrams_id, nodes_contexts.node_id
+-- from nodes_contexts
+-- join context_node_ngrams
+-- on context_node_ngrams.context_id = nodes_contexts.context_id;
+
+-- create index if not exists context_node_ngrams_view_context_id_idx on context_node_ngrams_view(context_id);
+-- create index if not exists context_node_ngrams_view_ngrams_id_idx on context_node_ngrams_view(ngrams_id);
+-- create index if not exists context_node_ngrams_view_node_id_idx on context_node_ngrams_view(node_id);
+
+create index if not exists context_node_ngrams_context_id_ngrams_id_idx on context_node_ngrams(context_id, ngrams_id);
+create index if not exists node_stories_ngrams_id_idx on node_stories(ngrams_id);

devops/postgres/upgrade/0.0.6.9.9.6.4.sql

+-- Remove unused old materialized view
+drop materialized view context_node_ngrams_view;
+
+-- FIX NGRAMS Parents
+with query as (
+with child_ngrams as
+(select jsonb_array_elements_text(ngrams_repo_element->'children') as term
+from node_stories),
+parent_ngrams as
+(select ngrams_repo_element->>'root' as term
+from node_stories)
+
+(select child_ngrams.term, ngrams.terms
+from child_ngrams
+left join ngrams on child_ngrams.term = ngrams.terms
+where ngrams.terms is null
+
+union
+
+select parent_ngrams.term, ngrams.terms
+from parent_ngrams
+left join ngrams on parent_ngrams.term = ngrams.terms
+where ngrams.terms is null
+and parent_ngrams.term is not null)
+
+order by term
+)
+INSERT INTO ngrams (terms) select term from query;
+
+
+-- ADD triggers
+ CREATE OR REPLACE FUNCTION check_node_stories_json()
+  RETURNS TRIGGER AS $$
+  DECLARE
+    missing_ngrams_exist boolean;
+  BEGIN
+      WITH child_ngrams as
+        (SELECT jsonb_array_elements_text(NEW.ngrams_repo_element->'children') AS term),
+        parent_ngrams AS
+        (SELECT NEW.ngrams_repo_element->>'root' AS term),
+
+        ngrams_child_parent AS
+            (SELECT child_ngrams.term, ngrams.terms
+         FROM child_ngrams
+         LEFT JOIN ngrams ON child_ngrams.term = ngrams.terms
+         WHERE ngrams.terms IS NULL
+
+        UNION
+
+        SELECT parent_ngrams.term, ngrams.terms
+        FROM parent_ngrams
+        LEFT JOIN ngrams ON parent_ngrams.term = ngrams.terms
+        WHERE ngrams.terms IS NULL
+        AND parent_ngrams.term IS NOT NULL)
+
+            SELECT EXISTS(SELECT * FROM ngrams_child_parent) INTO missing_ngrams_exist;
+
+            IF missing_ngrams_exist THEN
+              RAISE EXCEPTION 'node_stories: ngrams are missing: %', row_to_json(NEW);
+        END IF;
+
+            RETURN NEW;
+  END;
+  $$ LANGUAGE plpgsql;
+
+CREATE OR REPLACE TRIGGER check_node_stories_json_trg
+AFTER INSERT OR UPDATE
+ON node_stories
+FOR EACH ROW
+EXECUTE PROCEDURE check_node_stories_json();
+
+
+   CREATE OR REPLACE FUNCTION check_ngrams_json()
+    RETURNS TRIGGER AS $$
+    DECLARE
+      missing_ngrams_exist boolean;
+    BEGIN
+        WITH child_ngrams as
+          (SELECT jsonb_array_elements_text(ngrams_repo_element->'children') AS term
+           FROM node_stories
+           WHERE term = OLD.terms),
+          parent_ngrams AS
+          (SELECT ngrams_repo_element->>'root' AS term
+           FROM node_stories
+           WHERE term = OLD.terms),
+          child_parent_ngrams AS
+          (SELECT * FROM child_ngrams
+           UNION SELECT * FROM parent_ngrams)
+
+       SELECT EXISTS(SELECT * FROM child_parent_ngrams) INTO missing_ngrams_exist;
+
+       IF missing_ngrams_exist THEN
+          RAISE EXCEPTION 'ngrams are missing: %', row_to_json(OLD);
+       END IF;
+
+       RETURN OLD;
+    END;
+    $$ LANGUAGE plpgsql;
+
+  CREATE OR REPLACE TRIGGER check_ngrams_json_trg
+  AFTER DELETE
+  ON ngrams
+  FOR EACH ROW
+  EXECUTE PROCEDURE check_ngrams_json();
+
+
+
+

devops/postgres/upgrade/0.0.6.9.9.6.4_check.sql

+
+with child_ngrams as
+(select jsonb_array_elements_text(ngrams_repo_element->'children') as term
+from node_stories),
+parent_ngrams as
+(select ngrams_repo_element->>'root' as term
+from node_stories)
+
+(select child_ngrams.term, ngrams.terms
+from child_ngrams
+left join ngrams on child_ngrams.term = ngrams.terms
+where ngrams.terms is null
+
+union
+
+select parent_ngrams.term, ngrams.terms
+from parent_ngrams
+left join ngrams on parent_ngrams.term = ngrams.terms
+where ngrams.terms is null
+and parent_ngrams.term is not null)
+
+order by term;
+

gargantext.ini_toModify

@@ -84,3 +84,15 @@ MAIL_PASSWORD =
 MAIL_FROM     = 
 # NoAuth | Normal | SSL | TLS | STARTTLS
 MAIL_LOGIN_TYPE = Normal
+
+[nlp]
+# Possible choices (see Gargantext.Core.NLP):
+# - spacy:// (for http:// Spacy)
+# - spacys:// (for https:// Spacy)
+# - corenlp:// (for http:// CoreNLP)
+# - corenlps:// (for https:// CoreNLP)
+# - johnsnow:// (for http:// JohnSnow)
+# - johnsnows:// (for https:// JohnSnow)
+EN = corenlp://localhost:9000
+FR = spacy://localhost:8001
+All = corenlp://localhost:9000

nix/pkgs.nix

@@ -3,6 +3,61 @@
 rec {
   inherit pkgs;
   ghc = pkgs.haskell.compiler.ghc8107;
+  igraph_0_10_4 = pkgs.igraph.overrideAttrs (finalAttrs: previousAttrs: {
+    version = "0.10.4";
+
+    src = pkgs.fetchFromGitHub {
+      owner = "igraph";
+      repo = "igraph";
+      rev = "0.10.4";
+      hash = "sha256-LsTOxUktGZcp46Ec9QH3+9C+VADMYTZZCjKF1gp36xk=";
+    };
+
+    postPatch = ''
+      echo "0.10.4" > IGRAPH_VERSION
+    '';
+
+    outputs = [ "out" "doc" ];
+
+    buildInputs = [
+      pkgs.arpack
+      pkgs.blas
+      pkgs.glpk
+      pkgs.gmp
+      pkgs.lapack
+      pkgs.libxml2
+      pkgs.plfit
+    ] ++ pkgs.lib.optionals pkgs.stdenv.cc.isClang [
+      pkgs.llvmPackages.openmp
+    ];
+
+    cmakeFlags = [
+      "-DIGRAPH_USE_INTERNAL_BLAS=OFF"
+      "-DIGRAPH_USE_INTERNAL_LAPACK=OFF"
+      "-DIGRAPH_USE_INTERNAL_ARPACK=OFF"
+      "-DIGRAPH_USE_INTERNAL_GLPK=OFF"
+      "-DIGRAPH_USE_INTERNAL_GMP=OFF"
+      "-DIGRAPH_USE_INTERNAL_PLFIT=OFF"
+      "-DIGRAPH_GLPK_SUPPORT=ON"
+      "-DIGRAPH_GRAPHML_SUPPORT=ON"
+      "-DIGRAPH_OPENMP_SUPPORT=ON"
+      "-DIGRAPH_ENABLE_LTO=AUTO"
+      "-DIGRAPH_ENABLE_TLS=ON"
+      "-DBUILD_SHARED_LIBS=ON"
+    ];
+
+    postInstall = ''
+      mkdir -p "$out/share"
+      cp -r doc "$out/share"
+    '';
+
+    postFixup = previousAttrs.postFixup + ''
+      CUR_DIR=$PWD
+      cd "$out/include/igraph" && cp *.h ../
+      cd $CUR_DIR
+    '';
+
+  });
   hsBuildInputs = [
     ghc
     pkgs.cabal-install
@@ -16,9 +71,8 @@ rec {
     gsl
     #haskell-language-server
     hlint
-    igraph
     libffi
-    liblapack
+    lapack
     lzma
     pcre
     pkgconfig
@@ -32,6 +86,7 @@ rec {
     icu
     graphviz
     llvm_9
+    igraph_0_10_4
   ] ++ ( lib.optionals stdenv.isDarwin [
        darwin.apple_sdk.frameworks.Accelerate
        ]);

package.yaml

@@ -6,7 +6,7 @@ name: gargantext
 #         | | | +-----  Layers * : New versions with API additions
 #         | | | | +---  Layers * : New versions without API breaking changes
 #         | | | | |
-version: '0.0.6.9.5'
+version: '0.0.6.9.9.6.9'
 synopsis: Search, map, share
 description: Please see README.md
 category: Data
@@ -16,7 +16,8 @@ copyright:
     - ! 'Copyright: (c) 2017-Present: see git logs and README'
 license: AGPL-3
 homepage: https://gargantext.org
-ghc-options: -Wall
+ghc-options:
+  - -Wall
 dependencies:
   - extra
   - text
@@ -25,6 +26,7 @@ default-extensions:
   - DeriveGeneric
   - FlexibleContexts
   - FlexibleInstances
+  - GADTs
   - GeneralizedNewtypeDeriving
   - MultiParamTypeClasses
   - NamedFieldPuns
@@ -42,6 +44,9 @@ data-files:
   - ekg-assets/bootstrap-1.4.0.min.css
   - ekg-assets/chart_line_add.png
   - ekg-assets/cross.png
+  - test-data/ngrams/GarganText_NgramsTerms-QuantumComputing.json
+  - test-data/phylo/bpa_phylo_test.json
+  - test-data/phylo/open_science.json
 library:
   source-dirs: src
   ghc-options:
@@ -52,12 +57,14 @@ library:
   - -Wunused-imports
   - -Werror
   - -freduction-depth=300
+  - -fplugin=Clippy
   exposed-modules:
   - Gargantext
   - Gargantext.API
   - Gargantext.API.Admin.Auth.Types
   - Gargantext.API.Admin.EnvTypes
   - Gargantext.API.Admin.Settings
+  - Gargantext.API.Admin.Orchestrator.Types
   - Gargantext.API.Admin.Types
   - Gargantext.API.Dev
   - Gargantext.API.HashedResponse
@@ -66,18 +73,25 @@ library:
   - Gargantext.API.Ngrams.Tools
   - Gargantext.API.Ngrams.Types
   - Gargantext.API.Node
+  - Gargantext.API.Node.Corpus.New
+  - Gargantext.API.Node.Corpus.Types
   - Gargantext.API.Node.File
   - Gargantext.API.Node.Share
   - Gargantext.API.Prelude
   - Gargantext.Core
+  - Gargantext.Core.NLP
   - Gargantext.Core.Methods.Similarities
   - Gargantext.Core.NodeStory
   - Gargantext.Core.Text
   - Gargantext.Core.Text.Context
   - Gargantext.Core.Text.Corpus.API
+  - Gargantext.Core.Text.Corpus.API.Arxiv
+  - Gargantext.Core.Text.Corpus.API.Pubmed
+  - Gargantext.Core.Text.Corpus.Query
   - Gargantext.Core.Text.Corpus.Parsers
   - Gargantext.Core.Text.Corpus.Parsers.CSV
   - Gargantext.Core.Text.Corpus.Parsers.Date.Parsec
+  - Gargantext.Core.Text.Corpus.Parsers.JSON
   - Gargantext.Core.Text.List.Formats.CSV
   - Gargantext.Core.Text.Metrics
   - Gargantext.Core.Text.Metrics.CharByChar
@@ -88,6 +102,7 @@ library:
   - Gargantext.Core.Text.Terms
   - Gargantext.Core.Text.Terms.Eleve
   - Gargantext.Core.Text.Terms.Mono
+  - Gargantext.Core.Text.Terms.Multi
   - Gargantext.Core.Text.Terms.Multi.Lang.En
   - Gargantext.Core.Text.Terms.Multi.Lang.Fr
   - Gargantext.Core.Text.Terms.Multi.RAKE
@@ -95,6 +110,8 @@ library:
   - Gargantext.Core.Types
   - Gargantext.Core.Types.Individu
   - Gargantext.Core.Types.Main
+  - Gargantext.Core.Types.Query
+  - Gargantext.Core.Types.Phylo
   - Gargantext.Core.Utils
   - Gargantext.Core.Utils.Prefix
   - Gargantext.Core.Viz.Graph
@@ -125,7 +142,7 @@ library:
   - Gargantext.Database.Schema.Ngrams
   - Gargantext.Defaults
   - Gargantext.Utils.Jobs
-  - Gargantext.Utils.Jobs.API
+  - Gargantext.Utils.Jobs.Internal
   - Gargantext.Utils.Jobs.Map
   - Gargantext.Utils.Jobs.Monad
   - Gargantext.Utils.Jobs.Queue
@@ -157,11 +174,13 @@ library:
   - blaze-html
   - blaze-markup
   - blaze-svg
+  - boolexpr
   - bytestring
   - case-insensitive
   - cassava
   - cereal     # (IGraph)
   - cborg
+  - ghc-clippy-plugin
   - conduit
   - conduit-extra
   - containers
@@ -171,6 +190,7 @@ library:
   - crawlerISTEX
   - crawlerIsidore
   - crawlerPubMed
+  - cron
   - cryptohash
   - data-time-segment
   - deepseq
@@ -222,6 +242,7 @@ library:
   - morpheus-graphql-subscriptions
   - mtl
   - natural-transformation
+  - network-uri
   - opaleye
   - pandoc
   - parallel
@@ -242,6 +263,7 @@ library:
   - rake
   - random
   - rdf4h
+  - replace-attoparsec
   - regex-compat
   - regex-tdfa
   - resource-pool
@@ -322,15 +344,16 @@ executables:
     - -fprof-auto
     dependencies:
       - base
+      - cassava
       - containers
+      - full-text-search
       - gargantext
       - gargantext-prelude
-      - vector
-      - cassava
       - ini
       - optparse-generic
+      - postgresql-simple
       - unordered-containers
-      - full-text-search
+      - vector
 
   gargantext-cli:
     main: Main.hs
@@ -383,7 +406,7 @@ executables:
       - split
       - unordered-containers
       - cryptohash
-      - time 
+      - time
 
   gargantext-import:
     main: Main.hs
@@ -413,6 +436,7 @@ executables:
       - gargantext
       - gargantext-prelude
       - base
+      - cron
 
   gargantext-invitations:
     main: Main.hs
@@ -443,6 +467,7 @@ executables:
       - gargantext-prelude
       - base
       - postgresql-simple
+      - cron
 
   gargantext-admin:
     main: Main.hs
@@ -476,7 +501,6 @@ executables:
       - aeson
       - serialise
 
-
 tests:
    garg-test:
      main: Main.hs
@@ -496,30 +520,38 @@ tests:
      - -rtsopts
      - -with-rtsopts=-N
      dependencies:
+     - QuickCheck
+     - aeson
+     - async
      - base
+     - boolexpr
+     - bytestring
+     - conduit
+     - containers
+     - crawlerArxiv
+     - duckling
      - gargantext
      - gargantext-prelude
      - hspec
-     - QuickCheck
-     - quickcheck-instances
-     - time
+     - http-client
+     - http-client-tls
+     - mtl
      - parsec
+     - patches-class
+     - patches-map
      - duckling
+     - quickcheck-instances
+     - raw-strings-qq
+     - servant-job
+     - stm
+     - tasty
+     - tasty-hspec
+     - tasty-hunit
+     - tasty-quickcheck
      - text
+     - time
      - unordered-containers
-   jobqueue-test:
-     main: Main.hs
-     source-dirs: tests/queue
-     ghc-options:
-     - -threaded
-     - -rtsopts
-     - -with-rtsopts=-N
-     dependencies:
-     - base
-     - gargantext
-     - hspec
-     - async
-     - stm
+     - validity
 #  garg-doctest:
 #    main: Main.hs
 #    source-dirs: src-doctest
@@ -547,4 +579,3 @@ tests:
 #    - OverloadedStrings
 #    - RankNTypes
 #
-

src-test/Core/Utils.hs

@@ -18,8 +18,8 @@ import Gargantext.Prelude
 import Gargantext.Core.Utils
 
 -- | Core.Utils tests
-test :: IO ()
-test = hspec $ do
+test :: Spec
+test = do
   describe "check if groupWithCounts works" $ do
     it "simple integer array" $ do
       (groupWithCounts [1, 2, 3, 1, 2, 3]) `shouldBe` [(1, 2), (2, 2), (3, 2)]

src-test/Graph/Clustering.hs

@@ -30,8 +30,8 @@ myCooc = HashMap.fromList [((NgramsTerm {unNgramsTerm = "gev au"},NgramsTerm {un
 
 
 
-test :: IO ()
-test = hspec $ do
+test :: Spec
+test = do
   describe "Cross" $ do
     let
       (distanceMap,_,_) = doSimilarityMap Conditional 0 Weak myCooc

src-test/Main.hs

@@ -10,26 +10,45 @@ Portability : POSIX
 
 
 import Gargantext.Prelude
-import Gargantext.Core (Lang(..))
 
+import qualified Core.Text.Corpus.Query  as CorpusQuery
 import qualified Core.Utils as Utils
 --import qualified Ngrams.Lang.Fr as Fr
 --import qualified Ngrams.Lang as Lang
-import qualified Ngrams.Lang.Occurrences as Occ
-import qualified Ngrams.Metrics          as Metrics
+import qualified Ngrams.NLP              as NLP
+import qualified Ngrams.Query            as NgramsQuery
 import qualified Parsers.Date            as PD
 -- import qualified Graph.Distance          as GD
 import qualified Graph.Clustering        as Graph
 import qualified Utils.Crypto            as Crypto
+import qualified Utils.Jobs              as Jobs
+import qualified Offline.JSON            as JSON
+
+import Test.Tasty
+import Test.Tasty.Hspec
 
 main :: IO ()
 main = do
-  Utils.test
+  utilSpec         <- testSpec "Utils" Utils.test
+  clusteringSpec   <- testSpec "Graph Clustering" Graph.test
+  dateParserSpec   <- testSpec "Date Parsing" PD.testFromRFC3339
+  cryptoSpec       <- testSpec "Crypto" Crypto.test
+  nlpSpec          <- testSpec "NLP" NLP.test
+  jobsSpec         <- testSpec "Jobs" Jobs.test
+
+  defaultMain $ testGroup "Gargantext"
+    [ utilSpec
+    , clusteringSpec
+    , dateParserSpec
+    , cryptoSpec
+    , nlpSpec
+    , jobsSpec
+    , NgramsQuery.tests
+    , CorpusQuery.tests
+    , JSON.tests
+    ]
 --    Occ.parsersTest
 --    Lang.ngramsExtractionTest FR
 --    Lang.ngramsExtractionTest EN
 --    Metrics.main
-  Graph.test
-  PD.testFromRFC3339
 --    GD.test
-  Crypto.test

src-test/Ngrams/NLP.hs

+
+{-|
+Module      : Ngrams.NLP
+Description : 
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+
+module Ngrams.NLP where
+
+import Data.Text (Text)
+import Test.Hspec
+import Gargantext.Prelude
+import Gargantext.Core.Text.Terms.Multi
+
+
+test :: Spec
+test = do
+  describe "Text that should be cleaned before sending it to NLP tools as micro-services." $ do
+    let text   = "This is a url http://cnrs.gargantext.org to be remove and another one www.gargantext.org and digits 343242-2332 to be remove and some to keep: 232 231 33." :: Text
+    let result = "This is a url to be remove and another one and digits to be remove and some to keep: 232 231 33."
+    it "NLP Clean Text before sending to micro services:" $ cleanTextForNLP text `shouldBe` result
+

src-test/Ngrams/Query/PaginationCorpus.hs

+{-# LANGUAGE ScopedTypeVariables #-}
+module Ngrams.Query.PaginationCorpus where
+
+import           Prelude
+
+import           Data.Aeson
+import           Data.Map.Strict (Map)
+import           Gargantext.API.Ngrams
+import           Gargantext.API.Ngrams.Types
+import           Gargantext.Core.Types.Main
+import           Gargantext.Database.Admin.Types.Node
+import           System.IO.Unsafe
+import qualified Data.ByteString as B
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+
+import Paths_gargantext
+
+
+implementationElem :: NgramsElement
+implementationElem = NgramsElement {
+    _ne_ngrams = "implementation"
+  , _ne_size = 1
+  , _ne_list = MapTerm
+  , _ne_occurrences = Set.fromList [ NodeId 1, NodeId 2, NodeId 3, NodeId 4, NodeId 5 ]
+  , _ne_root = Nothing
+  , _ne_parent = Nothing
+  , _ne_children = mSetFromList [ "code", "functions", "language", "programs" ]
+  }
+
+languagesElem :: NgramsElement
+languagesElem = NgramsElement {
+    _ne_ngrams = NgramsTerm {unNgramsTerm = "languages"}
+  , _ne_size = 1
+  , _ne_list = MapTerm
+  , _ne_occurrences = Set.fromList [ NodeId 1, NodeId 2 , NodeId 3 , NodeId 4 ]
+  , _ne_root = Nothing
+  , _ne_parent = Nothing
+  , _ne_children = mSetFromList [ "approach", "use" ]
+  }
+
+termsElem :: NgramsElement
+termsElem = NgramsElement {
+    _ne_ngrams = NgramsTerm {unNgramsTerm = "terms"}
+  , _ne_size = 1
+  , _ne_list = MapTerm
+  , _ne_occurrences = Set.fromList [ NodeId 1, NodeId 2 , NodeId 3 ]
+  , _ne_root = Nothing
+  , _ne_parent = Nothing
+  , _ne_children = mSetFromList [ "algorithm", "evaluation", "monad", "programmers" ]
+  }
+
+proofElem :: NgramsElement
+proofElem = NgramsElement {
+    _ne_ngrams = NgramsTerm {unNgramsTerm = "proof"}
+  , _ne_size = 1
+  , _ne_list = MapTerm
+  , _ne_occurrences = Set.fromList [ NodeId 1, NodeId 2 ]
+  , _ne_root = Nothing
+  , _ne_parent = Nothing
+  , _ne_children = mSetFromList [ "proofs" ]
+  }
+
+sideEffectsElem :: NgramsElement
+sideEffectsElem = NgramsElement {
+    _ne_ngrams = NgramsTerm {unNgramsTerm = "side effects"}
+  , _ne_size = 1
+  , _ne_list = StopTerm
+  , _ne_occurrences = Set.fromList [ NodeId 1, NodeId 2, NodeId 3, NodeId 4, NodeId 5, NodeId 6 ]
+  , _ne_root = Nothing
+  , _ne_parent = Nothing
+  , _ne_children = mSetFromList [ ]
+  }
+
+ooElem :: NgramsElement
+ooElem = NgramsElement {
+    _ne_ngrams = NgramsTerm {unNgramsTerm = "object oriented"}
+  , _ne_size = 1
+  , _ne_list = StopTerm
+  , _ne_occurrences = Set.fromList [ NodeId 1, NodeId 2, NodeId 3, NodeId 4, NodeId 5 ]
+  , _ne_root = Nothing
+  , _ne_parent = Nothing
+  , _ne_children = mSetFromList [ "null pointer exception" ]
+  }
+
+javaElem :: NgramsElement
+javaElem = NgramsElement {
+    _ne_ngrams = NgramsTerm {unNgramsTerm = "java"}
+  , _ne_size = 1
+  , _ne_list = StopTerm
+  , _ne_occurrences = Set.fromList [ NodeId 1, NodeId 2, NodeId 3 ]
+  , _ne_root = Nothing
+  , _ne_parent = Nothing
+  , _ne_children = mSetFromList [ "JVM" ]
+  }
+
+pascalElem :: NgramsElement
+pascalElem = NgramsElement {
+    _ne_ngrams = NgramsTerm {unNgramsTerm = "pascal"}
+  , _ne_size = 1
+  , _ne_list = StopTerm
+  , _ne_occurrences = Set.fromList [ NodeId 1, NodeId 2 ]
+  , _ne_root = Nothing
+  , _ne_parent = Nothing
+  , _ne_children = mSetFromList [ "turbo", "borland" ]
+  }
+
+haskellElem :: NgramsElement
+haskellElem = NgramsElement {
+    _ne_ngrams = NgramsTerm {unNgramsTerm = "haskell"}
+  , _ne_size = 1
+  , _ne_list = CandidateTerm
+  , _ne_occurrences = Set.fromList [ NodeId 1, NodeId 2, NodeId 3, NodeId 4, NodeId 5, NodeId 6, NodeId 7, NodeId 8 ]
+  , _ne_root = Nothing
+  , _ne_parent = Nothing
+  , _ne_children = mSetFromList [ ]
+  }
+
+concHaskellElem :: NgramsElement
+concHaskellElem = NgramsElement {
+    _ne_ngrams = NgramsTerm {unNgramsTerm = "concurrent haskell"}
+  , _ne_size = 1
+  , _ne_list = CandidateTerm
+  , _ne_occurrences = Set.fromList [ NodeId 1, NodeId 2, NodeId 3, NodeId 4, NodeId 5 ]
+  , _ne_root = Nothing
+  , _ne_parent = Nothing
+  , _ne_children = mSetFromList [ "Simon Marlow" ]
+  }
+
+-- | A big (for the sake of the tests anyway) corpus which has
+-- * 4 @MapTerm@s
+-- * 4 @StopTerm@s
+-- * 2 @CandidateTerm@s
+paginationCorpus :: Versioned (Map NgramsTerm NgramsElement)
+paginationCorpus = Versioned 0 $ Map.fromList [
+    -- Map terms
+    ( "implementation", implementationElem)
+  , ( "languages", languagesElem)
+  , ( "terms", termsElem)
+  , ("proof", proofElem)
+
+    -- Stop terms
+  , ("side effects", sideEffectsElem)
+  , ("object oriented", ooElem)
+  , ("java", javaElem)
+  , ("pascal", pascalElem)
+
+    -- Candidate terms
+  , ("haskell", haskellElem)
+  , ("concurrent haskell", concHaskellElem)
+  ]
+
+quantumComputingCorpus :: Versioned (Map NgramsTerm NgramsElement)
+quantumComputingCorpus = unsafePerformIO $ do
+  pth      <- getDataFileName "test-data/ngrams/GarganText_NgramsTerms-QuantumComputing.json"
+  jsonBlob <- B.readFile pth
+  case eitherDecodeStrict' jsonBlob of
+    Left err    -> error err
+    Right (Versioned ver (mp :: Map NgramsTerm NgramsRepoElement)) ->
+      pure $ Versioned ver (Map.mapWithKey (\k -> ngramsElementFromRepo k) mp)
+{-# NOINLINE quantumComputingCorpus #-}

src-test/Offline/JSON.hs

+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Offline.JSON (tests) where
+
+import Data.Aeson
+import Data.Either
+import Gargantext.API.Node.Corpus.New
+import Gargantext.API.Node.Corpus.Types
+import Gargantext.Core.Types.Phylo
+import Gargantext.Core.Viz.Phylo.API
+import Prelude
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
+import Text.RawString.QQ
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.Char8 as C8
+
+import Paths_gargantext
+
+jsonRoundtrip :: (Show a, FromJSON a, ToJSON a, Eq a) => a -> Property
+jsonRoundtrip a =
+  counterexample ("Parsed JSON: " <> C8.unpack (encode a)) $ eitherDecode (encode a) === Right a
+
+tests :: TestTree
+tests = testGroup "JSON" [
+    testProperty "Datafield roundtrips" (jsonRoundtrip @Datafield)
+  , testProperty "WithQuery roundtrips" (jsonRoundtrip @WithQuery)
+  , testCase "WithQuery frontend compliance" testWithQueryFrontend
+  , testGroup "Phylo" [
+    testProperty "PeriodToNode"  (jsonRoundtrip @PeriodToNodeData)
+  , testProperty "GraphData"     (jsonRoundtrip @GraphData)
+  , testProperty "GraphDataData" (jsonRoundtrip @GraphDataData)
+  , testProperty "ObjectData"    (jsonRoundtrip @ObjectData)
+  , testProperty "PhyloData"     (jsonRoundtrip @PhyloData)
+  , testProperty "LayerData"     (jsonRoundtrip @LayerData)
+  , testCase "can parse bpa_phylo_test.json" testParseBpaPhylo
+  , testCase "can parse open_science.json" testOpenSciencePhylo
+  ]
+  ]
+
+testWithQueryFrontend :: Assertion
+testWithQueryFrontend = do
+  assertBool "JSON instance will break frontend!"
+    (isRight $ eitherDecode @WithQuery (C8.pack cannedWithQueryPayload))
+
+-- The aim of this type is to catch regressions in the frontend serialisation; this
+-- is what the frontend currently expects, and therefore if we were to change the JSON
+-- instances, this test would fail, and we will be notified.
+cannedWithQueryPayload :: String
+cannedWithQueryPayload = [r| {"query":"Haskell","node_id":138,"lang":"EN","flowListWith":{"type":"MyListsFirst"},"datafield":"External Arxiv","databases":"Arxiv"} |]
+
+testParseBpaPhylo :: Assertion
+testParseBpaPhylo = do
+  pth      <- getDataFileName "test-data/phylo/bpa_phylo_test.json"
+  jsonBlob <- B.readFile pth
+  case eitherDecodeStrict' @GraphData jsonBlob of
+    Left err    -> error err
+    Right _     -> pure ()
+
+testOpenSciencePhylo :: Assertion
+testOpenSciencePhylo = do
+  pth      <- getDataFileName "test-data/phylo/open_science.json"
+  jsonBlob <- B.readFile pth
+  case eitherDecodeStrict' @PhyloData jsonBlob of
+    Left err    -> error err
+    Right _     -> pure ()

src-test/Parsers/Date.hs

@@ -36,8 +36,8 @@ fromRFC3339Inv ::  Either ParseError ZonedTime -> Text
 fromRFC3339Inv (Right z) = toRFC3339 z
 fromRFC3339Inv (Left pe) = panic . pack $ show pe
 
-testFromRFC3339 :: IO ()
-testFromRFC3339 = hspec $ do
+testFromRFC3339 :: Spec
+testFromRFC3339 = do
   describe "Test fromRFC3339: " $ do
     it "is the inverse of Duckling's toRFC3339" $ property $
       ((==) <*> (fromRFC3339 . fromRFC3339Inv)) . Right . looseZonedTimePrecision

src-test/Utils/Crypto.hs

@@ -16,11 +16,10 @@ import Test.Hspec
 
 import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Hash
-import Gargantext.Prelude.Utils
 
 -- | Crypto Hash tests
-test :: IO ()
-test = hspec $ do
+test :: Spec
+test = do
   describe "Hash String with frontend works" $ do
     let text = "To hash with backend" :: Text
     let hashed = "8a69a94d164279af2b7d1443ce08da6184b3d7e815406076e148159c284b53c3" :: Hash

src/Gargantext/API.hs

@@ -26,16 +26,20 @@ Pouillard (who mainly made it).
 
 -}
 
+{-# LANGUAGE BangPatterns         #-}
+{-# LANGUAGE NumericUnderscores   #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeOperators        #-}
 module Gargantext.API
       where
 
-import Control.Exception (catch, finally, SomeException)
+import Control.Concurrent
+import Control.Exception (catch, finally, SomeException{-, displayException, IOException-})
 import Control.Lens
 import Control.Monad.Except
 import Control.Monad.Reader (runReaderT)
 import Data.Either
+import Data.Foldable (foldlM)
 import Data.List (lookup)
 import Data.Text (pack)
 import Data.Text.Encoding (encodeUtf8)
@@ -52,7 +56,8 @@ import Gargantext.API.Ngrams (saveNodeStoryImmediate)
 import Gargantext.API.Routes
 import Gargantext.API.Server (server)
 import Gargantext.Core.NodeStory
-import qualified Gargantext.Database.Prelude as DB
+-- import Gargantext.Database.Prelude (Cmd)
+-- import Gargantext.Database.Action.Metrics.NgramsByContext (refreshNgramsMaterialized)
 import Gargantext.Prelude hiding (putStrLn)
 import Network.HTTP.Types hiding (Query)
 import Network.Wai
@@ -62,6 +67,8 @@ import Network.Wai.Middleware.RequestLogger
 import Paths_gargantext (getDataDir)
 import Servant
 import System.FilePath
+import qualified Gargantext.Database.Prelude as DB
+import qualified System.Cron.Schedule as Cron
 
 data Mode = Dev | Mock | Prod
   deriving (Show, Read, Generic)
@@ -74,7 +81,8 @@ startGargantext mode port file = do
   portRouteInfo port
   app <- makeApp env
   mid <- makeDevMiddleware mode
-  run port (mid app) `finally` stopGargantext env
+  periodicActions <- schedulePeriodicActions env
+  run port (mid app) `finally` stopGargantext env periodicActions
 
   where runDbCheck env = do
           r <- runExceptT (runReaderT DB.dbCheck env) `catch`
@@ -91,9 +99,12 @@ portRouteInfo port = do
   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 
+-- | Stops the gargantext server and cancels all the periodic actions
+-- scheduled to run up to that point.
 -- TODO clean this Monad condition (more generic) ?
-stopGargantext :: HasNodeStoryImmediateSaver env => env -> IO ()
-stopGargantext env = do
+stopGargantext :: HasNodeStoryImmediateSaver env => env -> [ThreadId] -> IO ()
+stopGargantext env scheduledPeriodicActions = do
+  forM_ scheduledPeriodicActions killThread
   putStrLn "----- Stopping gargantext -----"
   runReaderT saveNodeStoryImmediate env
 
@@ -105,6 +116,31 @@ startGargantextMock port = do
   run port application
 -}
 
+-- | Schedules all sorts of useful periodic actions to be run while
+-- the server is alive accepting requests.
+schedulePeriodicActions :: DB.CmdCommon env => env -> IO [ThreadId]
+schedulePeriodicActions _env =
+  -- Add your scheduled actions here.
+  let actions = [
+          -- refreshDBViews
+        ]
+  in foldlM (\ !acc action -> (`mappend` acc) <$> Cron.execSchedule action) [] actions
+
+{-
+  where
+
+    refreshDBViews :: Cron.Schedule ()
+    refreshDBViews = do
+      let doRefresh = do
+            res <- DB.runCmd env (refreshNgramsMaterialized :: Cmd IOException ())
+            case res of
+              Left e   -> liftIO $ putStrLn $ pack ("Refreshing Ngrams materialized view failed: " <> displayException e)
+              Right () ->  do
+                _ <- liftIO $ putStrLn $ pack "Refresh Index Database done"
+                pure ()
+      Cron.addJob doRefresh "* 2 * * *"
+-}
+
 ----------------------------------------------------------------------
 
 fireWall :: Applicative f => Request -> FireWall -> f Bool

src/Gargantext/API/Admin/Auth.hs

@@ -40,30 +40,28 @@ module Gargantext.API.Admin.Auth
 import Control.Lens (view, (#))
 import Data.Aeson
 import Data.Swagger (ToSchema(..))
-import Data.Text (Text)
-import Data.Text.Lazy (toStrict)
 import Data.UUID (UUID, fromText, toText)
 import Data.UUID.V4 (nextRandom)
-import GHC.Generics (Generic)
 import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types
-import Gargantext.API.Job (jobLogSuccess)
 import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC, GargServer, _ServerError, GargM, GargError)
 import Gargantext.Core.Mail (MailModel(..), mail)
-import Gargantext.Core.Mail.Types (HasMail, mailSettings)
+import Gargantext.Core.Mail.Types (mailSettings)
 import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId)
-import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
+import Gargantext.Database.Prelude (Cmd', CmdM, CmdCommon)
 import Gargantext.Database.Query.Table.User
 import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
 import Gargantext.Database.Query.Tree.Root (getRoot)
+import Gargantext.Database.Action.User.New (guessUserName)
 import Gargantext.Database.Schema.Node (NodePoly(_node_id))
 import Gargantext.Prelude hiding (reverse)
 import Gargantext.Prelude.Crypto.Pass.User (gargPass)
-import Gargantext.Utils.Jobs (serveJobsAPI)
+import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
+import Protolude hiding (to)
 import Servant
 import Servant.Auth.Server
 import qualified Data.Text as Text
@@ -83,26 +81,32 @@ makeTokenForUser uid = do
   either joseError (pure . toStrict . LE.decodeUtf8) e
   -- TODO not sure about the encoding...
 
-checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
+checkAuthRequest :: ( HasSettings env, CmdCommon env, HasJoseError err)
                  => Username
                  -> GargPassword
                  -> Cmd' env err CheckAuth
-checkAuthRequest u (GargPassword p) = do
-  candidate <- head <$> getUsersWith u
+checkAuthRequest couldBeEmail (GargPassword p) = do
+  -- Sometimes user put email instead of username
+  -- hence we have to check before
+  let usrname = case guessUserName couldBeEmail of
+        Nothing      -> couldBeEmail -- we are sure this is not an email
+        Just (u,_)   -> u            -- this was an email in fact
+
+  candidate <- head <$> getUsersWith usrname
   case candidate of
     Nothing -> pure InvalidUser
     Just (UserLight { userLight_password = GargPassword h, .. }) ->
       case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
         Auth.PasswordCheckFail    -> pure InvalidPassword
         Auth.PasswordCheckSuccess -> do
-          muId <- head <$> getRoot (UserName u)
+          muId <- head <$> getRoot (UserName usrname)
           case _node_id <$> muId of
             Nothing  -> pure InvalidUser
             Just uid -> do
               token <- makeTokenForUser uid
               pure $ Valid token uid userLight_id
 
-auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
+auth :: (HasSettings env, CmdCommon env, HasJoseError err)
      => AuthRequest -> Cmd' env err AuthResponse
 auth (AuthRequest u p) = do
   checkAuthRequest' <- checkAuthRequest u p
@@ -177,7 +181,7 @@ forgotPassword :: GargServer ForgotPasswordAPI
      -- => ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse
 forgotPassword = forgotPasswordPost :<|> forgotPasswordGet
 
-forgotPasswordPost :: ( HasConnectionPool env, HasConfig env, HasMail env)
+forgotPasswordPost :: (CmdCommon env)
      => ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse
 forgotPasswordPost (ForgotPasswordRequest email) = do
   us <- getUsersWithEmail (Text.toLower email)
@@ -189,7 +193,7 @@ forgotPasswordPost (ForgotPasswordRequest email) = do
   -- users' emails
   pure $ ForgotPasswordResponse "ok"
 
-forgotPasswordGet :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env, HasServerError err)
+forgotPasswordGet :: (HasSettings env, CmdCommon env, HasJoseError err, HasServerError err)
      => Maybe Text -> Cmd' env err ForgotPasswordGet
 forgotPasswordGet Nothing = pure $ ForgotPasswordGet ""
 forgotPasswordGet (Just uuid) = do
@@ -205,7 +209,7 @@ forgotPasswordGet (Just uuid) = do
 
 ---------------------
 
-forgotPasswordGetUser :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env, HasServerError err)
+forgotPasswordGetUser :: ( HasSettings env, CmdCommon env, HasJoseError err, HasServerError err)
      => UserLight -> Cmd' env err ForgotPasswordGet
 forgotPasswordGetUser (UserLight { .. }) = do
   -- pick some random password
@@ -224,7 +228,7 @@ forgotPasswordGetUser (UserLight { .. }) = do
 
   pure $ ForgotPasswordGet password
 
-forgotUserPassword :: (HasConnectionPool env, HasConfig env, HasMail env)
+forgotUserPassword :: (CmdCommon env)
      => UserLight -> Cmd' env err ()
 forgotUserPassword (UserLight { .. }) = do
   --printDebug "[forgotUserPassword] userLight_id" userLight_id
@@ -249,7 +253,7 @@ forgotUserPassword (UserLight { .. }) = do
 --------------------------
 
 -- Generate a unique (in whole DB) UUID for passwords.
-generateForgotPasswordUUID :: (HasConnectionPool env, HasConfig env, HasMail env)
+generateForgotPasswordUUID :: (CmdCommon env)
   => Cmd' env err UUID
 generateForgotPasswordUUID = do
   uuid <- liftBase $ nextRandom
@@ -268,23 +272,19 @@ type ForgotPasswordAsyncAPI = Summary "Forgot password asnc"
 
 forgotPasswordAsync :: ServerT ForgotPasswordAsyncAPI (GargM Env GargError)
 forgotPasswordAsync =
-  serveJobsAPI ForgotPasswordJob $ \p log' ->
-    forgotPasswordAsync' p (liftBase . log')
+  serveJobsAPI ForgotPasswordJob $ \jHandle p -> forgotPasswordAsync' p jHandle
 
-forgotPasswordAsync' :: (FlowCmdM env err m)
+forgotPasswordAsync' :: (FlowCmdM env err m, MonadJobStatus m)
   => ForgotPasswordAsyncParams
-  -> (JobLog -> m ())
-  -> m JobLog
-forgotPasswordAsync' (ForgotPasswordAsyncParams { email }) logStatus = do
-  let jobLog = JobLog { _scst_succeeded = Just 1
-                      , _scst_failed    = Just 0
-                      , _scst_remaining = Just 1
-                      , _scst_events    = Just []
-                      }
-  logStatus jobLog
+  -> JobHandle m
+  -> m ()
+forgotPasswordAsync' (ForgotPasswordAsyncParams { email }) jobHandle = do
+
+  markStarted 2 jobHandle
+  markProgress 1 jobHandle
 
   -- printDebug "[forgotPasswordAsync'] email" email
 
   _ <- forgotPasswordPost $ ForgotPasswordRequest { _fpReq_email = email }
 
-  pure $ jobLogSuccess jobLog
+  markComplete jobHandle

src/Gargantext/API/Admin/EnvTypes.hs

 -- |
 
 {-# LANGUAGE TemplateHaskell     #-}
-
-module Gargantext.API.Admin.EnvTypes where
-
-import Control.Lens
+{-# LANGUAGE TypeFamilies        #-}
+
+module Gargantext.API.Admin.EnvTypes (
+    GargJob(..)
+  , Env(..)
+  , mkJobHandle
+  , env_logger
+  , env_manager
+  , env_self_url
+  , menv_firewall
+
+  , MockEnv(..)
+  , DevEnv(..)
+  , DevJobHandle(..)
+  , ConcreteJobHandle -- opaque
+  ) where
+
+import Control.Lens hiding ((:<))
 import Control.Monad.Except
 import Control.Monad.Reader
-import Data.Monoid
 import Data.Pool (Pool)
+import Data.Sequence (Seq, ViewL(..), viewl)
 import Database.PostgreSQL.Simple (Connection)
 import GHC.Generics (Generic)
 import Network.HTTP.Client (Manager)
 import Servant.Client (BaseUrl)
 import Servant.Job.Async (HasJobEnv(..), Job)
+import qualified Servant.Job.Async as SJ
 import System.Log.FastLogger
 import qualified Servant.Job.Core
 
 import Gargantext.API.Admin.Types
 import Gargantext.API.Admin.Orchestrator.Types
-import Gargantext.API.Prelude (GargError)
+import Gargantext.API.Job
+import Gargantext.API.Prelude (GargM)
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
+import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
 import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(..))
 import Gargantext.Prelude.Mail.Types (MailConfig)
 
 import qualified Gargantext.Utils.Jobs.Monad as Jobs
+import Gargantext.Utils.Jobs.Map (LoggerM, J(..), jTask, rjGetLog)
 
 data GargJob
   = TableNgramsJob
@@ -48,17 +66,22 @@ data GargJob
   | RecomputeGraphJob
   deriving (Show, Eq, Ord, Enum, Bounded)
 
+-- Do /not/ treat the data types of this type as strict, because it's convenient
+-- to be able to partially initialise things like an 'Env' during tests, without
+-- having to specify /everything/. This means that when we /construct/ an 'Env',
+-- we need to remember to force the fields to WHNF at that point.
 data Env = Env
-  { _env_settings  :: !Settings
-  , _env_logger    :: !LoggerSet
-  , _env_pool      :: !(Pool Connection)
-  , _env_nodeStory :: !NodeStoryEnv
-  , _env_manager   :: !Manager
-  , _env_self_url  :: !BaseUrl
-  , _env_scrapers  :: !ScrapersEnv
-  , _env_jobs      :: !(Jobs.JobEnv GargJob (Dual [JobLog]) JobLog)
-  , _env_config    :: !GargConfig
-  , _env_mail      :: !MailConfig
+  { _env_settings  :: ~Settings
+  , _env_logger    :: ~LoggerSet
+  , _env_pool      :: ~(Pool Connection)
+  , _env_nodeStory :: ~NodeStoryEnv
+  , _env_manager   :: ~Manager
+  , _env_self_url  :: ~BaseUrl
+  , _env_scrapers  :: ~ScrapersEnv
+  , _env_jobs      :: ~(Jobs.JobEnv GargJob (Seq JobLog) JobLog)
+  , _env_config    :: ~GargConfig
+  , _env_mail      :: ~MailConfig
+  , _env_nlp       :: ~NLPServerMap
   }
   deriving (Generic)
 
@@ -91,15 +114,78 @@ instance HasSettings Env where
 instance HasMail Env where
   mailSettings = env_mail
 
+instance HasNLPServer Env where
+  nlpServer = env_nlp
+
 instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
   _env = env_scrapers . Servant.Job.Core._env
 
 instance HasJobEnv Env JobLog JobLog where
   job_env = env_scrapers
 
-instance Jobs.MonadJob (ReaderT Env (ExceptT GargError IO)) GargJob (Dual [JobLog]) JobLog where
+instance Jobs.MonadJob (GargM Env err) GargJob (Seq JobLog) JobLog where
   getJobEnv = asks (view env_jobs)
 
+-- | 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 = JobHandle {
+      _jh_id     :: !(SJ.JobID 'SJ.Safe)
+    , _jh_logger :: LoggerM (GargM Env err) JobLog
+    }
+
+-- | Creates a new /concrete/ 'JobHandle', given its underlying 'JobID' and the logging function to
+-- be used to report the status.
+mkJobHandle :: SJ.JobID 'SJ.Safe
+            -> LoggerM (GargM Env err) JobLog
+            -> ConcreteJobHandle err
+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 hdl@(JobHandle _ logStatus) updateJobStatus =
+  Jobs.getLatestJobStatus hdl >>= logStatus . updateJobStatus
+
+instance Jobs.MonadJobStatus (GargM Env err) where
+
+  type JobHandle      (GargM Env err) = ConcreteJobHandle err
+  type JobType        (GargM Env err) = GargJob
+  type JobOutputType  (GargM Env err) = JobLog
+  type JobEventType   (GargM Env err) = JobLog
+
+  getLatestJobStatus (JobHandle jId _) = do
+    mb_jb <- Jobs.findJob jId
+    case mb_jb of
+      Nothing -> pure noJobLog
+      Just j  -> case jTask j of
+        QueuedJ _   -> pure noJobLog
+        RunningJ rj -> liftIO (rjGetLog rj) <&>
+                         \lgs -> case viewl lgs of
+                                   EmptyL -> noJobLog
+                                   l :< _ -> l
+        DoneJ lgs _ -> pure $ case viewl lgs of
+                                   EmptyL -> noJobLog
+                                   l :< _ -> l
+
+  withTracer extraLogger (JobHandle jId logger) n = n (JobHandle jId (\w -> logger w >> liftIO (extraLogger w)))
+
+  markStarted n jh = updateJobProgress jh (const $ jobLogStart (RemainingSteps n))
+
+  markProgress steps jh = updateJobProgress jh (jobLogProgress steps)
+
+  markFailure steps mb_msg jh =
+    updateJobProgress jh (\latest -> case mb_msg of
+                                       Nothing  -> jobLogFailures steps latest
+                                       Just msg -> addErrorEvent msg (jobLogFailures steps latest)
+                         )
+
+  markComplete jh = updateJobProgress jh jobLogComplete
+
+  markFailed mb_msg jh =
+    updateJobProgress jh (\latest -> case mb_msg of
+                                       Nothing  -> jobLogFailTotal latest
+                                       Just msg -> jobLogFailTotalWithMessage msg latest
+                         )
+
 data MockEnv = MockEnv
   { _menv_firewall :: !FireWall
   }
@@ -107,18 +193,42 @@ data MockEnv = MockEnv
 
 makeLenses ''MockEnv
 
-
-
 data DevEnv = DevEnv
   { _dev_env_settings  :: !Settings
   , _dev_env_config    :: !GargConfig
   , _dev_env_pool      :: !(Pool Connection)
   , _dev_env_nodeStory :: !NodeStoryEnv
   , _dev_env_mail      :: !MailConfig
+  , _dev_env_nlp       :: !NLPServerMap
   }
 
 makeLenses ''DevEnv
 
+-- | Our /mock/ job handle.
+data DevJobHandle = DevJobHandle
+
+instance Jobs.MonadJobStatus (GargM DevEnv err) where
+
+  type JobHandle (GargM DevEnv err) = DevJobHandle
+
+  type JobType        (GargM DevEnv err) = GargJob
+  type JobOutputType  (GargM DevEnv err) = JobLog
+  type JobEventType   (GargM DevEnv err) = JobLog
+
+  getLatestJobStatus DevJobHandle = pure noJobLog
+
+  withTracer _ DevJobHandle n = n DevJobHandle
+
+  markStarted _ _ = pure ()
+
+  markProgress _ _ = pure ()
+
+  markFailure _ _ _ = pure ()
+
+  markComplete _ = pure ()
+
+  markFailed _ _ = pure ()
+
 instance HasConfig DevEnv where
   hasConfig = dev_env_config
 
@@ -146,3 +256,6 @@ instance HasNodeArchiveStoryImmediateSaver DevEnv where
 
 instance HasMail DevEnv where
   mailSettings = dev_env_mail
+
+instance HasNLPServer DevEnv where
+  nlpServer = dev_env_nlp

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

 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE TypeOperators      #-}
 
 module Gargantext.API.Admin.Orchestrator.Types
   where
 
 import Control.Lens hiding (elements)
-import Control.Monad.Reader (MonadReader)
 import Data.Aeson
 import Data.Morpheus.Types
   ( GQLType
@@ -24,9 +23,7 @@ import Test.QuickCheck.Arbitrary
 
 import qualified Gargantext.API.GraphQL.Utils as GQLU
 import Gargantext.Core.Types (TODO(..))
-import Gargantext.Database.Prelude (HasConfig(..))
 import Gargantext.Prelude
-import Gargantext.Prelude.Config (gc_pubmed_api_key)
 
 ------------------------------------------------------------------------
 instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where
@@ -37,39 +34,24 @@ instance Arbitrary a => Arbitrary (JobOutput a) where
 
 -- | Main Types
 -- TODO IsidoreAuth
-data ExternalAPIs = All
-                  | PubMed { mAPIKey :: Maybe Text }
+data ExternalAPIs = PubMed
                   | Arxiv
                   | HAL
                   | IsTex
                   | Isidore
-  deriving (Show, Eq, Generic)
+  deriving (Show, Eq, Generic, Enum, Bounded)
 
 
 -- | Main Instances
 instance FromJSON ExternalAPIs
 instance ToJSON ExternalAPIs
 
-externalAPIs :: ( MonadReader env m
-                , HasConfig env) => m [ExternalAPIs]
-externalAPIs = do
-  pubmed_api_key <- view $ hasConfig . gc_pubmed_api_key
-
-  pure [ All
-       , PubMed { mAPIKey = Just pubmed_api_key }
-       , Arxiv
-       , HAL
-       , IsTex
-       , Isidore ]
+externalAPIs :: [ExternalAPIs]
+externalAPIs = [minBound .. maxBound]
 
 instance Arbitrary ExternalAPIs
   where
-    arbitrary = elements [ All
-                         , PubMed { mAPIKey = Nothing }
-                         , Arxiv
-                         , HAL
-                         , IsTex
-                         , Isidore ]
+    arbitrary = arbitraryBoundedEnum
 
 instance ToSchema ExternalAPIs where
   declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
@@ -101,7 +83,7 @@ data ScraperEvent = ScraperEvent
   , _scev_level   :: !(Maybe Text)
   , _scev_date    :: !(Maybe Text)
   }
-  deriving (Show, Generic)
+  deriving (Show, Generic, Eq)
 
 instance Arbitrary ScraperEvent where
   arbitrary = ScraperEvent <$> elements [Nothing, Just "test message"]
@@ -122,10 +104,13 @@ data JobLog = JobLog
   , _scst_remaining :: !(Maybe Int)
   , _scst_events    :: !(Maybe [ScraperEvent])
   }
-  deriving (Show, Generic)
+  deriving (Show, Generic, Eq)
 
 makeLenses ''JobLog
 
+noJobLog :: JobLog
+noJobLog = JobLog Nothing Nothing Nothing Nothing
+
 instance Arbitrary JobLog where
   arbitrary = JobLog
            <$> arbitrary

src/Gargantext/API/Admin/Settings.hs

@@ -12,6 +12,7 @@ TODO-SECURITY: Critical
 
 
 
+{-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell     #-}
 
@@ -43,10 +44,12 @@ import qualified Data.ByteString.Lazy as L
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Types
 -- import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
+import Gargantext.Core.NLP (nlpServerMap)
 import Gargantext.Database.Prelude (databaseParameters, hasConfig)
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (gc_js_job_timeout, gc_js_id_timeout)
 import qualified Gargantext.Prelude.Mail as Mail
+import qualified Gargantext.Prelude.NLP as NLP
 import qualified Gargantext.Utils.Jobs       as Jobs
 import qualified Gargantext.Utils.Jobs.Monad as Jobs
 import qualified Gargantext.Utils.Jobs.Queue as Jobs
@@ -175,31 +178,35 @@ devJwkFile = "dev.jwk"
 
 newEnv :: PortNumber -> FilePath -> IO Env
 newEnv port file = do
-  manager_env  <- newTlsManager
-  settings'    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
+  !manager_env  <- newTlsManager
+  !settings'    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
   when (port /= settings' ^. appPort) $
     panic "TODO: conflicting settings of port"
 
-  config_env    <- readConfig file
+  !config_env    <- readConfig file
   prios         <- Jobs.readPrios (file <> ".jobs")
   let prios' = Jobs.applyPrios prios Jobs.defaultPrios
   putStrLn $ "Overrides: " <> show prios
   putStrLn $ "New priorities: " <> show prios'
-  self_url_env  <- parseBaseUrl $ "http://0.0.0.0:" <> show port
-  dbParam       <- databaseParameters file
-  pool          <- newPool dbParam
+  !self_url_env  <- parseBaseUrl $ "http://0.0.0.0:" <> show port
+  dbParam        <- databaseParameters file
+  !pool          <- newPool dbParam
   --nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
-  nodeStory_env <- readNodeStoryEnv pool
-  scrapers_env  <- newJobEnv defaultSettings manager_env
+  !nodeStory_env <- readNodeStoryEnv pool
+  !scrapers_env  <- newJobEnv defaultSettings manager_env
 
   secret        <- Jobs.genSecret
   let jobs_settings = (Jobs.defaultJobSettings 1 secret)
                         & Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_job_timeout)
                         & Jobs.l_jsIDTimeout  .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_id_timeout)
-  jobs_env      <- Jobs.newJobEnv jobs_settings prios' manager_env
-  logger        <- newStderrLoggerSet defaultBufSize
-  config_mail   <- Mail.readConfig file
+  !jobs_env     <- Jobs.newJobEnv jobs_settings prios' manager_env
+  !logger        <- newStderrLoggerSet defaultBufSize
+  !config_mail  <- Mail.readConfig file
+  !nlp_env      <- nlpServerMap <$> NLP.readConfig file
 
+{-  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.
+-}
   pure $ Env
     { _env_settings  = settings'
     , _env_logger    = logger
@@ -211,6 +218,7 @@ newEnv port file = do
     , _env_self_url  = self_url_env
     , _env_config    = config_env
     , _env_mail      = config_mail
+    , _env_nlp       = nlp_env
     }
 
 newPool :: ConnectInfo -> IO (Pool Connection)

src/Gargantext/API/Dev.hs

@@ -15,15 +15,18 @@ module Gargantext.API.Dev where
 import Control.Exception (finally)
 import Control.Monad (fail)
 import Control.Monad.Reader (runReaderT)
+import Control.Monad.Except (runExceptT)
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Settings
 import Gargantext.API.Ngrams (saveNodeStoryImmediate)
 import Gargantext.API.Prelude
+import Gargantext.Core.NLP (nlpServerMap)
 import Gargantext.Core.NodeStory
 import Gargantext.Database.Prelude
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (readConfig)
 import qualified Gargantext.Prelude.Mail as Mail
+import qualified Gargantext.Prelude.NLP as NLP
 import Servant
 import System.IO (FilePath)
 
@@ -43,12 +46,14 @@ withDevEnv iniPath k = do
       nodeStory_env <- readNodeStoryEnv pool
       setts   <- devSettings devJwkFile
       mail    <- Mail.readConfig iniPath
+      nlp_config <- NLP.readConfig iniPath
       pure $ DevEnv
         { _dev_env_pool     = pool
         , _dev_env_nodeStory  = nodeStory_env
         , _dev_env_settings = setts
         , _dev_env_config   = cfg
-        , _dev_env_mail      = mail
+        , _dev_env_mail     = mail
+        , _dev_env_nlp      = nlpServerMap nlp_config
         }
 
 -- | Run Cmd Sugar for the Repl (GHCI)
@@ -65,6 +70,10 @@ runCmdReplServantErr = runCmdRepl
 runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
 runCmdDev env f =
   (either (fail . show) pure =<< runCmd env f)
+
+runCmdGargDev :: DevEnv -> GargM DevEnv GargError a -> IO a
+runCmdGargDev env cmd =
+  (either (fail . show) pure =<< runExceptT (runReaderT cmd env))
     `finally`
   runReaderT saveNodeStoryImmediate env
 

src/Gargantext/API/GraphQL.hs

@@ -31,6 +31,7 @@ import Data.Morpheus.Types
   , Undefined(..)
   )
 import Data.Proxy
+import Data.Text (Text)
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog)
 import Gargantext.API.Prelude (HasJobEnv')
@@ -38,6 +39,7 @@ import qualified Gargantext.API.GraphQL.Annuaire as GQLA
 import qualified Gargantext.API.GraphQL.AsyncTask as GQLAT
 import qualified Gargantext.API.GraphQL.Context as GQLCTX
 import qualified Gargantext.API.GraphQL.IMT as GQLIMT
+import qualified Gargantext.API.GraphQL.NLP as GQLNLP
 import qualified Gargantext.API.GraphQL.Node as GQLNode
 import qualified Gargantext.API.GraphQL.User as GQLUser
 import qualified Gargantext.API.GraphQL.UserInfo as GQLUserInfo
@@ -45,8 +47,8 @@ import qualified Gargantext.API.GraphQL.TreeFirstLevel as GQLTree
 import qualified Gargantext.API.GraphQL.Team as GQLTeam
 import Gargantext.API.Prelude (GargM, GargError)
 import Gargantext.API.Types
-import Gargantext.Core.Mail.Types (HasMail)
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Core.NLP (HasNLPServer)
+import Gargantext.Database.Prelude (CmdCommon)
 import Gargantext.Prelude
 import GHC.Generics (Generic)
 import Servant
@@ -67,11 +69,14 @@ import Gargantext.API.Admin.Types (HasSettings)
 data Query m
   = Query
     { annuaire_contacts   :: GQLA.AnnuaireContactArgs -> m [GQLA.AnnuaireContact]
+    , context_ngrams      :: GQLCTX.ContextNgramsArgs -> m [Text]
     , contexts            :: GQLCTX.NodeContextArgs -> m [GQLCTX.NodeContextGQL]
     , contexts_for_ngrams :: GQLCTX.ContextsForNgramsArgs -> m [GQLCTX.ContextGQL]
     , imt_schools         :: GQLIMT.SchoolsArgs -> m [GQLIMT.School]
     , job_logs            :: GQLAT.JobLogArgs -> m (Map Int JobLog)
+    , languages           :: GQLNLP.LanguagesArgs -> m GQLNLP.LanguagesMap
     , nodes               :: GQLNode.NodeArgs -> m [GQLNode.Node]
+    , nodes_corpus        :: GQLNode.CorpusArgs -> m [GQLNode.Corpus]
     , node_parent         :: GQLNode.NodeParentArgs -> m [GQLNode.Node]
     , user_infos          :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo]
     , users               :: GQLUser.UserArgs -> m [GQLUser.User m]
@@ -82,6 +87,7 @@ data Query m
 data Mutation m
   = Mutation
     { update_user_info       :: GQLUserInfo.UserInfoMArgs -> m Int
+    , update_user_pubmed_api_key :: GQLUser.UserPubmedAPIKeyMArgs -> m Int
     , delete_team_membership :: GQLTeam.TeamDeleteMArgs -> m [Int]
     , update_node_context_category :: GQLCTX.NodeContextCategoryMArgs -> m [Int]
     } deriving (Generic, GQLType)
@@ -104,29 +110,33 @@ data Contet m
 -- | The main GraphQL resolver: how queries, mutations and
 -- subscriptions are handled.
 rootResolver
-  :: (HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
+  :: (CmdCommon env, HasNLPServer env, HasJobEnv' env, HasSettings env)
   => RootResolver (GargM env GargError) e Query Mutation Undefined
 rootResolver =
   RootResolver
     { queryResolver = Query { annuaire_contacts   = GQLA.resolveAnnuaireContacts
+                            , context_ngrams      = GQLCTX.resolveContextNgrams
                             , contexts            = GQLCTX.resolveNodeContext
                             , contexts_for_ngrams = GQLCTX.resolveContextsForNgrams
                             , imt_schools         = GQLIMT.resolveSchools
                             , job_logs            = GQLAT.resolveJobLogs
+                            , languages           = GQLNLP.resolveLanguages
                             , nodes               = GQLNode.resolveNodes
+                            , nodes_corpus        = GQLNode.resolveNodesCorpus
                             , node_parent         = GQLNode.resolveNodeParent
                             , user_infos          = GQLUserInfo.resolveUserInfos
                             , users               = GQLUser.resolveUsers
                             , tree                = GQLTree.resolveTree
                             , team                = GQLTeam.resolveTeam }
     , mutationResolver = Mutation { update_user_info       = GQLUserInfo.updateUserInfo
+                                  , update_user_pubmed_api_key = GQLUser.updateUserPubmedAPIKey
                                   , delete_team_membership = GQLTeam.deleteTeamMembership
                                   , update_node_context_category = GQLCTX.updateNodeContextCategory }
     , subscriptionResolver = Undefined }
 
 -- | Main GraphQL "app".
 app
-  :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
+  :: (Typeable env, CmdCommon env, HasJobEnv' env, HasNLPServer env, HasSettings env)
   => App (EVENT (GargM env GargError)) (GargM env GargError)
 app = deriveApp rootResolver
 
@@ -163,7 +173,7 @@ gqapi = Proxy
 -- | Implementation of our API.
 --api :: Server API
 api
-  :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
+  :: (Typeable env, CmdCommon env, HasJobEnv' env, HasSettings env)
   => ServerT API (GargM env GargError)
 api (SAS.Authenticated _auser) = httpPubApp [] app :<|> pure httpPlayground
 api _                          = panic "401 in graphql" -- SAS.throwAll (_ServerError # err401)

src/Gargantext/API/GraphQL/Annuaire.hs

@@ -13,7 +13,6 @@ import Data.Morpheus.Types
 import Data.Proxy
 import Data.Text (Text)
 import Gargantext.API.Prelude (GargM, GargError)
-import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Database.Admin.Types.Hyperdata.Contact
   ( HyperdataContact
   , ContactWho
@@ -21,7 +20,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
   , cw_lastName
   , hc_who, ContactWhere, hc_where, cw_organization, cw_labTeamDepts, cw_role, cw_office, cw_country, cw_city, cw_touch, ct_mail, ct_phone, ct_url, hc_title, hc_source)
 import Gargantext.Database.Admin.Types.Node (NodeId(..))
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Database.Prelude (CmdCommon)
 import Gargantext.Database.Query.Table.Context (getContextWith)
 import Gargantext.Database.Schema.Node (node_hyperdata)
 import Gargantext.Prelude
@@ -55,13 +54,13 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
 
 -- | Function to resolve user from a query.
 resolveAnnuaireContacts
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => AnnuaireContactArgs -> GqlM e env [AnnuaireContact]
 resolveAnnuaireContacts AnnuaireContactArgs { contact_id } = dbAnnuaireContacts contact_id
 
 -- | Inner function to fetch the user from DB.
 dbAnnuaireContacts
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: CmdCommon env
   => Int -> GqlM e env [AnnuaireContact]
 dbAnnuaireContacts contact_id = do
   -- lift $ printDebug "[dbUsers]" user_id

src/Gargantext/API/GraphQL/Context.hs

@@ -17,11 +17,10 @@ import Data.Time.Format.ISO8601 (iso8601Show)
 import Gargantext.API.Admin.Types (HasSettings)
 import Gargantext.API.Prelude (GargM, GargError)
 import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
-import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument)
 import Gargantext.Database.Admin.Types.Node (ContextTitle, NodeId(..), NodeTypeId, UserId, unNodeId)
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
-import Gargantext.Database.Query.Table.NodeContext (getNodeContext, getContextsForNgramsTerms, ContextForNgramsTerms(..))
+import Gargantext.Database.Prelude (CmdCommon)
+import Gargantext.Database.Query.Table.NodeContext (getNodeContext, getContextsForNgramsTerms, ContextForNgramsTerms(..), {- getContextNgrams, -} getContextNgramsMatchingFTS)
 import qualified Gargantext.Database.Query.Table.NodeContext as DNC
 import Gargantext.Database.Schema.NodeContext (NodeContext, NodeContextPoly(..))
 import Gargantext.Prelude
@@ -95,6 +94,12 @@ data NodeContextCategoryMArgs = NodeContextCategoryMArgs
   , category   :: Int
   } deriving (Generic, GQLType)
 
+data ContextNgramsArgs
+  = ContextNgramsArgs
+    { context_id  :: Int
+    , list_id     :: Int }
+    deriving (Generic, GQLType)
+
 type GqlM e env = Resolver QUERY e (GargM env GargError)
 type GqlM' e env a = ResolverM e (GargM env GargError) a
 
@@ -102,22 +107,28 @@ type GqlM' e env a = ResolverM e (GargM env GargError) a
 
 -- | Function to resolve context from a query.
 resolveNodeContext
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => NodeContextArgs -> GqlM e env [NodeContextGQL]
 resolveNodeContext NodeContextArgs { context_id, node_id } =
   dbNodeContext context_id node_id
 
 resolveContextsForNgrams
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => ContextsForNgramsArgs -> GqlM e env [ContextGQL]
 resolveContextsForNgrams ContextsForNgramsArgs { corpus_id, ngrams_terms } =
   dbContextForNgrams corpus_id ngrams_terms
 
+resolveContextNgrams
+  :: (CmdCommon env)
+  => ContextNgramsArgs -> GqlM e env [Text]
+resolveContextNgrams ContextNgramsArgs { context_id, list_id } =
+  dbContextNgrams context_id list_id
+
 -- DB
 
 -- | Inner function to fetch the node context DB.
 dbNodeContext
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> Int -> GqlM e env [NodeContextGQL]
 dbNodeContext context_id node_id = do
   -- lift $ printDebug "[dbUsers]" user_id
@@ -127,14 +138,22 @@ dbNodeContext context_id node_id = do
   c <- lift $ getNodeContext (NodeId context_id) (NodeId node_id)
   pure $ toNodeContextGQL <$> [c]
 
+-- | Returns list of `ContextGQL` for given ngrams in given corpus id.
 dbContextForNgrams
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> [Text] -> GqlM e env [ContextGQL]
 dbContextForNgrams node_id ngrams_terms = do
   contextsForNgramsTerms <- lift $ getContextsForNgramsTerms (NodeId node_id) ngrams_terms
   --lift $ printDebug "[dbContextForNgrams] contextsForNgramsTerms" contextsForNgramsTerms
   pure $ toContextGQL <$> contextsForNgramsTerms
 
+-- | Fetch ngrams matching given context in a given list id.
+dbContextNgrams
+  :: (CmdCommon env)
+  => Int -> Int -> GqlM e env [Text]
+dbContextNgrams context_id list_id = do
+  lift $ getContextNgramsMatchingFTS (NodeId context_id) (NodeId list_id)
+
 -- Conversion functions
 
 toNodeContextGQL :: NodeContext -> NodeContextGQL
@@ -192,7 +211,7 @@ toHyperdataRowDocumentGQL hyperdata =
                                      }
     HyperdataRowContact { } -> Nothing
 
-updateNodeContextCategory :: (HasConnectionPool env, HasConfig env, HasMail env, HasSettings env) =>
+updateNodeContextCategory :: ( CmdCommon env, HasSettings env) =>
                              NodeContextCategoryMArgs -> GqlM' e env [Int]
 updateNodeContextCategory NodeContextCategoryMArgs { context_id, node_id, category } = do
   _ <- lift $ DNC.updateNodeContextCategory (NodeId context_id) (NodeId node_id) category

src/Gargantext/API/GraphQL/NLP.hs

+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Gargantext.API.GraphQL.NLP
+  ( Lang(..)
+  , LanguagesArgs(..)
+  , LanguagesMap
+  , resolveLanguages
+  )
+  where
+
+import Control.Lens (view)
+import qualified Data.Map.Strict as Map
+import Data.Morpheus.Types
+  ( GQLType
+  , Resolver
+  , QUERY
+  )
+import Gargantext.API.Prelude (GargM, GargError)
+import Gargantext.Core (Lang(..), NLPServerConfig(..), PosTagAlgo)  -- , allLangs)
+import Gargantext.Core.NLP (HasNLPServer(..))
+import Gargantext.Prelude
+import Protolude
+
+data LanguagesArgs
+  = LanguagesArgs
+    { } deriving (Generic, GQLType)
+
+type GqlM e env = Resolver QUERY e (GargM env GargError)
+
+type LanguagesMap = Map.Map Lang NLPServer
+
+data NLPServer = NLPServer
+  {
+    server :: !PosTagAlgo
+  , url    :: !Text
+  }
+  deriving (Show, Eq, Generic, GQLType)
+
+resolveLanguages
+  :: HasNLPServer env => LanguagesArgs -> GqlM e env LanguagesMap
+resolveLanguages LanguagesArgs { } = do
+  -- pure $ allLangs
+  lift $ do
+    ns <- view nlpServer
+    printDebug "[resolveLanguages] nlpServer" ns
+    pure $ Map.map (\(NLPServerConfig { .. }) -> NLPServer { server
+                                                           , url = Protolude.show url }) ns

src/Gargantext/API/GraphQL/Node.hs

@@ -3,7 +3,9 @@
 
 module Gargantext.API.GraphQL.Node where
 
+import Data.Aeson
 import Data.Either (Either(..))
+import qualified Data.HashMap.Strict as HashMap
 import Data.Morpheus.Types
   ( GQLType
   , Resolver
@@ -13,44 +15,68 @@ import Data.Morpheus.Types
 import Data.Text (Text)
 import qualified Data.Text as T
 import Gargantext.API.Prelude (GargM, GargError)
-import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Database.Admin.Types.Node (NodeId(..), NodeType)
 import qualified Gargantext.Database.Admin.Types.Node as NN
 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, getNode)
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Database.Prelude (CmdCommon)  -- , JSONB)
 import qualified Gargantext.Database.Schema.Node as N
 import Gargantext.Prelude
 import GHC.Generics (Generic)
 import qualified Prelude
+import qualified PUBMED.Types as PUBMED
 import Text.Read (readEither)
 
+data Corpus = Corpus
+  { id           :: Int
+  , name         :: Text
+  , parent_id    :: Maybe Int
+  , type_id      :: Int
+  } deriving (Show, Generic, GQLType)
+
 data Node = Node
-  { id        :: Int
-  , name      :: Text
-  , parent_id :: Maybe Int
-  , type_id   :: Int
+  { id           :: Int
+  , name         :: Text
+  , parent_id    :: Maybe Int
+  , type_id      :: Int
   } deriving (Show, Generic, GQLType)
 
+data CorpusArgs
+  = CorpusArgs
+    { corpus_id :: Int
+    } deriving (Generic, GQLType)
+
 data NodeArgs
   = NodeArgs
-    { node_id        :: Int
+    { node_id :: Int
     } deriving (Generic, GQLType)
 
 type GqlM e env = Resolver QUERY e (GargM env GargError)
 
 -- | Function to resolve user from a query.
 resolveNodes
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => NodeArgs -> GqlM e env [Node]
 resolveNodes NodeArgs { node_id } = dbNodes node_id
 
+resolveNodesCorpus
+  :: (CmdCommon env)
+  => CorpusArgs -> GqlM e env [Corpus]
+resolveNodesCorpus CorpusArgs { corpus_id } = dbNodesCorpus corpus_id
+
 dbNodes
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> GqlM e env [Node]
 dbNodes node_id = do
   node <- lift $ getNode $ NodeId node_id
   pure [toNode node]
 
+dbNodesCorpus
+  :: (CmdCommon env)
+  => Int -> GqlM e env [Corpus]
+dbNodesCorpus corpus_id = do
+  corpus <- lift $ getNode $ NodeId corpus_id
+  pure [toCorpus corpus]
+
 data NodeParentArgs
   = NodeParentArgs
     { node_id     :: Int
@@ -58,12 +84,12 @@ data NodeParentArgs
     } deriving (Generic, GQLType)
 
 resolveNodeParent
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => NodeParentArgs -> GqlM e env [Node]
 resolveNodeParent NodeParentArgs { node_id, parent_type } = dbParentNodes node_id parent_type
 
 dbParentNodes
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> Text -> GqlM e env [Node]
 dbParentNodes node_id parent_type = do
   let mParentType = readEither (T.unpack parent_type) :: Either Prelude.String NodeType
@@ -80,7 +106,22 @@ dbParentNodes node_id parent_type = do
           pure [toNode node]
 
 toNode :: NN.Node json -> Node
-toNode (N.Node { .. }) = Node { id = NN.unNodeId _node_id
-                              , name = _node_name
-                              , parent_id = NN.unNodeId <$> _node_parent_id
-                              , type_id = _node_typename }
+toNode N.Node { .. } = Node { id = NN.unNodeId _node_id
+                            , name = _node_name
+                            , parent_id = NN.unNodeId <$> _node_parent_id
+                            , type_id = _node_typename }
+
+toCorpus :: NN.Node Value -> Corpus
+toCorpus N.Node { .. } = Corpus { id = NN.unNodeId _node_id
+                                , name = _node_name
+                                , parent_id = NN.unNodeId <$> _node_parent_id
+                                , type_id = _node_typename }
+
+pubmedAPIKeyFromValue :: Value -> Maybe PUBMED.APIKey
+pubmedAPIKeyFromValue (Object kv) =
+  case HashMap.lookup "pubmed_api_key" kv of
+    Nothing -> Nothing
+    Just v  -> case fromJSON v of
+      Error _    -> Nothing
+      Success v' -> Just v'
+pubmedAPIKeyFromValue _           = Nothing

src/Gargantext/API/GraphQL/Team.hs

@@ -10,11 +10,10 @@ import Data.Text ( Text )
 import Gargantext.API.Admin.Types (HasSettings)
 import Gargantext.API.GraphQL.Utils (authUser, AuthStatus (Invalid, Valid))
 import Gargantext.API.Prelude (GargM, GargError)
-import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Core.Types (NodeId(..), unNodeId)
-import Gargantext.Database (HasConfig)
+import qualified Gargantext.Core.Types.Individu as Individu
 import Gargantext.Database.Action.Share (membersOf, deleteMemberShip)
-import Gargantext.Database.Prelude (HasConnectionPool)
+import Gargantext.Database.Prelude (CmdCommon)
 import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.User (getUsersWithNodeHyperdata)
 import Gargantext.Database.Schema.Node (NodePoly(Node, _node_id), _node_user_id)
@@ -45,15 +44,16 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
 type GqlM' e env a = ResolverM e (GargM env GargError) a
 
 
-resolveTeam :: (HasConnectionPool env, HasConfig env, HasMail env) => TeamArgs -> GqlM e env Team
+resolveTeam :: (CmdCommon env) => TeamArgs -> GqlM e env Team
 resolveTeam TeamArgs { team_node_id } = dbTeam team_node_id
 
-dbTeam :: (HasConnectionPool env, HasConfig env, HasMail env) => Int -> GqlM e env Team
+dbTeam :: (CmdCommon env) =>
+          Int -> GqlM e env Team
 dbTeam nodeId = do
   let nId = NodeId nodeId
   res <- lift $ membersOf nId
   teamNode <- lift $ getNode nId
-  userNodes <- lift $ getUsersWithNodeHyperdata $ uId teamNode
+  userNodes <- lift $ getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode
   let username = getUsername userNodes
   pure $ Team { team_owner_username = username
               , team_members = map toTeamMember res
@@ -69,10 +69,11 @@ dbTeam nodeId = do
     getUsername ((UserLight {userLight_username}, _):_) = userLight_username
 
 -- TODO: list as argument
-deleteTeamMembership :: (HasConnectionPool env, HasConfig env, HasMail env, HasSettings env) => TeamDeleteMArgs -> GqlM' e env [Int]
+deleteTeamMembership :: (CmdCommon env, HasSettings env) =>
+                        TeamDeleteMArgs -> GqlM' e env [Int]
 deleteTeamMembership TeamDeleteMArgs { token, shared_folder_id, team_node_id } = do
   teamNode <- lift $ getNode $ NodeId team_node_id
-  userNodes <- lift (getUsersWithNodeHyperdata $ uId teamNode)
+  userNodes <- lift (getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode)
   case userNodes of
     [] -> panic $ "[deleteTeamMembership] User with id " <> T.pack (show $ uId teamNode) <> " doesn't exist."
     (( _, node_u):_) -> do

src/Gargantext/API/GraphQL/TreeFirstLevel.hs

@@ -3,23 +3,21 @@
 
 module Gargantext.API.GraphQL.TreeFirstLevel where
 
-import Gargantext.Prelude
 import Data.Morpheus.Types (GQLType, lift, Resolver, QUERY)
-import GHC.Generics (Generic)
 import Data.Text (Text)
+import GHC.Generics (Generic)
 import Gargantext.API.Prelude (GargM, GargError)
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
-import Gargantext.Core.Mail.Types (HasMail)
-import qualified Gargantext.Database.Query.Tree as T
-import qualified Gargantext.Database.Schema.Node as N
-import qualified Gargantext.Database.Admin.Types.Node as NN
-import Gargantext.Database.Admin.Types.Node (allNodeTypes, NodeId (NodeId))
 import Gargantext.Core.Types (Tree, NodeTree, NodeType)
-import Gargantext.Core.Types.Main
-    ( Tree(TreeN), _tn_node, _tn_children, NodeTree(NodeTree, _nt_id, _nt_type), _nt_name )
-import Gargantext.Database.Query.Table.Node (getNode)
+import Gargantext.Core.Types.Main ( Tree(TreeN), _tn_node, _tn_children, NodeTree(NodeTree, _nt_id, _nt_type), _nt_name )
 import Gargantext.Database.Admin.Config (fromNodeTypeId)
+import Gargantext.Database.Admin.Types.Node (allNodeTypes, NodeId (NodeId))
+import Gargantext.Database.Prelude (CmdCommon)
+import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Schema.Node (NodePoly(_node_parent_id))
+import Gargantext.Prelude
+import qualified Gargantext.Database.Admin.Types.Node as NN
+import qualified Gargantext.Database.Query.Tree as T
+import qualified Gargantext.Database.Schema.Node as N
 
 data TreeArgs = TreeArgs
   {
@@ -45,10 +43,11 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
 
 type ParentId = Maybe NodeId
 
-resolveTree :: (HasConnectionPool env, HasConfig env, HasMail env) => TreeArgs -> GqlM e env (TreeFirstLevel (GqlM e env))
+resolveTree :: (CmdCommon env) => TreeArgs -> GqlM e env (TreeFirstLevel (GqlM e env))
 resolveTree TreeArgs { root_id } = dbTree root_id
 
-dbTree :: (HasConnectionPool env, HasConfig env, HasMail env) => Int -> GqlM e env (TreeFirstLevel (GqlM e env))
+dbTree :: (CmdCommon env) =>
+          Int -> GqlM e env (TreeFirstLevel (GqlM e env))
 dbTree root_id = do
   let rId = NodeId root_id
   t <- lift $ T.tree T.TreeFirstLevel rId allNodeTypes
@@ -59,7 +58,7 @@ dbTree root_id = do
     toParentId N.Node { _node_parent_id } = _node_parent_id
 
 
-toTree :: (HasConnectionPool env, HasConfig env, HasMail env) => NodeId -> ParentId -> Tree NodeTree -> TreeFirstLevel (GqlM e env)
+toTree :: (CmdCommon env) => NodeId -> ParentId -> Tree NodeTree -> TreeFirstLevel (GqlM e env)
 toTree rId pId TreeN { _tn_node, _tn_children } = TreeFirstLevel
   { parent   = resolveParent pId
   , root     = toTreeNode pId _tn_node
@@ -75,7 +74,7 @@ toTreeNode pId NodeTree { _nt_name, _nt_id, _nt_type } = TreeNode { name = _nt_n
 childrenToTreeNodes :: (Tree NodeTree, NodeId) -> TreeNode
 childrenToTreeNodes (TreeN {_tn_node}, rId) = toTreeNode (Just rId) _tn_node
 
-resolveParent :: (HasConnectionPool env, HasConfig env, HasMail env) => Maybe NodeId -> GqlM e env (Maybe TreeNode)
+resolveParent :: (CmdCommon env) => Maybe NodeId -> GqlM e env (Maybe TreeNode)
 resolveParent (Just pId) = do
   node <- lift $ getNode pId
   pure $ nodeToTreeNode node

src/Gargantext/API/GraphQL/User.hs

 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 
 module Gargantext.API.GraphQL.User where
 
 import Data.Maybe (listToMaybe)
 import Data.Morpheus.Types
   ( GQLType
-  , Resolver, QUERY
+  , Resolver, ResolverM, QUERY
   , lift
   )
 import Data.Text (Text)
+import Gargantext.API.Admin.Types (HasSettings)
 import Gargantext.API.Prelude (GargM, GargError)
-import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..))
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
-import Gargantext.Database.Query.Table.User (getUsersWithId, getUserHyperdata)
+import Gargantext.Database.Admin.Types.Node (NodeId(..))
+import Gargantext.Database.Prelude (CmdCommon)
+import qualified Gargantext.Database.Query.Table.User as DBUser
 import Gargantext.Database.Schema.User (UserLight(..))
 import Gargantext.Prelude
 import GHC.Generics (Generic)
+import qualified Gargantext.Core.Types.Individu as Individu
 
 data User m = User
   { u_email     :: Text
@@ -31,22 +34,29 @@ data UserArgs
     { user_id :: Int
     } deriving (Generic, GQLType)
 
+data UserPubmedAPIKeyMArgs
+  = UserPubmedAPIKeyMArgs
+    { user_id :: Int
+    , api_key  :: Text }
+    deriving (Generic, GQLType)
+
 type GqlM e env = Resolver QUERY e (GargM env GargError)
+type GqlM' e env a = ResolverM e (GargM env GargError) a
 
 -- | Function to resolve user from a query.
 resolveUsers
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => UserArgs -> GqlM e env [User (GqlM e env)]
 resolveUsers UserArgs { user_id } = dbUsers user_id
 
 -- | Inner function to fetch the user from DB.
 dbUsers
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> GqlM e env [User (GqlM e env)]
-dbUsers user_id = lift (map toUser <$> getUsersWithId user_id)
+dbUsers user_id = lift (map toUser <$> DBUser.getUsersWithId (Individu.RootId $ NodeId user_id))
 
 toUser
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => UserLight -> User (GqlM e env)
 toUser (UserLight { .. }) = User { u_email = userLight_email
                                  , u_hyperdata = resolveHyperdata userLight_id
@@ -54,6 +64,13 @@ toUser (UserLight { .. }) = User { u_email = userLight_email
                                  , u_username = userLight_username }
 
 resolveHyperdata
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> GqlM e env (Maybe HyperdataUser)
-resolveHyperdata userid = lift (listToMaybe <$> getUserHyperdata userid)
+resolveHyperdata userid = lift (listToMaybe <$> DBUser.getUserHyperdata (Individu.UserDBId userid))
+
+updateUserPubmedAPIKey :: ( CmdCommon env, HasSettings env) =>
+                          UserPubmedAPIKeyMArgs -> GqlM' e env Int
+updateUserPubmedAPIKey UserPubmedAPIKeyMArgs { user_id, api_key } = do
+  _ <- lift $ DBUser.updateUserPubmedAPIKey (Individu.RootId $ NodeId user_id) api_key
+
+  pure 1

src/Gargantext/API/GraphQL/UserInfo.hs

@@ -16,7 +16,6 @@ import Data.Morpheus.Types
 import Data.Text (Text)
 import qualified Data.Text as T
 import Gargantext.API.Prelude (GargM, GargError)
-import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Database.Admin.Types.Hyperdata
   ( HyperdataUser(..)
   , hc_source
@@ -40,7 +39,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
   , ct_phone
   , hc_who
   , hc_where)
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Database.Prelude (CmdCommon)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Query.Table.User (getUsersWithHyperdata, getUsersWithNodeHyperdata, updateUserEmail)
 import Gargantext.Database.Schema.User (UserLight(..))
@@ -49,6 +48,7 @@ import Gargantext.Prelude
 import GHC.Generics (Generic)
 import Gargantext.API.GraphQL.Utils (AuthStatus(Invalid, Valid), authUser)
 import Gargantext.API.Admin.Types (HasSettings)
+import qualified Gargantext.Core.Types.Individu as Individu
 
 data UserInfo = UserInfo
   { ui_id             :: Int
@@ -105,18 +105,18 @@ type GqlM' e env err = ResolverM e (GargM env err) Int
 
 -- | Function to resolve user from a query.
 resolveUserInfos
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => UserInfoArgs -> GqlM e env [UserInfo]
 resolveUserInfos UserInfoArgs { user_id } = dbUsers user_id
 
 -- | Mutation for user info
 updateUserInfo
-  :: (HasConnectionPool env, HasConfig env, HasMail env, HasSettings env)
+  :: (CmdCommon env, HasSettings env)
   -- => UserInfoMArgs -> ResolverM e (GargM env err) Int
   => UserInfoMArgs -> GqlM' e env err
 updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
   -- lift $ printDebug "[updateUserInfo] ui_id" ui_id
-  users <- lift (getUsersWithNodeHyperdata ui_id)
+  users <- lift (getUsersWithNodeHyperdata (Individu.UserDBId ui_id))
   case users of
     [] -> panic $ "[updateUserInfo] User with id " <> (T.pack $ show ui_id) <> " doesn't exist."
     ((UserLight { .. }, node_u):_) -> do
@@ -160,14 +160,14 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
 
 -- | Inner function to fetch the user from DB.
 dbUsers
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> GqlM e env [UserInfo]
 dbUsers user_id = do
   -- lift $ printDebug "[dbUsers]" user_id
 --  user <- getUsersWithId user_id
 --  hyperdata <- getUserHyperdata user_id
 --  lift (map toUser <$> zip user hyperdata)
-  lift (map toUser <$> (getUsersWithHyperdata user_id))
+  lift (map toUser <$> getUsersWithHyperdata (Individu.UserDBId user_id))
 
 toUser :: (UserLight, HyperdataUser) -> UserInfo
 toUser (UserLight { .. }, u_hyperdata) =

src/Gargantext/API/Job.hs

 module Gargantext.API.Job where
 
 import Control.Lens (over, _Just)
-import Data.IORef
 import Data.Maybe
 import qualified Data.Text as T
 
@@ -9,11 +8,13 @@ import Gargantext.Prelude
 
 import Gargantext.API.Admin.Orchestrator.Types
 
+newtype RemainingSteps = RemainingSteps { _RemainingSteps :: Int }
+  deriving (Show, Eq, Num)
 
-jobLogInit :: Int -> JobLog
-jobLogInit rem =
+jobLogStart :: RemainingSteps -> JobLog
+jobLogStart rem =
   JobLog { _scst_succeeded = Just 0
-         , _scst_remaining = Just rem
+         , _scst_remaining = Just (_RemainingSteps rem)
          , _scst_failed = Just 0
          , _scst_events = Just [] }
 
@@ -25,13 +26,24 @@ addEvent level message (JobLog { _scst_events = mEvts, .. }) = JobLog { _scst_ev
                           , _scev_level = Just level
                           , _scev_date = Nothing }
 
-jobLogSuccess :: JobLog -> JobLog
-jobLogSuccess jl = over (scst_succeeded . _Just) (+ 1) $
-                   over (scst_remaining . _Just) (\x -> x - 1) jl
+addErrorEvent :: T.Text -> JobLog -> JobLog
+addErrorEvent message = addEvent "ERROR" message
 
-jobLogFail :: JobLog -> JobLog
-jobLogFail jl = over (scst_failed . _Just) (+ 1) $
-                over (scst_remaining . _Just) (\x -> x - 1) jl
+jobLogProgress :: Int -> JobLog -> JobLog
+jobLogProgress n jl = over (scst_succeeded . _Just) (+ n) $
+                      over (scst_remaining . _Just) (\x -> x - n) jl
+
+-- | Mark a job as completely done, by adding the 'remaining' into 'succeeded'.
+-- At the end 'scst_remaining' will be 0, and 'scst_succeeded' will be 'oldvalue + remaining'.
+jobLogComplete :: JobLog -> JobLog
+jobLogComplete jl =
+  let remainingNow = fromMaybe 0 (_scst_remaining jl)
+  in jl & over scst_succeeded (Just . maybe remainingNow ((+) remainingNow))
+        & over scst_remaining (const (Just 0))
+
+jobLogFailures :: Int -> JobLog -> JobLog
+jobLogFailures n jl = over (scst_failed . _Just) (+ n) $
+                over (scst_remaining . _Just) (\x -> x - n) jl
 
 jobLogFailTotal :: JobLog -> JobLog
 jobLogFailTotal (JobLog { _scst_succeeded = mSucc
@@ -48,25 +60,7 @@ jobLogFailTotal (JobLog { _scst_succeeded = mSucc
       Just rem -> (Just 0, (+ rem) <$> mFail)
 
 jobLogFailTotalWithMessage :: T.Text -> JobLog -> JobLog
-jobLogFailTotalWithMessage message jl = addEvent "ERROR" message $ jobLogFailTotal jl
+jobLogFailTotalWithMessage message jl = addErrorEvent message $ jobLogFailTotal jl
 
 jobLogEvt :: JobLog -> ScraperEvent -> JobLog
 jobLogEvt jl evt = over (scst_events . _Just) (\evts -> (evt:evts)) jl
-
-runJobLog :: MonadBase IO m => Int -> (JobLog -> m ()) -> m (m (), m (), m JobLog)
-runJobLog num logStatus = do
-  jlRef <- liftBase $ newIORef $ jobLogInit num
-
-  return (logRefF jlRef, logRefSuccessF jlRef, getRefF jlRef)
-
-  where
-    logRefF ref = do
-      jl <- liftBase $ readIORef ref
-      logStatus jl
-    logRefSuccessF ref = do
-      jl <- liftBase $ readIORef ref
-      let jl' = jobLogSuccess jl
-      liftBase $ writeIORef ref jl'
-      logStatus jl'
-    getRefF ref = do
-      liftBase $ readIORef ref

src/Gargantext/API/Members.hs

@@ -9,8 +9,7 @@ import Gargantext.Core.Types (UserId)
 import Gargantext.Database.Admin.Types.Node (NodeType(NodeTeam))
 import Gargantext.Database.Query.Table.Node (getNodesIdWithType)
 import Gargantext.Database.Action.Share (membersOf)
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
-import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Database.Prelude (CmdCommon)
 import Control.Monad.Extra (concatMapM)
 
 type MembersAPI = Get '[JSON] [Text]
@@ -19,7 +18,8 @@ members :: UserId -> ServerT MembersAPI (GargM Env GargError)
 members _ = do
   getMembers
 
-getMembers :: (HasConnectionPool env, HasConfig env, HasMail env) => GargM env GargError [Text]
+getMembers :: (CmdCommon env) =>
+              GargM env GargError [Text]
 getMembers = do
   teamNodeIds <- getNodesIdWithType NodeTeam
   m <- concatMapM membersOf teamNodeIds

src/Gargantext/API/Metrics.hs

@@ -27,7 +27,8 @@ import Gargantext.API.Ngrams.NgramsTree
 import Gargantext.API.Ngrams.Types
 import Gargantext.API.Prelude (GargServer)
 import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeLocal)
-import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
+import Gargantext.Core.Types (CorpusId, ListId, ListType(..))
+import Gargantext.Core.Types.Query (Limit)
 import Gargantext.Core.Viz.Chart
 import Gargantext.Core.Viz.Types
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..), hl_chart, hl_pie, hl_scatter, hl_tree)
@@ -49,12 +50,12 @@ import qualified Gargantext.Database.Action.Metrics as Metrics
 type ScatterAPI = Summary "SepGen IncExc metrics"
                   :> QueryParam  "list"       ListId
                   :> QueryParamR "ngramsType" TabType
-                  :> QueryParam  "limit"      Int
+                  :> QueryParam  "limit"      Limit
                   :> Get '[JSON] (HashedResponse Metrics)
               :<|> Summary "Scatter update"
                   :> QueryParam  "list"       ListId
                   :> QueryParamR "ngramsType" TabType
-                  :> QueryParam  "limit"      Int
+                  :> QueryParam  "limit"      Limit
                   :> Post '[JSON] ()
               :<|> "hash" :> Summary "Scatter Hash"
                           :> QueryParam  "list"       ListId
@@ -149,7 +150,7 @@ type ChartApi = Summary " Chart API"
             :<|> Summary "Chart update"
                :> QueryParam  "list"       ListId
                :> QueryParamR "ngramsType" TabType
-               :> QueryParam  "limit"      Int
+               :> QueryParam  "limit"      Limit
                :> Post '[JSON] ()
             :<|> "hash" :> Summary "Chart Hash"
                :> QueryParam  "list"       ListId
@@ -224,7 +225,7 @@ getChartHash :: FlowCmdM env err m =>
   -> m Text
 getChartHash cId maybeListId tabType = do
   hash <$> getChart cId Nothing Nothing maybeListId tabType
- 
+
 -------------------------------------------------------------
 -- | Pie metrics API
 type PieApi = Summary "Pie Chart"
@@ -236,7 +237,7 @@ type PieApi = Summary "Pie Chart"
          :<|> Summary "Pie Chart update"
              :> QueryParam  "list"       ListId
              :> QueryParamR "ngramsType" TabType
-             :> QueryParam  "limit"      Int
+             :> QueryParam  "limit"      Limit
              :> Post '[JSON] ()
          :<|> "hash" :> Summary "Pie Hash"
                      :> QueryParam  "list"       ListId

src/Gargantext/API/Ngrams/List.hs

@@ -34,10 +34,12 @@ import Gargantext.API.Prelude (GargServer, GargM, GargError)
 import Gargantext.API.Types
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Text.Terms (ExtractedNgrams(..))
-import Gargantext.Core.Text.Terms.WithList (buildPatterns, termsInText)
+import Gargantext.Core.Text.Terms.WithList (MatchedText, buildPatterns, termsInText)
+import Gargantext.Core.Types (TermsCount)
 import Gargantext.Core.Types.Main (ListType(..))
 import Gargantext.Database.Action.Flow (saveDocNgramsWith)
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
+-- import Gargantext.Database.Action.Metrics.NgramsByContext (refreshNgramsMaterialized)
 import Gargantext.Database.Admin.Types.Hyperdata.Document
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Query.Table.Node (getNode)
@@ -47,9 +49,8 @@ import Gargantext.Database.Schema.Ngrams
 import Gargantext.Database.Schema.Node (_node_parent_id)
 import Gargantext.Database.Types (Indexed(..))
 import Gargantext.Prelude
-import Gargantext.Utils.Jobs (serveJobsAPI)
+import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
 import Servant
--- import Servant.Job.Async
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.Csv as Csv
 import qualified Data.HashMap.Strict as HashMap
@@ -166,23 +167,30 @@ reIndexWith cId lId nt lts = do
     -- fromListWith (<>)
     ngramsByDoc = map (HashMap.fromListWith (Map.unionWith (Map.unionWith (\(_a,b) (_a',b') -> (1,b+b')))))
                   $ map (map (\((k, cnt), v) -> (SimpleNgrams (text2ngrams k), over (traverse . traverse) (\p -> (p, cnt)) v)))
-                  $ map (\doc -> List.zip
-                                 (termsInText (buildPatterns $ map (\k -> (Text.splitOn " " $ unNgramsTerm k, [])) ts)
-                                              $ Text.unlines $ catMaybes
-                                              [ doc ^. context_hyperdata . hd_title
-                                              , doc ^. context_hyperdata . hd_abstract
-                                              ]
-                                 )
-                                 (List.cycle [Map.fromList $ [(nt, Map.singleton (doc ^. context_id) 1 )]])
-                        ) docs
+                  $ map (docNgrams nt ts) docs
 
   -- printDebug "ngramsByDoc: " ngramsByDoc
 
   -- Saving the indexation in database
   _ <- mapM (saveDocNgramsWith lId) ngramsByDoc
-
+  -- _ <- refreshNgramsMaterialized
   pure ()
 
+docNgrams :: NgramsType
+          -> [NgramsTerm]
+          -> Gargantext.Database.Admin.Types.Node.Context HyperdataDocument
+          -> [((MatchedText, TermsCount),
+                Map NgramsType (Map NodeId Int))]
+docNgrams nt ts doc =
+  List.zip
+  (termsInText (buildPatterns $ map (\k -> (Text.splitOn " " $ unNgramsTerm k, [])) ts)
+    $ Text.unlines $ catMaybes
+    [ doc ^. context_hyperdata . hd_title
+    , doc ^. context_hyperdata . hd_abstract
+    ]
+  )
+  (List.cycle [Map.fromList $ [(nt, Map.singleton (doc ^. context_id) 1 )]])
+
 toIndexedNgrams :: HashMap Text NgramsId -> Text -> Maybe (Indexed Int Ngrams)
 toIndexedNgrams m t = Indexed <$> i <*> n
   where
@@ -192,53 +200,35 @@ toIndexedNgrams m t = Indexed <$> i <*> n
 ------------------------------------------------------------------------
 jsonPostAsync :: ServerT JSONAPI (GargM Env GargError)
 jsonPostAsync lId =
-  serveJobsAPI UpdateNgramsListJobJSON $ \f log' ->
-      let
-        log'' x = do
-          -- printDebug "postAsync ListId" x
-          liftBase $ log' x
-      in postAsync' lId f log''
-
-postAsync' :: FlowCmdM env err m
+  serveJobsAPI UpdateNgramsListJobJSON $ \jHandle f ->
+    postAsync' lId f jHandle
+
+postAsync' :: (FlowCmdM env err m, MonadJobStatus m)
           => ListId
           -> WithJsonFile
-          -> (JobLog -> m ())
-          -> m JobLog
-postAsync' l (WithJsonFile m _) logStatus = do
-
-  logStatus JobLog { _scst_succeeded = Just 0
-                   , _scst_failed    = Just 0
-                   , _scst_remaining = Just 2
-                   , _scst_events    = Just []
-                   }
+          -> JobHandle m
+          -> m ()
+postAsync' l (WithJsonFile m _) jobHandle = do
+
+  markStarted 2 jobHandle
   -- printDebug "New list as file" l
   _ <- setList l m
   -- printDebug "Done" r
 
-  logStatus JobLog { _scst_succeeded = Just 1
-                   , _scst_failed    = Just 0
-                   , _scst_remaining = Just 1
-                   , _scst_events    = Just []
-                   }
-
+  markProgress 1 jobHandle
 
   corpus_node <- getNode l -- (Proxy :: Proxy HyperdataList)
   let corpus_id = fromMaybe (panic "") (_node_parent_id corpus_node)
   _ <- reIndexWith corpus_id l NgramsTerms (Set.fromList [MapTerm, CandidateTerm])
 
-  pure JobLog { _scst_succeeded = Just 2
-              , _scst_failed    = Just 0
-              , _scst_remaining = Just 0
-              , _scst_events    = Just []
-              }
-
+  markComplete jobHandle
 
 ------------------------------------------------------------------------
 
-readCsvText :: Text -> [(Text, Text, Text)]
+readCsvText :: Text -> Either Text [(Text, Text, Text)]
 readCsvText t = case eDec of
-  Left _ -> []
-  Right dec -> Vec.toList dec
+  Left err -> Left $ pack err
+  Right dec -> Right $ Vec.toList dec
   where
     lt = BSL.fromStrict $ P.encodeUtf8 t
     eDec = Csv.decodeWith
@@ -268,50 +258,44 @@ parseCsvData lst = Map.fromList $ conv <$> lst
 csvPost :: FlowCmdM env err m
         => ListId
         -> Text
-        -> m Bool
+        -> m (Either Text ())
 csvPost l m  = do
   -- printDebug "[csvPost] l" l
   -- printDebug "[csvPost] m" m
   -- status label forms
-  let lst = readCsvText m
-  let p = parseCsvData lst
-  --printDebug "[csvPost] lst" lst
-  -- printDebug "[csvPost] p" p
-  _ <- setListNgrams l NgramsTerms p
-  -- printDebug "ReIndexing List" l
-  corpus_node <- getNode l -- (Proxy :: Proxy HyperdataList)
-  let corpus_id = fromMaybe (panic "") (_node_parent_id corpus_node)
-  _ <- reIndexWith corpus_id l NgramsTerms (Set.fromList [MapTerm, CandidateTerm])
-
-  pure True
+  let eLst = readCsvText m
+  case eLst of
+    Left err -> pure $ Left err
+    Right lst -> do
+      let p = parseCsvData lst
+      --printDebug "[csvPost] lst" lst
+      -- printDebug "[csvPost] p" p
+      _ <- setListNgrams l NgramsTerms p
+      -- printDebug "ReIndexing List" l
+      corpus_node <- getNode l -- (Proxy :: Proxy HyperdataList)
+      let corpus_id = fromMaybe (panic "") (_node_parent_id corpus_node)
+      _ <- reIndexWith corpus_id l NgramsTerms (Set.fromList [MapTerm, CandidateTerm])
+
+      pure $ Right ()
 
 ------------------------------------------------------------------------
 csvPostAsync :: ServerT CSVAPI (GargM Env GargError)
 csvPostAsync lId =
-  serveJobsAPI UpdateNgramsListJobCSV $ \f@(WithTextFile _ft _ _n) log' -> do
-      let log'' x = do
-            -- printDebug "[csvPostAsync] filetype" ft
-            -- printDebug "[csvPostAsync] name" n
-            liftBase $ log' x
-      csvPostAsync' lId f log''
-
-
-csvPostAsync' :: FlowCmdM env err m
-             => ListId
-             -> WithTextFile
-             -> (JobLog -> m ())
-             -> m JobLog
-csvPostAsync' l (WithTextFile _ m _) logStatus = do
-  logStatus JobLog { _scst_succeeded = Just 0
-                   , _scst_failed    = Just 0
-                   , _scst_remaining = Just 1
-                   , _scst_events    = Just []
-                   }
-  _r <- csvPost l m
-
-  pure JobLog { _scst_succeeded = Just 1
-              , _scst_failed    = Just 0
-              , _scst_remaining = Just 0
-              , _scst_events    = Just []
-              }
+  serveJobsAPI UpdateNgramsListJobCSV $ \jHandle f -> do
+      markStarted 1 jHandle
+      ePost <- csvPost lId (_wtf_data f)
+      case ePost of
+        Left err -> markFailed (Just err) jHandle
+        Right () -> markComplete jHandle
+
+      getLatestJobStatus jHandle >>= printDebug "[csvPostAsync] job ended with joblog: "
+
 ------------------------------------------------------------------------
+
+
+-- | This is for debugging the CSV parser in the REPL
+importCsvFile :: FlowCmdM env err m
+              => ListId -> P.FilePath -> m (Either Text ())
+importCsvFile lId fp = do
+  contents <- liftBase $ P.readFile fp
+  csvPost lId contents

src/Gargantext/API/Ngrams/Tools.hs

@@ -138,7 +138,7 @@ filterListWithRootHashMap lt m = snd <$> HM.filter isMapTerm m
     isMapTerm (l, maybeRoot) = case maybeRoot of
       Nothing -> l == lt
       Just  r -> case HM.lookup r m of
-        Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
+        Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterListWithRootHashMap, unknown key: " <> unNgramsTerm r
         Just  (l',_) -> l' == lt
 
 filterListWithRoot :: [ListType]
@@ -149,7 +149,7 @@ filterListWithRoot lt m = snd <$> HM.filter isMapTerm m
     isMapTerm (l, maybeRoot) = case maybeRoot of
       Nothing -> elem l lt
       Just  r -> case HM.lookup r m of
-        Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
+        Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterListWithRoot, unknown key: " <> unNgramsTerm r
         Just  (l',_) -> elem l' lt
 
 groupNodesByNgrams :: ( At root_map

src/Gargantext/API/Node.hs

@@ -47,6 +47,7 @@ import Gargantext.API.Table
 import Gargantext.Core.Types (NodeTableResult)
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Types.Main (Tree, NodeTree)
+import Gargantext.Core.Types.Query (Limit, Offset)
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Core.Viz.Phylo.API (PhyloAPI, phyloAPI)
 import Gargantext.Database.Action.Flow.Pairing (pairing)
@@ -61,7 +62,7 @@ import Gargantext.Database.Query.Table.Node.Update (Update(..), update)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Query.Table.NodeContext (nodeContextsCategory, nodeContextsScore)
 import Gargantext.Database.Query.Table.NodeNode
-import Gargantext.Database.Query.Tree (tree, TreeMode(..))
+import Gargantext.Database.Query.Tree (tree, tree_flat, TreeMode(..))
 import Gargantext.Prelude
 import Servant
 import Test.QuickCheck (elements)
@@ -169,8 +170,8 @@ type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 
 type ChildrenApi a = Summary " Summary children"
                  :> QueryParam "type"   NodeType
-                 :> QueryParam "offset" Int
-                 :> QueryParam "limit"  Int
+                 :> QueryParam "offset" Offset
+                 :> QueryParam "limit"  Limit
                  -- :> Get '[JSON] [Node a]
                  :> Get '[JSON] (NodeTableResult a)
 
@@ -296,8 +297,8 @@ scoreApi = putScore
 type PairingApi = Summary " Pairing API"
                 :> QueryParam "view"   TabType
                 -- TODO change TabType -> DocType (CorpusId for pairing)
-                :> QueryParam "offset" Int
-                :> QueryParam "limit"  Int
+                :> QueryParam "offset" Offset
+                :> QueryParam "limit"  Limit
                 :> QueryParam "order"  OrderBy
                 :> Get '[JSON] [FacetDoc]
 
@@ -335,6 +336,13 @@ treeAPI :: NodeId -> GargServer TreeAPI
 treeAPI id = tree TreeAdvanced id
         :<|> tree TreeFirstLevel id
 
+type TreeFlatAPI = QueryParams "type" NodeType
+                    :> QueryParam "query" Text
+                    :> Get '[JSON] [NodeTree]
+
+treeFlatAPI :: NodeId -> GargServer TreeFlatAPI
+treeFlatAPI = tree_flat
+
 ------------------------------------------------------------------------
 -- | TODO Check if the name is less than 255 char
 rename :: NodeId -> RenameNode -> Cmd err [Int]

src/Gargantext/API/Node/Contact.hs

@@ -46,9 +46,9 @@ import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAnnuaire(..), HyperdataContact)
 import Gargantext.Database.Admin.Types.Hyperdata.Contact (hyperdataContact)
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Prelude (($), liftBase, (.), {-printDebug,-} pure)
+import Gargantext.Prelude (($), {-printDebug,-})
 import qualified Gargantext.Utils.Aeson as GUA
-import Gargantext.Utils.Jobs (serveJobsAPI)
+import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
 
 ------------------------------------------------------------------------
 type API = "contact" :> Summary "Contact endpoint"
@@ -73,35 +73,23 @@ data AddContactParams = AddContactParams         { firstname :: !Text, lastname
 ----------------------------------------------------------------------
 api_async :: User -> NodeId -> ServerT API_Async (GargM Env GargError)
 api_async u nId =
-  serveJobsAPI AddContactJob $ \p log ->
-      let
-        log' x = do
-          -- printDebug "addContact" x
-          liftBase $ log x
-      in addContact u nId p (liftBase . log')
-
-addContact :: (HasSettings env, FlowCmdM env err m)
+  serveJobsAPI AddContactJob $ \jHandle p ->
+    addContact u nId p jHandle
+
+addContact :: (HasSettings env, FlowCmdM env err m, MonadJobStatus m)
     => User
     -> NodeId
     -> AddContactParams
-    -> (JobLog -> m ())
-    -> m JobLog
-addContact u nId (AddContactParams fn ln) logStatus = do
-
-  logStatus JobLog { _scst_succeeded = Just 1
-                   , _scst_failed    = Just 0
-                   , _scst_remaining = Just 1
-                   , _scst_events    = Just []
-                   }
-  _ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) Nothing (Just 1, yield $ hyperdataContact fn ln) logStatus
-
-  pure  JobLog { _scst_succeeded = Just 2
-               , _scst_failed    = Just 0
-               , _scst_remaining = Just 0
-               , _scst_events    = Just []
-               }
-addContact _uId _nId _p logStatus = do
-  simuLogs logStatus 10
+    -> JobHandle m
+    -> m ()
+addContact u nId (AddContactParams fn ln) jobHandle = do
+
+  markStarted 2 jobHandle
+  _ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) Nothing (Just 1, yield $ hyperdataContact fn ln) jobHandle
+
+  markComplete jobHandle
+addContact _uId _nId _p jobHandle = do
+  simuLogs jobHandle 10
 
 ------------------------------------------------------------------------
 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.

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

@@ -14,6 +14,8 @@ data FileType = CSV
               | CSV_HAL
               | PresseRIS
               | WOS
+              | Iramuteq
+              | JSON
   deriving (Eq, Show, Generic)
 instance ToSchema FileType
 instance Arbitrary FileType where arbitrary = elements [CSV, PresseRIS]
@@ -26,7 +28,9 @@ instance FromHttpApiData FileType where
   parseUrlPiece "CSV_HAL"   = pure CSV_HAL
   parseUrlPiece "PresseRis" = pure PresseRIS
   parseUrlPiece "WOS"       = pure WOS
-  parseUrlPiece _           = pure CSV -- TODO error here
+  parseUrlPiece "Iramuteq"  = pure Iramuteq
+  parseUrlPiece "JSON"      = pure JSON
+  parseUrlPiece s           = panic $ "[G.A.A.Node.Corpus.New] File Type not implemented (yet): " <> s
 instance ToHttpApiData FileType where
   toUrlPiece = pack . show
 

src/Gargantext/API/Node/Share.hs

@@ -20,6 +20,7 @@ import Data.Swagger
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Gargantext.API.Prelude
+import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.Types.Individu (User(..), arbitraryUsername)
 import Gargantext.Database.Action.Share (ShareNodeWith(..))
 import Gargantext.Database.Action.Share as DB (shareNodeWith, unPublish)
@@ -56,11 +57,11 @@ instance Arbitrary ShareNodeParams where
 -- 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
+api :: (HasNodeError err, HasNLPServer env, CmdRandom env err m)
     => User
     -> NodeId
     -> ShareNodeParams
-    -> CmdR err Int
+    -> m Int
 api userInviting nId (ShareTeamParams user') = do
   let user'' = Text.toLower user'
   user <- case guessUserName user'' of
@@ -88,7 +89,7 @@ api userInviting nId (ShareTeamParams user') = do
                 True -> do
                   -- printDebug "[G.A.N.Share.api]" ("Invitation is enabled if you share a corpus at least" :: Text)
                   pure 0
-                False -> do 
+                False -> do
                   -- printDebug "[G.A.N.Share.api]" ("Your invitation is sent to: " <> user'')
                   newUsers [user'']
               pure ()

src/Gargantext/API/Node/Types.hs

@@ -15,7 +15,7 @@ import GHC.Generics (Generic)
 import Servant.Job.Utils (jsonOptions)
 import Web.FormUrlEncoded          (FromForm, ToForm)
 
-import Gargantext.Core (Lang(..){-, allLangs-})
+import Gargantext.Core (Lang(..))
 import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
 import Gargantext.Prelude
 import qualified Gargantext.Database.GargDB as GargDB