From 0cc0f9e67397f4ee95199cbe99fe775da7c8116e Mon Sep 17 00:00:00 2001
From: Alfredo Di Napoli <alfredo@well-typed.com>
Date: Mon, 4 Sep 2023 09:01:41 +0200
Subject: [PATCH] Add test for adding language to Corpus
---
gargantext.cabal | 2 +-
src/Gargantext/API/Node/Corpus/Update.hs | 5 +--
src/Gargantext/Database/Query/Table/Node.hs | 2 +-
test/Database/Operations.hs | 38 +++++++++++++++++++--
4 files changed, 41 insertions(+), 6 deletions(-)
diff --git a/gargantext.cabal b/gargantext.cabal
index b6c07de3..d5822b26 100644
--- a/gargantext.cabal
+++ b/gargantext.cabal
@@ -58,6 +58,7 @@ library
Gargantext.API.Node
Gargantext.API.Node.Corpus.New
Gargantext.API.Node.Corpus.Types
+ Gargantext.API.Node.Corpus.Update
Gargantext.API.Node.File
Gargantext.API.Node.Share
Gargantext.API.Prelude
@@ -175,7 +176,6 @@ library
Gargantext.API.Node.Corpus.New.File
Gargantext.API.Node.Corpus.New.Types
Gargantext.API.Node.Corpus.Searx
- Gargantext.API.Node.Corpus.Update
Gargantext.API.Node.Document.Export
Gargantext.API.Node.Document.Export.Types
Gargantext.API.Node.DocumentsFromWriteNodes
diff --git a/src/Gargantext/API/Node/Corpus/Update.hs b/src/Gargantext/API/Node/Corpus/Update.hs
index 4ec20aee..ab2c9ee9 100644
--- a/src/Gargantext/API/Node/Corpus/Update.hs
+++ b/src/Gargantext/API/Node/Corpus/Update.hs
@@ -7,17 +7,18 @@ import Control.Lens
import Control.Monad
import Data.Proxy
import Gargantext.Core
-import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Admin.Types.Hyperdata.Corpus
import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude
import Gargantext.Utils.Jobs
-- | Updates the 'HyperdataCorpus' with the input 'Lang'.
-addLanguageToCorpus :: (FlowCmdM env err m, MonadJobStatus m)
+addLanguageToCorpus :: (HasNodeError err, DbCmd' env err m, MonadJobStatus m)
=> CorpusId
-> Lang
-> m ()
diff --git a/src/Gargantext/Database/Query/Table/Node.hs b/src/Gargantext/Database/Query/Table/Node.hs
index c241ff5e..b1ff99e1 100644
--- a/src/Gargantext/Database/Query/Table/Node.hs
+++ b/src/Gargantext/Database/Query/Table/Node.hs
@@ -260,7 +260,7 @@ getNode nId = do
Just r -> pure r
getNodeWith :: (HasNodeError err, JSONB a)
- => NodeId -> proxy a -> Cmd err (Node a)
+ => NodeId -> proxy a -> DBCmd err (Node a)
getNodeWith nId _ = do
maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
case maybeNode of
diff --git a/test/Database/Operations.hs b/test/Database/Operations.hs
index 7e205085..0b59b52f 100644
--- a/test/Database/Operations.hs
+++ b/test/Database/Operations.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE TypeFamilies #-}
module Database.Operations (
tests
@@ -44,6 +45,13 @@ import Test.Hspec
import Test.QuickCheck.Monadic
import Test.Tasty.HUnit hiding (assert)
import Test.Tasty.QuickCheck
+import Gargantext.API.Node.Corpus.Update
+import Gargantext.Core
+import Gargantext.Utils.Jobs
+import qualified Gargantext.API.Admin.EnvTypes as EnvTypes
+import Gargantext.API.Admin.EnvTypes
+import Gargantext.API.Prelude
+import Gargantext.API.Admin.Orchestrator.Types
-- | Keeps a log of usernames we have already generated, so that our
-- roundtrip tests won't fail.
@@ -89,6 +97,21 @@ newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
, MonadIO
)
+instance MonadJobStatus TestMonad where
+ type JobHandle TestMonad = EnvTypes.ConcreteJobHandle GargError
+ type JobType TestMonad = GargJob
+ type JobOutputType TestMonad = JobLog
+ type JobEventType TestMonad = JobLog
+
+ getLatestJobStatus _ = TestMonad (pure noJobLog)
+ withTracer _ jh n = n jh
+ markStarted _ _ = TestMonad $ pure ()
+ markProgress _ _ = TestMonad $ pure ()
+ markFailure _ _ _ = TestMonad $ pure ()
+ markComplete _ = TestMonad $ pure ()
+ markFailed _ _ = TestMonad $ pure ()
+ addMoreSteps _ _ = TestMonad $ pure ()
+
data DBHandle = DBHandle {
_DBHandle :: Pool PG.Connection
, _DBTmp :: Tmp.DB
@@ -158,6 +181,7 @@ tests = sequential $ aroundAll withTestDB $ describe "Database" $ do
it "Read/Write roundtrip" prop_userCreationRoundtrip
describe "Corpus creation" $ do
it "Simple write/read" corpusReadWrite01
+ it "Can add language to Corpus" corpusAddLanguage
data ExpectedActual a =
Expected a
@@ -224,5 +248,15 @@ corpusReadWrite01 env = do
[corpusId] <- mk (Just "Test_Corpus") (Nothing :: Maybe HyperdataCorpus) parentId uid
liftIO $ corpusId `shouldBe` NodeId 409
-- Retrieve the corpus by Id
- [corpusId'] <- getCorporaWithParentId parentId
- liftIO $ corpusId `shouldBe` (_node_id corpusId')
+ [corpus] <- getCorporaWithParentId parentId
+ liftIO $ corpusId `shouldBe` (_node_id corpus)
+
+corpusAddLanguage :: TestEnv -> Assertion
+corpusAddLanguage env = do
+ flip runReaderT env $ runTestMonad $ do
+ parentId <- getRootId (UserName "alfredo")
+ [corpus] <- getCorporaWithParentId parentId
+ liftIO $ (_hc_lang . _node_hyperdata $ corpus) `shouldBe` Just EN -- defaults to English
+ addLanguageToCorpus (_node_id corpus) IT
+ [corpus'] <- getCorporaWithParentId parentId
+ liftIO $ (_hc_lang . _node_hyperdata $ corpus') `shouldBe` Just IT
--
2.21.0