Merge branch 'dev' into 97-dev-istex-search

.gitignore

@@ -38,3 +38,5 @@ repos
 repo.json*
 tmp*repo*json
 data
+
+devops/docker/js-cache

.gitlab-ci.yml

@@ -14,9 +14,22 @@ variables:
   #- apt-get install make xz-utils
 
 stages:
+  - deps
   - docs
   - test
 
+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
+
 docs:
   cache:
     # cache per branch name
@@ -47,3 +60,4 @@ test:
     - stack test --no-terminal --fast
 
       # TOOO
+

CHANGELOG.md

+## Version 0.0.5.8.5
+* [FRONT] CSS + Design, Graph Toolbar and many things
+* [BACK] Security FIX GQL route
+* [BACK] Arxiv API connexion
+
+## Version 0.0.5.8.4
+* [BACK] GraphQL routes
+* [FRONT] CSS, Forest Sidebar
+* [HAL] parser back and front
+
+## Version 0.0.5.8.3
+* [CRAWLERS] HAL for organizations, example done for IMT
+
+## Version 0.0.5.8.2
+* [FIX] Regex Error on HAL Date parsing with Duckling
+
+## Version 0.0.5.8.1
+* [FIX] Folder Up button working well now, using GraphQL
+
+## Version 0.0.5.8
+* [FIX] reindex ngrams-contexts function
+* [PARAM] decreasing the Candidate list
+* [FEAT] enabling Notebooks for Teams
+* [REFACT] Page user and email refactoring
+
+## Version 0.0.5.7.9.1
+* [FIX] Group revert + NLP French API implemented (WIP)
+* Default Names of Folder and Frames simplified
+
+## Version 0.0.5.7.9
+* [FEAT] New NLP server for postagging
+* [FIX] Spinglass unconnected componnent of graph
+
+## Version 0.0.5.7.8
+* [FIX] PubMed limit parser
+
+## Version 0.0.5.7.7
+* [FEAT FIX] Link Annuaire Corpus (WIP)
+* [UPGRADE METHOD] ./bin/psql gargantext.ini < devops/postgres/upgrade/0.0.5.7.7.sql
+
+## Version 0.0.5.7.6
+* [FIX] Default behavior of Ngrams Table: Cache off and Desc order by score
+
+## Version 0.0.5.7.5
+* [FIX] Progress length
+
+## Version 0.0.5.7.4
+* [FIX] User Page info get/update/security
+
+## Version 0.0.5.7.3
+* [OPTIM] HAL and PubMed parsers with Conduit
+* [BACK] Zip files added
+
+## Version 0.0.5.7.2
+* [FIX] Phylo default parameters on frontend side
+
+## Version 0.0.5.7.1
+* [FIX] Phylo error findBounds fixed
+
+## Version 0.0.5.7
+* [FEAT] Phylo Backend/Frontend connected for tests
+
+## Version 0.0.5.6.7
+* [BACK] fix limit with MAX_DOCS_SCRAPERS
+* [FEAT] Users Password Sugar function : in repl, runCmdReplEasy $ updateUsersPassword  ["user@mail.com"]
+
+## Version 0.0.5.6.6
+* [BACK] CSV List post and reindex after (for both CSV and JSON)
+
+## Version 0.0.5.6.5
+* [BACK] HAL parser with Conduit
+
+## Version 0.0.5.6.4
+* [FRONT] Forest Tooltip + Async progress bar fix
+
+## Version 0.0.5.6.3
+* [BACK][EXPORT][GEXF] node size
+
+## Version 0.0.5.6.2
+* [FRONT][FIX] Ngrams Batch change
+
+## Version 0.0.5.6.1
+* [BACK][FEAT] Confluence Method connection
+
+## Version 0.0.5.6
+* [BACK][FEAT] Phylo backend connection
+* [FRONT] Editable Metadata
+
+## Version 0.0.5.5.7
+* [FRONT][FIX] NgramsTable Cache search.
+
+## Version 0.0.5.5.6
+* [BACK][FIX] ./bin/psql gargantext.ini < devops/posgres/upgrade/0.0.5.5.6.sql
+* [FRONT] fix NodeType list show (Nodes options)
+
+## Version 0.0.5.5.5
+* [FORNT] fix Graph Explorer search ngrams
+* [FRONT] fix NodeType list show (main Nodes)
+
+## Version 0.0.5.5.4
+* [BACK][OPTIM] NgramsTable scores
+* [BACK] bin/client script to analyze backend performance and reproduce bugs
+* [FRONT] Adding Language selection
+
+## Version 0.0.5.5.3
+* [BACK] Adding a Max limit for others lists.
+
+## Version 0.0.5.5.2
+* [BACK][OPTIM] Index on node_node_ngrams to seed up ngrams table score
+  queries. Please execute the upgrade SQL script
+  devops/postgres/0.0.5.5.2.sql
+
+## Version 0.0.5.5.1
+* [BACK] FIX Graph Explorer search with selected ngrams
+* [FRONT] Clean CSS
+
+## Version 0.0.5.5
+* [FRONT] Visio frame removed, using a new tab instead (which is working)
+* [BACK] Scores on the docs view fixed
+
+## Version 0.0.5.3
+* [FRONT] SSL local option
+
+## Version 0.0.5.2
+* [QUAL] Scores in Ngrams Table fixed during workflow and user can
+  refresh it if needed.
+
+## Version 0.0.5.1
+* [OPTIM] Upgrade fix with indexes and scores counts
+
+## Version 0.0.5
+* [OPTIM][DATABASE] Upgrade Schema, move conTexts in contexts table which requires a version bump.
+
+## Version 0.0.4.9.9.6
+* [BACK] PubMed parser fixed
+* [FRONT] Visio Frame resized
+
+## Version 0.0.4.9.9.5
+* [FIX] Chart Sort
+
+## Version 0.0.4.9.9.4
+* [FEAT] Corpus docs download
+
+## Version 0.0.4.9.9.3
+* [BACK] Graph update with force option
+
+## Version 0.0.4.9.9.2
+* [BACK] Opaleye Upgrade
+
+## Version 0.0.4.9.9.1
+* [FRONT] 350-dev-graph-search-in-forms-not-labels
+* [FRONT] 359-dev-input-with-autocomplete
+
 ## Version 0.0.4.9.9
 * [FIX] Continuous Integration (CI)
 

bin/gargantext-client/Auth.hs

+module Auth where
+
+import Prelude
+import Data.Maybe
+import Core
+import Options
+
+import Control.Monad.IO.Class
+import Data.Text.Encoding (encodeUtf8)
+import Options.Generic
+import Servant.Client
+import qualified Servant.Auth.Client as SA
+
+import Gargantext.API.Client
+import qualified Gargantext.API.Admin.Auth.Types as Auth
+import qualified Gargantext.Core.Types.Individu  as Auth
+import qualified Gargantext.Database.Admin.Types.Node as Node
+
+-- | Authenticate and use the resulting Token to perform
+--   auth-restricted actions
+withAuthToken
+  :: ClientOpts -- ^ source of user/pass data
+  -> (SA.Token -> Node.NodeId -> ClientM a) -- ^ do something once authenticated
+  -> ClientM a
+withAuthToken opts act
+  -- both user and password CLI arguments passed
+  | Helpful (Just usr) <- user opts
+  , Helpful (Just pw)  <- pass opts = do
+      authRes <- postAuth (Auth.AuthRequest usr (Auth.GargPassword pw))
+      case Auth._authRes_valid authRes of
+        -- authentication failed, this function critically needs it to
+        -- be able to run the action, so we abort
+        Nothing -> problem $
+          "invalid auth response: " ++
+          maybe "" (show . Auth._authInv_message)
+                   (Auth._authRes_inval authRes)
+        -- authentication went through, we can run the action
+        Just (Auth.AuthValid tok tree_id _uid) -> do
+          let tok' = SA.Token (encodeUtf8 tok)
+          whenVerbose opts $ do
+            liftIO . putStrLn $ "[Debug] Authenticated: token=" ++ show tok ++
+                                ", tree_id=" ++ show tree_id
+          act tok' tree_id
+  -- user and/or pass CLI arguments not passed
+  | otherwise =
+      problem "auth-protected actions require --user and --pass"

bin/gargantext-client/Core.hs

+module Core (problem, whenVerbose) where
+
+import Prelude
+
+import Options
+import Options.Generic
+
+import Control.Exception
+import Control.Monad
+import Control.Monad.Catch
+import Servant.Client
+
+newtype GargClientException = GCE String
+instance Show GargClientException where
+  show (GCE s) = "Garg client exception: " ++ s
+
+instance Exception GargClientException
+
+-- | Abort with a message
+problem :: String -> ClientM a
+problem = throwM . GCE
+
+-- | Only run the given computation when the @--verbose@ flag is
+--   passed.
+whenVerbose :: Monad m => ClientOpts -> m () -> m ()
+whenVerbose opts act = when (unHelpful $ verbose opts) act

bin/gargantext-client/Main.hs

+module Main where
+
+import Control.Monad
+import Network.HTTP.Client
+import Options
+import Options.Generic
+import Prelude
+import Script (script)
+import Servant.Client
+
+main :: IO ()
+main = do
+  -- we parse CLI options
+  opts@(ClientOpts (Helpful uri) _ _ (Helpful verb)) <- getRecord "Gargantext client"
+  mgr <- newManager defaultManagerSettings
+  burl <- parseBaseUrl uri
+  when verb $ do
+    putStrLn $ "[Debug] user: " ++ maybe "<none>" show (unHelpful $ user opts)
+    putStrLn $ "[Debug] backend: " ++ show burl
+  -- we run 'script' from the Script module, reporting potential errors
+  res <- runClientM (script opts) (mkClientEnv mgr burl)
+  case res of
+    Left err -> putStrLn $ "[Client error] " ++ show err
+    Right a  -> print a

bin/gargantext-client/Options.hs

+{-# LANGUAGE TypeOperators #-}
+module Options where
+
+import Prelude
+import Options.Generic
+
+-- | Some general options to be specified on the command line.
+data ClientOpts = ClientOpts
+  { url     :: String <?> "URL to gargantext backend"
+  , user    :: Maybe Text <?> "(optional) username for auth-restricted actions"
+  , pass    :: Maybe Text <?> "(optional) password for auth-restricted actions"
+  , verbose :: Bool   <?> "Enable verbose output"
+  } deriving (Generic, Show)
+
+instance ParseRecord ClientOpts

bin/gargantext-client/Script.hs

+module Script (script) where
+
+import Auth
+import Control.Monad.IO.Class
+import Core
+import Gargantext.API.Client
+import Options
+import Prelude
+import Servant.Client
+import Tracking
+
+-- | An example script. Tweak, rebuild and re-run the executable to see the
+--   effect of your changes. You can hit any gargantext endpoint in the body
+--   of 'script' using the many (many!) client functions exposed by the
+--   'Gargantext.API.Client' module.
+--
+--   Don't forget to pass @--user@ and @--pass@ if you're using 'withAuthToken'.
+script :: ClientOpts -> ClientM ()
+script opts = do
+  -- we start by asking the backend for its version
+  ver <- getBackendVersion
+  liftIO . putStrLn $ "Backend version: " ++ show ver
+
+  -- next we authenticate using the credentials given on the command line
+  -- (through --user and --pass), erroring out loudly if the auth creds don't
+  -- go through, running the continuation otherwise.
+  withAuthToken opts $ \tok userNode -> do
+    liftIO . putStrLn $ "user node: " ++ show userNode
+    steps <-
+      -- we run a few client computations while tracking some EKG metrics
+      -- (any RTS stats or routing-related data), which means that we sample the
+      -- metrics at the beginning, the end, and in between each pair of steps.
+      tracking opts ["rts.gc.bytes_allocated"]
+        [ ("get roots", do
+              roots <- getRoots tok
+              liftIO . putStrLn $ "roots: " ++ show roots
+          )
+        , ("get user node detail", do
+              userNodeDetail <- getNode tok userNode
+              liftIO . putStrLn $ "user node details: " ++ show userNodeDetail
+          )
+        ]
+    -- we pretty print the values we sampled for all metrics and the
+    -- results of all the steps
+    whenVerbose opts (ppTracked steps)

bin/gargantext-client/Tracking.hs

+{-# LANGUAGE TupleSections #-}
+module Tracking
+  ( tracking
+  , ppTracked
+  , EkgMetric
+  , Step
+  ) where
+
+import Core
+import Options
+import Prelude
+
+import Control.Monad.IO.Class
+import Data.List (intersperse)
+import Data.Text (Text)
+import Servant.Client
+import System.Metrics.Json (Value)
+
+import Gargantext.API.Client
+
+import qualified Data.Text as T
+
+-- | e.g @["rts", "gc", "bytes_allocated"]@
+type EkgMetric = [Text]
+-- | Any textual description of a step
+type Step      = Text
+
+-- | Track EKG metrics before/after running a bunch of computations
+--   that can talk to the backend.
+tracking
+  :: ClientOpts
+  -> [Text] -- ^ e.g @["rts.gc.bytes_allocated"]@
+  -> [(Step, ClientM a)]
+  -> ClientM [Either [(EkgMetric, Value)] (Step, a)]
+-- no steps, nothing to do
+tracking _    _   []    = return []
+-- no metrics to track, we just run the steps
+tracking _    []  steps = traverse runStep steps
+-- metrics to track: we intersperse metric fetching and steps,
+-- starting and ending with metric fetching
+tracking opts ms' steps = mix (Left <$> fetchMetrics) (map runStep steps)
+
+  where fetchMetrics :: ClientM [(EkgMetric, Value)]
+        fetchMetrics = flip traverse ms $ \metric -> do
+          whenVerbose opts $
+            liftIO . putStrLn $ "[Debug] metric to track: " ++ T.unpack (T.intercalate "." metric)
+          dat <- (metric,) <$> getMetricSample metric
+          whenVerbose opts $
+            liftIO . putStrLn $ "[Debug] metric pulled: " ++ show dat
+          return dat
+        mix :: ClientM a -> [ClientM a] -> ClientM [a]
+        mix x xs = sequence $ [x] ++ intersperse x xs ++ [x]
+        ms = map (T.splitOn ".") ms'
+
+-- ^ A trivial function to print results of steps and sampled metrics
+ppTracked :: Show a => [Either [(EkgMetric, Value)] (Step, a)] -> ClientM ()
+ppTracked [] = return ()
+ppTracked (Right (step, a) : rest) = do
+  liftIO . putStrLn $ "[step: " ++ T.unpack step ++ "] returned: " ++ show a
+  ppTracked rest
+ppTracked (Left ms : rest) = do
+  liftIO . putStrLn $ unlines
+    [ T.unpack (T.intercalate "." metric) ++ " = " ++ show val
+    | (metric, val) <- ms
+    ]
+  ppTracked rest
+
+runStep :: (Step, ClientM a) -> ClientM (Either e (Step, a))
+runStep (step, act) = Right . (step,) <$> act

bin/gargantext-import/Main.hs

@@ -17,10 +17,11 @@ module Main where
 
 import Control.Exception (finally)
 import Data.Either
+import Data.Maybe (Maybe(..))
 import Data.Text (Text)
-import Prelude (read)
 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(..))
@@ -34,7 +35,7 @@ import Gargantext.Database.Admin.Types.Hyperdata (toHyperdataDocument)
 import Gargantext.Database.Admin.Types.Node (CorpusId)
 import Gargantext.Database.Prelude (Cmd)
 import Gargantext.Prelude
-import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..))
+import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..))
 
 main :: IO ()
 main = do
@@ -46,11 +47,14 @@ main = do
     --tt = (Unsupervised EN 6 0 Nothing)
     tt = (Multi EN)
     format = CsvGargV3 -- CsvHal --WOS
+    limit' = case (readMaybe limit :: Maybe Int) 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)) (read limit :: Int) tt  format corpusPath Nothing (\_ -> pure ())
+    corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) limit' tt  format Plain corpusPath Nothing (\_ -> pure ())
 
     corpusCsvHal :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
-    corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHal corpusPath Nothing (\_ -> pure ())
+    corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) limit' tt CsvHal Plain corpusPath Nothing (\_ -> pure ())
 
     annuaire :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
     annuaire = flowAnnuaire (UserName $ cs user) (Left "Annuaire") (Multi EN) corpusPath (\_ -> pure ())

bin/gargantext-init/Main.hs

@@ -15,31 +15,32 @@ Import a corpus binary.
 
 module Main where
 
-import Data.Text (Text)
 import Data.Either (Either(..))
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
-import Gargantext.API.Prelude (GargError)
 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.Query.Table.Node (getOrMkList)
-import Gargantext.Database.Query.Table.User (insertNewUsers, )
 import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
-import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
+import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (Cmd, )
+import Gargantext.Database.Query.Table.Node (getOrMkList)
+import Gargantext.Database.Query.Table.User (insertNewUsers, )
 import Gargantext.Prelude
-import System.Environment (getArgs)
+import Gargantext.Prelude.Config (GargConfig(..), readConfig)
 import Prelude (getLine)
+import System.Environment (getArgs)
 
--- TODO put this in gargantext.ini
-secret :: Text
-secret = "Database secret to change"
 
 main :: IO ()
 main = do
-  [iniPath] <- getArgs
+  params@[iniPath] <- getArgs
+
+  _ <- if length params /= 1
+      then panic "USAGE: ./gargantext-init gargantext.ini"
+      else pure ()
 
   putStrLn "Enter master user (gargantua) _password_ :"
   password  <- getLine
@@ -47,6 +48,8 @@ main = do
   putStrLn "Enter master user (gargantua) _email_ :"
   email     <- getLine
 
+  cfg       <- readConfig         iniPath
+  let secret = _gc_secretkey cfg
 
   let createUsers :: Cmd GargError Int64
       createUsers = insertNewUsers (NewUser "gargantua" (cs email) (GargPassword $ cs password)

bin/init

+#!/bin/bash
+
+ln -s $(nix-shell --run "which dot") ~/.local/bin/dot
+

bin/install

 #!/bin/bash
 
 #stack install --nix --profile --test --fast --no-install-ghc --skip-ghc-check
-stack install --nix --test --no-install-ghc --skip-ghc-check
+
+env LANG=C.UTF-8 stack install --nix --test --no-install-ghc --skip-ghc-check

cabal.project

 packages: .
-          -- ../servant-job
-          -- ../ekg-json
-          -- ../../../code/servant/servant
-          -- ../../../code/servant/servant-server
-          -- ../../../code/servant/servant-client-core
-          -- ../../../code/servant/servant-client
-          -- ../../../code/servant/servant-auth/servant-auth
-          -- ../../../code/servant/servant-auth/servant-auth-client
-          -- ../../../code/servant/servant-auth/servant-auth-server
-
-allow-newer: base, accelerate, servant, time
+
+allow-newer: base, accelerate, servant, time, classy-prelude
 
 -- Patches
 source-repository-package
@@ -20,7 +11,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/alpmestan/ekg-json.git
-  tag: c7bde4851a7cd41b3f3debf0c57f11bbcb11d698
+  tag: fd7e5d7325939103cd87d0dc592faf644160341c
 
 source-repository-package
   type: git
@@ -53,7 +44,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://gitlab.iscpif.fr/gargantext/crawlers/pubmed.git
-  tag: a9d8e08a7ef82f90e29dfaced4071704a3163394
+  tag: 9cdba6423decad5acfacb0f274212fd8723ce734
 
 source-repository-package
   type: git
@@ -112,7 +103,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/delanoe/haskell-opaleye.git
-  tag: d3ab7acd5ede737478763630035aa880f7e34444
+  tag: 756cb90f4ce725463d957bc899d764e0ed73738c
 
 source-repository-package
   type: git
@@ -146,4 +137,5 @@ source-repository-package
 
 constraints: unordered-containers==0.2.14.*,
              servant-ekg==0.3.1,
-             time==1.9.3
+             time==1.9.3,
+             stm==2.5.0.1

devops/docker/docker-compose.yaml

@@ -35,5 +35,13 @@ services:
     ports:
       - 9000:9000
 
+  johnsnownlp:
+    image: 'johnsnowlabs/nlp-server:latest'
+    volumes:
+      - js-cache:/home/johnsnowlabs/cache_pretrained
+    ports:
+      - 5000:5000
+
 volumes:
   garg-pgdata:
+  js-cache:

devops/postgres/create

 #!/bin/bash
 
 # sudo su postgres
-
 # postgresql://$USER:$PW@localhost/$DB
 
-PW="C8kdcUrAQy66U"
-DB="gargandbV5"
-USER="gargantua"
+INIFILE=$1
+
+getter () {
+  grep $1 $INIFILE | sed "s/^.*= //"
+}
+
+USER=$(getter "DB_USER")
+NAME=$(getter "DB_NAME")
+PASS=$(getter "DB_PASS")
+HOST=$(getter "DB_HOST")
+PORT=$(getter "DB_PORT")
+
 
 psql -c "CREATE USER \"${USER}\""
 psql -c "ALTER USER \"${USER}\" with PASSWORD '${PW}'"
+psql -c "DROP DATABASE IF EXISTS \"${NAME}\""
 
-psql -c "DROP DATABASE IF EXISTS \"${DB}\""
-createdb "${DB}"
-psql "${DB}" < schema.sql
-
-psql -c "ALTER DATABASE \"${DB}\" OWNER to \"${USER}\""
+createdb "${NAME}"
+psql "${NAME}" <  extensions.sql
 
+# if new
+#psql "${NAME}" < schema.sql
 
+psql ${NAME} < $2
 
+psql -c "ALTER DATABASE \"${NAME}\" OWNER to \"${USER}\""
 
 

devops/postgres/empty

+#!/bin/bash
+
+# sudo su postgres
+
+# postgresql://$USER:$PW@localhost/$DB
+
+PW="C8kdcUrAQy66U"
+DB="gargandb1"
+USER="gargantua"
+
+#psql -c "CREATE USER \"${USER}\""
+#psql -c "ALTER USER \"${USER}\" with PASSWORD '${PW}'"
+
+psql -c "DROP DATABASE IF EXISTS \"${DB}\""
+createdb "${DB}"
+psql -c "ALTER DATABASE \"${DB}\" OWNER to \"${USER}\""
+
+
+
+
+

devops/postgres/extensions.sql

+CREATE EXTENSION IF NOT EXISTS pgcrypto;
+CREATE EXTENSION IF NOT EXISTS tsm_system_rows;
+

devops/postgres/upgrade/0.0.5.5.2.sql

+CREATE  INDEX ON public.node_node_ngrams USING btree (node1_id,  node2_id, ngrams_type);

devops/postgres/upgrade/0.0.5.5.6.sql

+drop trigger trigger_count_insert on node_node_ngrams ;
+

devops/postgres/upgrade/0.0.5.7.7.sql

+
+ALTER TABLE nodes_contexts DROP CONSTRAINT nodes_contexts_pkey;
+ALTER TABLE nodes_contexts ADD COLUMN id SERIAL PRIMARY KEY ;
+
+CREATE TABLE public.nodescontexts_nodescontexts (
+    nodescontexts1 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
+    nodescontexts2 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
+
+    PRIMARY KEY (nodescontexts1, nodescontexts2)
+);
+ALTER TABLE public.nodescontexts_nodescontexts OWNER TO gargantua;
+
+CREATE INDEX ON public.nodescontexts_nodescontexts USING btree (nodescontexts1, nodescontexts2)
+

devops/postgres/upgrade/0.0.5/nodes2contexts.sql

+-- to delete
+-- DELETE FROM contexts;
+
+-- WITH docs (id,hash_id,typename,user_id,parent_id,name,date,hyperdata, search)
+WITH docs AS (SELECT * from nodes  WHERE nodes.typename IN (4,41)),
+
+inserted (id, hash_id) AS (
+  INSERT INTO contexts (hash_id,typename,user_id,parent_id,name,date,hyperdata, search)
+    SELECT d.hash_id,d.typename,d.user_id,NULL,d.name,d.date,d.hyperdata,search FROM docs AS d
+    RETURNING contexts.id, contexts.hash_id
+ ),
+
+indexed (node_id, context_id) AS (
+  SELECT docs.id, inserted.id from inserted
+  JOIN docs on docs.hash_id = inserted.hash_id
+),
+
+-- nodes_nodes -> nodes_contexts
+nodes_contexts_query AS (
+INSERT INTO nodes_contexts (node_id, context_id,score, category)
+SELECT nn.node1_id,i.context_id,nn.score,nn.category FROM nodes_nodes nn
+JOIN indexed i ON i.node_id = nn.node2_id
+),
+
+-- nodes_nodes_ngrams -> contexts_nodes_ngrams
+contexts_nodes_ngrams_query AS (
+INSERT INTO context_node_ngrams
+SELECT i.context_id, nnn.node1_id, nnn.ngrams_id, nnn.ngrams_type, nnn.weight FROM node_node_ngrams nnn
+JOIN indexed i ON i.node_id = nnn.node2_id
+),
+
+---- nodes_nodes_ngrams2 -> contexts_nodes_ngrams2
+context_node_ngrams2_query AS (
+INSERT INTO context_node_ngrams2
+SELECT i.context_id, nnn2.nodengrams_id, nnn2.weight FROM node_node_ngrams2 nnn2
+JOIN indexed i ON i.node_id = nnn2.node_id
+)
+
+-- WITH CASCADE it should update others tables
+DELETE FROM nodes n
+USING indexed i WHERE i.node_id = n.id
+;
+
+UPDATE contexts SET parent_id = id;
+
+

devops/postgres/upgrade/0.0.5/schema.sql

+
+-- TODO typename -> type_id
+CREATE TABLE public.contexts (
+    id        SERIAL,
+    hash_id   CHARACTER varying(66) DEFAULT ''::character varying NOT NULL,
+    typename  INTEGER NOT NULL,
+    user_id   INTEGER NOT NULL,
+    parent_id INTEGER REFERENCES public.contexts(id) ON DELETE CASCADE ,
+    name      CHARACTER varying(255) DEFAULT ''::character varying NOT NULL,
+    date      TIMESTAMP with time zone DEFAULT now() NOT NULL,
+    hyperdata jsonb DEFAULT '{}'::jsonb NOT NULL,
+    search tsvector,
+    PRIMARY KEY (id),
+    FOREIGN KEY (user_id)  REFERENCES public.auth_user(id) ON DELETE CASCADE
+);
+ALTER TABLE public.contexts OWNER TO gargantua;
+
+
+
+-- To attach contexts to a Corpus
+CREATE TABLE public.nodes_contexts (
+    node_id    INTEGER NOT NULL REFERENCES public.nodes(id)    ON DELETE CASCADE,
+    context_id INTEGER NOT NULL REFERENCES public.contexts(id) ON DELETE CASCADE,
+    score    REAL    ,
+    category INTEGER ,
+    PRIMARY KEY (node_id, context_id)
+);
+ALTER TABLE public.nodes_contexts OWNER TO gargantua;
+
+ ---------------------------------------------------------------
+CREATE TABLE public.context_node_ngrams (
+    context_id    INTEGER NOT NULL REFERENCES public.contexts (id) ON DELETE CASCADE,
+    node_id       INTEGER NOT NULL REFERENCES public.nodes    (id) ON DELETE CASCADE,
+    ngrams_id     INTEGER NOT NULL REFERENCES public.ngrams   (id) ON DELETE CASCADE,
+    ngrams_type   INTEGER  ,
+    weight double precision,
+    PRIMARY KEY (context_id, node_id, ngrams_id, ngrams_type)
+  );
+
+
+ALTER TABLE public.context_node_ngrams OWNER TO gargantua;
+
+CREATE TABLE public.context_node_ngrams2 (
+    context_id      INTEGER NOT NULL REFERENCES public.contexts  (id)       ON DELETE CASCADE,
+    nodengrams_id   INTEGER NOT NULL REFERENCES public.node_ngrams  (id) ON DELETE CASCADE,
+    weight double   precision,
+    PRIMARY KEY (context_id, nodengrams_id)
+);
+ALTER TABLE public.context_node_ngrams2 OWNER TO gargantua;
+
+
+
+CREATE INDEX        ON public.contexts USING gin (hyperdata);
+CREATE INDEX        ON public.contexts USING btree (user_id, typename, parent_id);
+CREATE INDEX        ON public.contexts USING btree (id, typename, date ASC);
+CREATE INDEX        ON public.contexts USING btree (id, typename, date DESC);
+CREATE INDEX        ON public.contexts USING btree (typename, id);
+CREATE UNIQUE INDEX ON public.contexts USING btree (hash_id);
+
+
+-- To make the links between Corpus Node and its contexts
+CREATE UNIQUE INDEX ON public.nodes_contexts  USING btree (node_id, context_id);
+CREATE INDEX        ON public.nodes_contexts  USING btree (node_id, context_id, category);
+
+
+------------------------------------------------------------------------
+CREATE UNIQUE INDEX ON public.context_node_ngrams USING btree (context_id, node_id, ngrams_id, ngrams_type);
+CREATE        INDEX ON public.context_node_ngrams USING btree (context_id,  node_id);
+CREATE        INDEX ON public.context_node_ngrams USING btree (ngrams_id, node_id);
+CREATE        INDEX ON public.context_node_ngrams USING btree (ngrams_type);
+
+CREATE INDEX ON public.context_node_ngrams2 USING btree (context_id);
+CREATE INDEX ON public.context_node_ngrams2 USING btree (nodengrams_id);
+CREATE INDEX ON public.context_node_ngrams2 USING btree (context_id, nodengrams_id);
+
+DROP TABLE if EXISTS public.node_nodengrams_nodengrams;
+
+DROP TRIGGER if EXISTS trigger_count_delete2    ON nodes_nodes;
+DROP TRIGGER if EXISTS trigger_count_update_add ON nodes_nodes;
+DROP TRIGGER if EXISTS trigger_delete_count     ON nodes_nodes;
+DROP TRIGGER if EXISTS trigger_insert_count     ON nodes_nodes;
+

nix/pkgs.nix

@@ -28,6 +28,7 @@ rec {
     #    gfortran7.cc.lib
     expat
     icu
+    graphviz
   ];
   libPaths = pkgs.lib.makeLibraryPath nonhsBuildInputs;
   shellHook = ''

package.yaml

 name: gargantext
-version: '0.0.4.9.9'
+
+#         +------------ Layer 3
+#         | +--+------- Layer 2
+#         | | +-------- Layer 1  : New versions with API changes
+#         | | | +-----  Layers * : New versions with API additions
+#         | | | | +---  Layers * : New versions without API breaking changes
+#         | | | | |
+version: '0.0.5.8.5'
 synopsis: Search, map, share
 description: Please see README.md
 category: Data
@@ -54,11 +61,13 @@ library:
   - Gargantext.API.Ngrams
   - Gargantext.API.Ngrams.Tools
   - Gargantext.API.Ngrams.Types
+  - Gargantext.API.Ngrams.Prelude
   - Gargantext.API.Admin.Settings
   - Gargantext.API.Admin.EnvTypes
+  - Gargantext.API.Admin.Auth.Types
   - Gargantext.API.Admin.Types
   - Gargantext.API.Prelude
-  - Gargantext.Client
+  - Gargantext.API.Client
   - Gargantext.Core
   - Gargantext.Core.NodeStory
   - Gargantext.Core.Methods.Distances
@@ -73,6 +82,7 @@ library:
   - Gargantext.Database.Query.Table.Node
   - Gargantext.Database.Query.Table.Node.UpdateOpaleye
   - Gargantext.Database.Query.Table.NgramsPostag
+  - Gargantext.Database.Schema.Ngrams
   - Gargantext.Database.Prelude
   - Gargantext.Database.Admin.Trigger.Init
   - Gargantext.Database.Admin.Config
@@ -101,7 +111,9 @@ library:
   - Gargantext.Core.Viz.Graph.Tools
   - Gargantext.Core.Viz.Graph.Tools.IGraph
   - Gargantext.Core.Viz.Graph.Index
-  - Gargantext.Core.Viz.AdaptativePhylo
+  - Gargantext.Core.Viz.Phylo
+  - Gargantext.Core.Viz.Phylo.API
+  - Gargantext.Core.Viz.Phylo.API.Tools
   - Gargantext.Core.Viz.Phylo.PhyloMaker
   - Gargantext.Core.Viz.Phylo.PhyloTools
   - Gargantext.Core.Viz.Phylo.PhyloExport
@@ -121,6 +133,7 @@ library:
   - aeson-lens
   - aeson-pretty
   - array
+  - arxiv
   - async
   - attoparsec
   - auto-update
@@ -139,6 +152,7 @@ library:
   - conduit-extra
   - containers
   - contravariant
+  - crawlerArxiv
   - crawlerHAL
   - crawlerISTEX
   - crawlerIsidore
@@ -160,7 +174,7 @@ library:
   - full-text-search
   - fullstop
   - gargantext-prelude
-    #  - gargantext-graph >= 0.1.0.0
+  - gargantext-graph >= 0.1.0.0
   - graphviz
   - hashable
   - haskell-igraph
@@ -179,6 +193,7 @@ library:
   - jose
   - json-stream
   - lens
+  - listsafe
   - located-base
   - logging-effect
   - matrix
@@ -201,6 +216,7 @@ library:
   - postgresql-simple
   - pretty-simple
   - probability
+  - process
   - product-profunctors
   - profunctors
   - protolude
@@ -244,6 +260,7 @@ library:
   - tagsoup
   - template-haskell
   - temporary
+  - text-conversions
   - text-metrics
   - time
   - time-locale-compat
@@ -322,9 +339,45 @@ executables:
       - unordered-containers
       - full-text-search
 
-  gargantext-adaptative-phylo:
+
+  gargantext-client:
     main: Main.hs
-    source-dirs: bin/gargantext-adaptative-phylo
+    source-dirs: bin/gargantext-client
+    ghc-options:
+    - -Wall
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -O2
+    - -Wmissing-signatures
+    default-extensions:
+    - DataKinds
+    - DeriveGeneric
+    - FlexibleContexts
+    - FlexibleInstances
+    - GeneralizedNewtypeDeriving
+    - MultiParamTypeClasses
+    - NamedFieldPuns
+    - NoImplicitPrelude
+    - OverloadedStrings
+    - RankNTypes
+    - RecordWildCards
+    dependencies:
+    - base
+    - extra
+    - servant
+    - text
+    - optparse-generic
+    - exceptions
+    - servant-client
+    - servant-auth-client
+    - gargantext
+    - ekg-json
+    - http-client
+
+  gargantext-phylo:
+    main: Main.hs
+    source-dirs: bin/gargantext-phylo
     ghc-options:
     - -threaded
     - -rtsopts
@@ -379,19 +432,20 @@ executables:
       - gargantext-prelude
       - base
 
-#  gargantext-upgrade:
-#    main: Main.hs
-#    source-dirs: bin/gargantext-upgrade
-#    ghc-options:
-#    - -threaded
-#    - -rtsopts
-#    - -with-rtsopts=-N
-#    - -O2
-#    - -Wmissing-signatures
-#    dependencies:
-#      - gargantext
-#      - gargantext-prelude
-#      - base
+  gargantext-upgrade:
+    main: Main.hs
+    source-dirs: bin/gargantext-upgrade
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -O2
+    - -Wmissing-signatures
+    dependencies:
+      - gargantext
+      - gargantext-prelude
+      - base
+      - postgresql-simple
 
   gargantext-admin:
     main: Main.hs

server

@@ -6,4 +6,4 @@ LOGFILE=$FOLDER"/"$FILE
 
 mkdir -p $FOLDER
 
-~/.local/bin/gargantext-server --ini gargantext.ini --run Dev +RTS > $LOGFILE 2>&1 & tail -F $LOGFILE # -p
+env LANG=en_US.UTF-8 ~/.local/bin/gargantext-server --ini gargantext.ini --run Dev +RTS > $LOGFILE 2>&1 & tail -F $LOGFILE # -p

src/Gargantext/API/Admin/Auth.hs

@@ -70,7 +70,7 @@ checkAuthRequest u (GargPassword p) = do
   candidate <- head <$> getUsersWith u
   case candidate of
     Nothing -> pure InvalidUser
-    Just (UserLight _id _u _email h) ->
+    Just (UserLight id _u _email (GargPassword h)) ->
       case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
         Auth.PasswordCheckFail    -> pure InvalidPassword
         Auth.PasswordCheckSuccess -> do
@@ -79,7 +79,7 @@ checkAuthRequest u (GargPassword p) = do
             Nothing  -> pure InvalidUser
             Just uid -> do
               token <- makeTokenForUser uid
-              pure $ Valid token uid
+              pure $ Valid token uid id
 
 auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
      => AuthRequest -> Cmd' env err AuthResponse
@@ -88,7 +88,7 @@ auth (AuthRequest u p) = do
   case checkAuthRequest' of
     InvalidUser     -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
     InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
-    Valid to trId   -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
+    Valid to trId uId   -> pure $ AuthResponse (Just $ AuthValid to trId uId) Nothing
 
 --type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
 

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

@@ -23,7 +23,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
 import Gargantext.Core.Types.Individu (Username, GargPassword(..), arbitraryUsername, arbitraryPassword)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
-import Gargantext.Database.Admin.Types.Node (NodeId(..), ListId, DocId)
+import Gargantext.Database.Admin.Types.Node (NodeId(..), ListId, DocId, UserId)
 import Gargantext.Prelude hiding (reverse)
 
 ---------------------------------------------------
@@ -45,13 +45,14 @@ data AuthInvalid = AuthInvalid { _authInv_message :: Text }
 
 data AuthValid = AuthValid { _authVal_token   :: Token
                            , _authVal_tree_id :: TreeId
+                           , _authVal_user_id :: UserId
                            }
   deriving (Generic)
 
 type Token  = Text
 type TreeId = NodeId
 
-data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
+data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId UserId
   deriving (Eq)
 
 newtype AuthenticatedUser = AuthenticatedUser
@@ -99,9 +100,10 @@ $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
 instance ToSchema AuthValid where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authVal_")
 instance Arbitrary AuthValid where
-  arbitrary = elements [ AuthValid to tr
+  arbitrary = elements [ AuthValid to tr u
                        | to <- ["token0", "token1"]
                        , tr <- [1..3]
+                       , u <-  [1..3]
                        ]
 
 data PathId = PathNode NodeId | PathNodeNode ListId DocId
\ No newline at end of file

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

@@ -36,6 +36,7 @@ instance Arbitrary a => Arbitrary (JobOutput a) where
 -- TODO IsidoreAuth
 data ExternalAPIs = All
                   | PubMed
+                  | Arxiv
                   | HAL
                   | IsTex
                   | Isidore

src/Gargantext/API/Admin/Settings.hs

@@ -106,7 +106,7 @@ repoSnapshot repoDir = repoDir <> "/repo.cbor"
 repoSaverAction :: RepoDirFilePath -> Serialise a => a -> IO ()
 repoSaverAction repoDir a = do
   withTempFile repoDir "tmp-repo.cbor" $ \fp h -> do
-    printDebug "repoSaverAction" fp
+    -- printDebug "repoSaverAction" fp
     L.hPut h $ serialise a
     hClose h
     renameFile fp (repoSnapshot repoDir)

src/Gargantext/API/Context.hs

+{-|
+Module      : Gargantext.API.Context
+Description : Server API
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE TypeOperators        #-}
+
+module Gargantext.API.Context
+  where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Servant
+
+import Gargantext.API.Admin.Auth (withAccess)
+import Gargantext.API.Admin.Auth.Types (PathId(..))
+import Gargantext.API.Prelude
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Prelude -- (Cmd, CmdM)
+import Gargantext.Database.Query.Table.Context
+
+-------------------------------------------------------------------
+-- TODO use Context instead of Node
+type ContextAPI a = Get '[JSON] (Node a)
+
+------------------------------------------------------------------------
+-- TODO NodeAPI -> ContextAPI
+contextAPI :: forall proxy a.
+       ( JSONB a
+       , FromJSON a
+       , ToJSON a
+       ) => proxy a
+         -> UserId
+         -> ContextId
+         -> GargServer (ContextAPI a)
+contextAPI p uId id' = withAccess (Proxy :: Proxy (ContextAPI a)) Proxy uId (PathNode id') contextAPI'
+  where
+    contextAPI' :: GargServer (ContextAPI a)
+    contextAPI' = getContextWith   id' p

src/Gargantext/API/GraphQL.hs

@@ -29,20 +29,23 @@ import Data.Morpheus.Types
   , RootResolver(..)
   , Undefined(..)
   )
+import Data.Proxy
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog)
 import Gargantext.API.Prelude (HasJobEnv')
 import qualified Gargantext.API.GraphQL.AsyncTask as GQLAT
+import qualified Gargantext.API.GraphQL.IMT as GQLIMT
 import qualified Gargantext.API.GraphQL.Node as GQLNode
 import qualified Gargantext.API.GraphQL.User as GQLUser
 import qualified Gargantext.API.GraphQL.UserInfo as GQLUserInfo
+import qualified Gargantext.API.GraphQL.TreeFirstLevel as GQLTree
 import Gargantext.API.Prelude (GargM, GargError)
 import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
 import Gargantext.Prelude
 import GHC.Generics (Generic)
 import Network.HTTP.Media ((//), (/:))
-import qualified Prelude as Prelude
+import qualified Prelude
 import Servant
   ( (:<|>) (..)
   , (:>)
@@ -56,15 +59,18 @@ import Servant
   )
 import qualified Servant.Auth as SA
 import qualified Servant.Auth.Server as SAS
+import Gargantext.API.Admin.Types (HasSettings)
 
 -- | Represents possible GraphQL queries.
 data Query m
   = Query
-    { job_logs    :: GQLAT.JobLogArgs -> m (Map Int JobLog)
+    { imt_schools :: GQLIMT.SchoolsArgs -> m [GQLIMT.School]
+    , job_logs    :: GQLAT.JobLogArgs -> m (Map Int JobLog)
     , nodes       :: GQLNode.NodeArgs -> m [GQLNode.Node]
     , node_parent :: GQLNode.NodeParentArgs -> m [GQLNode.Node]
     , user_infos  :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo]
     , users       :: GQLUser.UserArgs -> m [GQLUser.User m]
+    , tree        :: GQLTree.TreeArgs -> m GQLTree.TreeFirstLevel 
     } deriving (Generic, GQLType)
 
 data Mutation m
@@ -90,21 +96,23 @@ data Contet m
 -- | The main GraphQL resolver: how queries, mutations and
 -- subscriptions are handled.
 rootResolver
-  :: (HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env)
+  :: (HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
   => RootResolver (GargM env GargError) e Query Mutation Undefined
 rootResolver =
   RootResolver
-    { queryResolver = Query { job_logs    = GQLAT.resolveJobLogs
+    { queryResolver = Query { imt_schools = GQLIMT.resolveSchools
+                            , job_logs    = GQLAT.resolveJobLogs
                             , nodes       = GQLNode.resolveNodes
                             , node_parent = GQLNode.resolveNodeParent
                             , user_infos  = GQLUserInfo.resolveUserInfos
-                            , users       = GQLUser.resolveUsers }
+                            , users       = GQLUser.resolveUsers
+                            , tree        = GQLTree.resolveTree }
     , mutationResolver = Mutation { update_user_info = GQLUserInfo.updateUserInfo }
     , subscriptionResolver = Undefined }
 
 -- | Main GraphQL "app".
 app
-  :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env)
+  :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
   => App (EVENT (GargM env GargError)) (GargM env GargError)
 app = deriveApp rootResolver
 
@@ -130,6 +138,9 @@ type Playground = Get '[HTML] ByteString
 type API = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser
             :> "gql" :> (GQAPI :<|> Playground)
 
+gqapi :: Proxy API
+gqapi = Proxy
+
 -- serveEndpoint ::
 --   ( SubApp ServerApp e
 --   , PubApp e
@@ -145,8 +156,7 @@ type API = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser
 -- | Implementation of our API.
 --api :: Server API
 api
-  :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env)
+  :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail 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)
-api _ = httpPubApp [] app :<|> pure httpPlayground
+api _                          = panic "401 in graphql" -- SAS.throwAll (_ServerError # err401)

src/Gargantext/API/GraphQL/AsyncTask.hs

-{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 
@@ -9,24 +8,18 @@ import Control.Concurrent.MVar (readMVar)
 import Control.Lens
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Control.Monad.Base (liftBase)
 import Control.Monad.Reader (ask, liftIO)
 import Data.Either (Either(..))
 import qualified Data.IntMap.Strict as IntMap
-import Data.Maybe (Maybe(..), catMaybes)
+import Data.Maybe (catMaybes)
 import Data.Morpheus.Types
   ( GQLType
   , Resolver
-  , ResolverM
   , QUERY
   , lift
   )
-import Data.Text (Text)
-import qualified Data.Text as T
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
 import Gargantext.API.Prelude (GargM, GargError, HasJobEnv')
-import Gargantext.Core.Mail.Types (HasMail)
-import Gargantext.Database.Admin.Types.Node (NodeId(..))
 import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
 import Gargantext.Prelude
 import GHC.Generics (Generic)

src/Gargantext/API/GraphQL/IMT.hs

+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Gargantext.API.GraphQL.IMT
+  ( School(..)
+  , SchoolsArgs(..)
+  , resolveSchools
+  )
+  where
+
+import Data.Morpheus.Types
+  ( GQLType
+  , Resolver
+  , QUERY
+  )
+import Gargantext.API.Prelude (GargM, GargError)
+import Gargantext.Core.Ext.IMT (School(..), schools)
+import Gargantext.Prelude
+import GHC.Generics (Generic)
+
+data SchoolsArgs
+  = SchoolsArgs
+    { } deriving (Generic, GQLType)
+
+type GqlM e env = Resolver QUERY e (GargM env GargError)
+
+resolveSchools
+  :: SchoolsArgs -> GqlM e env [School]
+resolveSchools SchoolsArgs { } = pure $ schools

src/Gargantext/API/GraphQL/Node.hs

-
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 
@@ -22,7 +21,7 @@ import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
 import qualified Gargantext.Database.Schema.Node as N
 import Gargantext.Prelude
 import GHC.Generics (Generic)
-import qualified Prelude as Prelude
+import qualified Prelude
 import Text.Read (readEither)
 
 data Node = Node

src/Gargantext/API/GraphQL/TreeFirstLevel.hs

+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+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 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 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 )
+
+data TreeArgs = TreeArgs
+  {
+    root_id :: Int
+  } deriving (Generic, GQLType)
+
+data TreeNode = TreeNode
+  {
+    name      :: Text
+  , id        :: Int
+  , node_type :: NodeType
+  } deriving (Generic, GQLType)
+
+data TreeFirstLevel  = TreeFirstLevel
+  {
+    root     :: TreeNode
+  , parent   :: Maybe TreeNode
+  , children :: [TreeNode]
+  } deriving (Generic, GQLType)
+
+type GqlM e env = Resolver QUERY e (GargM env GargError)
+
+resolveTree :: (HasConnectionPool env, HasConfig env, HasMail env) => TreeArgs -> GqlM e env TreeFirstLevel
+resolveTree TreeArgs { root_id } = dbTree root_id
+
+dbTree :: (HasConnectionPool env, HasConfig env, HasMail env) => Int -> GqlM e env TreeFirstLevel
+dbTree root_id = do
+  t <- lift $ T.tree T.TreeFirstLevel (NodeId root_id) allNodeTypes
+  pure $ toTree t
+
+toTree :: Tree NodeTree -> TreeFirstLevel
+toTree TreeN {_tn_node, _tn_children} = TreeFirstLevel
+  { parent   = Nothing -- TODO
+  , root     = toTreeNode _tn_node
+  , children = map childrenToTreeNodes _tn_children
+  }
+
+toTreeNode :: NodeTree -> TreeNode
+toTreeNode NodeTree {_nt_name, _nt_id, _nt_type} = TreeNode { name = _nt_name, id = id2int _nt_id, node_type = _nt_type}
+  where
+    id2int :: NodeId -> Int
+    id2int (NodeId n) = n
+
+childrenToTreeNodes :: Tree NodeTree -> TreeNode
+childrenToTreeNodes TreeN {_tn_node} = toTreeNode _tn_node

src/Gargantext/API/GraphQL/UserInfo.hs

@@ -4,6 +4,7 @@
 module Gargantext.API.GraphQL.UserInfo where
 
 import Control.Lens
+import Data.Maybe (fromMaybe)
 import Data.Morpheus.Types
   ( GQLType
   , Resolver
@@ -37,13 +38,16 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
   , ct_phone
   , hc_who
   , hc_where)
-import Gargantext.Database.Admin.Types.Node (NodeId(..))
 import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
-import Gargantext.Database.Query.Table.User (getUsersWithHyperdata)
+import Gargantext.Database.Query.Table.User (getUsersWithHyperdata, getUsersWithNodeHyperdata, updateUserEmail)
 import Gargantext.Database.Schema.User (UserLight(..))
+import Gargantext.Database.Schema.Node (node_id, node_hyperdata, NodePoly (Node, _node_id))
 import Gargantext.Prelude
 import GHC.Generics (Generic)
+import Gargantext.API.GraphQL.Utils (AuthStatus(Invalid, Valid), authUser)
+import Gargantext.API.Admin.Types (HasSettings)
+import Gargantext.Database.Admin.Types.Node (unNodeId)
 
 data UserInfo = UserInfo
   { ui_id             :: Int
@@ -60,7 +64,8 @@ data UserInfo = UserInfo
   , ui_cwOffice       :: Maybe Text
   , ui_cwRole         :: Maybe Text
   , ui_cwTouchPhone   :: Maybe Text
-  , ui_cwTouchMail    :: Maybe Text }
+  , ui_cwTouchMail    :: Maybe Text  -- TODO: Remove. userLight_email should be used instead
+  }
   deriving (Generic, GQLType, Show)
 
 -- | Arguments to the "user info" query.
@@ -72,7 +77,8 @@ data UserInfoArgs
 -- | Arguments to the "user info" mutation,
 data UserInfoMArgs
   = UserInfoMArgs
-    { ui_id :: Int
+    { ui_id             :: Int
+    , token             :: Text
     , ui_username       :: Maybe Text
     , ui_email          :: Maybe Text
     , ui_title          :: Maybe Text
@@ -90,6 +96,7 @@ data UserInfoMArgs
     } deriving (Generic, GQLType)
 
 type GqlM e env = Resolver QUERY e (GargM env GargError)
+type GqlM' e env err = ResolverM e (GargM env err) Int
 
 -- | Function to resolve user from a query.
 resolveUserInfos
@@ -99,43 +106,60 @@ resolveUserInfos UserInfoArgs { user_id } = dbUsers user_id
 
 -- | Mutation for user info
 updateUserInfo
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
-  => UserInfoMArgs -> ResolverM e (GargM env GargError) Int
+  :: (HasConnectionPool env, HasConfig env, HasMail 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 (getUsersWithHyperdata ui_id)
+  -- lift $ printDebug "[updateUserInfo] ui_id" ui_id
+  users <- lift (getUsersWithNodeHyperdata ui_id)
   case users of
     [] -> panic $ "[updateUserInfo] User with id " <> (T.pack $ show ui_id) <> " doesn't exist."
-    ((u, u_hyperdata):_) -> do
-      lift $ printDebug "[updateUserInfo] u" u
-      let u_hyperdata' = uh ui_titleL ui_title $
-                         uh ui_sourceL ui_source $
-                         uh ui_cwFirstNameL ui_cwFirstName $
-                         uh ui_cwLastNameL ui_cwLastName $
-                         uh ui_cwCityL ui_cwCity $
-                         uh ui_cwCountryL ui_cwCountry $
-                         uh' ui_cwLabTeamDeptsL ui_cwLabTeamDepts $
-                         uh' ui_cwOrganizationL ui_cwOrganization $
-                         uh ui_cwOfficeL ui_cwOffice $
-                         uh ui_cwRoleL ui_cwRole $
-                         uh ui_cwTouchMailL ui_cwTouchMail $
-                         uh ui_cwTouchPhoneL ui_cwTouchPhone $
-                         u_hyperdata
-      lift $ printDebug "[updateUserInfo] with firstName" u_hyperdata'
-      _ <- lift $ updateHyperdata (NodeId ui_id) u_hyperdata'
-      --let _newUser = toUser (u, u_hyperdata')
-      pure 1
+    ((UserLight { .. }, node_u):_) -> do
+      testAuthUser <- lift $ authUser (nId node_u) token
+      case testAuthUser of
+        Invalid -> panic "[updateUserInfo] failed to validate user"
+        Valid -> do
+          let u_hyperdata = node_u ^. node_hyperdata
+          -- lift $ printDebug "[updateUserInfo] u" u
+          let u_hyperdata' = uh ui_titleL ui_title $
+                            uh ui_sourceL ui_source $
+                            uh ui_cwFirstNameL ui_cwFirstName $
+                            uh ui_cwLastNameL ui_cwLastName $
+                            uh ui_cwCityL ui_cwCity $
+                            uh ui_cwCountryL ui_cwCountry $
+                            uh' ui_cwLabTeamDeptsL ui_cwLabTeamDepts $
+                            uh' ui_cwOrganizationL ui_cwOrganization $
+                            uh ui_cwOfficeL ui_cwOffice $
+                            uh ui_cwRoleL ui_cwRole $
+                            uh ui_cwTouchMailL ui_cwTouchMail $
+                            uh ui_cwTouchPhoneL ui_cwTouchPhone $
+                            u_hyperdata
+          -- NOTE: We have 1 username and 2 emails: userLight_email and ui_cwTouchMail
+          -- The userLight_email is more important: it is used for login and sending mail.
+          -- Therefore we update ui_cwTouchMail and userLight_email.
+          -- ui_cwTouchMail is to be removed in the future.
+          let u' = UserLight { userLight_id
+                            , userLight_username
+                            , userLight_email = fromMaybe userLight_email $ view ui_cwTouchMailL u_hyperdata
+                            , userLight_password }
+          -- lift $ printDebug "[updateUserInfo] with firstName" u_hyperdata'
+          _ <- lift $ updateHyperdata (node_u ^. node_id) u_hyperdata'
+          _ <- lift $ updateUserEmail u'
+          --let _newUser = toUser (u, u_hyperdata')
+          pure 1
   where
     uh _ Nothing u_hyperdata = u_hyperdata
     uh lens' (Just val) u_hyperdata = u_hyperdata & lens' .~ Just val
     uh' _ Nothing u_hyperdata = u_hyperdata
     uh' lens' (Just val) u_hyperdata = u_hyperdata & lens' .~ val
+    nId Node {_node_id} = unNodeId _node_id
 
 -- | Inner function to fetch the user from DB.
 dbUsers
   :: (HasConnectionPool env, HasConfig env, HasMail 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)
@@ -156,7 +180,8 @@ toUser (UserLight { .. }, u_hyperdata) =
            , ui_cwOrganization = u_hyperdata ^. ui_cwOrganizationL
            , ui_cwOffice       = u_hyperdata ^. ui_cwOfficeL
            , ui_cwRole         = u_hyperdata ^. ui_cwRoleL
-           , ui_cwTouchMail    = u_hyperdata ^. ui_cwTouchMailL
+           --, ui_cwTouchMail    = u_hyperdata ^. ui_cwTouchMailL
+           , ui_cwTouchMail    = Just userLight_email
            , ui_cwTouchPhone   = u_hyperdata ^. ui_cwTouchPhoneL }
 
 sharedL :: Traversal' HyperdataUser HyperdataContact

src/Gargantext/API/GraphQL/Utils.hs

+{-|
+Module      : Gargantext.API.GraphQL.Utils
+Description : Utils for GraphQL API
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
 module Gargantext.API.GraphQL.Utils where
 
 import Data.Morpheus.Types (GQLTypeOptions, fieldLabelModifier)
 import qualified Data.Text as T
 import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
 import Gargantext.Prelude
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import Gargantext.API.Admin.Types (jwtSettings, HasSettings (settings))
+import Servant.Auth.Server (verifyJWT, JWTSettings)
+import Control.Lens.Getter (view)
+import Gargantext.Database.Prelude (Cmd')
+import Gargantext.API.Admin.Auth.Types (AuthenticatedUser (AuthenticatedUser, _authUser_id))
+import Data.ByteString (ByteString)
+import Gargantext.Database.Admin.Types.Node (unNodeId)
 
 unPrefix :: T.Text -> GQLTypeOptions -> GQLTypeOptions
 unPrefix prefix options = options { fieldLabelModifier = nflm }
   where
     nflm label = unCapitalize $ dropPrefix (T.unpack prefix) $ ( fieldLabelModifier options ) label
+
+data AuthStatus = Valid | Invalid
+
+authUser :: (HasSettings env) => Int -> Text -> Cmd' env err AuthStatus
+authUser ui_id token = do
+  let token' = encodeUtf8 token
+  jwtS <- view $ settings . jwtSettings
+  u <- liftBase $ getUserFromToken jwtS token'
+  case u of
+    Nothing -> pure Invalid
+    Just au -> 
+      if nId au == ui_id
+        then pure Valid
+        else pure Invalid
+        where
+          nId AuthenticatedUser {_authUser_id} = unNodeId _authUser_id
+
+getUserFromToken :: JWTSettings -> ByteString -> IO (Maybe AuthenticatedUser)
+getUserFromToken = verifyJWT

src/Gargantext/API/Ngrams.hs

@@ -103,7 +103,7 @@ import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, TODO, assertValid, HasInvalidError)
 import Gargantext.API.Ngrams.Tools
 import Gargantext.Database.Action.Flow.Types
-import Gargantext.Database.Action.Metrics.NgramsByNode (getOccByNgramsOnlyFast')
+import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast')
 import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Admin.Types.Node (NodeType(..))
 import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
@@ -245,7 +245,7 @@ setListNgrams ::  HasNodeStory env err m
               -> Map NgramsTerm NgramsRepoElement
               -> m ()
 setListNgrams listId ngramsType ns = do
-  printDebug "[setListNgrams]" (listId, ngramsType)
+  -- printDebug "[setListNgrams]" (listId, ngramsType)
   getter <- view hasNodeStory
   var <- liftBase $ (getter ^. nse_getter) [listId]
   liftBase $ modifyMVar_ var $
@@ -283,7 +283,7 @@ commitStatePatch :: (HasNodeStory env err m, HasMail env)
                  ->    Versioned NgramsStatePatch'
                  -> m (Versioned NgramsStatePatch')
 commitStatePatch listId (Versioned p_version p) = do
-  printDebug "[commitStatePatch]" listId
+  -- printDebug "[commitStatePatch]" listId
   var <- getNodeStoryVar [listId]
   vq' <- liftBase $ modifyMVar var $ \ns -> do
     let
@@ -343,10 +343,10 @@ tableNgramsPull listId ngramsType p_version = do
 -- Apply the given patch to the DB and returns the patch to be applied on the
 -- client.
 -- TODO-ACCESS check
-tableNgramsPut :: ( HasNodeStory env err m
-                  , HasInvalidError err
-                  , HasSettings env
-                  , HasMail env
+tableNgramsPut :: ( HasNodeStory    env err m
+                  , HasInvalidError     err
+                  , HasSettings     env
+                  , HasMail         env
                   )
                  => TabType
                  -> ListId
@@ -495,7 +495,7 @@ type MaxSize = Int
 getTableNgrams :: forall env err m.
                   (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
                => NodeType -> NodeId -> TabType
-               -> ListId -> Limit -> Maybe Offset
+               -> ListId   -> Limit  -> Maybe Offset
                -> Maybe ListType
                -> Maybe MinSize -> Maybe MaxSize
                -> Maybe OrderBy
@@ -523,14 +523,13 @@ getTableNgrams _nType nId tabType listId limit_ offset
     selected_inner roots n = maybe False (`Set.member` roots) (n ^. ne_root)
 
     ---------------------------------------
-    sortOnOrder Nothing = identity
+    sortOnOrder Nothing          = sortOnOrder (Just ScoreDesc)
     sortOnOrder (Just TermAsc)   = List.sortOn $ view ne_ngrams
     sortOnOrder (Just TermDesc)  = List.sortOn $ Down . view ne_ngrams
     sortOnOrder (Just ScoreAsc)  = List.sortOn $ view ne_occurrences
     sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view ne_occurrences
 
     ---------------------------------------
-
     filteredNodes :: Map NgramsTerm NgramsElement -> [NgramsElement]
     filteredNodes tableMap = rootOf <$> list & filter selected_node
       where
@@ -562,21 +561,17 @@ getTableNgrams _nType nId tabType listId limit_ offset
     setScores False table = pure table
     setScores True  table = do
       let ngrams_terms = table ^.. each . ne_ngrams
+      -- printDebug "ngrams_terms" ngrams_terms
       t1 <- getTime
       occurrences <- getOccByNgramsOnlyFast' nId
                                              listId
                                             ngramsType
                                             ngrams_terms
+      --printDebug "occurrences" occurrences
       t2 <- getTime
       liftBase $ hprint stderr
         ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n")
         (length ngrams_terms) t1 t2
-      {-
-      occurrences <- getOccByNgramsOnlySlow nType nId
-                                            (lIds <> [listId])
-                                            ngramsType
-                                            ngrams_terms
-      -}
       let
         setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
 
@@ -591,11 +586,13 @@ getTableNgrams _nType nId tabType listId limit_ offset
   let scoresNeeded = needsScores orderBy
   tableMap1 <- getNgramsTableMap listId ngramsType
   t1 <- getTime
+
   tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
                                     . Map.mapWithKey ngramsElementFromRepo
 
   fltr <- tableMap2 & v_data %%~ fmap NgramsTable . setScores (not scoresNeeded)
                                                   . filteredNodes
+
   let fltrCount = length $ fltr ^. v_data . _NgramsTable
 
   t2 <- getTime

src/Gargantext/API/Ngrams/List.hs

@@ -19,16 +19,17 @@ import Control.Lens hiding (elements, Indexed)
 import Data.Aeson
 import Data.Either (Either(..))
 import Data.HashMap.Strict (HashMap)
-import Data.Map (Map, toList, fromList)
-import Data.Maybe (catMaybes)
+import Data.Map (Map, toList)
+import Data.Maybe (catMaybes, fromMaybe)
 import Data.Set (Set)
-import Data.Text (Text, concat, pack)
+import Data.Text (Text, concat, pack, splitOn)
 import Data.Vector (Vector)
 import Gargantext.API.Admin.Orchestrator.Types
-import Gargantext.API.Ngrams (getNgramsTableMap, setListNgrams)
+import Gargantext.API.Ngrams (setListNgrams)
+import Gargantext.API.Ngrams.List.Types
+import Gargantext.API.Ngrams.Prelude (getNgramsList)
 import Gargantext.API.Ngrams.Tools (getTermsWith)
 import Gargantext.API.Ngrams.Types
-import Gargantext.API.Ngrams.List.Types
 import Gargantext.API.Prelude (GargServer)
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Text.Terms (ExtractedNgrams(..))
@@ -36,12 +37,13 @@ import Gargantext.Core.Text.Terms.WithList (buildPatterns, termsInText)
 import Gargantext.Core.Types.Main (ListType(..))
 import Gargantext.Database.Action.Flow (saveDocNgramsWith)
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
-import Gargantext.Database.Action.Metrics.NgramsByNode (getOccByNgramsOnlyFast')
 import Gargantext.Database.Admin.Types.Hyperdata.Document
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Query.Table.NodeNode (selectDocNodes)
+import Gargantext.Database.Query.Table.Node (getNode)
+import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
+import Gargantext.Database.Schema.Context
 import Gargantext.Database.Schema.Ngrams
-import Gargantext.Database.Schema.Node
+import Gargantext.Database.Schema.Node (_node_parent_id)
 import Gargantext.Database.Types (Indexed(..))
 import Gargantext.Prelude
 import Network.HTTP.Media ((//), (/:))
@@ -52,22 +54,12 @@ import qualified Data.Csv as Csv
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.List           as List
 import qualified Data.Map            as Map
+import qualified Data.Set            as Set
 import qualified Data.Text           as Text
 import qualified Data.Vector         as Vec
-import qualified Prelude             as Prelude
+import qualified Prelude
 import qualified Protolude           as P
 ------------------------------------------------------------------------
--- | TODO refactor 
-{-
-type API =  Get '[JSON, HTML] (Headers '[Header "Content-Disposition" Text] NgramsList)
-       -- :<|> ReqBody '[JSON] NgramsList :> Post '[JSON] Bool
-       :<|> PostAPI
-       :<|> CSVPostAPI
-api :: ListId -> GargServer API
-api l = get l :<|> postAsync l :<|> csvPostAsync l
--}
-
-----------------------
 type GETAPI = Summary "Get List"
             :> "lists"
               :> Capture "listId" ListId
@@ -110,7 +102,7 @@ csvApi = csvPostAsync
 get :: HasNodeStory env err m =>
        ListId -> m (Headers '[Header "Content-Disposition" Text] NgramsList)
 get lId = do
-  lst <- get' lId
+  lst <- getNgramsList lId
   let (NodeId id') = lId
   return $ addHeader (concat [ "attachment; filename=GarganText_NgramsList-"
                              , pack $ show id'
@@ -118,20 +110,14 @@ get lId = do
                              ]
                      ) lst
 
-get' :: HasNodeStory env err m
-    => ListId -> m NgramsList
-get' lId = fromList
-       <$> zip ngramsTypes
-       <$> mapM (getNgramsTableMap lId) ngramsTypes
-
 ------------------------------------------------------------------------
 -- TODO : purge list
 -- TODO talk
-post :: FlowCmdM env err m
+setList :: FlowCmdM env err m
     => ListId
     -> NgramsList
     -> m Bool
-post l m  = do
+setList l m  = do
   -- TODO check with Version for optim
   printDebug "New list as file" l
   _ <- mapM (\(nt, Versioned _v ns) -> setListNgrams l nt ns) $ toList m
@@ -154,20 +140,20 @@ reIndexWith cId lId nt lts = do
      <$> map (\(k,vs) -> k:vs)
      <$> HashMap.toList
      <$> getTermsWith identity [lId] nt lts
-  
+
   -- printDebug "ts" ts
 
   -- Taking the ngrams with 0 occurrences only (orphans)
-  occs <- getOccByNgramsOnlyFast' cId lId nt ts
+  -- occs <- getOccByNgramsOnlyFast' cId lId nt ts
 
   -- printDebug "occs" occs
 
-  let orphans = List.concat 
+  let orphans = ts {- List.concat
               $ map (\t -> case HashMap.lookup t occs of
                        Nothing -> [t]
                        Just n  -> if n <= 1 then [t] else [ ]
                        ) ts
-
+        -}
   -- printDebug "orphans" orphans
 
   -- Get all documents of the corpus
@@ -179,14 +165,14 @@ reIndexWith cId lId nt lts = do
   let
     ngramsByDoc = map (HashMap.fromList)
                 $ map (map (\(k,v) -> (SimpleNgrams (text2ngrams k), v)))
-                $  map (\doc -> List.zip
+                $ map (\doc -> List.zip
                                 (termsInText (buildPatterns $ map (\k -> (Text.splitOn " " $ unNgramsTerm k, [])) orphans)
                                              $ Text.unlines $ catMaybes
-                                               [ doc ^. node_hyperdata . hd_title
-                                               , doc ^. node_hyperdata . hd_abstract
+                                               [ doc ^. context_hyperdata . hd_title
+                                               , doc ^. context_hyperdata . hd_abstract
                                                ]
                                  )
-                                (List.cycle [Map.fromList $ [(nt, Map.singleton (doc ^. node_id) 1 )]])
+                                (List.cycle [Map.fromList $ [(nt, Map.singleton (doc ^. context_id) 1 )]])
                         ) docs
 
   -- printDebug "ngramsByDoc" ngramsByDoc
@@ -215,7 +201,7 @@ postAsync lId =
     JobFunction (\f log' ->
       let
         log'' x = do
-          printDebug "postAsync ListId" x
+          -- printDebug "postAsync ListId" x
           liftBase $ log' x
       in postAsync' lId f log'')
 
@@ -228,20 +214,32 @@ postAsync' l (WithFile _ m _) logStatus = do
 
   logStatus JobLog { _scst_succeeded = Just 0
                    , _scst_failed    = Just 0
-                   , _scst_remaining = Just 1
+                   , _scst_remaining = Just 2
                    , _scst_events    = Just []
                    }
   printDebug "New list as file" l
-  _ <- post l m
+  _ <- setList l m
   -- printDebug "Done" r
 
-  pure JobLog { _scst_succeeded = Just 1
+  logStatus JobLog { _scst_succeeded = Just 1
+              , _scst_failed    = Just 0
+              , _scst_remaining = Just 1
+              , _scst_events    = Just []
+              }
+
+
+  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 []
               }
-------------------------------------------------------------------------
 
+
+------------------------------------------------------------------------
 type CSVPostAPI = Summary "Update List (legacy v3 CSV)"
         :> "csv"
         :> "add"
@@ -262,12 +260,22 @@ readCsvText t = case eDec of
 parseCsvData :: [(Text, Text, Text)] -> Map NgramsTerm NgramsRepoElement
 parseCsvData lst = Map.fromList $ conv <$> lst
   where
-    conv (_status, label, _forms) =
+    conv (status, label, forms) =
         (NgramsTerm label, NgramsRepoElement { _nre_size = 1
-                                             , _nre_list = CandidateTerm
+                                             , _nre_list = case status == "map" of
+                                                             True  -> MapTerm
+                                                             False -> case status == "main" of
+                                                                True  -> CandidateTerm
+                                                                False -> StopTerm
                                              , _nre_root = Nothing
                                              , _nre_parent = Nothing
-                                             , _nre_children = MSet Map.empty })
+                                             , _nre_children = MSet
+                                                             $ Map.fromList
+                                                             $ map (\form -> (NgramsTerm form, ()))
+                                                             $ filter (/= "")
+                                                             $ splitOn "|&|" forms
+                                             }
+         )
 
 csvPost :: FlowCmdM env err m
         => ListId
@@ -282,11 +290,14 @@ csvPost l m  = do
   --printDebug "[csvPost] lst" lst
   printDebug "[csvPost] p" p
   _ <- setListNgrams l NgramsTerms p
-  pure True
-------------------------------------------------------------------------
-
+  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
 
+------------------------------------------------------------------------
 csvPostAsync :: GargServer CSVAPI
 csvPostAsync lId =
   serveJobsAPI $

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

@@ -14,7 +14,7 @@ import Web.FormUrlEncoded (FromForm, ToForm)
 import Protolude
 
 import Gargantext.API.Ngrams.Types (NgramsList)
-import Gargantext.API.Node.Corpus.New.File (FileType(..))
+import Gargantext.API.Node.Corpus.New.Types (FileType(..))
 import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
 
 ------------------------------------------------------------------------

src/Gargantext/API/Ngrams/Prelude.hs

@@ -16,19 +16,38 @@ module Gargantext.API.Ngrams.Prelude
 
 import Data.Maybe (catMaybes)
 import Control.Lens (view)
+import Data.Map (fromList)
 import Data.Hashable (Hashable)
 import Data.Validity
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types (ListType)
-import Gargantext.Database.Schema.Ngrams (NgramsType)
+import Gargantext.Database.Schema.Ngrams (NgramsType, ngramsTypes)
 import Gargantext.Prelude
 import Gargantext.Core.Text.List.Social.Prelude
+import Gargantext.API.Ngrams (getNgramsTableMap)
 import Gargantext.Core.Text.Context (TermList)
+import Gargantext.Core.NodeStory (HasNodeStory)
+import Gargantext.Database.Admin.Types.Node (ListId)
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Map.Strict as Map
 import qualified Data.List as List
 import qualified Data.Text as Text
 
+
+------------------------------------------------------------------------
+getNgramsList :: HasNodeStory env err m
+    => ListId -> m NgramsList
+getNgramsList lId = fromList
+       <$> zip ngramsTypes
+       <$> mapM (getNgramsTableMap lId) ngramsTypes
+
+getTermList :: HasNodeStory env err m
+            => ListId -> ListType -> NgramsType -> m (Maybe TermList)
+getTermList lId listType ngramsType = do
+  ngramsList <- getNgramsList lId
+  pure $ toTermList listType ngramsType ngramsList
+
+
 ------------------------------------------------------------------------
 -- | Tools
 -- Usage example: toTermList MapTerm NgramsTerms ngramsList

src/Gargantext/API/Ngrams/Tools.hs

@@ -135,16 +135,16 @@ filterListWithRootHashMap lt m = snd <$> HM.filter isMapTerm m
         Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
         Just  (l',_) -> l' == lt
 
-filterListWithRoot :: ListType
+filterListWithRoot :: [ListType]
                    -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
                    -> HashMap NgramsTerm (Maybe RootTerm)
 filterListWithRoot lt m = snd <$> HM.filter isMapTerm m
   where
     isMapTerm (l, maybeRoot) = case maybeRoot of
-      Nothing -> l == lt
+      Nothing -> elem l lt
       Just  r -> case HM.lookup r m of
         Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
-        Just  (l',_) -> l' == lt
+        Just  (l',_) -> elem l' lt
 
 groupNodesByNgrams :: ( At root_map
                       , Index root_map ~ NgramsTerm

src/Gargantext/API/Ngrams/Types.hs

@@ -578,7 +578,7 @@ ngramsElementFromRepo
                 , _ne_parent      = p
                 , _ne_children    = c
                 , _ne_ngrams      = ngrams
-                , _ne_occurrences = panic $ "API.Ngrams.Types._ne_occurrences"
+                , _ne_occurrences = 0 -- panic $ "API.Ngrams.Types._ne_occurrences"
                 {-
                 -- Here we could use 0 if we want to avoid any `panic`.
                 -- It will not happen using getTableNgrams if

src/Gargantext/API/Node.hs

@@ -36,12 +36,8 @@ import Data.Maybe
 import Data.Swagger
 import Data.Text (Text())
 import GHC.Generics (Generic)
-import Servant
-import Test.QuickCheck (elements)
-import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-
-import Gargantext.API.Admin.Auth.Types (PathId(..))
 import Gargantext.API.Admin.Auth (withAccess)
+import Gargantext.API.Admin.Auth.Types (PathId(..))
 import Gargantext.API.Metrics
 import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableCorpus)
 import Gargantext.API.Ngrams.Types (TabType(..))
@@ -53,6 +49,7 @@ import Gargantext.Core.Types (NodeTableResult)
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Types.Main (Tree, NodeTree)
 import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Viz.Phylo.API (PhyloAPI, phyloAPI)
 import Gargantext.Database.Action.Flow.Pairing (pairing)
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Node
@@ -63,12 +60,15 @@ import Gargantext.Database.Query.Table.Node.Children (getChildren)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 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.Prelude
-import Gargantext.Core.Viz.Phylo.Legacy.LegacyAPI (PhyloAPI, phyloAPI)
-import qualified Gargantext.API.Node.DocumentsFromWriteNodes as DocumentsFromWriteNodes
+import Servant
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 import qualified Gargantext.API.Node.DocumentUpload as DocumentUpload
+import qualified Gargantext.API.Node.DocumentsFromWriteNodes as DocumentsFromWriteNodes
 import qualified Gargantext.API.Node.FrameCalcUpload as FrameCalcUpload
 import qualified Gargantext.API.Node.Share  as Share
 import qualified Gargantext.API.Node.Update as Update
@@ -76,10 +76,6 @@ import qualified Gargantext.API.Search as Search
 import qualified Gargantext.Database.Action.Delete as Action (deleteNode)
 import qualified Gargantext.Database.Query.Table.Node.Update as U (update, Update(..))
 
-{-
-import qualified Gargantext.Core.Text.List.Learn as Learn
-import qualified Data.Vector as Vec
---}
 
 -- | Admin NodesAPI
 -- TODO
@@ -212,7 +208,7 @@ nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode
            :<|> postNodeAsyncAPI  uId id'
            :<|> FrameCalcUpload.api uId id'
            :<|> putNode       id'
-           :<|> Update.api  uId id'
+           :<|> Update.api uId id'
            :<|> Action.deleteNode (RootId $ NodeId uId) id'
            :<|> getChildren   id' p
 
@@ -271,7 +267,7 @@ catApi :: CorpusId -> GargServer CatApi
 catApi = putCat
   where
     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
-    putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
+    putCat cId cs' = nodeContextsCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 
 ------------------------------------------------------------------------
 type ScoreApi =  Summary " To Score NodeNodes"
@@ -292,7 +288,7 @@ scoreApi :: CorpusId -> GargServer ScoreApi
 scoreApi = putScore
   where
     putScore :: CorpusId -> NodesToScore -> Cmd err [Int]
-    putScore cId cs' = nodeNodesScore $ map (\n -> (cId, n, nts_score cs')) (nts_nodesId cs')
+    putScore cId cs' = nodeContextsScore $ map (\n -> (cId, n, nts_score cs')) (nts_nodesId cs')
 
 ------------------------------------------------------------------------
 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
@@ -316,7 +312,7 @@ pairs cId = do
 type PairWith = Summary "Pair a Corpus with an Annuaire"
               :> "annuaire" :> Capture "annuaire_id" AnnuaireId
               :> QueryParam "list_id"     ListId
-              :> Post '[JSON] Int
+              :> Post '[JSON] [Int]
 
 pairWith :: CorpusId -> GargServer PairWith
 pairWith cId aId lId = do

src/Gargantext/API/Node/Contact.hs

@@ -22,6 +22,7 @@ Portability : POSIX
 module Gargantext.API.Node.Contact
       where
 
+import Conduit
 import Data.Aeson
 import Data.Either (Either(Right))
 import Data.Maybe (Maybe(..))
@@ -93,7 +94,7 @@ addContact u nId (AddContactParams fn ln) logStatus = do
                    , _scst_remaining = Just 1
                    , _scst_events    = Just []
                    }
-  _ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) Nothing [[hyperdataContact fn ln]] logStatus
+  _ <- 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

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

@@ -25,7 +25,7 @@ import Servant.Job.Types
 import Servant.Job.Utils (jsonOptions)
 import Web.FormUrlEncoded (FromForm)
 
-import qualified Gargantext.API.Node.Corpus.New.File as NewFile
+import qualified Gargantext.API.Node.Corpus.New.Types as NewTypes
 import Gargantext.API.Admin.Orchestrator.Types hiding (AsyncJobs)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
@@ -40,7 +40,7 @@ type Api = Summary "New Annuaire endpoint"
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
 data AnnuaireWithForm = AnnuaireWithForm
-  { _wf_filetype :: !NewFile.FileType
+  { _wf_filetype :: !NewTypes.FileType
   , _wf_data     :: !Text
   , _wf_lang     :: !(Maybe Lang)
   } deriving (Eq, Show, Generic)

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

 {-|
 Module      : Gargantext.API.Node.Corpus.Export
-Description : Get Metrics from Storage (Database like)
+Description : Corpus export
 Copyright   : (c) CNRS, 2017-Present
 License     : AGPL + CECILL v3
 Maintainer  : team@gargantext.org
@@ -19,28 +19,30 @@ module Gargantext.API.Node.Corpus.Export
 import Data.Map (Map)
 import Data.Maybe (fromMaybe)
 import Data.Set (Set)
+import Data.Text (Text)
 import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.HashMap.Strict as HashMap
 
 import Gargantext.API.Node.Corpus.Export.Types
+import qualified Gargantext.API.Node.Document.Export.Types as DocumentExport
 import Gargantext.API.Ngrams.Types
 import Gargantext.API.Ngrams.Tools (filterListWithRoot, mapTermListRoot, getRepo')
 import Gargantext.API.Prelude (GargNoServer)
 import Gargantext.Prelude.Crypto.Hash (hash)
 import Gargantext.Core.Types
 import Gargantext.Core.NodeStory
-import Gargantext.Database.Action.Metrics.NgramsByNode (getNgramsByNodeOnlyUser)
+import Gargantext.Database.Action.Metrics.NgramsByContext (getNgramsByContextOnlyUser)
 import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
 import Gargantext.Database.Prelude (Cmd)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername)
-import Gargantext.Database.Query.Table.NodeNode (selectDocNodes)
+import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
-import Gargantext.Database.Schema.Node (_node_id, _node_hyperdata)
+import Gargantext.Database.Schema.Context (_context_id, _context_hyperdata)
 import Gargantext.Prelude
 
 --------------------------------------------------
@@ -61,39 +63,41 @@ getCorpus cId lId nt' = do
     Just l  -> pure l
   
   ns   <- Map.fromList
-       <$> map (\n -> (_node_id n, n))
+       <$> map (\n -> (_context_id n, n))
        <$> selectDocNodes cId
 
   repo <- getRepo' [listId]
-  ngs  <- getNodeNgrams cId listId nt repo
+  ngs  <- getContextNgrams cId listId MapTerm nt repo
   let  -- uniqId is hash computed already for each document imported in database
     r = Map.intersectionWith
-        (\a b -> Document { _d_document = a
-                          , _d_ngrams = Ngrams (Set.toList b) (hash b)
-                          , _d_hash = d_hash a b }
+        (\a b -> DocumentExport.Document { _d_document = context2node a
+                                         , _d_ngrams = DocumentExport.Ngrams (Set.toList b) (hash b)
+                                         , _d_hash = d_hash a b }
         ) ns (Map.map (Set.map unNgramsTerm) ngs)
           where
-            d_hash  a b = hash [ fromMaybe "" (_hd_uniqId $ _node_hyperdata a)
+            d_hash :: Context HyperdataDocument -> Set Text -> Text
+            d_hash  a b = hash [ fromMaybe "" (_hd_uniqId $ _context_hyperdata a)
                                , hash b
                                ]
   pure $ Corpus { _c_corpus = Map.elems r
-                , _c_hash = hash $ List.map _d_hash $ Map.elems r }
+                , _c_hash = hash $ List.map DocumentExport._d_hash $ Map.elems r }
 
-getNodeNgrams :: HasNodeError err
+getContextNgrams :: HasNodeError err
         => CorpusId
         -> ListId
+        -> ListType
         -> NgramsType
         -> NodeListStory
-        -> Cmd err (Map NodeId (Set NgramsTerm))
-getNodeNgrams cId lId nt repo = do
+        -> Cmd err (Map ContextId (Set NgramsTerm))
+getContextNgrams cId lId listType nt repo = do
 --  lId <- case lId' of
 --    Nothing -> defaultList cId
 --    Just  l -> pure l
 
   lIds <- selectNodesWithUsername NodeList userMaster
-  let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
+  let ngs = filterListWithRoot [listType] $ mapTermListRoot [lId] nt repo
   -- TODO HashMap
-  r <- getNgramsByNodeOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
+  r <- getNgramsByContextOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
   pure r
 
 -- TODO

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

@@ -17,51 +17,26 @@ import Data.Aeson.TH (deriveJSON)
 import Data.Swagger
 import Data.Text (Text)
 import GHC.Generics (Generic)
+import qualified Gargantext.API.Node.Document.Export.Types as DocumentExport
 import Gargantext.Core.Types
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
-import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
 import Servant
 
 
 -- Corpus Export
 data Corpus =
-  Corpus { _c_corpus :: [Document]
+  Corpus { _c_corpus :: [DocumentExport.Document]
          , _c_hash   :: Hash
          } deriving (Generic)
 
--- | Document Export
-data Document =
-  Document { _d_document :: Node HyperdataDocument
-           , _d_ngrams   :: Ngrams
-           , _d_hash     :: Hash
-           } deriving (Generic)
-
-data Ngrams =
-  Ngrams { _ng_ngrams :: [Text]
-         , _ng_hash   :: Hash
-         } deriving (Generic)
-
 type Hash = Text
 -------
 instance ToSchema Corpus where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_c_")
-
-instance ToSchema Document where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_d_")
-
-instance ToSchema Ngrams where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ng_")
-
 -------
 instance ToParamSchema Corpus where
   toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
-
-instance ToParamSchema Document where
-  toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
-
-instance ToParamSchema Ngrams where
-  toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
 --------------------------------------------------
 type API = Summary "Corpus Export"
             :> "export"
@@ -70,5 +45,3 @@ type API = Summary "Corpus Export"
             :> Get '[JSON] Corpus
 
 $(deriveJSON (unPrefix "_c_") ''Corpus)
-$(deriveJSON (unPrefix "_d_") ''Document)
-$(deriveJSON (unPrefix "_ng_") ''Ngrams)
\ No newline at end of file

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

@@ -18,10 +18,12 @@ New corpus means either:
 module Gargantext.API.Node.Corpus.New
       where
 
+import Conduit
 import Control.Lens hiding (elements, Empty)
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import qualified Data.ByteString.Base64 as BSB64
+import Data.Conduit.Internal (zipSources)
 import Data.Either
 import Data.Maybe (fromMaybe)
 import Data.Swagger
@@ -35,19 +37,15 @@ import qualified Data.Text.Encoding as TE
 -- import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary
 
-import Gargantext.Prelude
-
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs, ScraperEvent(..), scst_events)
 import Gargantext.API.Admin.Types (HasSettings)
-import Gargantext.API.Job (jobLogSuccess, jobLogFailTotal, jobLogFailTotalWithMessage)
-import Gargantext.API.Node.Corpus.New.File
+import Gargantext.API.Job (addEvent, jobLogSuccess, jobLogFailTotal)
+import Gargantext.API.Node.Corpus.New.Types
 import Gargantext.API.Node.Corpus.Searx
 import Gargantext.API.Node.Corpus.Types
 import Gargantext.API.Node.Types
 import Gargantext.Core (Lang(..){-, allLangs-})
 import Gargantext.Core.Text.List.Social (FlowSocialListWith(..))
-import qualified Gargantext.Core.Text.Corpus.API as API
-import qualified Gargantext.Core.Text.Corpus.Parsers as Parser (FileFormat(..), parseFormat)
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Action.Flow (flowCorpus, getDataText, flowDataText, TermType(..){-, allDataOrigins-})
@@ -61,8 +59,11 @@ import Gargantext.Database.Prelude (hasConfig)
 import Gargantext.Database.Query.Table.Node (getNodeWith)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Schema.Node (node_hyperdata)
-import qualified Gargantext.Database.GargDB as GargDB
+import Gargantext.Prelude
 import Gargantext.Prelude.Config (gc_max_docs_parsers)
+import qualified Gargantext.Core.Text.Corpus.API as API
+import qualified Gargantext.Core.Text.Corpus.Parsers as Parser (FileType(..), parseFormatC)
+import qualified Gargantext.Database.GargDB as GargDB
 ------------------------------------------------------------------------
 {-
 data Query = Query { query_query      :: Text
@@ -174,6 +175,8 @@ type AddWithFile = Summary "Add with MultipartData to corpus endpoint"
 
 ------------------------------------------------------------------------
 -- TODO WithQuery also has a corpus id
+
+
 addToCorpusWithQuery :: FlowCmdM env err m
                        => User
                        -> CorpusId
@@ -213,24 +216,41 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
       -- TODO if cid is folder -> create Corpus
       --      if cid is corpus -> add to corpus
       --      if cid is root   -> create corpus in Private
-      txts <- mapM (\db -> getDataText db (Multi l) q maybeLimit) [database2origin dbs]
-  
-      logStatus JobLog { _scst_succeeded = Just 2
-                       , _scst_failed    = Just 0
-                       , _scst_remaining = Just $ 1 + length txts
-                       , _scst_events    = Just []
-                       }
-
-      cids <- mapM (\txt -> flowDataText user txt (Multi l) cid Nothing logStatus) txts
-      printDebug "corpus id" cids
-      printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
-      sendMail user
-      -- TODO ...
-      pure JobLog { _scst_succeeded = Just 3
-                  , _scst_failed    = Just 0
-                  , _scst_remaining = Just 0
-                  , _scst_events    = Just []
-                  }
+      printDebug "[G.A.N.C.New] getDataText with query" q
+      eTxts <- mapM (\db -> getDataText db (Multi l) q maybeLimit) [database2origin dbs]
+
+      let lTxts = lefts eTxts
+      printDebug "[G.A.N.C.New] eTxts" lTxts
+      case lTxts of
+        [] -> do
+          let txts = rights eTxts
+          -- TODO Sum lenghts of each txt elements
+          logStatus $ JobLog { _scst_succeeded = Just 2
+                             , _scst_failed    = Just 0
+                             , _scst_remaining = Just $ 1 + length txts
+                             , _scst_events    = Just []
+                             }
+
+          cids <- mapM (\txt -> do
+                           flowDataText user txt (Multi l) cid Nothing logStatus) txts
+          printDebug "corpus id" cids
+          printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
+          sendMail user
+          -- TODO ...
+          pure JobLog { _scst_succeeded = Just 3
+                      , _scst_failed    = Just 0
+                      , _scst_remaining = Just 0
+                      , _scst_events    = Just []
+                      }
+        
+        (err:_) -> do
+          printDebug "Error: " err
+          pure $ addEvent "ERROR" (T.pack $ show err) $
+            JobLog { _scst_succeeded = Just 2
+                   , _scst_failed    = Just 1
+                   , _scst_remaining = Just 0
+                   , _scst_events    = Just []
+                   }
 
 
 type AddWithForm = Summary "Add with FormUrlEncoded to corpus endpoint"
@@ -248,63 +268,70 @@ addToCorpusWithForm :: (FlowCmdM env err m)
                     -> (JobLog -> m ())
                     -> JobLog
                     -> m JobLog
-addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus jobLog = do
+addToCorpusWithForm user cid (NewWithForm ft ff d l _n) logStatus jobLog = do
   printDebug "[addToCorpusWithForm] Parsing corpus: " cid
   printDebug "[addToCorpusWithForm] fileType" ft
+  printDebug "[addToCorpusWithForm] fileFormat" ff
   logStatus jobLog
+  limit' <- view $ hasConfig . gc_max_docs_parsers
+  let limit = fromIntegral limit' :: Integer
   let
-    parse = case ft of
-      CSV_HAL   -> Parser.parseFormat Parser.CsvHal
-      CSV       -> Parser.parseFormat Parser.CsvGargV3
-      WOS       -> Parser.parseFormat Parser.WOS
-      PresseRIS -> Parser.parseFormat Parser.RisPresse
-      ZIP       -> Parser.parseFormat Parser.ZIP
+    parseC = case ft of
+      CSV_HAL   -> Parser.parseFormatC Parser.CsvHal
+      CSV       -> Parser.parseFormatC Parser.CsvGargV3
+      WOS       -> Parser.parseFormatC Parser.WOS
+      PresseRIS -> Parser.parseFormatC Parser.RisPresse
   
   -- TODO granularity of the logStatus
-  let data' = case ft of
-        ZIP -> case BSB64.decode $ TE.encodeUtf8 d of
+  let data' = case ff of
+        Plain -> cs d
+        ZIP   -> case BSB64.decode $ TE.encodeUtf8 d of
           Left err -> panic $ T.pack "[addToCorpusWithForm] error decoding base64: " <> T.pack err
           Right decoded -> decoded
-        _   -> cs d
-  eDocs <- liftBase $ parse data'
-  case eDocs of
-    Right docs' -> do
+  eDocsC <- liftBase $ parseC ff data'
+  case eDocsC of
+    Right (mCount, docsC) -> do
       -- TODO Add progress (jobStatus) update for docs - this is a
       -- long action
-      limit' <- view $ hasConfig . gc_max_docs_parsers
-      let limit = fromIntegral limit'
-      if length docs' > limit then do
-        printDebug "[addToCorpusWithForm] number of docs exceeds the limit" (show $ length docs')
-        let panicMsg' = [ "[addToCorpusWithForm] number of docs ("
-                        , show $ length docs'
-                        , ") exceeds the MAX_DOCS_PARSERS limit ("
-                        , show limit
-                        , ")" ]
-        let panicMsg = T.concat $ T.pack <$> panicMsg'
-        logStatus $ jobLogFailTotalWithMessage panicMsg jobLog
-        panic panicMsg
-      else
-        pure ()
-      let docs = splitEvery 500 $ take limit docs'
-
-      printDebug "Parsing corpus finished : " cid
-      logStatus jobLog2
-
-      printDebug "Starting extraction     : " cid
+
+      let docsC' = zipSources (yieldMany [1..]) docsC
+                  .| mapMC (\(idx, doc) ->
+                        if idx > limit then do
+                          --printDebug "[addToCorpusWithForm] number of docs exceeds the limit" (show limit)
+                          let panicMsg' = [ "[addToCorpusWithForm] number of docs "
+                                          , "exceeds the MAX_DOCS_PARSERS limit ("
+                                          , show limit
+                                          , ")" ]
+                          let panicMsg = T.concat $ T.pack <$> panicMsg'
+                          --logStatus $ jobLogFailTotalWithMessage panicMsg jobLog
+                          panic panicMsg
+                        else
+                          pure doc)
+                  .| mapC toHyperdataDocument
+
+      --printDebug "Parsing corpus finished : " cid
+      --logStatus jobLog2
+
+      --printDebug "Starting extraction     : " cid
       -- TODO granularity of the logStatus
+      printDebug "flowCorpus with lang" l
+
       _cid' <- flowCorpus user
                           (Right [cid])
                           (Multi $ fromMaybe EN l)
                           Nothing
-                          (map (map toHyperdataDocument) docs)
+                          --(Just $ fromIntegral $ length docs, docsC')
+                          (mCount, transPipe liftBase docsC') -- TODO fix number of docs
+                          --(map (map toHyperdataDocument) docs)
                           logStatus
 
       printDebug "Extraction finished   : " cid
       printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
-      sendMail user
+      -- TODO uncomment this
+      --sendMail user
 
       logStatus jobLog3
-      pure $ jobLog3
+      pure jobLog3
     Left e -> do
       printDebug "[addToCorpusWithForm] parse error" e
 

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

@@ -20,19 +20,16 @@ module Gargantext.API.Node.Corpus.New.File
 
 import Control.Lens ((.~), (?~))
 import Control.Monad (forM)
-import Data.Aeson
 import Data.Maybe
 import Data.Monoid (mempty)
 import Data.Swagger
 import Data.Text (Text())
-import GHC.Generics (Generic)
 
 import Servant
 import Servant.Multipart
 import Servant.Swagger.Internal
-import Test.QuickCheck (elements)
-import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
+import Gargantext.API.Node.Corpus.New.Types
 import Gargantext.Core.Types (TODO)
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude -- (Cmd, CmdM)
@@ -41,38 +38,9 @@ import Gargantext.Prelude.Crypto.Hash (hash)
 
 -------------------------------------------------------------
 type Hash = Text
-data FileType = CSV
-              | CSV_HAL
-              | PresseRIS
-              | WOS
-              | ZIP
-  deriving (Eq, Show, Generic)
-
-instance ToSchema FileType
-instance Arbitrary FileType where arbitrary = elements [CSV, PresseRIS]
-instance ToParamSchema FileType
-
-instance FromJSON FileType
-instance ToJSON FileType
 
 instance ToParamSchema (MultipartData Mem) where toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
 
-instance FromHttpApiData FileType
-  where
-    parseUrlPiece "CSV"       = pure CSV
-    parseUrlPiece "CSV_HAL"   = pure CSV_HAL
-    parseUrlPiece "PresseRis" = pure PresseRIS
-    parseUrlPiece "ZIP"       = pure ZIP
-    parseUrlPiece "WOS"       = pure WOS
-    parseUrlPiece _           = pure CSV -- TODO error here
-instance ToHttpApiData FileType where
-  toUrlPiece t = case t of
-    CSV -> "CSV"
-    CSV_HAL -> "CSV_HAL"
-    PresseRIS -> "PresseRis"
-    ZIP -> "ZIP"
-    WOS -> "WOS"
-
 instance (ToParamSchema a, HasSwagger sub) =>
          HasSwagger (MultipartForm tag a :> sub) where
   -- TODO
@@ -89,6 +57,7 @@ instance (ToParamSchema a, HasSwagger sub) =>
 
 type WithUpload' = Summary "Upload file(s) to a corpus"
                 :> QueryParam "fileType"  FileType
+                :> QueryParam "fileFormat" FileFormat
                 :> MultipartForm Mem (MultipartData Mem)
                 :> Post '[JSON] [Hash]
 
@@ -96,11 +65,14 @@ type WithUpload' = Summary "Upload file(s) to a corpus"
 --postUpload :: NodeId -> GargServer UploadAPI
 postUpload :: NodeId
            -> Maybe FileType
+           -> Maybe FileFormat
            -> MultipartData Mem
            -> Cmd err [Hash]
-postUpload _ Nothing _ = panic "fileType is a required parameter"
-postUpload _ (Just fileType) multipartData = do
+postUpload _ Nothing _ _ = panic "fileType is a required parameter"
+postUpload _ _ Nothing _ = panic "fileFormat is a required parameter"
+postUpload _ (Just fileType) (Just fileFormat) multipartData = do
   printDebug "File Type: " fileType
+  printDebug "File format: " fileFormat
   is <- liftBase $ do
     printDebug "Inputs:" ()
     forM (inputs multipartData) $ \input -> do

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

+module Gargantext.API.Node.Corpus.New.Types where
+
+import Data.Aeson
+import Data.Swagger
+import Data.Text (pack)
+import GHC.Generics (Generic)
+import Servant
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+
+import Gargantext.Prelude
+
+data FileType = CSV
+              | CSV_HAL
+              | PresseRIS
+              | WOS
+  deriving (Eq, Show, Generic)
+instance ToSchema FileType
+instance Arbitrary FileType where arbitrary = elements [CSV, PresseRIS]
+instance ToParamSchema FileType
+instance FromJSON FileType
+instance ToJSON FileType
+
+instance FromHttpApiData FileType where
+  parseUrlPiece "CSV"       = pure CSV
+  parseUrlPiece "CSV_HAL"   = pure CSV_HAL
+  parseUrlPiece "PresseRis" = pure PresseRIS
+  parseUrlPiece "WOS"       = pure WOS
+  parseUrlPiece _           = pure CSV -- TODO error here
+instance ToHttpApiData FileType where
+  toUrlPiece = pack . show
+
+data FileFormat = Plain | ZIP
+  deriving (Eq, Show, Generic)
+instance ToSchema FileFormat
+instance Arbitrary FileFormat where arbitrary = elements [ Plain, ZIP ]
+instance ToParamSchema FileFormat
+instance FromJSON FileFormat
+instance ToJSON FileFormat
+instance FromHttpApiData FileFormat where
+  parseUrlPiece "Plain" = pure Plain
+  parseUrlPiece "ZIP"   = pure ZIP
+  parseUrlPiece _       = pure Plain -- TODO error here
+instance ToHttpApiData FileFormat where
+  toUrlPiece = pack . show

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

@@ -17,7 +17,7 @@ import GHC.Generics (Generic)
 import Network.HTTP.Client
 import Network.HTTP.Client.TLS
 
-import qualified Prelude as Prelude
+import qualified Prelude
 import Protolude (catMaybes, encodeUtf8, rightToMaybe, Text)
 import Gargantext.Prelude
 import Gargantext.Prelude.Config

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

@@ -22,6 +22,7 @@ import Gargantext.Database.Action.Flow (DataOrigin(..))
 
 data Database = Empty
               | PubMed
+              | Arxiv
               | HAL
               | IsTex
               | Isidore
@@ -33,6 +34,7 @@ instance ToSchema Database
 database2origin :: Database -> DataOrigin
 database2origin Empty   = InternalOrigin T.IsTex
 database2origin PubMed  = ExternalOrigin T.PubMed
+database2origin Arxiv   = ExternalOrigin T.Arxiv
 database2origin HAL     = ExternalOrigin T.HAL
 database2origin IsTex   = ExternalOrigin T.IsTex
 database2origin Isidore = ExternalOrigin T.Isidore

src/Gargantext/API/Node/DocumentsFromWriteNodes.hs

@@ -16,6 +16,7 @@ Portability : POSIX
 module Gargantext.API.Node.DocumentsFromWriteNodes
       where
 
+import Conduit
 import Control.Lens ((^.))
 import Data.Aeson
 import Data.Either (Either(..), rights)
@@ -101,7 +102,7 @@ documentsFromWriteNodes uId nId _p logStatus = do
   let parsedE = (\(node, contents) -> hyperdataDocumentFromFrameWrite (node ^. node_hyperdata, contents)) <$> frameWritesWithContents
   let parsed = rights parsedE
 
-  _ <- flowDataText (RootId (NodeId uId)) (DataNew [parsed]) (Multi EN) cId Nothing logStatus
+  _ <- flowDataText (RootId (NodeId uId)) (DataNew (Just $ fromIntegral $ length parsed, yieldMany parsed)) (Multi EN) cId Nothing logStatus
 
   pure $ jobLogSuccess jobLog
 ------------------------------------------------------------------------

src/Gargantext/Core/Methods/Distances.hs

@@ -53,5 +53,3 @@ instance Arbitrary GraphMetric where
 
 ------------------------------------------------------------------------
 
-
-