Setup ggtx rollback test infrastructure

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

@@ -106,6 +106,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" )

test/Test/Database/Transactions.hs

@@ -16,6 +16,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
@@ -29,19 +30,24 @@ 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 (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
@@ -189,8 +195,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 +219,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)
@@ -277,3 +298,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 = runTestMonad 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
+    ) `catch` \(_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"
+