[NLP] implement NLP server selection in INI file

bin/gargantext-invitations/Main.hs

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

gargantext.cabal

@@ -46,6 +46,7 @@ library
       Gargantext.API.Prelude
       Gargantext.Core
       Gargantext.Core.Methods.Similarities
+      Gargantext.Core.NLP
       Gargantext.Core.NodeStory
       Gargantext.Core.Text
       Gargantext.Core.Text.Context
@@ -438,6 +439,7 @@ library
     , morpheus-graphql-subscriptions
     , mtl
     , natural-transformation
+    , network-uri
     , opaleye
     , pandoc
     , parallel

gargantext.ini_toModify

@@ -84,3 +84,8 @@ MAIL_PASSWORD =
 MAIL_FROM     = 
 # NoAuth | Normal | SSL | TLS | STARTTLS
 MAIL_LOGIN_TYPE = Normal
+
+[nlp]
+EN = corenlp://localhost:9000
+FR = spacy://localhost:8001
+All = corenlp://localhost:9000

package.yaml

@@ -222,6 +222,7 @@ library:
   - morpheus-graphql-subscriptions
   - mtl
   - natural-transformation
+  - network-uri
   - opaleye
   - pandoc
   - parallel

src/Gargantext/API/Admin/Auth.hs

@@ -52,11 +52,11 @@ import Gargantext.API.Admin.Types
 import Gargantext.API.Job (jobLogSuccess)
 import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC, GargServer, _ServerError, GargM, GargError)
 import Gargantext.Core.Mail (MailModel(..), mail)
-import Gargantext.Core.Mail.Types (HasMail, mailSettings)
+import Gargantext.Core.Mail.Types (mailSettings)
 import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId)
-import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
+import Gargantext.Database.Prelude (Cmd', CmdM, CmdCommon)
 import Gargantext.Database.Query.Table.User
 import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
 import Gargantext.Database.Query.Tree.Root (getRoot)
@@ -83,7 +83,7 @@ makeTokenForUser uid = do
   either joseError (pure . toStrict . LE.decodeUtf8) e
   -- TODO not sure about the encoding...
 
-checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
+checkAuthRequest :: ( HasSettings env, CmdCommon env, HasJoseError err)
                  => Username
                  -> GargPassword
                  -> Cmd' env err CheckAuth
@@ -102,7 +102,7 @@ checkAuthRequest u (GargPassword p) = do
               token <- makeTokenForUser uid
               pure $ Valid token uid userLight_id
 
-auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
+auth :: (HasSettings env, CmdCommon env, HasJoseError err)
      => AuthRequest -> Cmd' env err AuthResponse
 auth (AuthRequest u p) = do
   checkAuthRequest' <- checkAuthRequest u p
@@ -177,7 +177,7 @@ forgotPassword :: GargServer ForgotPasswordAPI
      -- => ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse
 forgotPassword = forgotPasswordPost :<|> forgotPasswordGet
 
-forgotPasswordPost :: ( HasConnectionPool env, HasConfig env, HasMail env)
+forgotPasswordPost :: (CmdCommon env)
      => ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse
 forgotPasswordPost (ForgotPasswordRequest email) = do
   us <- getUsersWithEmail (Text.toLower email)
@@ -189,7 +189,7 @@ forgotPasswordPost (ForgotPasswordRequest email) = do
   -- users' emails
   pure $ ForgotPasswordResponse "ok"
 
-forgotPasswordGet :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env, HasServerError err)
+forgotPasswordGet :: (HasSettings env, CmdCommon env, HasJoseError err, HasServerError err)
      => Maybe Text -> Cmd' env err ForgotPasswordGet
 forgotPasswordGet Nothing = pure $ ForgotPasswordGet ""
 forgotPasswordGet (Just uuid) = do
@@ -205,7 +205,7 @@ forgotPasswordGet (Just uuid) = do
 
 ---------------------
 
-forgotPasswordGetUser :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env, HasServerError err)
+forgotPasswordGetUser :: ( HasSettings env, CmdCommon env, HasJoseError err, HasServerError err)
      => UserLight -> Cmd' env err ForgotPasswordGet
 forgotPasswordGetUser (UserLight { .. }) = do
   -- pick some random password
@@ -224,7 +224,7 @@ forgotPasswordGetUser (UserLight { .. }) = do
 
   pure $ ForgotPasswordGet password
 
-forgotUserPassword :: (HasConnectionPool env, HasConfig env, HasMail env)
+forgotUserPassword :: (CmdCommon env)
      => UserLight -> Cmd' env err ()
 forgotUserPassword (UserLight { .. }) = do
   --printDebug "[forgotUserPassword] userLight_id" userLight_id
@@ -249,7 +249,7 @@ forgotUserPassword (UserLight { .. }) = do
 --------------------------
 
 -- Generate a unique (in whole DB) UUID for passwords.
-generateForgotPasswordUUID :: (HasConnectionPool env, HasConfig env, HasMail env)
+generateForgotPasswordUUID :: (CmdCommon env)
   => Cmd' env err UUID
 generateForgotPasswordUUID = do
   uuid <- liftBase $ nextRandom

src/Gargantext/API/Admin/EnvTypes.hs

@@ -22,6 +22,7 @@ import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Prelude (GargError)
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
+import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
 import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(..))
@@ -59,6 +60,7 @@ data Env = Env
   , _env_jobs      :: !(Jobs.JobEnv GargJob (Dual [JobLog]) JobLog)
   , _env_config    :: !GargConfig
   , _env_mail      :: !MailConfig
+  , _env_nlp       :: !NLPServerMap
   }
   deriving (Generic)
 
@@ -91,6 +93,9 @@ instance HasSettings Env where
 instance HasMail Env where
   mailSettings = env_mail
 
+instance HasNLPServer Env where
+  nlpServer = env_nlp
+
 instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
   _env = env_scrapers . Servant.Job.Core._env
 
@@ -115,6 +120,7 @@ data DevEnv = DevEnv
   , _dev_env_pool      :: !(Pool Connection)
   , _dev_env_nodeStory :: !NodeStoryEnv
   , _dev_env_mail      :: !MailConfig
+  , _dev_env_nlp       :: !NLPServerMap
   }
 
 makeLenses ''DevEnv
@@ -146,3 +152,6 @@ instance HasNodeArchiveStoryImmediateSaver DevEnv where
 
 instance HasMail DevEnv where
   mailSettings = dev_env_mail
+
+instance HasNLPServer DevEnv where
+  nlpServer = dev_env_nlp

src/Gargantext/API/Admin/Settings.hs

@@ -43,10 +43,12 @@ import qualified Data.ByteString.Lazy as L
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Types
 -- import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
+import Gargantext.Core.NLP (nlpServerMap)
 import Gargantext.Database.Prelude (databaseParameters, hasConfig)
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (gc_js_job_timeout, gc_js_id_timeout)
 import qualified Gargantext.Prelude.Mail as Mail
+import qualified Gargantext.Prelude.NLP as NLP
 import qualified Gargantext.Utils.Jobs       as Jobs
 import qualified Gargantext.Utils.Jobs.Monad as Jobs
 import qualified Gargantext.Utils.Jobs.Queue as Jobs
@@ -199,6 +201,7 @@ newEnv port file = do
   jobs_env      <- Jobs.newJobEnv jobs_settings prios' manager_env
   logger        <- newStderrLoggerSet defaultBufSize
   config_mail   <- Mail.readConfig file
+  config_nlp    <- NLP.readConfig file
 
   pure $ Env
     { _env_settings  = settings'
@@ -211,6 +214,7 @@ newEnv port file = do
     , _env_self_url  = self_url_env
     , _env_config    = config_env
     , _env_mail      = config_mail
+    , _env_nlp       = nlpServerMap config_nlp
     }
 
 newPool :: ConnectInfo -> IO (Pool Connection)

src/Gargantext/API/Dev.hs

@@ -19,11 +19,13 @@ import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Settings
 import Gargantext.API.Ngrams (saveNodeStoryImmediate)
 import Gargantext.API.Prelude
+import Gargantext.Core.NLP (nlpServerMap)
 import Gargantext.Core.NodeStory
 import Gargantext.Database.Prelude
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (readConfig)
 import qualified Gargantext.Prelude.Mail as Mail
+import qualified Gargantext.Prelude.NLP as NLP
 import Servant
 import System.IO (FilePath)
 
@@ -43,12 +45,14 @@ withDevEnv iniPath k = do
       nodeStory_env <- readNodeStoryEnv pool
       setts   <- devSettings devJwkFile
       mail    <- Mail.readConfig iniPath
+      nlp_config <- NLP.readConfig iniPath
       pure $ DevEnv
         { _dev_env_pool     = pool
         , _dev_env_nodeStory  = nodeStory_env
         , _dev_env_settings = setts
         , _dev_env_config   = cfg
         , _dev_env_mail     = mail
+        , _dev_env_nlp      = nlpServerMap nlp_config
         }
 
 -- | Run Cmd Sugar for the Repl (GHCI)

src/Gargantext/API/GraphQL.hs

@@ -45,8 +45,7 @@ import qualified Gargantext.API.GraphQL.TreeFirstLevel as GQLTree
 import qualified Gargantext.API.GraphQL.Team as GQLTeam
 import Gargantext.API.Prelude (GargM, GargError)
 import Gargantext.API.Types
-import Gargantext.Core.Mail.Types (HasMail)
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Database.Prelude (CmdCommon)
 import Gargantext.Prelude
 import GHC.Generics (Generic)
 import Servant
@@ -104,7 +103,7 @@ data Contet m
 -- | The main GraphQL resolver: how queries, mutations and
 -- subscriptions are handled.
 rootResolver
-  :: (HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
+  :: (CmdCommon env, HasJobEnv' env, HasSettings env)
   => RootResolver (GargM env GargError) e Query Mutation Undefined
 rootResolver =
   RootResolver
@@ -126,7 +125,7 @@ rootResolver =
 
 -- | Main GraphQL "app".
 app
-  :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
+  :: (Typeable env, CmdCommon env, HasJobEnv' env, HasSettings env)
   => App (EVENT (GargM env GargError)) (GargM env GargError)
 app = deriveApp rootResolver
 
@@ -163,7 +162,7 @@ gqapi = Proxy
 -- | Implementation of our API.
 --api :: Server API
 api
-  :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
+  :: (Typeable env, CmdCommon env, HasJobEnv' env, HasSettings env)
   => ServerT API (GargM env GargError)
 api (SAS.Authenticated _auser) = httpPubApp [] app :<|> pure httpPlayground
 api _                          = panic "401 in graphql" -- SAS.throwAll (_ServerError # err401)

src/Gargantext/API/GraphQL/Annuaire.hs

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

src/Gargantext/API/GraphQL/Context.hs

@@ -17,10 +17,9 @@ import Data.Time.Format.ISO8601 (iso8601Show)
 import Gargantext.API.Admin.Types (HasSettings)
 import Gargantext.API.Prelude (GargM, GargError)
 import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
-import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument)
 import Gargantext.Database.Admin.Types.Node (ContextTitle, NodeId(..), NodeTypeId, UserId, unNodeId)
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Database.Prelude (CmdCommon)
 import Gargantext.Database.Query.Table.NodeContext (getNodeContext, getContextsForNgramsTerms, ContextForNgramsTerms(..))
 import qualified Gargantext.Database.Query.Table.NodeContext as DNC
 import Gargantext.Database.Schema.NodeContext (NodeContext, NodeContextPoly(..))
@@ -102,13 +101,13 @@ type GqlM' e env a = ResolverM e (GargM env GargError) a
 
 -- | Function to resolve context from a query.
 resolveNodeContext
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => NodeContextArgs -> GqlM e env [NodeContextGQL]
 resolveNodeContext NodeContextArgs { context_id, node_id } =
   dbNodeContext context_id node_id
 
 resolveContextsForNgrams
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => ContextsForNgramsArgs -> GqlM e env [ContextGQL]
 resolveContextsForNgrams ContextsForNgramsArgs { corpus_id, ngrams_terms } =
   dbContextForNgrams corpus_id ngrams_terms
@@ -117,7 +116,7 @@ resolveContextsForNgrams ContextsForNgramsArgs { corpus_id, ngrams_terms } =
 
 -- | Inner function to fetch the node context DB.
 dbNodeContext
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> Int -> GqlM e env [NodeContextGQL]
 dbNodeContext context_id node_id = do
   -- lift $ printDebug "[dbUsers]" user_id
@@ -128,7 +127,7 @@ dbNodeContext context_id node_id = do
   pure $ toNodeContextGQL <$> [c]
 
 dbContextForNgrams
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> [Text] -> GqlM e env [ContextGQL]
 dbContextForNgrams node_id ngrams_terms = do
   contextsForNgramsTerms <- lift $ getContextsForNgramsTerms (NodeId node_id) ngrams_terms
@@ -192,7 +191,7 @@ toHyperdataRowDocumentGQL hyperdata =
                                      }
     HyperdataRowContact { } -> Nothing
 
-updateNodeContextCategory :: (HasConnectionPool env, HasConfig env, HasMail env, HasSettings env) =>
+updateNodeContextCategory :: ( CmdCommon env, HasSettings env) =>
                              NodeContextCategoryMArgs -> GqlM' e env [Int]
 updateNodeContextCategory NodeContextCategoryMArgs { context_id, node_id, category } = do
   _ <- lift $ DNC.updateNodeContextCategory (NodeId context_id) (NodeId node_id) category

src/Gargantext/API/GraphQL/Node.hs

@@ -13,11 +13,10 @@ import Data.Morpheus.Types
 import Data.Text (Text)
 import qualified Data.Text as T
 import Gargantext.API.Prelude (GargM, GargError)
-import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Database.Admin.Types.Node (NodeId(..), NodeType)
 import qualified Gargantext.Database.Admin.Types.Node as NN
 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, getNode)
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Database.Prelude (CmdCommon)
 import qualified Gargantext.Database.Schema.Node as N
 import Gargantext.Prelude
 import GHC.Generics (Generic)
@@ -40,12 +39,12 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
 
 -- | Function to resolve user from a query.
 resolveNodes
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => NodeArgs -> GqlM e env [Node]
 resolveNodes NodeArgs { node_id } = dbNodes node_id
 
 dbNodes
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> GqlM e env [Node]
 dbNodes node_id = do
   node <- lift $ getNode $ NodeId node_id
@@ -58,12 +57,12 @@ data NodeParentArgs
     } deriving (Generic, GQLType)
 
 resolveNodeParent
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => NodeParentArgs -> GqlM e env [Node]
 resolveNodeParent NodeParentArgs { node_id, parent_type } = dbParentNodes node_id parent_type
 
 dbParentNodes
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> Text -> GqlM e env [Node]
 dbParentNodes node_id parent_type = do
   let mParentType = readEither (T.unpack parent_type) :: Either Prelude.String NodeType

src/Gargantext/API/GraphQL/Team.hs

@@ -10,11 +10,9 @@ import Data.Text ( Text )
 import Gargantext.API.Admin.Types (HasSettings)
 import Gargantext.API.GraphQL.Utils (authUser, AuthStatus (Invalid, Valid))
 import Gargantext.API.Prelude (GargM, GargError)
-import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Core.Types (NodeId(..), unNodeId)
-import Gargantext.Database (HasConfig)
 import Gargantext.Database.Action.Share (membersOf, deleteMemberShip)
-import Gargantext.Database.Prelude (HasConnectionPool)
+import Gargantext.Database.Prelude (CmdCommon)
 import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.User (getUsersWithNodeHyperdata)
 import Gargantext.Database.Schema.Node (NodePoly(Node, _node_id), _node_user_id)
@@ -45,10 +43,11 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
 type GqlM' e env a = ResolverM e (GargM env GargError) a
 
 
-resolveTeam :: (HasConnectionPool env, HasConfig env, HasMail env) => TeamArgs -> GqlM e env Team
+resolveTeam :: (CmdCommon env) => TeamArgs -> GqlM e env Team
 resolveTeam TeamArgs { team_node_id } = dbTeam team_node_id
 
-dbTeam :: (HasConnectionPool env, HasConfig env, HasMail env) => Int -> GqlM e env Team
+dbTeam :: (CmdCommon env) =>
+          Int -> GqlM e env Team
 dbTeam nodeId = do
   let nId = NodeId nodeId
   res <- lift $ membersOf nId
@@ -69,7 +68,8 @@ dbTeam nodeId = do
     getUsername ((UserLight {userLight_username}, _):_) = userLight_username
 
 -- TODO: list as argument
-deleteTeamMembership :: (HasConnectionPool env, HasConfig env, HasMail env, HasSettings env) => TeamDeleteMArgs -> GqlM' e env [Int]
+deleteTeamMembership :: (CmdCommon env, HasSettings env) =>
+                        TeamDeleteMArgs -> GqlM' e env [Int]
 deleteTeamMembership TeamDeleteMArgs { token, shared_folder_id, team_node_id } = do
   teamNode <- lift $ getNode $ NodeId team_node_id
   userNodes <- lift (getUsersWithNodeHyperdata $ uId teamNode)

src/Gargantext/API/GraphQL/TreeFirstLevel.hs

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

src/Gargantext/API/GraphQL/User.hs

@@ -10,9 +10,8 @@ import Data.Morpheus.Types
   )
 import Data.Text (Text)
 import Gargantext.API.Prelude (GargM, GargError)
-import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..))
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Database.Prelude (CmdCommon)
 import Gargantext.Database.Query.Table.User (getUsersWithId, getUserHyperdata)
 import Gargantext.Database.Schema.User (UserLight(..))
 import Gargantext.Prelude
@@ -35,18 +34,18 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
 
 -- | Function to resolve user from a query.
 resolveUsers
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => UserArgs -> GqlM e env [User (GqlM e env)]
 resolveUsers UserArgs { user_id } = dbUsers user_id
 
 -- | Inner function to fetch the user from DB.
 dbUsers
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> GqlM e env [User (GqlM e env)]
 dbUsers user_id = lift (map toUser <$> getUsersWithId user_id)
 
 toUser
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => UserLight -> User (GqlM e env)
 toUser (UserLight { .. }) = User { u_email = userLight_email
                                  , u_hyperdata = resolveHyperdata userLight_id
@@ -54,6 +53,6 @@ toUser (UserLight { .. }) = User { u_email = userLight_email
                                  , u_username = userLight_username }
 
 resolveHyperdata
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> GqlM e env (Maybe HyperdataUser)
 resolveHyperdata userid = lift (listToMaybe <$> getUserHyperdata userid)

src/Gargantext/API/GraphQL/UserInfo.hs

@@ -16,7 +16,6 @@ import Data.Morpheus.Types
 import Data.Text (Text)
 import qualified Data.Text as T
 import Gargantext.API.Prelude (GargM, GargError)
-import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Database.Admin.Types.Hyperdata
   ( HyperdataUser(..)
   , hc_source
@@ -40,7 +39,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
   , ct_phone
   , hc_who
   , hc_where)
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Database.Prelude (CmdCommon)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Query.Table.User (getUsersWithHyperdata, getUsersWithNodeHyperdata, updateUserEmail)
 import Gargantext.Database.Schema.User (UserLight(..))
@@ -105,13 +104,13 @@ type GqlM' e env err = ResolverM e (GargM env err) Int
 
 -- | Function to resolve user from a query.
 resolveUserInfos
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => UserInfoArgs -> GqlM e env [UserInfo]
 resolveUserInfos UserInfoArgs { user_id } = dbUsers user_id
 
 -- | Mutation for user info
 updateUserInfo
-  :: (HasConnectionPool env, HasConfig env, HasMail env, HasSettings env)
+  :: (CmdCommon env, HasSettings env)
   -- => UserInfoMArgs -> ResolverM e (GargM env err) Int
   => UserInfoMArgs -> GqlM' e env err
 updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
@@ -160,7 +159,7 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
 
 -- | Inner function to fetch the user from DB.
 dbUsers
-  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  :: (CmdCommon env)
   => Int -> GqlM e env [UserInfo]
 dbUsers user_id = do
   -- lift $ printDebug "[dbUsers]" user_id

src/Gargantext/API/Members.hs

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

src/Gargantext/API/Ngrams.hs

@@ -105,14 +105,13 @@ import Gargantext.API.Job
 import Gargantext.API.Ngrams.Types
 import Gargantext.API.Prelude
 import Gargantext.Core.NodeStory
-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.NgramsByContext (getOccByNgramsOnlyFast)
 import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Admin.Types.Node (NodeType(..))
-import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig)
+import Gargantext.Database.Prelude (CmdCommon)
 import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngramsType, ngrams_terms)
 import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
@@ -295,7 +294,7 @@ newNgramsFromNgramsStatePatch p =
 commitStatePatch :: ( HasNodeStory env err m
                     , HasNodeStoryImmediateSaver env
                     , HasNodeArchiveStoryImmediateSaver env
-                    , HasMail env)
+                    , CmdCommon env )
                  => ListId
                  ->    Versioned NgramsStatePatch'
                  -> m (Versioned NgramsStatePatch')
@@ -394,8 +393,7 @@ tableNgramsPut :: ( HasNodeStory    env err m
                   , HasNodeStoryImmediateSaver env
                   , HasNodeArchiveStoryImmediateSaver env
                   , HasInvalidError     err
-                  , HasSettings     env
-                  , HasMail         env
+                  , CmdCommon     env
                   )
                  => TabType
                  -> ListId
@@ -542,7 +540,7 @@ type MaxSize = Int
 
 
 getTableNgrams :: forall env err m.
-                  (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
+                  (HasNodeStory env err m, HasNodeError err, CmdCommon env)
                => NodeType -> NodeId -> TabType
                -> ListId   -> Limit  -> Maybe Offset
                -> Maybe ListType
@@ -639,9 +637,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
 getNgramsTable' :: forall env err m.
                    ( HasNodeStory env err m
                    , HasNodeError err
-                   , HasConnectionPool env
-                   , HasConfig env
-                   , HasMail env)
+                   , CmdCommon env)
                 => NodeId
                 -> ListId
                 -> TableNgrams.NgramsType
@@ -656,9 +652,7 @@ setNgramsTableScores :: forall env err m t.
                         ( Each t t NgramsElement NgramsElement
                         , HasNodeStory env err m
                         , HasNodeError err
-                        , HasConnectionPool env
-                        , HasConfig env
-                        , HasMail env)
+                        , CmdCommon env )
                      => NodeId
                      -> ListId
                      -> TableNgrams.NgramsType
@@ -686,7 +680,7 @@ setNgramsTableScores nId listId ngramsType table = do
 
 
 scoresRecomputeTableNgrams :: forall env err m.
-  (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
+  (HasNodeStory env err m, HasNodeError err, CmdCommon env)
   => NodeId -> TabType -> ListId -> m Int
 scoresRecomputeTableNgrams nId tabType listId = do
   tableMap <- getNgramsTableMap listId ngramsType
@@ -769,7 +763,7 @@ type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
                            :> "update"
                            :> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog
 
-getTableNgramsCorpus :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
+getTableNgramsCorpus :: (HasNodeStory env err m, HasNodeError err, CmdCommon env)
                => NodeId
                -> TabType
                -> ListId
@@ -787,7 +781,7 @@ getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize o
 
 
 
-getTableNgramsVersion :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
+getTableNgramsVersion :: (HasNodeStory env err m, HasNodeError err, CmdCommon env)
                => NodeId
                -> TabType
                -> ListId
@@ -803,7 +797,7 @@ getTableNgramsVersion _nId _tabType listId = currentVersion listId
 
 
 -- | Text search is deactivated for now for ngrams by doc only
-getTableNgramsDoc :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
+getTableNgramsDoc :: ( HasNodeStory env err m, HasNodeError err, CmdCommon env)
                => DocId -> TabType
                -> ListId -> Limit -> Maybe Offset
                -> Maybe ListType

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

@@ -23,9 +23,9 @@ import Gargantext.Prelude
 import Gargantext.Prelude.Config
 
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
---import Gargantext.API.Admin.Types (HasSettings)
 import Gargantext.API.Job (jobLogSuccess)
-import Gargantext.Core (Lang(..), PosTagAlgo(..))
+import Gargantext.Core (Lang(..))
+import Gargantext.Core.NLP (nlpServerGet)
 import qualified Gargantext.Core.Text.Corpus.API as API
 import Gargantext.Core.Text.List (buildNgramsLists)
 import Gargantext.Core.Text.List.Group.WithStem ({-StopSize(..),-} GroupParams(..))
@@ -120,6 +120,7 @@ insertSearxResponse :: (MonadBase IO m, FlowCmdM env err m)
                     -> m ()
 insertSearxResponse _ _ _ _ (Left _) = pure ()
 insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) = do
+  server <- view (nlpServerGet l)
   -- docs :: [Either Text HyperdataDocument]
   let docs = hyperdataDocumentFromSearxResult l <$> _srs_results
   --printDebug "[triggerSearxSearch] docs" docs
@@ -138,10 +139,10 @@ insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) =
   _ <- Doc.add cId ids
   (_masterUserId, _masterRootId, masterCorpusId)
     <- getOrMk_RootWithCorpus (UserName userMaster) (Left "") mCorpus
-  let
-    gp = case l of
-      FR -> GroupWithPosTag l Spacy HashMap.empty
-      _       -> GroupWithPosTag l CoreNLP HashMap.empty
+  let gp = GroupWithPosTag l server HashMap.empty
+    -- gp = case l of
+    --   FR -> GroupWithPosTag l Spacy HashMap.empty
+    --   _       -> GroupWithPosTag l CoreNLP HashMap.empty
   ngs         <- buildNgramsLists user cId masterCorpusId Nothing gp
   _userListId <- flowList_DbRepo listId ngs
 

src/Gargantext/API/Node/Share.hs

@@ -20,6 +20,7 @@ import Data.Swagger
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Gargantext.API.Prelude
+import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.Types.Individu (User(..), arbitraryUsername)
 import Gargantext.Database.Action.Share (ShareNodeWith(..))
 import Gargantext.Database.Action.Share as DB (shareNodeWith, unPublish)
@@ -56,11 +57,11 @@ instance Arbitrary ShareNodeParams where
 -- TODO permission
 -- TODO refactor userId which is used twice
 -- TODO change return type for better warning/info/success/error handling on the front
-api :: HasNodeError err
+api :: (HasNodeError err, HasNLPServer env, CmdRandom env err m)
     => User
     -> NodeId
     -> ShareNodeParams
-    -> CmdR err Int
+    -> m Int
 api userInviting nId (ShareTeamParams user') = do
   let user'' = Text.toLower user'
   user <- case guessUserName user'' of

src/Gargantext/API/Prelude.hs

@@ -34,6 +34,7 @@ import Data.Typeable
 import Data.Validity
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Admin.Types
+import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Core.Types
@@ -61,6 +62,7 @@ type EnvC env =
   , HasConfig         env
   , HasNodeStoryEnv   env
   , HasMail           env
+  , HasNLPServer      env
   )
 
 type ErrC err =

src/Gargantext/Core.hs

@@ -74,6 +74,11 @@ instance HasDBid Lang where
   fromDBid _ = panic "HasDBid lang, not implemented"
 
 ------------------------------------------------------------------------
+data NLPServerConfig = NLPServerConfig
+  { server :: !PosTagAlgo
+  , url    :: !URI }
+  deriving (Show, Eq)
+------------------------------------------------------------------------
 type Form = Text
 type Lem  = Text
 ------------------------------------------------------------------------
@@ -90,4 +95,3 @@ instance HasDBid PosTagAlgo where
   fromDBid 2 = JohnSnowServer
   fromDBid 3 = Spacy
   fromDBid _ = panic "HasDBid posTagAlgo : Not implemented"
-

src/Gargantext/Core/Mail.hs

@@ -139,4 +139,3 @@ email_signature =
           , "-- "
           , "The Gargantext Team (CNRS)"
           ]
-

src/Gargantext/Core/NLP.hs

+module Gargantext.Core.NLP where
+
+import Control.Lens (Getter, at, non)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromJust)
+import Network.URI (URI(..), parseURI)
+import Gargantext.Core (Lang(..), NLPServerConfig(..), PosTagAlgo(..))
+import Gargantext.Prelude.NLP.Types (NLPConfig(..))
+import Gargantext.Utils.Tuple (uncurryMaybeSecond)
+import Protolude hiding (All)
+
+
+type NLPServerMap = Map.Map Lang NLPServerConfig
+
+class HasNLPServer env where
+  nlpServer :: Getter env NLPServerMap
+  nlpServerGet :: Lang -> Getter env NLPServerConfig
+  -- default implementation
+  nlpServerGet l = nlpServer . at l . non defaultNLPServer
+
+defaultNLPServer :: NLPServerConfig
+defaultNLPServer = NLPServerConfig { server = CoreNLP
+                                   , url = fromJust $ parseURI "http://localhost:9000"
+                                   }
+
+nlpServerConfigFromURI :: URI -> Maybe NLPServerConfig
+nlpServerConfigFromURI uri@(URI { uriScheme = "corenlp:" }) =
+  Just $ NLPServerConfig { server = CoreNLP
+                         , url = uri { uriScheme = "http:" }
+                         }
+nlpServerConfigFromURI uri@(URI { uriScheme = "johnsnow:" }) =
+  Just $ NLPServerConfig { server = JohnSnowServer
+                         , url = uri { uriScheme = "http:" }
+                         }
+nlpServerConfigFromURI uri@(URI { uriScheme = "spacy:" }) =
+  Just $ NLPServerConfig { server = Spacy
+                         , url = uri { uriScheme = "http:" }
+                         }
+nlpServerConfigFromURI _ = Nothing
+
+
+nlpServerMap :: NLPConfig -> NLPServerMap
+nlpServerMap (NLPConfig { .. }) =
+  Map.fromList $ catMaybes [ uncurryMaybeSecond (EN, nlpServerConfigFromURI _nlp_en)
+                           , uncurryMaybeSecond (FR, nlpServerConfigFromURI _nlp_fr)
+                           , uncurryMaybeSecond (All, nlpServerConfigFromURI _nlp_all) ]

src/Gargantext/Core/Text/List.hs

@@ -139,8 +139,8 @@ getGroupParams :: ( HasNodeError err
                   , HasTreeError err
                   )
                => GroupParams -> HashSet Ngrams -> m GroupParams
-getGroupParams gp@(GroupWithPosTag l a _m) ng = do
-  !hashMap <- HashMap.fromList <$> selectLems l a (HashSet.toList ng)
+getGroupParams gp@(GroupWithPosTag l nsc _m) ng = do
+  !hashMap <- HashMap.fromList <$> selectLems l nsc (HashSet.toList ng)
   -- printDebug "hashMap" hashMap
   pure $ over gwl_map (\x -> x <> hashMap) gp
 getGroupParams gp _ = pure gp

src/Gargantext/Core/Text/List/Group/WithStem.hs

@@ -23,7 +23,7 @@ import Data.HashSet (HashSet)
 import Data.Map.Strict (Map)
 import Data.Maybe (catMaybes)
 import Gargantext.API.Ngrams.Types
-import Gargantext.Core (Lang(..), PosTagAlgo(..), Form, Lem)
+import Gargantext.Core (Lang(..), Form, Lem, NLPServerConfig)
 import Gargantext.Core.Text.List.Group.Prelude
 import Gargantext.Core.Text.List.Social.Patch
 import Gargantext.Core.Text.List.Social.Prelude
@@ -62,7 +62,7 @@ data GroupParams = GroupParams { unGroupParams_lang     :: !Lang
                                }
                  | GroupIdentity
                  | GroupWithPosTag { _gwl_lang       :: !Lang
-                                   , _gwl_algo :: !PosTagAlgo
+                                   , _gwl_nlp_config :: !NLPServerConfig
                                    , _gwl_map        :: !(HashMap Form Lem)
                                    }
   deriving (Eq)

src/Gargantext/Core/Text/List/Management.sh

@@ -92,5 +92,3 @@ restrictListSize corpusId listId ngramsType listType size = do
 
 
 -}
-
-

src/Gargantext/Core/Text/Terms.hs

@@ -83,13 +83,13 @@ makeLenses ''TermType
 ------------------------------------------------------------------------
 -- | Sugar to extract terms from text (hidding 'mapM' from end user).
 --extractTerms :: Traversable t => TermType Lang -> t Text -> IO (t [Terms])
-extractTerms :: TermType Lang -> [Text] -> IO [[TermsWithCount]]
-extractTerms (Unsupervised {..}) xs = mapM (terms (Unsupervised { _tt_model = Just m', .. })) xs
+extractTerms :: NLPServerConfig -> TermType Lang -> [Text] -> IO [[TermsWithCount]]
+extractTerms ncs (Unsupervised {..}) xs = mapM (terms ncs (Unsupervised { _tt_model = Just m', .. })) xs
   where
     m' = case _tt_model of
       Just m''-> m''
       Nothing -> newTries _tt_windowSize (Text.intercalate " " xs)
-extractTerms termTypeLang xs = mapM (terms termTypeLang) xs
+extractTerms ncs termTypeLang xs = mapM (terms ncs termTypeLang) xs
 
 
 ------------------------------------------------------------------------
@@ -170,11 +170,11 @@ isSimpleNgrams _                = False
 -- 'Multi' : multi terms
 -- 'MonoMulti' : mono and multi
 -- TODO : multi terms should exclude mono (intersection is not empty yet)
-terms :: TermType Lang -> Text -> IO [TermsWithCount]
-terms (Mono      lang) txt = pure $ monoTerms lang txt
-terms (Multi     lang) txt = multiterms lang txt
-terms (MonoMulti lang) txt = terms (Multi lang) txt
-terms (Unsupervised { .. }) txt = pure $ termsUnsupervised (Unsupervised { _tt_model = Just m', .. }) txt
+terms :: NLPServerConfig -> TermType Lang -> Text -> IO [TermsWithCount]
+terms _   (Mono      lang) txt = pure $ monoTerms lang txt
+terms ncs (Multi     lang) txt = multiterms ncs lang txt
+terms ncs (MonoMulti lang) txt = terms ncs (Multi lang) txt
+terms _   (Unsupervised { .. }) txt = pure $ termsUnsupervised (Unsupervised { _tt_model = Just m', .. }) txt
   where
     m' = maybe (newTries _tt_ngramsSize txt) identity _tt_model
 -- terms (WithList  list) txt = pure . concat $ extractTermsWithList list txt

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

@@ -19,7 +19,7 @@ import Data.Text hiding (map, group, filter, concat)
 import Data.List (concat)
 
 import Gargantext.Prelude
-import Gargantext.Core (Lang(..))
+import Gargantext.Core (Lang(..), NLPServerConfig(..), PosTagAlgo(..))
 import Gargantext.Core.Types
 import Gargantext.Core.Utils (groupWithCounts)
 
@@ -38,8 +38,8 @@ import qualified Gargantext.Utils.SpacyNLP as SpacyNLP
 type NLP_API = Lang -> Text -> IO PosSentences
 
 -------------------------------------------------------------------
-multiterms :: Lang -> Text -> IO [TermsWithCount]
-multiterms l txt = do
+multiterms :: NLPServerConfig -> Lang -> Text -> IO [TermsWithCount]
+multiterms nsc l txt = do
   ret <- multiterms' tokenTag2terms l txt
   pure $ groupWithCounts ret
   where
@@ -47,20 +47,21 @@ multiterms l txt = do
     multiterms' f lang txt' = concat
                        <$> map (map f)
                        <$> map (filter (\t -> _my_token_pos t == Just NP))
-                       <$> tokenTags lang txt'
+                       <$> tokenTags nsc lang txt'
 
 -------------------------------------------------------------------
 tokenTag2terms :: TokenTag -> Terms
 tokenTag2terms (TokenTag ws t _ _) =  Terms ws t
 
-tokenTags :: Lang -> Text -> IO [[TokenTag]]
-tokenTags EN txt = tokenTagsWith EN txt corenlp
-tokenTags FR txt = do
-  -- printDebug "[Spacy Debug]" txt
-  if txt == ""
-     then pure [[]]
-     else tokenTagsWith FR txt SpacyNLP.nlp
-tokenTags l  _   = panic $ "[G.C.T.T.Multi] Lang NLP API not implemented yet " <> (cs $ show l)
+tokenTags :: NLPServerConfig -> Lang -> Text -> IO [[TokenTag]]
+tokenTags (NLPServerConfig { server = CoreNLP, url }) l txt = tokenTagsWith l txt $ corenlp url
+tokenTags (NLPServerConfig { server = Spacy, url }) l txt = tokenTagsWith l txt $ SpacyNLP.nlp url
+-- tokenTags FR txt = do
+--   -- printDebug "[Spacy Debug]" txt
+--   if txt == ""
+--      then pure [[]]
+--      else tokenTagsWith FR txt SpacyNLP.nlp
+tokenTags _ l  _   = panic $ "[G.C.T.T.Multi] Lang NLP API not implemented yet " <> (cs $ show l)
 
 tokenTagsWith :: Lang -> Text -> NLP_API -> IO [[TokenTag]]
 tokenTagsWith lang txt nlp = map (groupTokens lang)

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

@@ -34,6 +34,7 @@ import Gargantext.Core.Text.Terms.Multi.PosTagging.Types
 import Gargantext.Core.Types
 import Gargantext.Prelude
 import Network.HTTP.Simple
+import Network.URI (URI(..))
 
 -- import qualified Gargantext.Utils.SpacyNLP as SpacyNLP
 
@@ -76,21 +77,21 @@ filter' xs = filter isNgrams xs
 corenlp' :: ( FromJSON a
             , ConvertibleStrings p ByteString
             )
-          => Lang -> p -> IO (Response a)
-corenlp' lang txt = do
+          => URI -> Lang -> p -> IO (Response a)
+corenlp' uri lang txt = do
     let properties = case lang of
             EN -> "{\"annotators\": \"tokenize,ssplit,pos,ner\", \"outputFormat\": \"json\"}"
             FR -> "{\"annotators\": \"tokenize,ssplit,pos,lemma,ner\", \"parse.model\":\"edu/stanford/nlp/models/lexparser/frenchFactored.ser.gz\", \"pos.model\":\"edu/stanford/nlp/models/pos-tagger/french/french.tagger\", \"tokenize.language\":\"fr\", \"outputFormat\": \"json\"}"
             _  -> panic $ pack "not implemented yet"
-    url <- parseRequest $ "POST http://localhost:9000/?properties=" <> properties
+    req <- parseRequest $ "POST " <> show (uri { uriQuery = "?properties=" <> properties })
     -- curl -XPOST 'http://localhost:9000/?properties=%7B%22annotators%22:%20%22tokenize,ssplit,pos,ner%22,%20%22outputFormat%22:%20%22json%22%7D' -d 'hello world, hello' | jq .
-    let request = setRequestBodyLBS (cs txt) url
+    let request = setRequestBodyLBS (cs txt) req
     httpJSON request
 
 
-corenlp :: Lang -> Text -> IO PosSentences
-corenlp lang txt = do
-  response <- corenlp' lang txt
+corenlp :: URI -> Lang -> Text -> IO PosSentences
+corenlp uri lang txt = do
+  response <- corenlp' uri lang txt
   pure (getResponseBody response)
 
 -- | parseWith
@@ -101,11 +102,11 @@ corenlp lang txt = do
 -- Named Entity Recognition example
 -- parseWith  _tokenNer     "Hello world of Peter."
 -- [[("``","O"),("Hello","O"),("world","O"),("of","O"),("Peter","PERSON"),(".","O"),("''","O")]]
-tokenWith :: (Token -> t) -> Lang -> Text -> IO [[(Text, t)]]
-tokenWith f lang s = map (map (\t -> (_tokenWord t, f t)))
+tokenWith :: URI -> (Token -> t) -> Lang -> Text -> IO [[(Text, t)]]
+tokenWith uri f lang s = map (map (\t -> (_tokenWord t, f t)))
                   <$> map _sentenceTokens
                   <$> _sentences
-                  <$> corenlp lang s
+                  <$> corenlp uri lang s
 
 ----------------------------------------------------------------------------------
 -- Here connect to the JohnSnow Server as it has been done above with the corenlp'

src/Gargantext/Database/Action/Delete.hs

@@ -22,13 +22,12 @@ import Data.Text
 import Servant
 
 import Gargantext.Core
-import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Action.Share (delFolderTeam)
 import Gargantext.Database.Action.User (getUserId)
 import Gargantext.Database.Admin.Types.Hyperdata.File
 import Gargantext.Database.Admin.Types.Node -- (NodeType(..))
-import Gargantext.Database.Prelude (Cmd', HasConfig, HasConnectionPool)
+import Gargantext.Database.Prelude (Cmd', CmdCommon)
 import Gargantext.Database.Query.Table.Node (getNodeWith)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Schema.Node
@@ -40,7 +39,7 @@ import qualified Gargantext.Database.Query.Table.Node as N (getNode, deleteNode)
 -- TODO
 -- Delete Corpus children accoring its types
 -- Delete NodeList (NodeStory + cbor file)
-deleteNode :: (HasMail env, HasConfig env, HasConnectionPool env, HasNodeError err)
+deleteNode :: (CmdCommon env, HasNodeError err)
            => User
            -> NodeId
            -> Cmd' env err Int

src/Gargantext/Database/Action/Flow.hs

@@ -78,6 +78,7 @@ import Gargantext.Core (Lang(..), PosTagAlgo(..))
 -- import Gargantext.Core.Ext.IMT (toSchoolName)
 import Gargantext.Core.Ext.IMTUser (readFile_Annuaire)
 import Gargantext.Core.Flow.Types
+import Gargantext.Core.NLP (nlpServerGet)
 import Gargantext.Core.Text
 import Gargantext.Core.Text.Corpus.Parsers (parseFile, FileFormat, FileType, splitOn)
 import Gargantext.Core.Text.List (buildNgramsLists)
@@ -346,6 +347,7 @@ flowCorpusUser :: ( FlowCmdM env err m
                -> Maybe FlowSocialListWith
                -> m CorpusId
 flowCorpusUser l user userCorpusId listId ctype mfslw = do
+  server <- view (nlpServerGet l)
   -- User List Flow
   (masterUserId, _masterRootId, masterCorpusId)
     <- getOrMk_RootWithCorpus (UserName userMaster) (Left "") ctype
@@ -358,7 +360,7 @@ flowCorpusUser l user userCorpusId listId ctype mfslw = do
            pure ()
          _ -> do
            ngs  <- buildNgramsLists user userCorpusId masterCorpusId mfslw
-                     $ GroupWithPosTag l CoreNLP HashMap.empty
+                   $ GroupWithPosTag l server HashMap.empty
 
          -- printDebug "flowCorpusUser:ngs" ngs
 
@@ -558,10 +560,11 @@ instance ExtractNgramsT HyperdataDocument
                          $ maybe ["Nothing"] (splitOn Authors (doc^. hd_bdd))
                          $ _hd_authors doc
 
+          ncs <- view (nlpServerGet $ lang' ^. tt_lang)
 
           termsWithCounts' <- map (\(t, cnt) -> (enrichedTerms (lang' ^. tt_lang) CoreNLP NP t, cnt))
                               <$> concat
-                              <$> liftBase (extractTerms lang' $ hasText doc)
+                              <$> liftBase (extractTerms ncs lang' $ hasText doc)
 
           pure $ HashMap.fromList
                $  [(SimpleNgrams source, (Map.singleton Sources     1, 1))                    ]

src/Gargantext/Database/Action/Mail.hs

@@ -33,4 +33,3 @@ sendMail u = do
                      , mailInfo_address  = userLight_email    userLight
                      }
            )
-

src/Gargantext/Database/Prelude.hs

@@ -15,10 +15,10 @@ Portability : POSIX
 
 module Gargantext.Database.Prelude where
 
+--import Control.Monad.Logger (MonadLogger)
 import Control.Exception
 import Control.Lens (Getter, view)
 import Control.Monad.Except
---import Control.Monad.Logger (MonadLogger)
 import Control.Monad.Random
 import Control.Monad.Reader
 import Control.Monad.Trans.Control (MonadBaseControl)
@@ -34,17 +34,18 @@ import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(Conversion
 import Database.PostgreSQL.Simple.Internal  (Field)
 import Database.PostgreSQL.Simple.Types (Query(..))
 import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(), readIniFile', val)
 import Opaleye (Unpackspec, showSql, FromFields, Select, runSelect, SqlJsonb, DefaultFromField, toFields, matchMaybe, MaybeFields)
 import Opaleye.Aggregate (countRows)
-import qualified Opaleye.Internal.Constant
-import qualified Opaleye.Internal.Operators
 import System.IO (FilePath, stderr)
 import Text.Read (readMaybe)
 import qualified Data.ByteString      as DB
 import qualified Data.List as DL
 import qualified Database.PostgreSQL.Simple as PGS
+import qualified Opaleye.Internal.Constant
+import qualified Opaleye.Internal.Operators
 
 -------------------------------------------------------
 class HasConnectionPool env where
@@ -79,11 +80,15 @@ type CmdM' env err m =
   -- , MonadRandom             m
   )
 
-type CmdM env err m =
-  ( CmdM'             env err m
-  , HasConnectionPool env
+type CmdCommon env =
+  ( HasConnectionPool env
   , HasConfig         env
   , HasMail           env
+  , HasNLPServer      env )
+
+type CmdM env err m =
+  ( CmdM'     env err m
+  , CmdCommon env
   )
 
 type CmdRandom env err m =

src/Gargantext/Database/Query/Table/NgramsPostag.hs

@@ -155,11 +155,11 @@ SELECT terms,id FROM ins_form_ret
 
 -- TODO add lang and postag algo
 -- TODO remove when form == lem in insert
-selectLems :: Lang -> PosTagAlgo -> [Ngrams] -> Cmd err [(Form, Lem)]
-selectLems l a ns = runPGSQuery querySelectLems (PGS.Only $ Values fields datas)
+selectLems :: Lang -> NLPServerConfig -> [Ngrams] -> Cmd err [(Form, Lem)]
+selectLems l (NLPServerConfig { server }) ns = runPGSQuery querySelectLems (PGS.Only $ Values fields datas)
   where
     fields = map (\t -> QualifiedIdentifier Nothing t) ["int4","int4","text", "int4"]
-    datas  = map (\d -> [toField $ toDBid l, toField $ toDBid a] <> toRow d) ns 
+    datas  = map (\d -> [toField $ toDBid l, toField $ toDBid server] <> toRow d) ns
 
 ----------------------
 querySelectLems :: PGS.Query
@@ -203,5 +203,3 @@ createTable_NgramsPostag = map (\(PGS.Only a) -> a)
     CREATE UNIQUE INDEX ON public.ngrams_postag (lang_id,algo_id,postag,ngrams_id,lemm_id);
 
       |]
-
-

src/Gargantext/Utils/SpacyNLP.hs

@@ -27,6 +27,7 @@ import Gargantext.Core.Types (POS(..), NER(..))
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Prelude
 import Network.HTTP.Simple (parseRequest, httpJSON, setRequestBodyLBS, getResponseBody, Response)
+import Network.URI (URI(..))
 
 
 data SpacyData = SpacyData { _spacy_data :: ![SpacyText]}
@@ -79,10 +80,10 @@ data SpacyTags =
 data SpacyRequest = SpacyRequest { _spacyRequest_text :: !Text }
   deriving (Show)
 
-spacyRequest :: Text -> IO SpacyData
-spacyRequest txt = do
-  url <- parseRequest $ unpack "POST http://localhost:8001/pos"
-  let request = setRequestBodyLBS (encode $ SpacyRequest txt) url
+spacyRequest :: URI -> Text -> IO SpacyData
+spacyRequest uri txt = do
+  req <- parseRequest $ "POST " <> show (uri { uriPath = "/pos" })
+  let request = setRequestBodyLBS (encode $ SpacyRequest txt) req
   result <- httpJSON request :: IO (Response SpacyData)
   pure $ getResponseBody result
 
@@ -119,8 +120,8 @@ spacyDataToPosSentences (SpacyData ds) = PosSentences
 
 -----------------------------------------------------------------
 
-nlp :: Lang -> Text -> IO PosSentences
-nlp FR txt  = spacyDataToPosSentences <$> spacyRequest txt
-nlp _  _ = panic "Make sure you have the right model for your lang for spacy Server"
-
-
+nlp :: URI -> Lang -> Text -> IO PosSentences
+nlp uri FR txt = spacyDataToPosSentences <$> spacyRequest uri txt
+nlp _ _ _ = panic "Make sure you have the right model for your lang for spacy Server"
+-- nlp FR txt  = spacyDataToPosSentences <$> spacyRequest txt
+-- nlp _  _ = panic "Make sure you have the right model for your lang for spacy Server"

src/Gargantext/Utils/Tuple.hs

@@ -8,3 +8,7 @@ uncurryMaybe :: (Maybe a, Maybe b) -> Maybe (a, b)
 uncurryMaybe (Nothing, _) = Nothing
 uncurryMaybe (_, Nothing) = Nothing
 uncurryMaybe (Just a, Just b) = Just (a, b)
+
+uncurryMaybeSecond :: (a, Maybe b) -> Maybe (a, b)
+uncurryMaybeSecond (_, Nothing) = Nothing
+uncurryMaybeSecond (a, Just b) = Just (a, b)

stack.yaml

@@ -37,9 +37,10 @@ extra-deps:
 - HSvm-0.1.1.3.22
 - hsparql-0.3.8
 
-- git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
-  commit: 791c2a7046a3760f8ae5fabdbd708f61caa63741
-  #- git: https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude
+#- git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
+#  commit: 791c2a7046a3760f8ae5fabdbd708f61caa63741
+- git: https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude
+  commit: 175d4b295be2a0f56edc4eb6c7d8227d81bc2841
 - git: https://gitlab.iscpif.fr/gargantext/gargantext-graph.git
   commit: 588e104fe7593210956610cab0041fd16584a4ce
   # Data Mining Libs