Move the error handling in a dbtx to go via MonadError, not via exceptions

This means, of course, that now rollback tests are failing, but that's
fine, we can then fix things properly in the DbTx code.

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

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

test/Test/Database/Transactions.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE TupleSections        #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
 
 {-| Tests for the transactional DB API -}
 
@@ -29,12 +30,11 @@ 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.Core.Types.Individu
 import Gargantext.Database.Query.Table.User
 import Gargantext.Database.Schema.Prelude (Table (..))
 import Gargantext.Database.Transactional
-import Gargantext.Prelude hiding (catch)
+import Gargantext.Prelude hiding (throwIO, catch)
 import Opaleye (selectTable, requiredTableField, SqlInt4)
 import Opaleye qualified as O
 import Prelude qualified
@@ -48,6 +48,7 @@ import Test.Tasty.HUnit hiding (assert)
 import Text.RawString.QQ
 import Gargantext.Database.Action.User
 import Gargantext.Database.Query.Table.Node.Error
+import Control.Monad.Except (handleError)
 
 --
 -- For these tests we do not want to test the normal GGTX database queries, but rather
@@ -85,9 +86,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
@@ -97,8 +98,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
@@ -169,23 +174,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)
@@ -260,9 +265,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
+  handleError (\(_ :: 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)
@@ -303,7 +308,7 @@ opaCountQueries env = runTestDBTxMonad env $ do
 -- 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 = runTestMonad env $ do
+testGGTXErrorRollback env = runTestMonadM @NodeError env $ do
   let ur = NewUser "alfredo" "alfredo@foo.com" (GargPassword "mypass")
   let newUsers = ur NE.:| []
   hashed <- liftIO $ mapM toUserHash newUsers
@@ -315,7 +320,7 @@ testGGTXErrorRollback env = runTestMonad env $ do
   void $ (runDBTx $ do
     void $ updateUserEmail (insertedUr { userLight_email = "alfredo@bar.com" })
     nodeError $ NoRootFound -- it doesn't matter which exception
-    ) `catch` \(_e :: NodeError) -> pure () -- swallow it.
+    ) `catchError` \(_e :: NodeError) -> liftIO $ putStrLn ("GOT EXCEPTION: " <> displayException _e) -- swallow it.
 
   -- let's check that the email hasn't been changed.
   insertedUr' <- runDBQuery $ getUserLightDB (UserName "alfredo")

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