diff --git a/gargantext.cabal b/gargantext.cabal
index 561b300720536772709e970a204653770e932d23..c35898385ff90f9fcc0b15f49151e5787ec00da1 100644
--- a/gargantext.cabal
+++ b/gargantext.cabal
@@ -62,11 +62,13 @@ library
Gargantext.API.Node.Corpus.Update
Gargantext.API.Node.File
Gargantext.API.Node.Share
+ Gargantext.API.Node.Update
Gargantext.API.Prelude
Gargantext.API.Routes
Gargantext.Core
- Gargantext.Core.NLP
+ Gargantext.Core.Mail.Types
Gargantext.Core.Methods.Similarities
+ Gargantext.Core.NLP
Gargantext.Core.NodeStory
Gargantext.Core.Text
Gargantext.Core.Text.Context
@@ -192,7 +194,6 @@ library
Gargantext.API.Node.Get
Gargantext.API.Node.New
Gargantext.API.Node.Types
- Gargantext.API.Node.Update
Gargantext.API.Public
Gargantext.API.Search
Gargantext.API.Server
@@ -205,7 +206,6 @@ library
Gargantext.Core.Flow.Ngrams
Gargantext.Core.Flow.Types
Gargantext.Core.Mail
- Gargantext.Core.Mail.Types
Gargantext.Core.Methods.Graph.BAC.Proxemy
Gargantext.Core.Methods.Graph.MaxClique
Gargantext.Core.Methods.Matrix.Accelerate.Utils
@@ -938,6 +938,7 @@ test-suite garg-test-tasty
, crawlerArxiv
, duckling ^>= 0.2.0.0
, extra ^>= 1.7.9
+ , fast-logger ^>= 3.0.5
, fmt
, gargantext
, gargantext-prelude
@@ -1041,6 +1042,7 @@ test-suite garg-test-hspec
, crawlerArxiv
, duckling ^>= 0.2.0.0
, extra ^>= 1.7.9
+ , fast-logger ^>= 3.0.5
, fmt
, gargantext
, gargantext-prelude
diff --git a/src/Gargantext/API/Admin/EnvTypes.hs b/src/Gargantext/API/Admin/EnvTypes.hs
index 6e0dc13ad88302359409d346242bc2b2b99337be..ad8b6e770d42403e71bdb695d647673f86ad2283 100644
--- a/src/Gargantext/API/Admin/EnvTypes.hs
+++ b/src/Gargantext/API/Admin/EnvTypes.hs
@@ -8,6 +8,7 @@ module Gargantext.API.Admin.EnvTypes (
GargJob(..)
, Env(..)
, Mode(..)
+ , modeToLoggingLevels
, mkJobHandle
, env_logger
, env_manager
diff --git a/src/Gargantext/API/Node/Update.hs b/src/Gargantext/API/Node/Update.hs
index 5eaecd614b608d96f8d75cafc70cea783723c5f7..056b8cb719bfb8165b4e1c9c588f8f5fe36d12de 100644
--- a/src/Gargantext/API/Node/Update.hs
+++ b/src/Gargantext/API/Node/Update.hs
@@ -181,24 +181,31 @@ updateNode _userId phyloId (UpdateNodePhylo config) jobHandle = do
updateNode _uId tId (UpdateNodeParamsTexts _mode) jobHandle = do
markStarted 3 jobHandle
corpusId <- view node_parent_id <$> getNode tId
- lId <- defaultList $ fromMaybe (panic "[G.A.N.Update] updateNode/UpdateNodeParamsTexts: no defaultList") corpusId
markProgress 1 jobHandle
_ <- case corpusId of
- Just cId -> do
- _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
- _ <- updateNgramsOccurrences cId (Just lId)
- _ <- updateContextScore cId (Just lId)
- _ <- Metrics.updateChart cId (Just lId) NgramsTypes.Docs Nothing
- -- printDebug "updateContextsScore" (cId, lId, u)
+ Just cId -> updateDocs cId
+ Nothing -> do
+ _ <- panic "[G.A.N.Update] updateNode/UpdateNodeParamsText: no corpus Id given"
pure ()
- Nothing -> pure ()
markComplete jobHandle
updateNode _uId _nId _p jobHandle = do
simuLogs jobHandle 10
+------------------------------------------------------------------------
+
+updateDocs :: (FlowCmdM env err m, MonadJobStatus m)
+ => NodeId -> m ()
+updateDocs cId = do
+ lId <- defaultList cId
+ _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
+ _ <- updateNgramsOccurrences cId (Just lId)
+ _ <- updateContextScore cId (Just lId)
+ _ <- Metrics.updateChart cId (Just lId) NgramsTypes.Docs Nothing
+ -- printDebug "updateContextsScore" (cId, lId, u)
+ pure ()
------------------------------------------------------------------------
-- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
diff --git a/src/Gargantext/Core/NLP.hs b/src/Gargantext/Core/NLP.hs
index d5103e922080ec9731f12be0403a05d1d23d20d6..74cb58c99a2fbd261bae6bb25f9cf1fb682c1eaf 100644
--- a/src/Gargantext/Core/NLP.hs
+++ b/src/Gargantext/Core/NLP.hs
@@ -1,3 +1,13 @@
+{-|
+Module : Gargantext.Core.NLP
+Description : GarganText NLP
+Copyright : (c) CNRS, 2017-Present
+License : AGPL + CECILL v3
+Maintainer : team@gargantext.org
+Stability : experimental
+Portability : POSIX
+-}
+
module Gargantext.Core.NLP where
import Control.Lens (Getter, at, non)
diff --git a/test/Test/Database/Operations.hs b/test/Test/Database/Operations.hs
index e8fdface9e1ca7215e941e39cd1f522b85640f08..b452a73927af3dab29bf2943aea2bc079d66dddb 100644
--- a/test/Test/Database/Operations.hs
+++ b/test/Test/Database/Operations.hs
@@ -64,6 +64,7 @@ tests = sequential $ aroundAll withTestDB $ describe "Database" $ do
it "Can perform a simple search inside documents" corpusSearch01
it "Can perform search by author in documents" corpusSearch02
it "Can perform more complex searches using the boolean API" corpusSearch03
+ it "Can correctly count doc score" corpusScore01
data ExpectedActual a =
Expected a
diff --git a/test/Test/Database/Operations/DocumentSearch.hs b/test/Test/Database/Operations/DocumentSearch.hs
index 7fb3e3177e9f727a604f31daf38130281e9042fe..bf3c04cb37f81538c941c8c747d470a7bf63e3db 100644
--- a/test/Test/Database/Operations/DocumentSearch.hs
+++ b/test/Test/Database/Operations/DocumentSearch.hs
@@ -1,14 +1,28 @@
+{-|
+Module : Test.Database.Operations.DocumentSearch
+Description : GarganText database tests
+Copyright : (c) CNRS, 2017-Present
+License : AGPL + CECILL v3
+Maintainer : team@gargantext.org
+Stability : experimental
+Portability : POSIX
+-}
+
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
+
module Test.Database.Operations.DocumentSearch where
import Prelude
+import Control.Lens (view)
import Control.Monad.Reader
import Data.Aeson.QQ.Simple
import Data.Aeson.Types
import Data.Maybe
+import Gargantext.API.Node.Update (updateDocs)
import Gargantext.Core
+import Gargantext.Core.NLP (nlpServerGet)
import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.Flow
import Gargantext.Database.Action.Search
@@ -104,11 +118,6 @@ exampleDocument_04 = either error id $ parseEither parseJSON $ [aesonQQ|
}
|]
-nlpServerConfig :: NLPServerConfig
-nlpServerConfig =
- let uri = parseURI "http://localhost:9000"
- in NLPServerConfig CoreNLP (fromMaybe (error "parseURI for nlpServerConfig failed") uri)
-
corpusAddDocuments :: TestEnv -> Assertion
corpusAddDocuments env = do
flip runReaderT env $ runTestMonad $ do
@@ -118,9 +127,11 @@ corpusAddDocuments env = do
[corpus] <- getCorporaWithParentId parentId
let corpusId = _node_id corpus
- ids <- addDocumentsToHyperCorpus nlpServerConfig
+ let lang = EN
+ server <- view (nlpServerGet lang)
+ ids <- addDocumentsToHyperCorpus server
(Just $ _node_hyperdata $ corpus)
- (Multi EN)
+ (Multi lang)
corpusId
[exampleDocument_01, exampleDocument_02, exampleDocument_03, exampleDocument_04]
liftIO $ length ids `shouldBe` 4
@@ -177,3 +188,23 @@ corpusSearch03 env = do
length results1 `shouldBe` 1
map facetDoc_title results2 `shouldBe` ["Haskell for OCaml programmers"]
map facetDoc_title results3 `shouldBe` ["PyPlasm: computational geometry made easy", "Haskell for OCaml programmers"]
+
+-- | Check that the score doc count is correct
+corpusScore01 :: TestEnv -> Assertion
+corpusScore01 env = do
+ flip runReaderT env $ runTestMonad $ do
+
+ parentId <- getRootId (UserName userMaster)
+ [corpus] <- getCorporaWithParentId parentId
+
+ results <- searchInCorpus (_node_id corpus) False (mkQ "Haskell") Nothing Nothing Nothing
+
+ liftIO $ do
+ map facetDoc_title results `shouldBe` ["Haskell for OCaml programmers", "Rust for functional programmers"]
+
+ map facetDoc_score results `shouldBe` [Just 0.0, Just 0.0]
+
+ _ <- updateDocs (_node_id corpus)
+
+ liftIO $ do
+ map facetDoc_score results `shouldBe` [Just 0.0, Just 0.0]
diff --git a/test/Test/Database/Setup.hs b/test/Test/Database/Setup.hs
index 92a522b93f15aaf1f7df869325c775c99e62dcda..30448ba8b22d95030e0120270f4a8bd1cb3e4bf6 100644
--- a/test/Test/Database/Setup.hs
+++ b/test/Test/Database/Setup.hs
@@ -10,20 +10,21 @@ import Control.Monad
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Pool hiding (withResource)
+import Data.Pool qualified as Pool
import Data.String
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as TE
+import Database.PostgreSQL.Simple qualified as PG
+import Database.PostgreSQL.Simple.Options qualified as Client
+import Database.PostgreSQL.Simple.Options qualified as Opts
+import Database.Postgres.Temp qualified as Tmp
+import Gargantext.API.Admin.EnvTypes (Mode(Mock))
import Gargantext.Prelude.Config
+import Gargantext.System.Logging (withLoggerHoisted)
import Paths_gargantext
import Prelude
import Shelly hiding (FilePath, run)
-import qualified Data.Pool as Pool
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import qualified Database.PostgreSQL.Simple as PG
-import qualified Database.PostgreSQL.Simple.Options as Client
-import qualified Database.PostgreSQL.Simple.Options as Opts
-import qualified Database.Postgres.Temp as Tmp
-import qualified Shelly as SH
-
+import Shelly qualified as SH
import Test.Database.Types
-- | Test DB settings.
@@ -73,7 +74,8 @@ setup = do
(PG.close) 2 60 2
bootstrapDB db pool gargConfig
ugen <- emptyCounter
- pure $ TestEnv (DBHandle pool db) gargConfig ugen
+ withLoggerHoisted Mock $ \logger -> do
+ pure $ TestEnv (DBHandle pool db) gargConfig ugen logger
withTestDB :: (TestEnv -> IO ()) -> IO ()
withTestDB = bracket setup teardown
diff --git a/test/Test/Database/Types.hs b/test/Test/Database/Types.hs
index 8e8105dd4680783096ede74fe9f9c78e36c6faeb..537d7bee769aa2732b109105e71984af85363a05 100644
--- a/test/Test/Database/Types.hs
+++ b/test/Test/Database/Types.hs
@@ -1,3 +1,13 @@
+{-|
+Module : Test.Database.Types
+Description : GarganText tests
+Copyright : (c) CNRS, 2017-Present
+License : AGPL + CECILL v3
+Maintainer : team@gargantext.org
+Stability : experimental
+Portability : POSIX
+-}
+
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
@@ -10,18 +20,27 @@ import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.IORef
+import Data.Map qualified as Map
+import Data.Maybe (fromMaybe)
import Data.Pool
+import Data.Text qualified as T
+import Database.PostgreSQL.Simple qualified as PG
+import Database.Postgres.Temp qualified as Tmp
import Gargantext
import Gargantext.API.Admin.EnvTypes
+import Gargantext.API.Admin.EnvTypes qualified as EnvTypes
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Prelude
+import Gargantext.Core.Mail.Types (HasMail(..))
+import Gargantext.Core.NLP (HasNLPServer(..))
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Prelude.Config
+import Gargantext.Prelude.Mail.Types (MailConfig(..), LoginType(NoAuth))
+import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..))
import Gargantext.Utils.Jobs
+import Network.URI (parseURI)
import Prelude
-import qualified Database.PostgreSQL.Simple as PG
-import qualified Database.Postgres.Temp as Tmp
-import qualified Gargantext.API.Admin.EnvTypes as EnvTypes
+import System.Log.FastLogger qualified as FL
newtype Counter = Counter { _Counter :: IORef Int }
deriving Eq
@@ -39,6 +58,7 @@ data TestEnv = TestEnv {
test_db :: !DBHandle
, test_config :: !GargConfig
, test_usernameGen :: !Counter
+ , test_logger :: !(Logger (GargM TestEnv GargError))
}
newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
@@ -79,3 +99,40 @@ instance HasConnectionPool TestEnv where
instance HasConfig TestEnv where
hasConfig = to test_config
+instance HasMail TestEnv where
+ mailSettings = to $ const (MailConfig { _mc_mail_host = "localhost"
+ , _mc_mail_port = 25
+ , _mc_mail_user = "test"
+ , _mc_mail_from = "test@localhost"
+ , _mc_mail_password = "test"
+ , _mc_mail_login_type = NoAuth })
+
+coreNLPConfig :: NLPServerConfig
+coreNLPConfig =
+ let uri = parseURI "http://localhost:9000"
+ in NLPServerConfig CoreNLP (fromMaybe (error "parseURI for nlpServerConfig failed") uri)
+
+
+instance HasNLPServer TestEnv where
+ nlpServer = to $ const (Map.singleton EN coreNLPConfig)
+
+instance MonadLogger (GargM TestEnv GargError) where
+ getLogger = asks test_logger
+
+instance HasLogger (GargM TestEnv GargError) where
+ data instance Logger (GargM TestEnv GargError) =
+ GargTestLogger {
+ test_logger_mode :: Mode
+ , test_logger_set :: FL.LoggerSet
+ }
+ type instance LogInitParams (GargM TestEnv GargError) = Mode
+ type instance LogPayload (GargM TestEnv GargError) = FL.LogStr
+ initLogger = \mode -> do
+ test_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
+ pure $ GargTestLogger mode test_logger_set
+ destroyLogger = \GargTestLogger{..} -> liftIO $ FL.rmLoggerSet test_logger_set
+ logMsg = \(GargTestLogger mode logger_set) lvl msg -> do
+ let pfx = "[" <> show lvl <> "] "
+ when (lvl `elem` (modeToLoggingLevels mode)) $
+ liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
+ logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)