Tests compile again

src/Gargantext/API/Errors.hs

@@ -79,6 +79,11 @@ backendErrorToFrontendError = \case
          $ FE_validation_error $ case prettyValidation validationError of
              Nothing -> "unknown_validation_error"
              Just v  -> T.pack v
+  -- Worker errors might contain sensitive information, so we don't
+  -- want to expose that to the frontend.
+  InternalWorkerError _workerError
+    -> let msg = T.pack $ "An unexpected error occurred in one of the async worker tasks. Please check your server logs."
+       in mkFrontendErr' msg $ FE_internal_server_error msg
   AccessPolicyError accessPolicyError
     -> case accessPolicyError of
          AccessPolicyNodeError nodeError

src/Gargantext/API/Errors/Types.hs

@@ -118,6 +118,7 @@ data BackendInternalError
   | InternalTreeError           !TreeError
   | InternalUnexpectedError     !SomeException
   | InternalValidationError     !Validation
+  | InternalWorkerError         !IOException
   | AccessPolicyError           !AccessPolicyErrorReason
   deriving (Show, Typeable)
 

src/Gargantext/Core/Worker/Env.hs

@@ -12,7 +12,7 @@ Portability : POSIX
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-orphans      #-}  -- orphan HasNodeError IOException
+{-# OPTIONS_GHC -Wno-orphans      #-}  -- orphan HasNodeError BackendInternalError
 
 
 module Gargantext.Core.Worker.Env where
@@ -20,13 +20,12 @@ module Gargantext.Core.Worker.Env where
 
 import Control.Concurrent.STM.TVar (TVar, modifyTVar, newTVarIO, readTVarIO)
 import Control.Exception.Safe qualified as CES
-import Control.Lens (prism', to, view)
+import Control.Lens (to, view)
 import Control.Lens.TH
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Maybe (fromJust)
 import Data.Pool qualified as Pool
 import Database.PostgreSQL.Simple qualified as PSQL
-import GHC.IO.Exception (IOException(..), IOErrorType(OtherError))
 import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog)
 import Gargantext.API.Errors (BackendInternalError)
 import Gargantext.API.Job (RemainingSteps(..), jobLogStart, jobLogProgress, jobLogFailures, jobLogComplete, addErrorEvent, jobLogFailTotal, jobLogFailTotalWithMessage, jobLogAddMore, addWarningEvent)
@@ -40,22 +39,18 @@ import Gargantext.Core.NLP (HasNLPServer(..), NLPServerMap, nlpServerMap)
 import Gargantext.Core.NodeStory (HasNodeStoryEnv(..), NodeStoryEnv, mkNodeStoryEnv)
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
 import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
-import Gargantext.Core.Types (HasValidationError(..))
 import Gargantext.Core.Worker.Types (JobInfo(..))
 import Gargantext.Database.Prelude (HasConnectionPool(..))
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
-import Gargantext.Database.Query.Tree.Error (HasTreeError(..))
 import Gargantext.Prelude hiding (to)
 import Gargantext.System.Logging (HasLogger(..), Logger, LogLevel(..), MonadLogger(..), withLogger, logMsg, withLoggerIO)
 import Gargantext.System.Logging.Loggers
 import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
-import Prelude qualified
 import System.Log.FastLogger qualified as FL
 
 
 data WorkerEnv = WorkerEnv
   { _w_env_config    :: ~GargConfig
-  , _w_env_logger    :: ~(Logger (GargM WorkerEnv IOException))
+  , _w_env_logger    :: ~(Logger (GargM WorkerEnv BackendInternalError))
   -- the pool is a pool for gargantext db, not pgmq db!
   , _w_env_pool      :: ~(Pool.Pool PSQL.Connection)
   , _w_env_nodeStory :: ~(NodeStoryEnv BackendInternalError)
@@ -98,11 +93,11 @@ withWorkerEnv settingsFile k = do
 instance HasConfig WorkerEnv where
   hasConfig = to _w_env_config
 
-instance HasLogger (GargM WorkerEnv IOException) where
-  newtype instance Logger (GargM WorkerEnv IOException)  =
+instance HasLogger (GargM WorkerEnv BackendInternalError) where
+  newtype instance Logger (GargM WorkerEnv BackendInternalError)  =
     GargWorkerLogger { _GargWorkerLogger :: MonadicStdLogger FL.LogStr IO }
-  type instance LogInitParams (GargM WorkerEnv IOException) = LogConfig
-  type instance LogPayload (GargM WorkerEnv IOException)    = FL.LogStr
+  type instance LogInitParams (GargM WorkerEnv BackendInternalError) = LogConfig
+  type instance LogPayload (GargM WorkerEnv BackendInternalError)    = FL.LogStr
   initLogger cfg = fmap GargWorkerLogger $ (liftIO $ monadicStdLogger cfg)
   destroyLogger = liftIO . _msl_destroy . _GargWorkerLogger
   logMsg (GargWorkerLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
@@ -120,7 +115,7 @@ instance HasNLPServer WorkerEnv where
 instance HasNodeStoryEnv WorkerEnv BackendInternalError where
   hasNodeStory = to _w_env_nodeStory
 
-instance MonadLogger (GargM WorkerEnv IOException) where
+instance MonadLogger (GargM WorkerEnv BackendInternalError) where
   getLogger = asks _w_env_logger
 
 instance CET.HasCentralExchangeNotification WorkerEnv where
@@ -131,34 +126,10 @@ instance CET.HasCentralExchangeNotification WorkerEnv where
         logMsg ioL DEBUG $ "[ce_notify]: " <> show (_gc_notifications_config c) <> " :: " <> show m
       CE.notify c m
 
----------
-instance HasValidationError IOException where
-  _ValidationError = prism' mkIOException (const Nothing)
-    where
-      mkIOException v = IOError { ioe_handle = Nothing
-                                , ioe_type = OtherError
-                                , ioe_location = "Worker job (validation)"
-                                , ioe_description = show v
-                                , ioe_errno = Nothing
-                                , ioe_filename = Nothing }
-
-instance HasTreeError IOException where
-  _TreeError = prism' mkIOException (const Nothing)
-    where
-      mkIOException v = IOError { ioe_handle = Nothing
-                                , ioe_type = OtherError
-                                , ioe_location = "Worker job (tree)"
-                                , ioe_description = show v
-                                , ioe_errno = Nothing
-                                , ioe_filename = Nothing }
-
-instance HasNodeError IOException where
-  _NodeError = prism' (Prelude.userError . show) (const Nothing)
-
 ---------------
 
 newtype WorkerMonad a =
-  WorkerMonad { _WorkerMonad :: GargM WorkerEnv IOException a }
+  WorkerMonad { _WorkerMonad :: GargM WorkerEnv BackendInternalError a }
   deriving ( Functor
            , Applicative
            , Monad
@@ -166,7 +137,7 @@ newtype WorkerMonad a =
            , MonadReader WorkerEnv
            , MonadBase IO
            , MonadBaseControl IO
-           , MonadError IOException
+           , MonadError BackendInternalError
            , MonadFail
            , CES.MonadThrow
            , CES.MonadCatch

test/Test/API/Authentication.hs

@@ -57,7 +57,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith (\ctx -> setupE
       it "requires no auth and authenticates the user 'alice'" $ \(SpecContext testEnv port _app _) -> do
 
         -- Let's create the Alice user.
-        void $ flip runReaderT testEnv $ runTestMonad $ do
+        void $ runTestMonad testEnv $ do
           void $ new_user $ mkNewUser "alice@gargan.text" (GargPassword "alice")
 
         let authPayload = AuthRequest "alice" (GargPassword "alice")

test/Test/API/Export.hs

@@ -17,6 +17,7 @@ import Gargantext.Database.Action.Flow (addDocumentsToHyperCorpus)
 import Gargantext.Database.Action.User (getUserId)
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus)
 import Gargantext.Database.Admin.Types.Node (NodeType(NodeFolder, NodeCorpus, NodeFolderPrivate))
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getOrMkList, getNodeWith, insertDefaultNode, insertNode)
 import Gargantext.Database.Query.Tree.Root (getRootId)
 import Gargantext.Database.Schema.Node (node_hyperdata)
@@ -41,20 +42,20 @@ tests = sequential $ around withTestDBAndPort $ beforeWith dbEnvSetup $ do
   describe "Export API" $ do
     describe "Check CorpusSQLiteData creation" $ do
       it "correctly creates CorpusSQLiteData" $ \ctx -> do
-        flip runReaderT (_sctx_env ctx) $ runTestMonad $ do
-          aliceUserId    <- getUserId (UserName "alice")
-          aliceRootId    <- getRootId (UserName "alice")
-          alicePrivateFolderId <- insertNode NodeFolderPrivate (Just "NodeFolderPrivate") Nothing aliceRootId aliceUserId
-          aliceFolderId  <- insertDefaultNode NodeFolder alicePrivateFolderId aliceUserId
-          corpusId       <- insertDefaultNode NodeCorpus aliceFolderId aliceUserId
-          aliceListId    <- getOrMkList corpusId aliceUserId
-          corpus <- getNodeWith corpusId (Proxy @HyperdataCorpus)
-  
+        runTestMonad (_sctx_env ctx) $ do
+          aliceUserId    <- runDBQuery $ getUserId (UserName "alice")
+          aliceRootId    <- runDBQuery $ getRootId (UserName "alice")
+          alicePrivateFolderId <- runDBTx $ insertNode NodeFolderPrivate (Just "NodeFolderPrivate") Nothing aliceRootId aliceUserId
+          aliceFolderId  <- runDBTx $ insertDefaultNode NodeFolder alicePrivateFolderId aliceUserId
+          corpusId       <- runDBTx $ insertDefaultNode NodeCorpus aliceFolderId aliceUserId
+          aliceListId    <- runDBTx $ getOrMkList corpusId aliceUserId
+          corpus <- runDBQuery $ getNodeWith corpusId (Proxy @HyperdataCorpus)
+
           let docs = [ exampleDocument_01, exampleDocument_02 ]
-          
+
           let lang = EN
           _ <- addDocumentsToHyperCorpus (Just $ corpus ^. node_hyperdata) (Multi lang) corpusId docs
-  
+
           (CorpusSQLiteData { .. }) <- mkCorpusSQLiteData corpusId Nothing
 
           liftIO $ do
@@ -65,7 +66,7 @@ tests = sequential $ around withTestDBAndPort $ beforeWith dbEnvSetup $ do
             length _csd_map_context_ngrams `shouldBe` 0
             length _csd_stop_context_ngrams `shouldBe` 0
             length _csd_candidate_context_ngrams `shouldBe` 0
-    
+
     describe "GET /api/v1.0/corpus/cId/sqlite" $ do
       it "returns correct SQLite db" $ \ctx -> do
         let port = _sctx_port ctx

test/Test/API/Prelude.hs

@@ -28,7 +28,7 @@ import Gargantext.Core.Types (NodeId, NodeType(..), ParentId)
 import Gargantext.Core.Worker.Env ()  -- instance HasNodeError
 import Gargantext.Database.Action.User
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus
-import Gargantext.Database.Prelude (DBCmd)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (insertNode, mk, getUserRootPublicNode, getUserRootPrivateNode, getUserRootShareNode)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node.User (getUserByName)
@@ -44,19 +44,21 @@ checkEither :: (Show a, Monad m) => m (Either a b) -> m b
 checkEither = fmap (either (\x -> panicTrace $ "checkEither:" <> T.pack (show x)) identity)
 
 newCorpusForUser :: TestEnv -> T.Text -> IO NodeId
-newCorpusForUser env uname = flip runReaderT env $ runTestMonad $ do
+newCorpusForUser env uname = runTestMonad env $ runDBTx $ do
   uid      <- getUserId (UserName uname)
   parentId <- getRootId (UserName uname)
   let corpusName = "Test_Corpus"
-  (corpusId:_) <- mk (Just corpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
-  pure corpusId
+  xs <- mk (Just corpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
+  case xs of
+    [corpusId] -> pure corpusId
+    _          -> panicTrace $ "impossible: " <> show xs
 
 -- | Creates a new folder for the input user, nested under the given 'ParentId', if given.
 newFolderForUser' :: HasNodeError err
                   => User
                   -> T.Text
                   -> ParentId
-                  -> DBCmd err NodeId
+                  -> DBUpdate err NodeId
 newFolderForUser' ur folderName parentId = do
   uid      <- getUserId ur
   insertNode NodeFolder (Just folderName) Nothing parentId uid
@@ -66,11 +68,11 @@ addFolderForUser :: TestEnv
                  -> T.Text
                  -> ParentId
                  -> IO NodeId
-addFolderForUser env ur folderName parentId = flip runReaderT env $ runTestMonad $ do
+addFolderForUser env ur folderName parentId = runTestMonad env $ runDBTx $ do
   newFolderForUser' ur folderName parentId
 
 newFolderForUser :: TestEnv -> User -> T.Text -> IO NodeId
-newFolderForUser env uname folderName = flip runReaderT env $ runTestMonad $ do
+newFolderForUser env uname folderName = runTestMonad env $ runDBTx $ do
   parentId <- getRootId uname
   newFolderForUser' uname folderName parentId
 
@@ -86,33 +88,37 @@ newShareFolderForUser :: TestEnv -> User -> IO NodeId
 newShareFolderForUser env ur = newFolder env ur NodeFolderShared
 
 newFolder :: TestEnv -> User -> NodeType -> IO NodeId
-newFolder env ur nt = flip runReaderT env $ runTestMonad $ do
+newFolder env ur nt = runTestMonad env $ runDBTx $ do
   let nodeName = show nt
   uid      <- getUserId ur
   parentId <- getRootId ur
   insertNode nt (Just nodeName) Nothing parentId uid
 
 getRootPublicFolderIdForUser :: TestEnv -> User -> IO NodeId
-getRootPublicFolderIdForUser env uname = flip runReaderT env $ runTestMonad $ do
+getRootPublicFolderIdForUser env uname = runTestMonad env $ runDBQuery $ do
   _node_id <$> (getUserId uname >>= getUserRootPublicNode)
 
 getRootPrivateFolderIdForUser :: TestEnv -> User -> IO NodeId
-getRootPrivateFolderIdForUser env uname = flip runReaderT env $ runTestMonad $ do
+getRootPrivateFolderIdForUser env uname = runTestMonad env $ runDBQuery $ do
   _node_id <$> (getUserId uname >>= getUserRootPrivateNode)
 
 getRootShareFolderIdForUser :: TestEnv -> User -> IO NodeId
-getRootShareFolderIdForUser env uname = flip runReaderT env $ runTestMonad $ do
+getRootShareFolderIdForUser env uname = runTestMonad env $ runDBQuery $
+  getRootShareFolderIdForUserTx uname
+
+getRootShareFolderIdForUserTx :: User -> DBQuery BackendInternalError x NodeId
+getRootShareFolderIdForUserTx uname = do
   _node_id <$> (getUserId uname >>= getUserRootShareNode)
 
 newTeamWithOwner :: TestEnv -> User -> T.Text -> IO NodeId
-newTeamWithOwner env uname teamName = flip runReaderT env $ runTestMonad $ do
+newTeamWithOwner env uname teamName = runTestMonad env $ runDBTx $ do
   uid      <- getUserId uname
-  parentId <- liftIO $ getRootShareFolderIdForUser env uname
+  parentId <- getRootShareFolderIdForUserTx uname
   insertNode NodeTeam (Just teamName) Nothing parentId uid
 
 myUserNodeId :: TestEnv -> T.Text -> IO NodeId
-myUserNodeId env uname = flip runReaderT env $ runTestMonad $ do
-  _node_id <$> getUserByName uname
+myUserNodeId env uname = runTestMonad env $ do
+  _node_id <$> runDBQuery (getUserByName uname)
 
 shouldFailWith :: Show a => Either ClientError a -> BackendErrorCode -> Assertion
 action `shouldFailWith` backendError = case action of

test/Test/API/Setup.hs

@@ -16,7 +16,6 @@ import Control.Concurrent.Async qualified as Async
 import Control.Concurrent.MVar
 import Control.Exception.Safe
 import Control.Lens
-import Control.Monad.Reader
 import Data.ByteString.Lazy.Char8 qualified as C8L
 import Data.Cache qualified as InMemory
 import Data.Streaming.Network (bindPortTCP)
@@ -34,7 +33,7 @@ import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Admin.Trigger.Init
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Node (UserId)
-import Gargantext.Database.Prelude ()
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getOrMkList)
 import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..))
 import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
@@ -156,26 +155,27 @@ withBackendServerAndProxy action =
     log_cfg te = cfg te ^. gc_logging
 
 setupEnvironment :: TestEnv -> IO ()
-setupEnvironment env = flip runReaderT env $ runTestMonad $ do
-  void $ initFirstTriggers "secret_key"
+setupEnvironment env = runTestMonad env $ do
+  cfg <- view hasConfig
+  runDBTx $ void $ initFirstTriggers "secret_key"
   void $ new_user $ mkNewUser (userMaster <> "@cnrs.com") (GargPassword "secret_key")
-  (masterUserId, _masterRootId, masterCorpusId)
-              <- getOrMkRootWithCorpus MkCorpusUserMaster (Nothing :: Maybe HyperdataCorpus)
-  masterListId <- getOrMkList masterCorpusId masterUserId
-  -- printDebug "[setupEnvironment] masterListId: " masterListId
-  void $ initLastTriggers masterListId
+  runDBTx $ do
+    (masterUserId, _masterRootId, masterCorpusId)
+                <- getOrMkRootWithCorpus cfg MkCorpusUserMaster (Nothing :: Maybe HyperdataCorpus)
+    masterListId <- getOrMkList masterCorpusId masterUserId
+    -- printDebug "[setupEnvironment] masterListId: " masterListId
+    void $ initLastTriggers masterListId
 
 -- | Creates two users, Alice & Bob. Alice shouldn't be able to see
 -- Bob's private data and vice-versa.
 createAliceAndBob :: TestEnv -> IO [UserId]
-createAliceAndBob testEnv = do
-  flip runReaderT testEnv $ runTestMonad $ do
-    let nur1 = mkNewUser "alice@gargan.text" (GargPassword "alice")
-    let nur2 = mkNewUser "bob@gargan.text" (GargPassword "bob")
-
-    aliceId <- new_user nur1
-    bobId   <- new_user nur2
-    pure [aliceId, bobId]
+createAliceAndBob testEnv = runTestMonad testEnv $ do
+  let nur1 = mkNewUser "alice@gargan.text" (GargPassword "alice")
+  let nur2 = mkNewUser "bob@gargan.text" (GargPassword "bob")
+
+  aliceId <- new_user nur1
+  bobId   <- new_user nur2
+  pure [aliceId, bobId]
 
 dbEnvSetup :: SpecContext a -> IO (SpecContext a)
 dbEnvSetup ctx = do

test/Test/Database/Operations.hs

@@ -23,7 +23,7 @@ import Gargantext.Database.Action.User
 import Gargantext.Database.Action.User.New
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (runPGSQuery)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Tree.Root (getRootId)
 import Gargantext.Database.Schema.Node (NodePoly(..))
@@ -123,7 +123,7 @@ testCorpusName :: Text
 testCorpusName = "Text_Corpus"
 
 writeRead01 :: TestEnv -> Assertion
-writeRead01 env = flip runReaderT env $ runTestMonad $ do
+writeRead01 env = runTestMonad env $ do
   let nur1 = mkNewUser testUser testUserPassword
   let nur2 = mkNewUser "paul@acme.com" (GargPassword "my_secret")
 
@@ -134,21 +134,20 @@ writeRead01 env = flip runReaderT env $ runTestMonad $ do
   liftBase $ uid2 `shouldBe` UnsafeMkUserId 3
 
   -- Getting the users by username returns the expected IDs
-  uid1' <- getUserId testUsername
-  uid2' <- getUserId (UserName "paul")
+  (uid1', uid2') <- runDBQuery $ (,) <$> getUserId testUsername <*> 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
+setupTestUser env = runTestMonad env $ 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 x = runTestMonad env $ do
         let nur = mkNewUser testUser testUserPassword
         
         -- This should fail, because user 'alfredo' exists already.
@@ -165,19 +164,19 @@ mkUserDup env = do
   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)
+runEnv env act = run (runTestMonad env act)
 
 prop_userCreationRoundtrip :: TestEnv -> Property
 prop_userCreationRoundtrip env = monadicIO $ do
   nextAvailableCounter <- run (nextCounter $ test_usernameGen env)
   nur  <- pick (uniqueArbitraryNewUser nextAvailableCounter)
   uid <- runEnv env (new_user nur)
-  ur' <- runEnv env (getUserId (UserName $ _nu_username nur))
+  ur' <- runEnv env (runDBQuery $ 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
+setupTestCorpus env = runTestMonad env $ runDBTx $ do
   uid      <- getUserId testUsername
   parentId <- getRootId testUsername
   _ <- mk (Just testCorpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
@@ -186,23 +185,24 @@ setupTestCorpus env = flip runReaderT env $ runTestMonad $ do
 -- | 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 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)
+  runTestMonad env $ do
+    uid      <- runDBQuery $ getUserId testUsername
+    parentId <- runDBQuery $ getRootId testUsername
+    [corpusId] <- runDBTx $ mk (Just testCorpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
+    [Only corpusId'] <- runDBQuery $ mkPGQuery [sql|SELECT id FROM nodes WHERE name = ?|] (Only testCorpusName)
     liftIO $ corpusId `shouldBe` UnsafeMkNodeId corpusId'
     -- Retrieve the corpus by Id
-    [corpus] <- getCorporaWithParentId parentId
+    [corpus] <- runDBQuery $ getCorporaWithParentId parentId
     liftIO $ corpusId `shouldBe` (_node_id corpus)
 
 -- | We test that we can update the existing language for a 'Corpus'.
 corpusAddLanguage :: TestEnv -> Assertion
 corpusAddLanguage env = do
-  flip runReaderT env $ runTestMonad $ do
-    parentId <- getRootId testUsername
-    [corpus] <- getCorporaWithParentId parentId
+  runTestMonad env $ do
+    parentId <- runDBQuery $ getRootId testUsername
+    corpus   <- runDBQuery $ getCorporaWithParentIdOrFail parentId
     liftIO $ (_hc_lang . _node_hyperdata $ corpus) `shouldBe` Just EN -- defaults to English
-    addLanguageToCorpus (_node_id corpus) IT
-    [corpus'] <- getCorporaWithParentId parentId
+    corpus' <- runDBTx $ do
+      addLanguageToCorpus (_node_id corpus) IT
+      getCorporaWithParentIdOrFail parentId
     liftIO $ (_hc_lang . _node_hyperdata $ corpus') `shouldBe` Just IT

test/Test/Database/Operations/DocumentSearch.hs

@@ -19,16 +19,22 @@ import Data.Text qualified as T
 import Gargantext.Core
 import Gargantext.Core.Text.Corpus.Query qualified as API
 import Gargantext.Core.Text.Terms.Mono.Stem
+import Gargantext.Core.Types
 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 (HyperdataCorpus)
 import Gargantext.Database.Admin.Types.Hyperdata.Document
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Facet
 import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Database.Query.Table.Node.Error (errorWith)
 import Gargantext.Database.Query.Tree.Root
 import Gargantext.Database.Schema.Node (NodePoly(..))
+import Gargantext.Prelude.Error (panicTrace)
 import Prelude
 import Test.Database.Types
 import Test.Hspec.Expectations
@@ -108,12 +114,19 @@ exampleDocument_04 = either error id $ parseEither parseJSON $ [aesonQQ|
 }
 |]
 
+getCorporaWithParentIdOrFail :: HasNodeError err => NodeId -> DBQuery err x (Node HyperdataCorpus)
+getCorporaWithParentIdOrFail parentId = do
+  xs <- getCorporaWithParentId parentId
+  case xs of
+    [corpus] -> pure corpus
+    _        -> errorWith $ "getCorporaWithParentIdOrFail, impossible: " <> T.pack (show xs)
+
 addCorpusDocuments :: TestEnv -> IO TestEnv
-addCorpusDocuments env = flip runReaderT env $ runTestMonad $ do
+addCorpusDocuments env = runTestMonad env $ do
   -- NOTE(adn) We need to create user 'gargantua'(!!) in order
   -- for 'addDocumentsToHyperCorpus' to work.
-  parentId <- getRootId (UserName userMaster)
-  [corpus] <- getCorporaWithParentId parentId
+  parentId   <- runDBQuery $ getRootId (UserName userMaster)
+  [corpus] <- runDBQuery $ getCorporaWithParentId parentId
   let corpusId = _node_id corpus
 
   let lang = EN
@@ -123,14 +136,19 @@ addCorpusDocuments env = flip runReaderT env $ runTestMonad $ do
                                  corpusId
                                  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
+corpusAddDocuments env = runTestMonad env $ do
+
+  cnt <- runDBQuery $ do
+    parentId <- getRootId (UserName userMaster)
+    xs <- getCorporaWithParentId parentId
+    case xs of
+      [corpus] -> do
+        let corpusId = _node_id corpus
+        searchCountInCorpus corpusId False Nothing
+      _ -> panicTrace $ "corpusAddDocuments, impossible: " <> T.pack (show xs)
+
   liftIO $ cnt `shouldBe` 4
 
 stemmingTest :: TestEnv -> Assertion
@@ -152,13 +170,14 @@ mkQ txt = either (\e -> error $ "(query) = " <> T.unpack txt <> ": " <> e) id .
 
 corpusSearch01 :: TestEnv -> Assertion
 corpusSearch01 env = do
-  flip runReaderT env $ runTestMonad $ do
+  runTestMonad env $ do
 
-    parentId <- getRootId (UserName userMaster)
-    [corpus] <- getCorporaWithParentId parentId
+    (results1, results2) <- runDBQuery $ do
+      parentId <- getRootId (UserName userMaster)
+      corpus <- getCorporaWithParentIdOrFail parentId
 
-    results1 <- searchInCorpus (_node_id corpus) False (mkQ "mineral") Nothing Nothing Nothing
-    results2 <- searchInCorpus (_node_id corpus) False (mkQ "computational") Nothing Nothing Nothing
+      (,) <$> searchInCorpus (_node_id corpus) False (mkQ "mineral") Nothing Nothing Nothing
+          <*> searchInCorpus (_node_id corpus) False (mkQ "computational") Nothing Nothing Nothing
 
     liftIO $ length results1 `shouldBe` 1
     liftIO $ length results2 `shouldBe` 1
@@ -166,13 +185,14 @@ corpusSearch01 env = do
 -- | Check that we support more complex queries
 corpusSearch02 :: TestEnv -> Assertion
 corpusSearch02 env = do
-  flip runReaderT env $ runTestMonad $ do
+  runTestMonad env $ do
 
-    parentId <- getRootId (UserName userMaster)
-    [corpus] <- getCorporaWithParentId parentId
+    (results1, results2) <- runDBQuery $ do
+      parentId <- getRootId (UserName userMaster)
+      corpus <- getCorporaWithParentIdOrFail parentId
 
-    results1 <- searchInCorpus (_node_id corpus) False (mkQ "Raphael") Nothing Nothing Nothing
-    results2 <- searchInCorpus (_node_id corpus) False (mkQ "Raphael Poss") Nothing Nothing Nothing
+      (,) <$> searchInCorpus (_node_id corpus) False (mkQ "Raphael") Nothing Nothing Nothing
+          <*> searchInCorpus (_node_id corpus) False (mkQ "Raphael Poss") Nothing Nothing Nothing
 
     liftIO $ do
       length results1 `shouldBe` 2 -- Haskell & Rust
@@ -181,14 +201,15 @@ corpusSearch02 env = do
 -- | Check that we support more complex queries via the bool API
 corpusSearch03 :: TestEnv -> Assertion
 corpusSearch03 env = do
-  flip runReaderT env $ runTestMonad $ do
+  runTestMonad env $ do
 
-    parentId <- getRootId (UserName userMaster)
-    [corpus] <- getCorporaWithParentId parentId
+    (results1, results2, results3) <- runDBQuery $ do
+      parentId <- getRootId (UserName userMaster)
+      corpus <- getCorporaWithParentIdOrFail parentId
 
-    results1 <- searchInCorpus (_node_id corpus) False (mkQ "\"Manuel Agnelli\"") Nothing Nothing Nothing
-    results2 <- searchInCorpus (_node_id corpus) False (mkQ "Raphael AND -Rust") Nothing Nothing Nothing
-    results3 <- searchInCorpus (_node_id corpus) False (mkQ "(Raphael AND (NOT Rust)) OR PyPlasm") Nothing Nothing Nothing
+      (,,) <$> searchInCorpus (_node_id corpus) False (mkQ "\"Manuel Agnelli\"") Nothing Nothing Nothing
+           <*> searchInCorpus (_node_id corpus) False (mkQ "Raphael AND -Rust") Nothing Nothing Nothing
+           <*> searchInCorpus (_node_id corpus) False (mkQ "(Raphael AND (NOT Rust)) OR PyPlasm") Nothing Nothing Nothing
 
     liftIO $ do
       length results1 `shouldBe` 1
@@ -199,12 +220,12 @@ corpusSearch03 env = do
 --   TODO This test is unfinished because `updateDocs` needs more work
 corpusScore01 :: TestEnv -> Assertion
 corpusScore01 env = do
-  flip runReaderT env $ runTestMonad $ do
-
-    parentId <- getRootId (UserName userMaster)
-    [corpus] <- getCorporaWithParentId parentId
+  runTestMonad env $ do
 
-    results <- searchInCorpus (_node_id corpus) False (mkQ "Haskell") Nothing Nothing Nothing
+    results <- runDBQuery $ do
+      parentId <- getRootId (UserName userMaster)
+      corpus <- getCorporaWithParentIdOrFail parentId
+      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"]
@@ -219,12 +240,11 @@ corpusScore01 env = do
 -- | Check that we support search with tsquery
 corpusSearchDB01 :: TestEnv -> Assertion
 corpusSearchDB01 env = do
-  flip runReaderT env $ runTestMonad $ do
-
-    parentId <- getRootId (UserName userMaster)
-    [corpus] <- getCorporaWithParentId parentId
-
-    results <- searchDocInDatabase (_node_id corpus) ("first second")
+  runTestMonad env $ do
+    results <- runDBQuery $ do
+      parentId <- getRootId (UserName userMaster)
+      corpus <- getCorporaWithParentIdOrFail parentId
+      searchDocInDatabase (_node_id corpus) ("first second")
 
     liftIO $ do
       length results `shouldBe` 0 -- doesn't exist, we just check that proper to_tsquery is called

test/Test/Database/Operations/NodeStory.hs

@@ -13,7 +13,7 @@ Portability : POSIX
 
 module Test.Database.Operations.NodeStory where
 
-import Control.Lens ((?~), _2)
+import Control.Lens ((?~), _2, view)
 import Control.Monad.Reader
 import Data.Map.Strict qualified as Map
 import Data.Map.Strict.Patch qualified as PM
@@ -21,21 +21,22 @@ import Data.Set qualified as Set
 import Database.PostgreSQL.Simple qualified as PSQL
 import Database.PostgreSQL.Simple.SqlQQ
 import Gargantext.API.Ngrams (commitStatePatch, mSetFromList, setListNgrams, saveNodeStory)
-import Gargantext.API.Ngrams.Types (MSet(..), NgramsPatch(..), NgramsRepoElement(..), NgramsTerm(..), Versioned(..), mkNgramsTablePatch, nre_children, nre_list, nre_parent, nre_root)
 import Gargantext.API.Ngrams.Tools (getNodeStory)
+import Gargantext.API.Ngrams.Types (MSet(..), NgramsPatch(..), NgramsRepoElement(..), NgramsTerm(..), Versioned(..), mkNgramsTablePatch, nre_children, nre_list, nre_parent, nre_root)
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Text.Ngrams (NgramsType(..))
-import Gargantext.Core.Types.Individu
 import Gargantext.Core.Types (ListType(..), ListId, NodeId, UserId)
+import Gargantext.Core.Types.Individu
 import Gargantext.Core.Worker.Env ()  -- instance HasNodeError
 import Gargantext.Database.Action.User (getUserId)
 import Gargantext.Database.Admin.Config (userMaster)
-import Gargantext.Database.Prelude (runPGSQuery)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Ngrams (selectNgramsId)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Tree.Root
 import Gargantext.Database.Schema.Node (NodePoly(..))
 import Gargantext.Prelude
+import Test.Database.Operations.DocumentSearch (getCorporaWithParentIdOrFail)
 import Test.Database.Types
 import Test.Hspec.Expectations
 import Test.Tasty.HUnit
@@ -43,18 +44,21 @@ import Test.Tasty.HUnit
 
 commonInitialization :: TestMonad ( UserId, NodeId, ListId, ArchiveList )
 commonInitialization = do
-  let user = UserName userMaster
-  parentId <- getRootId user
-  [corpus] <- getCorporaWithParentId parentId
-  let corpusId = _node_id corpus
+  env <- view hasNodeStory
+
+  runDBTx $ do
+    let user = UserName userMaster
+    parentId <- getRootId user
+    corpus   <- getCorporaWithParentIdOrFail parentId
+    let corpusId = _node_id corpus
 
-  userId <- getUserId user
+    userId <- getUserId user
 
-  listId <- getOrMkList corpusId userId
+    listId <- getOrMkList corpusId userId
 
-  a <- getNodeStory listId
+    a <- getNodeStory env listId
 
-  pure $ (userId, corpusId, listId, a)
+    pure $ (userId, corpusId, listId, a)
 
 
 initArchiveList :: ArchiveList
@@ -89,25 +93,26 @@ simpleChildTerm = ( simpleChildTerm'
 
 createListTest :: TestEnv -> Assertion
 createListTest env = do
-  flip runReaderT env $ runTestMonad $ do
+  runTestMonad env $ do
     (userId, corpusId, listId, _a) <- commonInitialization
 
-    listId' <- getOrMkList corpusId userId
+    listId' <- runDBTx $ getOrMkList corpusId userId
 
     liftIO $ listId `shouldBe` listId'
 
 
 queryNodeStoryTest :: TestEnv -> Assertion
 queryNodeStoryTest env = do
-  flip runReaderT env $ runTestMonad $ do
+  runTestMonad env $ do
+    nse <- view hasNodeStory
     (_userId, _corpusId, listId, a) <- commonInitialization
 
     liftIO $ do
       a `shouldBe` initArchiveList
 
-    saveNodeStory listId a
+    runDBTx $ saveNodeStory nse listId a
 
-    a' <- getNodeStory listId
+    a' <- runDBQuery $ getNodeStory nse listId
 
     liftIO $ do
       a' `shouldBe` a
@@ -115,34 +120,35 @@ queryNodeStoryTest env = do
 
 insertNewTermsToNodeStoryTest :: TestEnv -> Assertion
 insertNewTermsToNodeStoryTest env = do
-  flip runReaderT env $ runTestMonad $ do
+  runTestMonad env $ do
+    nse <- view hasNodeStory
     (_userId, _corpusId, listId, _a) <- commonInitialization
 
     let (terms, nre) = simpleTerm
     let nls = Map.singleton terms nre
-    setListNgrams listId NgramsTerms nls
+    runDBTx $ setListNgrams nse listId NgramsTerms nls
 
-    a <- getNodeStory listId
+    a <- runDBQuery $ getNodeStory nse listId
 
     liftIO $ do
       a `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nls })
     -- check that the ngrams are in the DB as well
-    ngramsMap <- selectNgramsId [unNgramsTerm terms]
+    ngramsMap <- runDBQuery $ selectNgramsId [unNgramsTerm terms]
     liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` [unNgramsTerm terms]
 
     -- Finally, check that node stories are inserted correctly
-    dbTerms <- runPGSQuery [sql|
-                               SELECT terms
-                               FROM ngrams
-                               JOIN node_stories ON ngrams.id = ngrams_id
-                               WHERE node_id = ?
-                               |] (PSQL.Only listId)
+    dbTerms <- runDBQuery $ mkPGQuery [sql| SELECT terms
+                                              FROM ngrams
+                                              JOIN node_stories ON ngrams.id = ngrams_id
+                                              WHERE node_id = ?
+                                              |] (PSQL.Only listId)
     liftIO $ dbTerms `shouldBe` [PSQL.Only $ unNgramsTerm terms]
 
 
 insertNewTermsWithChildrenToNodeStoryTest :: TestEnv -> Assertion
 insertNewTermsWithChildrenToNodeStoryTest env = do
-  flip runReaderT env $ runTestMonad $ do
+  runTestMonad env $ do
+    nse <- view hasNodeStory
     (_userId, _corpusId, listId, _a) <- commonInitialization
 
     let (tParent, nreParent) = simpleParentTerm
@@ -150,24 +156,23 @@ insertNewTermsWithChildrenToNodeStoryTest env = do
     let terms = unNgramsTerm <$> [tParent, tChild]
 
     let nls = Map.fromList [(tParent, nreParent), (tChild, nreChild)]
-    setListNgrams listId NgramsTerms nls
+    runDBTx $ setListNgrams nse listId NgramsTerms nls
 
-    a <- getNodeStory listId
+    a <- runDBQuery $ getNodeStory nse listId
 
     liftIO $ do
       a `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nls })
 
     -- `setListNgrams` calls saveNodeStory already so we should have
     -- the terms in the DB by now
-    ngramsMap <- selectNgramsId terms
+    ngramsMap <- runDBQuery $ selectNgramsId terms
     liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` terms
 
-    dbTerms <- runPGSQuery [sql|
-                               SELECT terms
-                               FROM ngrams
-                               JOIN node_stories ON ngrams.id = ngrams_id
-                               WHERE node_id = ?
-                               |] (PSQL.Only listId)
+    dbTerms <- runDBQuery $ mkPGQuery [sql| SELECT terms
+                                              FROM ngrams
+                                              JOIN node_stories ON ngrams.id = ngrams_id
+                                              WHERE node_id = ?
+                                              |] (PSQL.Only listId)
     liftIO $ (Set.fromList $ (\(PSQL.Only t) -> t) <$> dbTerms) `shouldBe` (Set.fromList terms)
 
     -- let (Just (tParentId, _)) = head $ filter ((==) (unNgramsTerm tParent) . snd) $ Map.toList ngramsMap2
@@ -181,7 +186,8 @@ insertNewTermsWithChildrenToNodeStoryTest env = do
 
 insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest :: TestEnv -> Assertion
 insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest env = do
-  flip runReaderT env $ runTestMonad $ do
+  runTestMonad env $ do
+    nse <- view hasNodeStory
     (_userId, _corpusId, listId, _a) <- commonInitialization
 
     let (tParent, nreParent) = simpleParentTerm
@@ -192,46 +198,46 @@ insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest env = do
     let nls = Map.fromList [(tParent, nreParent), (tChild, nreChildBrokenType)]
     let nlsWithChildFixed = Map.fromList [(tParent, nreParent), (tChild, nreChildGoodType)]
 
-    setListNgrams listId NgramsTerms nls
+    runDBTx $ setListNgrams nse listId NgramsTerms nls
 
-    a <- getNodeStory listId
+    a <- runDBQuery $ getNodeStory nse listId
 
     liftIO $ do
       a `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nlsWithChildFixed })
 
-    ngramsMap <- selectNgramsId terms
+    ngramsMap <- runDBQuery $ selectNgramsId terms
     liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` terms
 
-    dbTerms <- runPGSQuery [sql|
-                               SELECT terms
-                               FROM ngrams
-                               JOIN node_stories ON ngrams.id = ngrams_id
-                               WHERE node_id = ?
-                               |] (PSQL.Only listId)
+    dbTerms <- runDBQuery $ mkPGQuery  [sql| SELECT terms
+                                                FROM ngrams
+                                                JOIN node_stories ON ngrams.id = ngrams_id
+                                                WHERE node_id = ?
+                                                |] (PSQL.Only listId)
     liftIO $ (Set.fromList $ (\(PSQL.Only t) -> t) <$> dbTerms) `shouldBe` (Set.fromList terms)
 
     let (Just (tChildId, _)) = head $ filter ((==) (unNgramsTerm tChild) . snd) $ Map.toList ngramsMap
 
-    [PSQL.Only childType] <- runPGSQuery [sql|SELECT ngrams_repo_element->>'list'
-                                             FROM node_stories
-                                             WHERE ngrams_id = ?|] (PSQL.Only tChildId)
+    [PSQL.Only childType] <- runDBQuery $ mkPGQuery [sql|SELECT ngrams_repo_element->>'list'
+                                                          FROM node_stories
+                                                          WHERE ngrams_id = ?|] (PSQL.Only tChildId)
     liftIO $ childType `shouldBe` ("MapTerm" :: Text)
 
 setListNgramsUpdatesNodeStoryTest :: TestEnv -> Assertion
 setListNgramsUpdatesNodeStoryTest env = do
-  flip runReaderT env $ runTestMonad $ do
+  runTestMonad env $ do
+    nse <- view hasNodeStory
     (_userId, _corpusId, listId, _a) <- commonInitialization
 
     let (terms, nre) = simpleTerm
     let nls = Map.singleton terms nre
-    setListNgrams listId NgramsTerms nls
+    runDBTx $ setListNgrams nse listId NgramsTerms nls
 
-    a <- getNodeStory listId
+    a <- runDBQuery $ getNodeStory nse listId
 
     liftIO $ do
       a `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nls })
     -- check that the ngrams are in the DB as well
-    ngramsMap <- selectNgramsId [unNgramsTerm terms]
+    ngramsMap <- runDBQuery $ selectNgramsId [unNgramsTerm terms]
     liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` [unNgramsTerm terms]
 
     let nre2 = NgramsRepoElement { _nre_size = 1
@@ -241,9 +247,9 @@ setListNgramsUpdatesNodeStoryTest env = do
                                  , _nre_children =  MSet Map.empty }
     let terms2 = "WORLD"
     let nls2 = Map.singleton (NgramsTerm terms2) nre2
-    setListNgrams listId NgramsTerms nls2
+    runDBTx $ setListNgrams nse listId NgramsTerms nls2
 
-    a' <- getNodeStory listId
+    a' <- runDBQuery $ getNodeStory nse listId
 
     liftIO $ do
       a' `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms $ nls <> nls2 })
@@ -251,15 +257,16 @@ setListNgramsUpdatesNodeStoryTest env = do
 
 setListNgramsUpdatesNodeStoryWithChildrenTest :: TestEnv -> Assertion
 setListNgramsUpdatesNodeStoryWithChildrenTest env = do
-  flip runReaderT env $ runTestMonad $ do
+  runTestMonad env $ do
+    nse <- view hasNodeStory
     (_userId, _corpusId, listId, _a) <- commonInitialization
 
     let (tChild, nreChild) = simpleChildTerm
     let (tParent, nreParent) = simpleParentTerm
     let nls = Map.fromList [(tParent, nreParent), (tChild, nreChild)]
-    setListNgrams listId NgramsTerms nls
+    runDBTx $ setListNgrams nse listId NgramsTerms nls
 
-    a <- getNodeStory listId
+    a <- runDBQuery $ getNodeStory nse listId
 
     liftIO $ do
       a `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nls })
@@ -268,13 +275,13 @@ setListNgramsUpdatesNodeStoryWithChildrenTest env = do
     -- 'nreChild' should become Nothing
     let nreParentNew = nreParent { _nre_children = MSet $ Map.empty }
     let nlsToInsert = Map.fromList [(tParent, nreParentNew)]
-    setListNgrams listId NgramsTerms nlsToInsert
+    runDBTx $ setListNgrams nse listId NgramsTerms nlsToInsert
 
     let nreChildNew = nreChild { _nre_parent = Nothing
                                , _nre_root = Nothing }
     let nlsNew = Map.fromList [(tParent, nreParentNew), (tChild, nreChildNew)]
 
-    a' <- getNodeStory listId
+    a' <- runDBQuery $ getNodeStory nse listId
 
     liftIO $ do
       a' `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nlsNew })
@@ -282,7 +289,8 @@ setListNgramsUpdatesNodeStoryWithChildrenTest env = do
 
 commitPatchSimpleTest :: TestEnv -> Assertion
 commitPatchSimpleTest env = do
-  flip runReaderT env $ runTestMonad $ do
+  runTestMonad env $ do
+    nse <- view hasNodeStory
     (_userId, _corpusId, listId, a) <- commonInitialization
 
     -- initially, the node story table is empty
@@ -292,16 +300,16 @@ commitPatchSimpleTest env = do
     let (term, nre) = simpleTerm
     let tPatch = NgramsReplace { _patch_old = Nothing
                                , _patch_new = Just nre }
-    ver <- currentVersion listId
+    ver <- runDBQuery $ currentVersion listId
     let ntp = mkNgramsTablePatch $ Map.singleton term tPatch
     let (pm, _validation) = PM.singleton NgramsTerms ntp
     let patch = Versioned ver pm
 
-    _patchApplied <- commitStatePatch listId patch
+    _patchApplied <- runDBTx $ commitStatePatch nse listId patch
 
     let nls = Map.fromList [(term, nre)]
 
-    a' <- getNodeStory listId
+    a' <- runDBQuery $ getNodeStory nse listId
 
     liftIO $ do
       a' `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nls

test/Test/Database/Operations/PublishNode.hs

@@ -17,7 +17,7 @@ import Gargantext.Core
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Action.User (getUserId)
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (DBCmd)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.NodeNode
 import Gargantext.Database.Schema.Node (NodePoly(..))
@@ -26,14 +26,14 @@ import Test.Database.Types
 import Test.Tasty.HUnit
 
 publishStrict :: SourceId -> TargetId -> DBCmd err ()
-publishStrict = publishNode NPP_publish_no_edits_allowed
+publishStrict sid = runDBTx . publishNode NPP_publish_no_edits_allowed sid
 
 publishLenient :: SourceId -> TargetId -> DBCmd err ()
-publishLenient = publishNode NPP_publish_edits_only_owner_or_super
+publishLenient sid = runDBTx . publishNode NPP_publish_edits_only_owner_or_super sid
 
 testGetUserRootPublicNode :: TestEnv -> Assertion
 testGetUserRootPublicNode testEnv = do
-  alicePublicFolder <- flip runReaderT testEnv $ runTestMonad $ do
+  alicePublicFolder <- runTestMonad testEnv $ runDBQuery $ do
     aliceId <- getUserId (UserName "alice")
     getUserRootPublicNode aliceId
   _node_typename alicePublicFolder @?= (toDBid NodeFolderPublic)
@@ -42,20 +42,20 @@ testIsReadOnlyWorks :: TestEnv -> Assertion
 testIsReadOnlyWorks testEnv = do
   alicePrivateFolderId <- newPrivateFolderForUser testEnv alice
   alicePublicFolderId  <- newPublicFolderForUser testEnv alice
-  flip runReaderT testEnv $ runTestMonad $ do
+  runTestMonad testEnv $ do
     -- Create a corpus, by default is not read only
-    aliceUserId <- getUserId (UserName "alice")
-    corpusId    <- insertDefaultNode NodeCorpus alicePrivateFolderId aliceUserId
+    aliceUserId <- runDBQuery $ getUserId (UserName "alice")
+    corpusId    <- runDBTx $ insertDefaultNode NodeCorpus alicePrivateFolderId aliceUserId
 
-    isNodeReadOnly corpusId >>= liftIO . (@?= False)
+    runDBQuery (isNodeReadOnly corpusId) >>= liftIO . (@?= False)
 
     -- Publish the node, then check that's now public.
     publishStrict (SourceId corpusId) (TargetId alicePublicFolderId)
-    isNodeReadOnly corpusId >>= liftIO . (@?= True)
+    runDBQuery (isNodeReadOnly corpusId) >>= liftIO . (@?= True)
 
     -- Finally check that if we unpublish, the node is back to normal
-    unpublishNode (SourceId corpusId) (TargetId alicePublicFolderId)
-    isNodeReadOnly corpusId >>= liftIO . (@?= False)
+    runDBTx $ unpublishNode (SourceId corpusId) (TargetId alicePublicFolderId)
+    runDBQuery (isNodeReadOnly corpusId) >>= liftIO . (@?= False)
 
 -- | In this test, we check that if we publish the root of a subtree,
 -- then all the children (up to the first level) are also marked read-only.
@@ -63,16 +63,16 @@ testPublishRecursiveFirstLevel :: TestEnv -> Assertion
 testPublishRecursiveFirstLevel testEnv = do
   alicePrivateFolderId <- newPrivateFolderForUser testEnv alice
   alicePublicFolderId  <- newPublicFolderForUser testEnv alice
-  flip runReaderT testEnv $ runTestMonad $ do
+  runTestMonad testEnv $ do
     -- Create a corpus, by default is not read only
-    aliceUserId    <- getUserId (UserName "alice")
-    aliceFolderId  <- insertDefaultNode NodeFolder alicePrivateFolderId aliceUserId
-    corpusId       <- insertDefaultNode NodeCorpus aliceFolderId aliceUserId
+    aliceUserId    <- runDBQuery $ getUserId (UserName "alice")
+    aliceFolderId  <- runDBTx $ insertDefaultNode NodeFolder alicePrivateFolderId aliceUserId
+    corpusId       <- runDBTx $ insertDefaultNode NodeCorpus aliceFolderId aliceUserId
 
     publishStrict (SourceId aliceFolderId) (TargetId alicePublicFolderId)
 
-    isNodeReadOnly aliceFolderId >>= liftIO . (@?= True)
-    isNodeReadOnly corpusId      >>= liftIO . (@?= True)
+    runDBQuery (isNodeReadOnly aliceFolderId) >>= liftIO . (@?= True)
+    runDBQuery (isNodeReadOnly corpusId)      >>= liftIO . (@?= True)
 
 -- | In this test, we check that if we publish the root of a subtree,
 -- then all the children of the children are also marked read-only.
@@ -80,25 +80,25 @@ testPublishRecursiveNLevel :: TestEnv -> Assertion
 testPublishRecursiveNLevel testEnv = do
   alicePrivateFolderId <- newPrivateFolderForUser testEnv alice
   alicePublicFolderId  <- newPublicFolderForUser testEnv alice
-  flip runReaderT testEnv $ runTestMonad $ do
+  runTestMonad testEnv $ do
     -- Create a corpus, by default is not read only
-    aliceUserId    <- getUserId (UserName "alice")
-    aliceFolderId  <- insertDefaultNode NodeFolder alicePrivateFolderId aliceUserId
-    aliceSubFolderId <- insertDefaultNode NodeFolder aliceFolderId aliceUserId
-    corpusId       <- insertDefaultNode NodeCorpus aliceSubFolderId aliceUserId
+    aliceUserId    <- runDBQuery $ getUserId (UserName "alice")
+    aliceFolderId  <- runDBTx $ insertDefaultNode NodeFolder alicePrivateFolderId aliceUserId
+    aliceSubFolderId <- runDBTx $ insertDefaultNode NodeFolder aliceFolderId aliceUserId
+    corpusId       <- runDBTx $ insertDefaultNode NodeCorpus aliceSubFolderId aliceUserId
 
     publishStrict (SourceId aliceFolderId) (TargetId alicePublicFolderId)
 
-    isNodeReadOnly aliceFolderId    >>= liftIO . (@?= True)
-    isNodeReadOnly aliceSubFolderId >>= liftIO . (@?= True)
-    isNodeReadOnly corpusId         >>= liftIO . (@?= True)
+    runDBQuery (isNodeReadOnly aliceFolderId)    >>= liftIO . (@?= True)
+    runDBQuery (isNodeReadOnly aliceSubFolderId) >>= liftIO . (@?= True)
+    runDBQuery (isNodeReadOnly corpusId)         >>= liftIO . (@?= True)
 
 testPublishLenientWorks :: TestEnv -> Assertion
 testPublishLenientWorks testEnv = do
   alicePrivateFolderId <- newPrivateFolderForUser testEnv alice
   alicePublicFolderId  <- newPublicFolderForUser testEnv alice
-  flip runReaderT testEnv $ runTestMonad $ do
-    aliceUserId <- getUserId (UserName "alice")
-    corpusId    <- insertDefaultNode NodeCorpus alicePrivateFolderId aliceUserId
+  runTestMonad testEnv $ do
+    aliceUserId <- runDBQuery $ getUserId (UserName "alice")
+    corpusId    <- runDBTx $ insertDefaultNode NodeCorpus alicePrivateFolderId aliceUserId
     publishLenient (SourceId corpusId) (TargetId alicePublicFolderId)
-    isNodeReadOnly corpusId >>= liftIO . (@?= True)
+    runDBQuery (isNodeReadOnly corpusId) >>= liftIO . (@?= True)

test/Test/Database/Setup.hs

@@ -23,7 +23,7 @@ import Gargantext.Core.Config.Types
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.Config.Worker (wsDatabase, wsDefinitions)
 import Gargantext.Core.NLP (nlpServerMap)
-import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
+import Gargantext.Core.NodeStory (mkNodeStoryEnv)
 import Gargantext.Core.Worker (initWorkerState)
 import Gargantext.Core.Worker.Env (WorkerEnv(..))
 import Gargantext.Prelude
@@ -116,7 +116,7 @@ setup = do
         pool <- newPool (setNumStripes (Just 2) poolConfig)
         bootstrapDB db pool gargConfig
         ugen <- emptyCounter
-        test_nodeStory <- fromDBNodeStoryEnv pool
+        let test_nodeStory = mkNodeStoryEnv
         withLoggerIO log_cfg $ \logger -> do
 
           let wPoolConfig = defaultPoolConfig (PG.connectPostgreSQL (Tmp.toConnectionString db))
@@ -124,7 +124,7 @@ setup = do
                                               idleTime
                                               maxResources
           wPool <- newPool (setNumStripes (Just 2) wPoolConfig)
-          wNodeStory <- fromDBNodeStoryEnv wPool
+          let wNodeStory = mkNodeStoryEnv
           _w_env_job_state <- newTVarIO Nothing
           withLoggerIO log_cfg $ \wioLogger -> do
             let wEnv = WorkerEnv { _w_env_config = gargConfig

test/Test/Database/Transactions.hs

@@ -10,7 +10,7 @@ module Test.Database.Transactions (
      tests
   ) where
 
-import System.Random.Stateful
+import Control.Concurrent.Async (forConcurrently)
 import Control.Exception.Safe
 import Control.Exception.Safe qualified as Safe
 import Control.Monad.Reader
@@ -26,15 +26,17 @@ import Database.PostgreSQL.Simple.Options qualified as Client
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.ToField
 import Database.Postgres.Temp qualified as Tmp
+import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.Database.Transactional
 import Gargantext.Prelude
 import Prelude qualified
 import Shelly as SH
+import System.Random.Stateful
 import Test.Database.Types hiding (Counter)
 import Test.Hspec
 import Test.Tasty.HUnit hiding (assert)
 import Text.RawString.QQ
-import Control.Concurrent.Async (forConcurrently)
+import Gargantext.Database.Query.Table.Node.Error (errorWith)
 
 --
 -- For these tests we do not want to test the normal GGTX database queries, but rather
@@ -47,9 +49,9 @@ import Control.Concurrent.Async (forConcurrently)
 -- | 2  | ...
 --
 
-newtype TestDBTxMonad a = TestDBTxMonad { _TestDBTxMonad :: TestMonadM DBHandle a }
+newtype TestDBTxMonad a = TestDBTxMonad { _TestDBTxMonad :: TestMonadM DBHandle BackendInternalError a }
   deriving ( Functor, Applicative, Monad
-           , MonadReader DBHandle, MonadError IOException
+           , MonadReader DBHandle, MonadError BackendInternalError
            , MonadBase IO
            , MonadBaseControl IO
            , MonadFail
@@ -59,6 +61,9 @@ newtype TestDBTxMonad a = TestDBTxMonad { _TestDBTxMonad :: TestMonadM DBHandle
            , MonadThrow
            )
 
+runTestDBTxMonad :: DBHandle -> TestMonadM DBHandle BackendInternalError a -> IO a
+runTestDBTxMonad env = flip runReaderT env . _TestMonad
+
 setup :: IO DBHandle
 setup = do
   res <- Tmp.startConfig tmpPgConfig
@@ -137,23 +142,23 @@ data Counter = Counter
 instance PG.FromRow Counter where
   fromRow = Counter <$> field <*> field
 
-getCounterById :: CounterId -> DBQuery IOException r Counter
+getCounterById :: CounterId -> DBQuery BackendInternalError r Counter
 getCounterById (CounterId cid) = do
   xs <- mkPGQuery [sql| SELECT * FROM public.ggtx_test_counter_table WHERE id = ?; |] (PG.Only cid)
   case xs of
     [c] -> pure c
-    rst -> dbFail $ Prelude.userError ("getCounterId returned more than one result: " <> show rst)
+    rst -> errorWith $ "getCounterId returned more than one result: " <> T.pack (show rst)
 
-insertCounter :: DBUpdate IOException Counter
+insertCounter :: DBUpdate BackendInternalError Counter
 insertCounter = do
   mkPGUpdateReturningOne [sql| INSERT INTO public.ggtx_test_counter_table(counter_value) VALUES(0) RETURNING id, counter_value|] ()
 
-updateCounter :: CounterId -> Int -> DBUpdate IOException Counter
+updateCounter :: CounterId -> Int -> DBUpdate BackendInternalError Counter
 updateCounter cid x = do
   mkPGUpdateReturningOne [sql| UPDATE public.ggtx_test_counter_table SET counter_value = ? WHERE id = ? RETURNING *|] (x, cid)
 
 -- | We deliberately write this as a composite operation.
-stepCounter :: CounterId -> DBUpdate IOException Counter
+stepCounter :: CounterId -> DBUpdate BackendInternalError Counter
 stepCounter cid = do
   Counter{..} <- getCounterById cid
   mkPGUpdateReturningOne [sql| UPDATE public.ggtx_test_counter_table SET counter_value = ? WHERE id = ? RETURNING *|] (counterValue + 1, cid)
@@ -179,22 +184,22 @@ tests = parallel $ around withTestCounterDB $
       it "should return a consistent state to different actors" testConsistency
 
 simplePGQueryWorks :: DBHandle -> Assertion
-simplePGQueryWorks env = flip runReaderT env $ runTestMonad $ do
+simplePGQueryWorks env = runTestDBTxMonad env $ do
   x <- runDBQuery $ getCounterById (CounterId 1)
   liftIO $ counterValue x `shouldBe` 42
 
 simplePGInsertWorks :: DBHandle -> Assertion
-simplePGInsertWorks env = flip runReaderT env $ runTestMonad $ do
+simplePGInsertWorks env = runTestDBTxMonad env $ do
   x <- runDBTx $ insertCounter
   liftIO $ x `shouldBe` (Counter (CounterId 2) 0)
 
 simplePGUpdateWorks :: DBHandle -> Assertion
-simplePGUpdateWorks env = flip runReaderT env $ runTestMonad $ do
+simplePGUpdateWorks env = runTestDBTxMonad env $ do
   x <- runDBTx $ updateCounter (CounterId 1) 99
   liftIO $ x `shouldBe` (Counter (CounterId 1) 99)
 
 mixQueriesAndUpdates :: DBHandle -> Assertion
-mixQueriesAndUpdates env = flip runReaderT env $ runTestMonad $ do
+mixQueriesAndUpdates env = runTestDBTxMonad env $ do
   (final_1, final_2) <- runDBTx $ do
     c1 <- insertCounter
     c2 <- insertCounter
@@ -206,14 +211,14 @@ mixQueriesAndUpdates env = flip runReaderT env $ runTestMonad $ do
     final_2 `shouldBe` (Counter (CounterId 3) 1)
 
 testRollback :: DBHandle -> Assertion
-testRollback env = flip runReaderT env $ runTestMonad $ do
+testRollback env = runTestDBTxMonad env $ do
   initialCounter <- runDBTx $ insertCounter >>= stepCounter . counterId
   liftIO $ counterValue initialCounter `shouldBe` 1
   -- Let's do another transaction where at the very last instruction we
   -- fail.
   Safe.handle (\(_ :: SomeException) -> pure ()) $ runDBTx $ do
     _x' <- stepCounter (counterId initialCounter)
-    dbFail (Prelude.userError "urgh")
+    errorWith "urgh"
 
   -- Let's check that the second 'stepCounter' didn't actually modified the counter's value.
   finalCounter <- runDBTx $ getCounterById (counterId initialCounter)
@@ -225,9 +230,9 @@ testConsistency :: DBHandle -> Assertion
 testConsistency env = do
 
   let competing_actors = 10
-  initialCounter <- flip runReaderT env $ runTestMonad $ runDBTx insertCounter
+  initialCounter <- runTestDBTxMonad env $ runDBTx insertCounter
 
-  results <- forConcurrently [ 1 .. competing_actors ] $ \x -> flip runReaderT env $ runTestMonad $ do
+  results <- forConcurrently [ 1 .. competing_actors ] $ \x -> runTestDBTxMonad env $ do
     -- random delay
     liftIO $ do
       delay_us <- uniformRM (100, 2_000_000) globalStdGen

test/Test/Database/Types.hs

@@ -39,6 +39,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
 import Network.URI (parseURI)
 import Prelude qualified
 import System.Log.FastLogger qualified as FL
+import GHC.IO.Exception (userError)
 
 
 newtype Counter = Counter { _Counter :: IORef Int }
@@ -56,15 +57,15 @@ nextCounter (Counter ref) = atomicModifyIORef' ref (\old -> (succ old, old))
 data TestEnv = TestEnv {
     test_db                  :: !DBHandle
   , test_config              :: !GargConfig
-  , test_nodeStory           :: !NodeStoryEnv
+  , test_nodeStory           :: !(NodeStoryEnv BackendInternalError)
   , test_usernameGen         :: !Counter
   , test_logger              :: !(Logger (GargM TestEnv BackendInternalError))
   , test_worker_tid          :: !ThreadId
   }
 
-newtype TestMonadM e a = TestMonad { runTestMonad :: ReaderT e IO a }
+newtype TestMonadM env err a = TestMonad { _TestMonad :: ReaderT env IO a }
   deriving ( Functor, Applicative, Monad
-           , MonadReader e, MonadError IOException
+           , MonadReader env
            , MonadBase IO
            , MonadBaseControl IO
            , MonadFail
@@ -74,7 +75,20 @@ newtype TestMonadM e a = TestMonad { runTestMonad :: ReaderT e IO a }
            , MonadThrow
            )
 
-type TestMonad = TestMonadM TestEnv
+runTestMonadM :: env -> TestMonadM env err a -> IO a
+runTestMonadM env = flip runReaderT env . _TestMonad
+
+runTestMonad :: TestEnv -> TestMonadM TestEnv BackendInternalError a -> IO a
+runTestMonad env = flip runReaderT env . _TestMonad
+
+-- | Shoehorn a BackendInternalError into an IOException, suitable
+-- for testing.
+instance MonadError BackendInternalError (TestMonadM env BackendInternalError) where
+  throwError e = TestMonad $ throwError (userError $ show e)
+  catchError (TestMonad m) hdl =
+    TestMonad $ ReaderT $ \e -> catchError (flip runReaderT e m) (\e' -> runTestMonadM e $ hdl (InternalWorkerError e'))
+
+type TestMonad = TestMonadM TestEnv BackendInternalError
 data TestJobHandle = TestNoJobHandle
 
 instance MonadJobStatus TestMonad where
@@ -116,16 +130,9 @@ instance HasMail TestEnv where
                                         , _mc_mail_login_type   = NoAuth
                                         , _mc_send_login_emails = LogEmailToConsole })
 
-instance HasNodeStoryEnv TestEnv where
+instance HasNodeStoryEnv TestEnv BackendInternalError where
   hasNodeStory = to test_nodeStory
 
-instance HasNodeStoryImmediateSaver TestEnv where
-  hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
-
-instance HasNodeArchiveStoryImmediateSaver TestEnv where
-  hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate
-
-
 coreNLPConfig :: NLPServerConfig
 coreNLPConfig =
   let uri = parseURI "http://localhost:9000"