Commit 0c34eb47 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

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.
parent 947cbe5a
...@@ -28,14 +28,15 @@ module Gargantext.Database.Query.Table.Node.Error ( ...@@ -28,14 +28,15 @@ module Gargantext.Database.Query.Table.Node.Error (
) where ) where
import Control.Lens (Prism', (#), (^?)) import Control.Lens (Prism', (#), (^?))
import Control.Lens qualified as L
import Data.Aeson (object) import Data.Aeson (object)
import Data.Text qualified as T import Data.Text qualified as T
import Gargantext.Core.Types.Individu ( Username ) import Gargantext.Core.Types.Individu ( Username )
import Gargantext.Database.Admin.Types.Node (ListId, NodeId(..), ContextId, UserId, ParentId) import Gargantext.Database.Admin.Types.Node (ListId, NodeId(..), ContextId, UserId, ParentId)
import Gargantext.Database.Transactional
import Gargantext.Prelude hiding (sum, head) import Gargantext.Prelude hiding (sum, head)
import Prelude hiding (null, id, map, sum, show) import Prelude hiding (null, id, map, sum, show)
import Prelude qualified import Prelude qualified
import Gargantext.Database.Transactional
data NodeCreationError data NodeCreationError
= UserParentAlreadyExists UserId ParentId = UserParentAlreadyExists UserId ParentId
...@@ -89,6 +90,9 @@ data NodeError = NoListFound ListId ...@@ -89,6 +90,9 @@ data NodeError = NoListFound ListId
| MoveError NodeId NodeId T.Text | MoveError NodeId NodeId T.Text
| NodeNotExportable NodeId T.Text | NodeNotExportable NodeId T.Text
instance HasNodeError NodeError where
_NodeError = L.prism' Prelude.id Just
instance Prelude.Show NodeError instance Prelude.Show NodeError
where where
show (NoListFound {}) = "No list found" show (NoListFound {}) = "No list found"
......
...@@ -4,6 +4,7 @@ ...@@ -4,6 +4,7 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-| Tests for the transactional DB API -} {-| Tests for the transactional DB API -}
...@@ -29,12 +30,11 @@ import Database.PostgreSQL.Simple.Options qualified as Client ...@@ -29,12 +30,11 @@ import Database.PostgreSQL.Simple.Options qualified as Client
import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.ToField import Database.PostgreSQL.Simple.ToField
import Database.Postgres.Temp qualified as Tmp import Database.Postgres.Temp qualified as Tmp
import Gargantext.API.Errors.Types (BackendInternalError)
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
import Gargantext.Database.Query.Table.User import Gargantext.Database.Query.Table.User
import Gargantext.Database.Schema.Prelude (Table (..)) import Gargantext.Database.Schema.Prelude (Table (..))
import Gargantext.Database.Transactional import Gargantext.Database.Transactional
import Gargantext.Prelude hiding (catch) import Gargantext.Prelude hiding (throwIO, catch)
import Opaleye (selectTable, requiredTableField, SqlInt4) import Opaleye (selectTable, requiredTableField, SqlInt4)
import Opaleye qualified as O import Opaleye qualified as O
import Prelude qualified import Prelude qualified
...@@ -48,6 +48,7 @@ import Test.Tasty.HUnit hiding (assert) ...@@ -48,6 +48,7 @@ import Test.Tasty.HUnit hiding (assert)
import Text.RawString.QQ import Text.RawString.QQ
import Gargantext.Database.Action.User import Gargantext.Database.Action.User
import Gargantext.Database.Query.Table.Node.Error 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 -- For these tests we do not want to test the normal GGTX database queries, but rather
...@@ -85,9 +86,9 @@ countersTable = ...@@ -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 deriving ( Functor, Applicative, Monad
, MonadReader DBHandle, MonadError BackendInternalError , MonadReader DBHandle, MonadError IOException
, MonadBase IO , MonadBase IO
, MonadBaseControl IO , MonadBaseControl IO
, MonadFail , MonadFail
...@@ -97,8 +98,12 @@ newtype TestDBTxMonad a = TestDBTxMonad { _TestDBTxMonad :: TestMonadM DBHandle ...@@ -97,8 +98,12 @@ newtype TestDBTxMonad a = TestDBTxMonad { _TestDBTxMonad :: TestMonadM DBHandle
, MonadThrow , MonadThrow
) )
runTestDBTxMonad :: DBHandle -> TestMonadM DBHandle BackendInternalError a -> IO a runTestDBTxMonad :: DBHandle -> TestMonadM DBHandle IOException a -> IO a
runTestDBTxMonad env = flip runReaderT env . _TestMonad 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 :: IO DBHandle
setup = do setup = do
...@@ -169,23 +174,23 @@ teardown test_db = do ...@@ -169,23 +174,23 @@ teardown test_db = do
instance PG.FromRow Counter where instance PG.FromRow Counter where
fromRow = Counter <$> field <*> field fromRow = Counter <$> field <*> field
getCounterById :: CounterId -> DBQuery BackendInternalError r Counter getCounterById :: CounterId -> DBQuery IOException r Counter
getCounterById (CounterId cid) = do getCounterById (CounterId cid) = do
xs <- mkPGQuery [sql| SELECT * FROM public.ggtx_test_counter_table WHERE id = ?; |] (PG.Only cid) xs <- mkPGQuery [sql| SELECT * FROM public.ggtx_test_counter_table WHERE id = ?; |] (PG.Only cid)
case xs of case xs of
[c] -> pure c [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 insertCounter = do
mkPGUpdateReturningOne [sql| INSERT INTO public.ggtx_test_counter_table(counter_value) VALUES(0) RETURNING id, counter_value|] () 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 updateCounter cid x = do
mkPGUpdateReturningOne [sql| UPDATE public.ggtx_test_counter_table SET counter_value = ? WHERE id = ? RETURNING *|] (x, cid) mkPGUpdateReturningOne [sql| UPDATE public.ggtx_test_counter_table SET counter_value = ? WHERE id = ? RETURNING *|] (x, cid)
-- | We deliberately write this as a composite operation. -- | We deliberately write this as a composite operation.
stepCounter :: CounterId -> DBUpdate BackendInternalError Counter stepCounter :: CounterId -> DBUpdate IOException Counter
stepCounter cid = do stepCounter cid = do
Counter{..} <- getCounterById cid Counter{..} <- getCounterById cid
mkPGUpdateReturningOne [sql| UPDATE public.ggtx_test_counter_table SET counter_value = ? WHERE id = ? RETURNING *|] (counterValue + 1, 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 ...@@ -260,9 +265,9 @@ testRollback env = runTestDBTxMonad env $ do
liftIO $ counterValue initialCounter `shouldBe` 1 liftIO $ counterValue initialCounter `shouldBe` 1
-- Let's do another transaction where at the very last instruction we -- Let's do another transaction where at the very last instruction we
-- fail. -- fail.
Safe.handle (\(_ :: SomeException) -> pure ()) $ runDBTx $ do handleError (\(_ :: IOException) -> pure ()) $ runDBTx $ do
_x' <- stepCounter (counterId initialCounter) _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. -- Let's check that the second 'stepCounter' didn't actually modified the counter's value.
finalCounter <- runDBTx $ getCounterById (counterId initialCounter) finalCounter <- runDBTx $ getCounterById (counterId initialCounter)
...@@ -303,7 +308,7 @@ opaCountQueries env = runTestDBTxMonad env $ do ...@@ -303,7 +308,7 @@ opaCountQueries env = runTestDBTxMonad env $ do
-- to update it, and check that if we throw an error in the update -- to update it, and check that if we throw an error in the update
-- transaction, the changes are not propagated -- transaction, the changes are not propagated
testGGTXErrorRollback :: TestEnv -> Assertion testGGTXErrorRollback :: TestEnv -> Assertion
testGGTXErrorRollback env = runTestMonad env $ do testGGTXErrorRollback env = runTestMonadM @NodeError env $ do
let ur = NewUser "alfredo" "alfredo@foo.com" (GargPassword "mypass") let ur = NewUser "alfredo" "alfredo@foo.com" (GargPassword "mypass")
let newUsers = ur NE.:| [] let newUsers = ur NE.:| []
hashed <- liftIO $ mapM toUserHash newUsers hashed <- liftIO $ mapM toUserHash newUsers
...@@ -315,7 +320,7 @@ testGGTXErrorRollback env = runTestMonad env $ do ...@@ -315,7 +320,7 @@ testGGTXErrorRollback env = runTestMonad env $ do
void $ (runDBTx $ do void $ (runDBTx $ do
void $ updateUserEmail (insertedUr { userLight_email = "alfredo@bar.com" }) void $ updateUserEmail (insertedUr { userLight_email = "alfredo@bar.com" })
nodeError $ NoRootFound -- it doesn't matter which exception 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. -- let's check that the email hasn't been changed.
insertedUr' <- runDBQuery $ getUserLightDB (UserName "alfredo") insertedUr' <- runDBQuery $ getUserLightDB (UserName "alfredo")
......
...@@ -17,7 +17,6 @@ module Test.Database.Types where ...@@ -17,7 +17,6 @@ module Test.Database.Types where
import Control.Exception.Safe import Control.Exception.Safe
import Control.Lens import Control.Lens
import Control.Monad.Except
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Control import Control.Monad.Trans.Control
import Data.IORef import Data.IORef
...@@ -25,8 +24,7 @@ import Data.Map qualified as Map ...@@ -25,8 +24,7 @@ import Data.Map qualified as Map
import Data.Pool import Data.Pool
import Database.PostgreSQL.Simple qualified as PG import Database.PostgreSQL.Simple qualified as PG
import Database.Postgres.Temp qualified as Tmp import Database.Postgres.Temp qualified as Tmp
import GHC.IO.Exception (userError) import Gargantext hiding (throwIO, to)
import Gargantext hiding (to)
import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Errors.Types import Gargantext.API.Errors.Types
import Gargantext.API.Prelude import Gargantext.API.Prelude
...@@ -41,6 +39,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..)) ...@@ -41,6 +39,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
import Network.URI (parseURI) import Network.URI (parseURI)
import Prelude qualified import Prelude qualified
import System.Log.FastLogger qualified as FL import System.Log.FastLogger qualified as FL
import System.IO.Error (userError)
newtype Counter = Counter { _Counter :: IORef Int } newtype Counter = Counter { _Counter :: IORef Int }
...@@ -64,10 +63,11 @@ data TestEnv = TestEnv { ...@@ -64,10 +63,11 @@ data TestEnv = TestEnv {
, test_worker_tid :: !ThreadId , 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 deriving ( Functor, Applicative, Monad
, MonadReader env , MonadReader env
, MonadBase IO , MonadBase IO
, MonadError err
, MonadBaseControl IO , MonadBaseControl IO
, MonadFail , MonadFail
, MonadIO , MonadIO
...@@ -76,10 +76,10 @@ newtype TestMonadM env err a = TestMonad { _TestMonad :: ReaderT env IO a } ...@@ -76,10 +76,10 @@ newtype TestMonadM env err a = TestMonad { _TestMonad :: ReaderT env IO a }
, MonadThrow , MonadThrow
) )
instance HasLogger (TestMonadM TestEnv BackendInternalError) where instance HasLogger (TestMonadM TestEnv err) where
data instance Logger (TestMonadM TestEnv BackendInternalError) = TestLogger { _IOLogger :: IOStdLogger } data instance Logger (TestMonadM TestEnv err) = TestLogger { _IOLogger :: IOStdLogger }
type instance LogInitParams (TestMonadM TestEnv BackendInternalError) = LogConfig type instance LogInitParams (TestMonadM TestEnv err) = LogConfig
type instance LogPayload (TestMonadM TestEnv BackendInternalError) = Prelude.String type instance LogPayload (TestMonadM TestEnv err) = Prelude.String
initLogger cfg = fmap TestLogger $ (liftIO $ ioStdLogger cfg) initLogger cfg = fmap TestLogger $ (liftIO $ ioStdLogger cfg)
destroyLogger = liftIO . _iosl_destroy . _IOLogger destroyLogger = liftIO . _iosl_destroy . _IOLogger
logMsg (TestLogger ioLogger) lvl msg = liftIO $ _iosl_log_msg ioLogger lvl msg logMsg (TestLogger ioLogger) lvl msg = liftIO $ _iosl_log_msg ioLogger lvl msg
...@@ -89,18 +89,19 @@ instance MonadLogger (TestMonadM TestEnv BackendInternalError) where ...@@ -89,18 +89,19 @@ instance MonadLogger (TestMonadM TestEnv BackendInternalError) where
getLogger = TestMonad $ do getLogger = TestMonad $ do
initLogger @(TestMonadM TestEnv BackendInternalError) (LogConfig Nothing ERROR) initLogger @(TestMonadM TestEnv BackendInternalError) (LogConfig Nothing ERROR)
runTestMonadM :: env -> TestMonadM env err a -> IO a runTestMonadM :: Show err => env -> TestMonadM env err a -> IO a
runTestMonadM env = flip runReaderT env . _TestMonad 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 :: TestEnv -> TestMonadM TestEnv BackendInternalError a -> IO a
runTestMonad env = flip runReaderT env . _TestMonad runTestMonad env m = do
res <- flip runReaderT env . runExceptT . _TestMonad $ m
-- | Shoehorn a BackendInternalError into an IOException, suitable case res of
-- for testing. Left err -> throwIO $ userError ("runTestMonad: " <> show err)
instance MonadError BackendInternalError (TestMonadM env BackendInternalError) where Right x -> pure x
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 type TestMonad = TestMonadM TestEnv BackendInternalError
data TestJobHandle = TestNoJobHandle data TestJobHandle = TestNoJobHandle
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment