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/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"