Merge branch 'adinapoli/issue-480' into 'dev'

Fix bug in DB transaction rollbacks in the presence of domain-specific errors

Closes #480

See merge request !420

src/Gargantext/API/Dev.hs

@@ -55,7 +55,7 @@ defaultSettingsFile :: SettingsFile
 defaultSettingsFile = SettingsFile "gargantext-settings.toml"
 
 -- | Run Cmd Sugar for the Repl (GHCI)
-runCmdRepl :: Show err => CmdRandom DevEnv err a -> IO a
+runCmdRepl :: (Typeable err, Show err) => CmdRandom DevEnv err a -> IO a
 runCmdRepl f = withDevEnv defaultSettingsFile $ \env -> runCmdDev env f
 
 runCmdReplServantErr :: CmdRandom DevEnv ServerError a -> IO a
@@ -65,7 +65,7 @@ runCmdReplServantErr = runCmdRepl
 -- the command.
 -- This function is constrained to the DevEnv rather than
 -- using HasConnectionPool and HasRepoVar.
-runCmdDev :: Show err => DevEnv -> CmdRandom DevEnv err a -> IO a
+runCmdDev :: (Typeable err, Show err) => DevEnv -> CmdRandom DevEnv err a -> IO a
 runCmdDev env f =
   either (fail . show) pure =<< runCmd env f
 

src/Gargantext/Database/Action/Delete.hs

@@ -32,7 +32,7 @@ import Gargantext.Database.GargDB qualified as GargDB
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getNodeWith)
 import Gargantext.Database.Query.Table.Node qualified as N (getNode, deleteNode)
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError, errorWith)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError, nodeErrorWith)
 import Gargantext.Database.Schema.Node
 import Gargantext.Prelude
 
@@ -51,7 +51,7 @@ deleteNode u nodeId = do
   (num, upd_node, cleanup) <- runDBTx $ do
     node' <- N.getNode nodeId
     (rows, clean_it) <- case view node_typename node' of
-      nt | nt == toDBid NodeUser -> errorWith "[G.D.A.D.deleteNode] Not allowed to delete NodeUser (yet)"
+      nt | nt == toDBid NodeUser -> nodeErrorWith "[G.D.A.D.deleteNode] Not allowed to delete NodeUser (yet)"
       nt | nt == toDBid NodeTeam -> do
         uId   <- getUserId u
         if _node_user_id node' == uId

src/Gargantext/Database/Action/Share.hs

@@ -26,7 +26,7 @@ import Gargantext.Database.Admin.Config (hasNodeType, isInNodeTypes)
 import Gargantext.Database.Admin.Types.Hyperdata.Any (HyperdataAny(..))
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Query.Table.Node (getNode, getNodesWith)
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError, errorWith)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError, nodeErrorWith)
 import Gargantext.Database.Query.Table.User
 import Gargantext.Database.Query.Tree.Root (getRootId)
 import Gargantext.Database.Schema.Node
@@ -98,10 +98,10 @@ shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
   nodeToCheck <- getNode   n
   userIdCheck <- getUserId u
   if not (hasNodeType nodeToCheck NodeTeam)
-    then errorWith "[G.D.A.S.shareNodeWith] Can share node Team only"
+    then nodeErrorWith "[G.D.A.S.shareNodeWith] Can share node Team only"
     else
       if (view node_user_id nodeToCheck == userIdCheck)
-        then errorWith "[G.D.A.S.shareNodeWith] Can share to others only"
+        then nodeErrorWith "[G.D.A.S.shareNodeWith] Can share to others only"
         else do
           folderSharedId  <- getFolderId u NodeFolderShared
           ret <- shareNode (SourceId folderSharedId) (TargetId n)
@@ -111,7 +111,7 @@ shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
 shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
   nodeToCheck <- getNode n
   if not (isInNodeTypes nodeToCheck publicNodeTypes)
-    then errorWith $ "[G.D.A.S.shareNodeWith] Can share this nodesTypes only: "
+    then nodeErrorWith $ "[G.D.A.S.shareNodeWith] Can share this nodesTypes only: "
                    <> (show publicNodeTypes)
     else do
       folderToCheck <- getNode nId
@@ -120,9 +120,9 @@ shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
           ret <- shareNode (SourceId nId) (TargetId n)
           let msgs = [CE.UpdateTreeFirstLevel nId, CE.UpdateTreeFirstLevel n]
           pure (ret, msgs)
-        else errorWith "[G.D.A.S.shareNodeWith] Can share NodeWith NodeFolderPublic only"
+        else nodeErrorWith "[G.D.A.S.shareNodeWith] Can share NodeWith NodeFolderPublic only"
 
-shareNodeWith _ _ = errorWith "[G.D.A.S.shareNodeWith] Not implemented for this NodeType"
+shareNodeWith _ _ = nodeErrorWith "[G.D.A.S.shareNodeWith] Not implemented for this NodeType"
 
 ------------------------------------------------------------------------
 getFolderId :: HasNodeError err => User -> NodeType -> DBQuery err x NodeId
@@ -130,7 +130,7 @@ getFolderId u nt = do
   rootId <- getRootId u
   s <- getNodesWith rootId HyperdataAny (Just nt) Nothing Nothing
   case head s of
-    Nothing -> errorWith "[G.D.A.S.getFolderId] No folder shared found"
+    Nothing -> nodeErrorWith "[G.D.A.S.getFolderId] No folder shared found"
     Just  f -> pure (_node_id f)
 
 ------------------------------------------------------------------------

src/Gargantext/Database/Action/User.hs

@@ -72,7 +72,7 @@ getUsername user@(UserDBId _) = do
   users <- getUsersWithId user
   case head users of
     Just u  -> pure $ userLight_username u
-    Nothing -> errorWith "G.D.A.U.getUserName: User not found with that id"
+    Nothing -> nodeErrorWith "G.D.A.U.getUserName: User not found with that id"
 getUsername (RootId   rid) = do
   n <- getNode rid
   getUsername (UserDBId $ _node_user_id n)

src/Gargantext/Database/Class.hs

@@ -2,15 +2,16 @@
 
 module Gargantext.Database.Class where
 
+import Control.Exception.Safe (MonadCatch)
 import Control.Lens (Getter)
 import Control.Monad.Random ( MonadRandom )
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Pool (Pool)
 import Database.PostgreSQL.Simple (Connection)
-import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
 import Gargantext.Core.Config (HasConfig(..))
 import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Core.NLP (HasNLPServer)
+import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
 import Gargantext.Prelude
 
 -- $typesAndConstraints
@@ -61,6 +62,13 @@ type IsCmd env err m =
   ( MonadReader     env     m
   , MonadError          err m
   , MonadBaseControl IO     m
+  -- These 3 instances below are needed because in the transactional code
+  -- we can throw 'err' as an exception, which requires 'err' to be an 'Exception'
+  -- and thus have a 'Show' and 'Typeable' instances. The fact that we can catch
+  -- exceptions in the evaluator of the 'DBTx' monad code means we need a 'MonadCatch'.
+  , Typeable err
+  , Show err
+  , MonadCatch m
   )
 
 -- | Only the /minimum/ amount of class constraints required

src/Gargantext/Database/Prelude.hs

@@ -89,7 +89,8 @@ withConn k = do
   pool <- view connPool
   liftBase $ withResource pool (liftBase . k)
 
-runCmd :: env
+runCmd :: (Show err, Typeable err)
+       => env
        -> CmdRandom env err a
        -> IO (Either err a)
 runCmd env m = runExceptT $ runReaderT m env

src/Gargantext/Database/Query/Table/Node/Error.hs

@@ -19,7 +19,7 @@ module Gargantext.Database.Query.Table.Node.Error (
   , HasNodeError(..)
 
   -- * Functions
-  , errorWith
+  , nodeErrorWith
   , nodeError
   , nodeCreationError
   , nodeLookupError
@@ -28,14 +28,15 @@ module Gargantext.Database.Query.Table.Node.Error (
   ) where
 
 import Control.Lens (Prism', (#), (^?))
+import Control.Lens qualified as L
 import Data.Aeson (object)
 import Data.Text qualified as T
 import Gargantext.Core.Types.Individu ( Username )
 import Gargantext.Database.Admin.Types.Node (ListId, NodeId(..), ContextId, UserId, ParentId)
+import Gargantext.Database.Transactional
 import Gargantext.Prelude hiding (sum, head)
 import Prelude hiding (null, id, map, sum, show)
 import Prelude qualified
-import Gargantext.Database.Transactional
 
 data NodeCreationError
   = UserParentAlreadyExists UserId ParentId
@@ -89,6 +90,9 @@ data NodeError = NoListFound ListId
                | MoveError NodeId NodeId T.Text
                | NodeNotExportable NodeId T.Text
 
+instance HasNodeError NodeError where
+  _NodeError = L.prism' Prelude.id Just
+
 instance Prelude.Show NodeError
   where
     show (NoListFound {})   = "No list found"
@@ -106,6 +110,8 @@ instance Prelude.Show NodeError
     show (MoveError s t reason) = "Moving " <> show s <> " to " <> show t <> " failed: " <> T.unpack reason
     show (NodeNotExportable nid reason) = "Node " <> show nid <> " is not exportable: " <> show reason
 
+instance Exception NodeError
+
 instance ToJSON NodeError where
   toJSON (DoesNotExist n) =
     object [ ( "error", "Node does not exist" )
@@ -135,8 +141,8 @@ instance ToJSON NodeError where
 class HasNodeError e where
   _NodeError :: Prism' e NodeError
 
-errorWith :: HasNodeError e => Text -> DBTx e r a
-errorWith x = nodeError (NodeError $ toException $ userError $ T.unpack x)
+nodeErrorWith :: HasNodeError e => Text -> DBTx e r a
+nodeErrorWith x = nodeError (NodeError $ toException $ userError $ T.unpack x)
 
 nodeError :: HasNodeError e => NodeError -> DBTx e r a
 nodeError ne = dbFail $ _NodeError # ne

src/Gargantext/Database/Query/Tree/Root.hs

@@ -37,7 +37,7 @@ getRootId :: (HasNodeError err) => User -> DBQuery err x NodeId
 getRootId u = do
   maybeRoot <- head <$> getRoot u
   case maybeRoot of
-    Nothing -> errorWith "[G.D.Q.T.R.getRootId] No root id"
+    Nothing -> nodeErrorWith "[G.D.Q.T.R.getRootId] No root id"
     Just  r -> pure (_node_id r)
 
 getRoot :: User -> DBQuery err x [Node HyperdataUser]
@@ -115,7 +115,7 @@ mkCorpus :: (HasNodeError err, MkCorpus a)
 mkCorpus cName c rootId userId = do
   c' <- mk (Just cName) c rootId userId
   _tId <- case head c' of
-            Nothing  -> errorWith "[G.D.Q.T.Root.getOrMk...] mk Corpus failed"
+            Nothing  -> nodeErrorWith "[G.D.Q.T.Root.getOrMk...] mk Corpus failed"
             Just c'' -> insertDefaultNode NodeTexts c'' userId
 
   corpusId <- maybe (nodeError NoCorpusFound) pure (head c')

src/Gargantext/Database/Transactional.hs

@@ -33,8 +33,10 @@ module Gargantext.Database.Transactional (
   , mkOpaInsert
   , mkOpaDelete
 
-  -- * Throwing errors (which allows rollbacks)
+  -- * Throwing and catching errors (which allows rollbacks)
   , dbFail
+  , catchDBTxError
+  , handleDBTxError
   ) where
 
 import Control.Exception.Safe qualified as Safe
@@ -42,6 +44,7 @@ import Control.Lens
 import Control.Monad.Base
 import Control.Monad.Error.Class
 import Control.Monad.Free
+import Control.Monad.Free.Church
 import Control.Monad.Trans.Control (MonadBaseControl, control)
 import Data.Int (Int64)
 import Data.Pool (withResource, Pool)
@@ -51,7 +54,12 @@ import Database.PostgreSQL.Simple.Transaction qualified as PG
 import Gargantext.Database.Class
 import Opaleye
 import Prelude
-import Control.Monad.Free.Church
+
+data DBTxException err
+  = RollbackRequested err
+  deriving (Show, Eq)
+
+instance (Show err, Safe.Typeable err) => Safe.Exception (DBTxException err) where
 
 data DBOperation = DBRead | DBWrite
 
@@ -133,7 +141,7 @@ type DBReadOnly err r a = DBTx err DBRead a
 -- Strict constraints to perform transactional read and writes.
 -- Isomorphic to a DBCmd, but it doesn't impose a 'HasConfig' constraint, as
 -- values can always be passed as parameters of a query or update.
-type DBTxCmd err a = forall m env. (IsCmd env err m, HasConnectionPool env) => m a
+type DBTxCmd err a = forall m env. (IsCmd env err m, HasConnectionPool env, Safe.MonadCatch m) => m a
 
 instance Functor (DBTransactionOp err r) where
   fmap f = \case
@@ -179,23 +187,37 @@ withReadOnlyTransactionM conn action =
 
 -- | Run a PostgreSQL transaction, suitable for operations that mixes read and writes,
 -- and actually the only choice available to run 'DBUpdate' operations.
-runDBTx :: DBUpdate err a -> DBTxCmd err a
+runDBTx :: (Show err, Safe.Typeable err) => DBUpdate err a -> DBTxCmd err a
 runDBTx (DBTx m) = do
   pool <- view connPool
-  withResourceM pool $ \conn -> withTransactionM conn $ foldF (evalOp conn) m
+  withResourceM pool $ \conn ->
+    (withTransactionM conn $ foldF (evalOp conn) m)
+      -- IMPORTANT: We are catching the exception (after 'withTransactionM' has run, so rollback already
+      -- happened) and we are rethrowing this via 'throwError', such that application code can catch this
+      -- via 'catchDBTxError'.
+      -- /NOTA BENE/: the parenthesis around 'withTransactionM' ARE NOT OPTIONAL! If we remove them, we
+      -- would be catching this exception from 'foldF', meaning that we wouldn't let 'withTransactionM'
+      -- handle it, resulting in ROLLBACK NOT HAPPENING!
+      `Safe.catches`
+        [ Safe.Handler $ \(RollbackRequested err) -> throwError err ]
 
 -- | Runs a DB query.
 -- /NOTE/ the input type is 'DBReadOnly', i.e. a transaction where /all/
 -- the operations are 'DBRead'. This makes impossible to sneak in updates
 -- into otherwise read-only queries.
-runDBQuery :: DBReadOnly err r a -> DBTxCmd err a
+runDBQuery :: (Show err, Safe.Typeable err) => DBReadOnly err r a -> DBTxCmd err a
 runDBQuery (DBTx m) = do
   pool <- view connPool
-  withResourceM pool $ \conn -> withReadOnlyTransactionM conn $ foldF (evalOp conn) m
+  withResourceM pool $ \conn ->
+    (withReadOnlyTransactionM conn $ foldF (evalOp conn) m)
+      -- IMPORTANT: Same proviso as for 'runDBTx'. Technically speaking we wouldn't need
+      -- to throw and catch things for a query, but we are doing so for consistency with 'runDBTx'.
+      `Safe.catches`
+        [ Safe.Handler $ \(RollbackRequested err) -> throwError err ]
 
 -- | The main evaluator, turns our pure operations into side-effects that run into the
 -- 'DBCmd'.
-evalOp :: PG.Connection -> DBTransactionOp err r a -> DBTxCmd err a
+evalOp :: (Show err, Safe.Typeable err) => PG.Connection -> DBTransactionOp err r a -> DBTxCmd err a
 evalOp conn = \case
   PGQuery   qr q cc             -> cc <$> liftBase (PG.query conn qr q)
   PGUpdate  qr a cc             -> cc <$> liftBase (PG.execute conn qr a)
@@ -206,7 +228,7 @@ evalOp conn = \case
   OpaInsert ins  cc             -> cc <$> liftBase (runInsert conn ins)
   OpaUpdate upd  cc             -> cc <$> liftBase (runUpdate conn upd)
   OpaDelete del  cc             -> cc <$> liftBase (runDelete conn del)
-  DBFail    err                 -> throwError err
+  DBFail    err                 -> liftBase (Safe.throwIO $ RollbackRequested err)
 
 evalOpaCountQuery :: PG.Connection -> Select a -> IO Int
 evalOpaCountQuery conn sel = do
@@ -228,6 +250,49 @@ queryOne conn q v = do
     [ ] -> Safe.throwIO $ userError "queryOne: no result returned. Check your SQL!"
     _   -> Safe.throwIO $ userError "queryOne: more than one result returned. Have you used the 'RETURNING' directive?"
 
+{-
+
+Throwing and catching exceptions in a DBTx monad
+================================================
+
+It's /VERY/ important to understand the proper way to throw and catch exceptions in a DBTx monad,
+as not doing so might lead to footguns.
+
+We need to remember that when we are composing 'DBTx' operations, we are just writing a DSL which
+won't get evaluated until we call either 'runDBTx' or 'runDBQuery', therefore if some parts of
+our transaction throw an error, we wouldn't know until there.
+There are two types of errors we might have, and it's important to be precise in terminology:
+
+1. IO Exception: these are being thrown by the evaluators for SQL queries, i.e. we might have
+   IO errors being thrown by wrongly-formatted SQL queries or the Postgres DB dying on us for any reason;
+   These exceptions get caught by 'withTransactionM' which allows proper rollback behavior, but crucially
+   these kind of exceptions gets rethrown by 'withTransactionM' and must be caught via the classic
+   exception handlers in upstream code, but the crucial point is that even if we don't catch them, the
+   transaction has been rolled back successfully;
+2. Domain-specific ERRORS (not exceptions, ERRORS!) being thrown within a transaction itself via things like
+   'nodeError' and friends. These are errors which can be thrown because our transaction code didn't go as
+   planned (look for the implementation of 'insertNodeWithHyperdata' for a concrete example). These errors
+   are translated into the evaluator as proper exception but then caught and rethrown via 'throwError', which
+   is crucial, because it means that them being thrown as an exception means 'withTransactionM' can rollback
+   as we expect to, but upstream application code can still handle these errors via 'catchError' and friends.
+
+In order to facilitate the handling of this, we expose the 'catchDBTxError' and 'handleDBTxError', which are
+just wrappers over 'catchError' -- this is what users should be using if they want to handle domain-specific errors.
+
+But the crucial bit, and let's state this again, is that rollbacks will happen in both scenario, which is
+what we want.
+-}
+
+catchDBTxError :: DBTxCmd err a
+               -> (err -> DBTxCmd err a)
+               -> DBTxCmd err a
+catchDBTxError = catchError
+
+handleDBTxError :: (err -> DBTxCmd err a)
+                -> DBTxCmd err a
+                -> DBTxCmd err a
+handleDBTxError = flip catchError
+
 --
 -- Smart constructors
 --
@@ -235,9 +300,6 @@ queryOne conn q v = do
 -- we are not exposing for information hiding purposes.
 --
 
-dbFail :: err -> DBTx err r b
-dbFail = DBTx . liftF . DBFail
-
 mkPGQuery :: (PG.ToRow q, PG.FromRow a)
            => PG.Query
            -> q
@@ -270,3 +332,6 @@ mkOpaInsert a = DBTx $ liftF (OpaInsert a id)
 
 mkOpaDelete :: Delete a -> DBUpdate err a
 mkOpaDelete a = DBTx $ liftF (OpaDelete a id)
+
+dbFail :: err -> DBTx err r b
+dbFail = DBTx . liftF . DBFail

test/Test/Database/Operations/DocumentSearch.hs

@@ -31,7 +31,7 @@ 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.Table.Node.Error (nodeErrorWith)
 import Gargantext.Database.Query.Tree.Root
 import Gargantext.Database.Query.Table.NodeContext (selectCountDocs)
 import Gargantext.Database.Schema.Node (NodePoly(..))
@@ -119,7 +119,7 @@ getCorporaWithParentIdOrFail parentId = do
   xs <- getCorporaWithParentId parentId
   case xs of
     [corpus] -> pure corpus
-    _        -> errorWith $ "getCorporaWithParentIdOrFail, impossible: " <> T.pack (show xs)
+    _        -> nodeErrorWith $ "getCorporaWithParentIdOrFail, impossible: " <> T.pack (show xs)
 
 addCorpusDocuments :: TestEnv -> IO TestEnv
 addCorpusDocuments env = runTestMonad env $ do

test/Test/Database/Transactions.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE TupleSections        #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
 
 {-| Tests for the transactional DB API -}
 
@@ -16,6 +17,7 @@ import Control.Exception.Safe
 import Control.Exception.Safe qualified as Safe
 import Control.Monad.Reader
 import Control.Monad.Trans.Control
+import Data.List.NonEmpty qualified as NE
 import Data.Pool
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Data.String
@@ -28,20 +30,24 @@ 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.Query.Table.Node.Error (errorWith)
+import Gargantext.Core.Types.Individu
+import Gargantext.Database.Query.Table.User
 import Gargantext.Database.Schema.Prelude (Table (..))
 import Gargantext.Database.Transactional
-import Gargantext.Prelude
+import Gargantext.Prelude hiding (throwIO, catch)
 import Opaleye (selectTable, requiredTableField, SqlInt4)
 import Opaleye qualified as O
 import Prelude qualified
 import Shelly as SH
 import System.Random.Stateful
+import Test.API.Setup (setupEnvironment)
+import Test.Database.Setup
 import Test.Database.Types hiding (Counter)
 import Test.Hspec
 import Test.Tasty.HUnit hiding (assert)
 import Text.RawString.QQ
+import Gargantext.Database.Action.User
+import Gargantext.Database.Query.Table.Node.Error
 
 --
 -- For these tests we do not want to test the normal GGTX database queries, but rather
@@ -79,9 +85,9 @@ countersTable  =
          )
 
 
-newtype TestDBTxMonad a = TestDBTxMonad { _TestDBTxMonad :: TestMonadM DBHandle BackendInternalError a }
+newtype TestDBTxMonad a = TestDBTxMonad { _TestDBTxMonad :: TestMonadM DBHandle IOException a }
   deriving ( Functor, Applicative, Monad
-           , MonadReader DBHandle, MonadError BackendInternalError
+           , MonadReader DBHandle, MonadError IOException
            , MonadBase IO
            , MonadBaseControl IO
            , MonadFail
@@ -91,8 +97,12 @@ newtype TestDBTxMonad a = TestDBTxMonad { _TestDBTxMonad :: TestMonadM DBHandle
            , MonadThrow
            )
 
-runTestDBTxMonad :: DBHandle -> TestMonadM DBHandle BackendInternalError a -> IO a
-runTestDBTxMonad env = flip runReaderT env . _TestMonad
+runTestDBTxMonad :: DBHandle -> TestMonadM DBHandle IOException a -> IO a
+runTestDBTxMonad env m = do
+  res <- flip runReaderT env . runExceptT . _TestMonad $ m
+  case res of
+    Left err -> throwIO $ Prelude.userError ("runTestDBTxMonad: " <> displayException err)
+    Right x  -> pure x
 
 setup :: IO DBHandle
 setup = do
@@ -163,23 +173,23 @@ teardown test_db = do
 instance PG.FromRow Counter where
   fromRow = Counter <$> field <*> field
 
-getCounterById :: CounterId -> DBQuery BackendInternalError r Counter
+getCounterById :: CounterId -> DBQuery IOException 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 -> errorWith $ "getCounterId returned more than one result: " <> T.pack (show rst)
+    rst -> dbFail $ Prelude.userError $ "getCounterId returned more than one result: " <> show rst
 
-insertCounter :: DBUpdate BackendInternalError Counter
+insertCounter :: DBUpdate IOException Counter
 insertCounter = do
   mkPGUpdateReturningOne [sql| INSERT INTO public.ggtx_test_counter_table(counter_value) VALUES(0) RETURNING id, counter_value|] ()
 
-updateCounter :: CounterId -> Int -> DBUpdate BackendInternalError Counter
+updateCounter :: CounterId -> Int -> DBUpdate IOException 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 BackendInternalError Counter
+stepCounter :: CounterId -> DBUpdate IOException Counter
 stepCounter cid = do
   Counter{..} <- getCounterById cid
   mkPGUpdateReturningOne [sql| UPDATE public.ggtx_test_counter_table SET counter_value = ? WHERE id = ? RETURNING *|] (counterValue + 1, cid)
@@ -189,8 +199,15 @@ stepCounter cid = do
 --
 
 tests :: Spec
-tests = parallel $ around withTestCounterDB $
-  describe "Database Transactions" $ do
+tests = describe "Database Transactions" $ do
+  counterDBTests
+  ggtxDBTests
+
+-- | Testing the transactional behaviour outside the classic GGTX operations.
+-- We test that throwing exceptions in IO leads to rollbacks.
+counterDBTests :: Spec
+counterDBTests = parallel $ around withTestCounterDB $
+  describe "Counter Transactions" $ do
     describe "Opaleye count queries" $ do
       it "Supports counting rows" opaCountQueries
     describe "Pure PG Queries" $ do
@@ -206,6 +223,14 @@ tests = parallel $ around withTestCounterDB $
     describe "Read/Write Consistency" $ do
       it "should return a consistent state to different actors" testConsistency
 
+-- | Testing the transactional behaviour inside the classic GGTX operations.
+-- We test that throwing something like a 'NodeError' results in a proper rollback.
+ggtxDBTests :: Spec
+ggtxDBTests = parallel $ around withTestDB $ beforeWith (\ctx -> setupEnvironment ctx >>= (const $ pure ctx)) $
+  describe "GGTX Transactions" $ do
+    describe "Rollback support" $ do
+      it "can rollback if a ggtx error gets thrown" testGGTXErrorRollback
+
 simplePGQueryWorks :: DBHandle -> Assertion
 simplePGQueryWorks env = runTestDBTxMonad env $ do
   x <- runDBQuery $ getCounterById (CounterId 1)
@@ -239,9 +264,9 @@ testRollback env = runTestDBTxMonad env $ do
   liftIO $ counterValue initialCounter `shouldBe` 1
   -- Let's do another transaction where at the very last instruction we
   -- fail.
-  Safe.handle (\(_ :: SomeException) -> pure ()) $ runDBTx $ do
+  handleDBTxError (\(_ :: IOException) -> pure ()) $ runDBTx $ do
     _x' <- stepCounter (counterId initialCounter)
-    errorWith "urgh"
+    dbFail $ Prelude.userError "urgh"
 
   -- Let's check that the second 'stepCounter' didn't actually modified the counter's value.
   finalCounter <- runDBTx $ getCounterById (counterId initialCounter)
@@ -277,3 +302,26 @@ opaCountQueries env = runTestDBTxMonad env $ do
     _ <- insertCounter
     mkOpaCountQuery (selectTable countersTable)
   liftIO $ num @?= 3
+
+-- | In this simple test we create a user node in GGTX, we try
+-- to update it, and check that if we throw an error in the update
+-- transaction, the changes are not propagated
+testGGTXErrorRollback :: TestEnv -> Assertion
+testGGTXErrorRollback env = runTestMonadM @NodeError env $ do
+  let ur = NewUser "alfredo" "alfredo@foo.com" (GargPassword "mypass")
+  let newUsers = ur NE.:| []
+  hashed <- liftIO $ mapM toUserHash newUsers
+  void $ runDBTx $ insertNewUsers hashed
+  -- Retrieve the user, check the details
+  insertedUr <- runDBQuery $ getUserLightDB (UserName "alfredo")
+  liftIO $ userLight_username insertedUr `shouldBe` "alfredo"
+  -- CRUCIAL bit: try to update the email, throw an exception in the same tx block
+  void $ (runDBTx $ do
+    void $ updateUserEmail (insertedUr { userLight_email = "alfredo@bar.com" })
+    nodeError $ NoRootFound -- it doesn't matter which exception
+    ) `catchDBTxError` \(_e :: NodeError) -> pure () -- swallow it.
+
+  -- let's check that the email hasn't been changed.
+  insertedUr' <- runDBQuery $ getUserLightDB (UserName "alfredo")
+  liftIO $ userLight_email insertedUr' `shouldBe` "alfredo@foo.com"
+

test/Test/Database/Types.hs

@@ -17,7 +17,6 @@ module Test.Database.Types where
 
 import Control.Exception.Safe
 import Control.Lens
-import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.Trans.Control
 import Data.IORef
@@ -25,8 +24,7 @@ import Data.Map qualified as Map
 import Data.Pool
 import Database.PostgreSQL.Simple qualified as PG
 import Database.Postgres.Temp qualified as Tmp
-import GHC.IO.Exception (userError)
-import Gargantext hiding (to)
+import Gargantext hiding (throwIO, to)
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
@@ -41,6 +39,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
 import Network.URI (parseURI)
 import Prelude qualified
 import System.Log.FastLogger qualified as FL
+import System.IO.Error (userError)
 
 
 newtype Counter = Counter { _Counter :: IORef Int }
@@ -64,10 +63,11 @@ data TestEnv = TestEnv {
   , test_worker_tid          :: !ThreadId
   }
 
-newtype TestMonadM env err a = TestMonad { _TestMonad :: ReaderT env IO a }
+newtype TestMonadM env err a = TestMonad { _TestMonad :: ExceptT err (ReaderT env IO) a }
   deriving ( Functor, Applicative, Monad
            , MonadReader env
            , MonadBase IO
+           , MonadError err
            , MonadBaseControl IO
            , MonadFail
            , MonadIO
@@ -76,10 +76,10 @@ newtype TestMonadM env err a = TestMonad { _TestMonad :: ReaderT env IO a }
            , MonadThrow
            )
 
-instance HasLogger (TestMonadM TestEnv BackendInternalError) where
-  data instance Logger (TestMonadM TestEnv BackendInternalError)        = TestLogger { _IOLogger :: IOStdLogger }
-  type instance LogInitParams (TestMonadM TestEnv BackendInternalError) = LogConfig
-  type instance LogPayload (TestMonadM TestEnv BackendInternalError)    = Prelude.String
+instance HasLogger (TestMonadM TestEnv err) where
+  data instance Logger (TestMonadM TestEnv err)        = TestLogger { _IOLogger :: IOStdLogger }
+  type instance LogInitParams (TestMonadM TestEnv err) = LogConfig
+  type instance LogPayload (TestMonadM TestEnv err)    = Prelude.String
   initLogger cfg = fmap TestLogger $ (liftIO $ ioStdLogger cfg)
   destroyLogger = liftIO . _iosl_destroy . _IOLogger
   logMsg (TestLogger ioLogger) lvl msg = liftIO $ _iosl_log_msg ioLogger lvl msg
@@ -89,18 +89,19 @@ instance MonadLogger (TestMonadM TestEnv BackendInternalError) where
   getLogger = TestMonad $ do
     initLogger @(TestMonadM TestEnv BackendInternalError) (LogConfig Nothing ERROR)
 
-runTestMonadM :: env -> TestMonadM env err a -> IO a
-runTestMonadM env = flip runReaderT env . _TestMonad
+runTestMonadM :: Show err => env -> TestMonadM env err a -> IO a
+runTestMonadM env m = do
+  res <- flip runReaderT env . runExceptT . _TestMonad $ m
+  case res of
+    Left err -> throwIO $ userError (show err)
+    Right x  -> pure x
 
 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'))
+runTestMonad env m = do
+  res <- flip runReaderT env . runExceptT . _TestMonad $ m
+  case res of
+    Left err -> throwIO $ userError ("runTestMonad: " <> show err)
+    Right x  -> pure x
 
 type TestMonad = TestMonadM TestEnv BackendInternalError
 data TestJobHandle = TestNoJobHandle