Fix rollaback behavior (issue #480)

This commit fixes the bug with DbTx rollbacks and domain-specific
errors. What we do now is throwing an exception during the evaluation of
`DbFail`, to later catch it _after_ `withTransactionM` has performed a
clean rollback, and only at that point we call `throwError`.

This also means that we need to catch `DbTx` errors via the `MonadError`
interface, not via the exception-handling interface, to get proper
rollback behavior.

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/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,9 @@ type IsCmd env err m =
   ( MonadReader     env     m
   , MonadError          err m
   , MonadBaseControl IO     m
+  , 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/Transactional.hs

@@ -42,6 +42,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 +52,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 +139,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 +185,26 @@ 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)
+      `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
 
 -- | 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 +215,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

test/Test/Database/Transactions.hs

@@ -320,7 +320,7 @@ testGGTXErrorRollback env = runTestMonadM @NodeError env $ do
   void $ (runDBTx $ do
     void $ updateUserEmail (insertedUr { userLight_email = "alfredo@bar.com" })
     nodeError $ NoRootFound -- it doesn't matter which exception
-    ) `catchError` \(_e :: NodeError) -> liftIO $ putStrLn ("GOT EXCEPTION: " <> displayException _e) -- swallow it.
+    ) `catchError` \(_e :: NodeError) -> pure () -- swallow it.
 
   -- let's check that the email hasn't been changed.
   insertedUr' <- runDBQuery $ getUserLightDB (UserName "alfredo")