[test] paralellize db tests

Ref: #238, #341, #418

gargantext.cabal

@@ -179,6 +179,7 @@ library
       Gargantext.Core.Config.Types
       Gargantext.Core.Config.Utils
       Gargantext.Core.Config.Worker
+      Gargantext.Core.Mail
       Gargantext.Core.Mail.Types
       Gargantext.Core.Methods.Similarities
       Gargantext.Core.Methods.Similarities.Conditional
@@ -344,7 +345,6 @@ library
       Gargantext.Core.Ext.IMTUser
       Gargantext.Core.Flow.Ngrams
       Gargantext.Core.Flow.Types
-      Gargantext.Core.Mail
       Gargantext.Core.Methods.Graph.MaxClique
       Gargantext.Core.Methods.Matrix.Accelerate.Utils
       Gargantext.Core.Methods.Similarities.Accelerate.Conditional

src/Gargantext/API/Table.hs

@@ -123,7 +123,7 @@ searchInCorpus' cId t q o l order = do
       pure $ TableResult 0 []
     Right boolQuery -> do
       docs          <- searchInCorpus cId t boolQuery o l order
-      countAllDocs  <- searchCountInCorpus cId t boolQuery
+      countAllDocs  <- searchCountInCorpus cId t (Just boolQuery)
       pure $ TableResult { tr_docs = docs
                          , tr_count = countAllDocs }
 

src/Gargantext/Database/Action/Search.hs

@@ -235,23 +235,25 @@ searchInCorpus :: HasDBid NodeType
 searchInCorpus cId t q o l order = runOpaQuery
                                  $ filterWith o l order
                                  $ queryInCorpus cId t
-                                 $ q
+                                 $ Just q
 
 searchCountInCorpus :: HasDBid NodeType
                     => CorpusId
                     -> IsTrash
-                    -> API.Query
+                    -> Maybe API.Query
                     -> DBCmd err Int
-searchCountInCorpus cId t q = runCountOpaQuery
+searchCountInCorpus cId t mq = runCountOpaQuery
                              $ queryInCorpus cId t
-                            $ q
+                             $ mq
 
+-- | Arrow query for searching in corpus. If query parameter is None,
+-- it is assumed that there is no text query (i.e. return all docs).
 queryInCorpus :: HasDBid NodeType
               => CorpusId
               -> IsTrash
-              -> API.Query
+              -> Maybe API.Query
               -> O.Select FacetDocRead
-queryInCorpus cId t q = proc () -> do
+queryInCorpus cId t mq = proc () -> do
   c <- queryContextSearchTable -< ()
   nc <- optionalRestrict queryNodeContextTable -<
     \nc' -> (nc' ^. nc_context_id) .== _cs_id c
@@ -261,7 +263,10 @@ queryInCorpus cId t q = proc () -> do
                  else matchMaybe (view nc_category <$> nc) $ \case
                         Nothing -> toFields False
                         Just c' -> c' .>= sqlInt4 1
-  restrict -< (c ^. cs_search)           @@ queryToTsSearch q
+  restrict -< case mq of
+                -- Some idempotent operation
+                Nothing -> sqlBool True .== sqlBool True
+                Just q -> (c ^. cs_search)           @@ queryToTsSearch q
   restrict -< (c ^. cs_typename )       .== sqlInt4 (toDBid NodeDocument)
   returnA  -< FacetDoc { facetDoc_id         = c^.cs_id
                        , facetDoc_created    = c^.cs_date

test/Test/Database/Operations.hs

@@ -13,10 +13,12 @@ module Test.Database.Operations (
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Text qualified as T
+import Data.Text.Encoding qualified as TE
 import Database.PostgreSQL.Simple
 import Database.PostgreSQL.Simple.SqlQQ
 import Gargantext.API.Node.Corpus.Update
 import Gargantext.Core
+import Gargantext.Core.Mail (EmailAddress)
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Action.User
 import Gargantext.Database.Action.User.New
@@ -37,6 +39,7 @@ import Test.QuickCheck.Monadic
 import Test.Tasty.HUnit hiding (assert)
 import Test.Tasty.QuickCheck
 
+
 -- | Keeps a log of usernames we have already generated, so that our
 -- roundtrip tests won't fail.
 uniqueArbitraryNewUser :: Int -> Gen (NewUser GargPassword)
@@ -49,15 +52,19 @@ uniqueArbitraryNewUser currentIx = do
    ascii_txt = fmap (T.pack . getPrintableString) arbitrary
 
 tests :: Spec
-tests = sequential $ aroundAll withTestDB $ beforeAllWith (\ctx -> setupEnvironment ctx >>= (const $ pure ctx)) $ describe "Database" $ do
-  describe "Read/Writes" $ do
+tests = parallel $ around withTestDB $ beforeWith (\ctx -> setupEnvironment ctx >>= (const $ pure ctx)) $
+  describe "Database" $ do
     describe "User creation" $ do
       it "Simple write/read" writeRead01
-      it "Simple duplicate"  mkUserDup
       it "Read/Write roundtrip" prop_userCreationRoundtrip
+    describe "With test user" $ beforeWith setupTestUser $ do
+      describe "User tests" $ do
+        it "Simple duplicate"  mkUserDup
       describe "Corpus creation" $ do
         it "Simple write/read" corpusReadWrite01
+      describe "With test corpus" $ beforeWith setupTestCorpus $ do
         it "Can add language to Corpus" corpusAddLanguage
+        describe "With test documents" $ beforeWith addCorpusDocuments $ do
           it "Can add documents to a Corpus" corpusAddDocuments
           describe "Corpus search" $ do
             it "Can stem query terms" stemmingTest
@@ -96,10 +103,21 @@ instance Eq a => Eq (ExpectedActual a) where
   (Actual a)   == (Expected b) = a == b
   _ == _ = False
 
+
+testUsername' :: Text
+testUsername' = "alfredo"
+testUsername :: User
+testUsername = UserName testUsername'
+testUser :: EmailAddress
+testUser = testUsername' <> "@well-typed.com"
+testUserPassword :: GargPassword
+testUserPassword = GargPassword "my_secret"
+testCorpusName :: Text
+testCorpusName = "Text_Corpus"
+
 writeRead01 :: TestEnv -> Assertion
-writeRead01 env = do
-  flip runReaderT env $ runTestMonad $ do
-    let nur1 = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
+writeRead01 env = flip runReaderT env $ runTestMonad $ do
+  let nur1 = mkNewUser testUser testUserPassword
   let nur2 = mkNewUser "paul@acme.com" (GargPassword "my_secret")
 
   uid1 <- new_user nur1
@@ -109,16 +127,24 @@ writeRead01 env = do
   liftBase $ uid2 `shouldBe` UnsafeMkUserId 3
 
   -- Getting the users by username returns the expected IDs
-    uid1' <- getUserId (UserName "alfredo")
+  uid1' <- getUserId testUsername
   uid2' <- getUserId (UserName "paul")
   liftBase $ uid1' `shouldBe` UnsafeMkUserId 2
   liftBase $ uid2' `shouldBe` UnsafeMkUserId 3
 
+-- | Create test user, to be used in subsequent tests
+setupTestUser :: TestEnv -> IO TestEnv
+setupTestUser env = flip runReaderT env $ runTestMonad $ do
+  let nur = mkNewUser testUser testUserPassword
+  _ <- new_user nur
+  pure env
+
 mkUserDup :: TestEnv -> Assertion
 mkUserDup env = do
   let x = flip runReaderT env $ runTestMonad $ do
+        let nur = mkNewUser testUser testUserPassword
+        
         -- This should fail, because user 'alfredo' exists already.
-            let nur = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
         new_user nur
   --
   -- SqlError {sqlState = "23505", sqlExecStatus = FatalError
@@ -129,7 +155,7 @@ mkUserDup env = do
   -- Postgres increments the underlying SERIAL for the user even if the request fails, see
   -- https://stackoverflow.com/questions/37204749/serial-in-postgres-is-being-increased-even-though-i-added-on-conflict-do-nothing
   -- This means that the next available ID is '3'.
-  x `shouldThrow` (\SqlError{..} -> sqlErrorDetail == "Key (username)=(alfredo) already exists.")
+  x `shouldThrow` (\SqlError{..} -> sqlErrorDetail == ("Key (username)=(" <> TE.encodeUtf8 testUsername' <> ") already exists."))
 
 runEnv :: TestEnv -> TestMonad a -> PropertyM IO a
 runEnv env act = run (flip runReaderT env $ runTestMonad act)
@@ -142,15 +168,22 @@ prop_userCreationRoundtrip env = monadicIO $ do
   ur' <- runEnv env (getUserId (UserName $ _nu_username nur))
   run (Expected uid `shouldBe` Actual ur')
 
+-- | Create a test corpus, to be used in subsequent tests
+setupTestCorpus :: TestEnv -> IO TestEnv
+setupTestCorpus env = flip runReaderT env $ runTestMonad $ do
+  uid      <- getUserId testUsername
+  parentId <- getRootId testUsername
+  _ <- mk (Just testCorpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
+  pure env
+
 -- | We test that we can create and later read-back a 'Corpus'.
 corpusReadWrite01 :: TestEnv -> Assertion
 corpusReadWrite01 env = do
   flip runReaderT env $ runTestMonad $ do
-    uid      <- getUserId (UserName "alfredo")
-    parentId <- getRootId (UserName "alfredo")
-    let corpusName = "Test_Corpus"
-    [corpusId] <- mk (Just corpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
-    [Only corpusId'] <- runPGSQuery [sql|SELECT id FROM nodes WHERE name = ?|] (Only corpusName)
+    uid      <- getUserId testUsername
+    parentId <- getRootId testUsername
+    [corpusId] <- mk (Just testCorpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
+    [Only corpusId'] <- runPGSQuery [sql|SELECT id FROM nodes WHERE name = ?|] (Only testCorpusName)
     liftIO $ corpusId `shouldBe` UnsafeMkNodeId corpusId'
     -- Retrieve the corpus by Id
     [corpus] <- getCorporaWithParentId parentId
@@ -160,7 +193,7 @@ corpusReadWrite01 env = do
 corpusAddLanguage :: TestEnv -> Assertion
 corpusAddLanguage env = do
   flip runReaderT env $ runTestMonad $ do
-    parentId <- getRootId (UserName "alfredo")
+    parentId <- getRootId testUsername
     [corpus] <- getCorporaWithParentId parentId
     liftIO $ (_hc_lang . _node_hyperdata $ corpus) `shouldBe` Just EN -- defaults to English
     addLanguageToCorpus (_node_id corpus) IT

test/Test/Database/Operations/DocumentSearch.hs

@@ -12,33 +12,31 @@ Portability : POSIX
 
 module Test.Database.Operations.DocumentSearch where
 
-import Prelude
-
+-- import Gargantext.API.Node.Update (updateDocs)
+-- import Network.URI (parseURI)
 import Control.Lens (view)
 import Control.Monad.Reader
 import Data.Aeson.QQ.Simple
 import Data.Aeson.Types
--- import Gargantext.API.Node.Update (updateDocs)
+import Data.Text qualified as T
 import Gargantext.Core
 import Gargantext.Core.NLP (nlpServerGet)
+import Gargantext.Core.Text.Corpus.Query qualified as API
+import Gargantext.Core.Text.Terms.Mono.Stem
 import Gargantext.Core.Types.Individu
 import Gargantext.Core.Worker.Env ()  -- instance HasNodeError
 import Gargantext.Database.Action.Flow
 import Gargantext.Database.Action.Search
+import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Admin.Types.Hyperdata.Document
+import Gargantext.Database.Query.Facet
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Tree.Root
 import Gargantext.Database.Schema.Node (NodePoly(..))
--- import Network.URI (parseURI)
-
+import Prelude
 import Test.Database.Types
 import Test.Hspec.Expectations
 import Test.Tasty.HUnit
-import Gargantext.Core.Text.Terms.Mono.Stem
-import Gargantext.Database.Admin.Config (userMaster)
-import qualified Data.Text as T
-import qualified Gargantext.Core.Text.Corpus.Query as API
-import Gargantext.Database.Query.Facet
 
 
 exampleDocument_01 :: HyperdataDocument
@@ -114,9 +112,8 @@ exampleDocument_04 = either error id $ parseEither parseJSON $ [aesonQQ|
 }
 |]
 
-corpusAddDocuments :: TestEnv -> Assertion
-corpusAddDocuments env = do
-  flip runReaderT env $ runTestMonad $ do
+addCorpusDocuments :: TestEnv -> IO TestEnv
+addCorpusDocuments env = flip runReaderT env $ runTestMonad $ do
   -- NOTE(adn) We need to create user 'gargantua'(!!) in order
   -- for 'addDocumentsToHyperCorpus' to work.
   parentId <- getRootId (UserName userMaster)
@@ -124,13 +121,23 @@ corpusAddDocuments env = do
   let corpusId = _node_id corpus
 
   let lang = EN
+  let docs = [exampleDocument_01, exampleDocument_02, exampleDocument_03, exampleDocument_04]
   server <- view (nlpServerGet lang)
-    ids <- addDocumentsToHyperCorpus server
+  _ <- addDocumentsToHyperCorpus server
                                  (Just $ _node_hyperdata $ corpus)
                                  (Multi lang)
                                  corpusId
-                                     [exampleDocument_01, exampleDocument_02, exampleDocument_03, exampleDocument_04]
-    liftIO $ length ids `shouldBe` 4
+                                 docs
+  pure env
+  
+corpusAddDocuments :: TestEnv -> Assertion
+corpusAddDocuments env = flip runReaderT env $ runTestMonad $ do
+  parentId <- getRootId (UserName userMaster)
+  [corpus] <- getCorporaWithParentId parentId
+  let corpusId = _node_id corpus
+  
+  cnt <- searchCountInCorpus corpusId False Nothing
+  liftIO $ cnt `shouldBe` 4
 
 stemmingTest :: TestEnv -> Assertion
 stemmingTest _env = do