[tests] attempt to add tests for doc score

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

src/Gargantext/API/Admin/EnvTypes.hs

@@ -8,6 +8,7 @@ module Gargantext.API.Admin.EnvTypes (
     GargJob(..)
   , Env(..)
   , Mode(..)
+  , modeToLoggingLevels
   , mkJobHandle
   , env_logger
   , env_manager

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.

src/Gargantext/Core/NLP.hs

+{-|
+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)

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

test/Test/Database/Operations/DocumentSearch.hs

+{-|
+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]

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

test/Test/Database/Types.hs

+{-|
+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)