Initial simple test for pure queries

gargantext.cabal

@@ -766,6 +766,7 @@ common commonTestDependencies
     , quickcheck-instances ^>= 0.3.25.2
     , raw-strings-qq
     , resource-pool >= 0.4.0.0 && < 0.5
+    , recover-rtti
     , safe-exceptions >= 0.1.7.4 && < 0.2
     , servant-auth-client
     , servant-client >= 0.20 && < 0.21
@@ -842,6 +843,7 @@ test-suite garg-test-tasty
       Test.Database.Operations.NodeStory
       Test.Database.Operations.PublishNode
       Test.Database.Setup
+      Test.Database.Transactions
       Test.Database.Types
       Test.Graph.Clustering
       Test.Graph.Distance
@@ -909,6 +911,7 @@ test-suite garg-test-hspec
       Test.Database.Operations.NodeStory
       Test.Database.Operations.PublishNode
       Test.Database.Setup
+      Test.Database.Transactions
       Test.Database.Types
       Test.Instances
       Test.Server.ReverseProxy

src/Gargantext/Database/Transactional.hs

@@ -7,6 +7,7 @@ module Gargantext.Database.Transactional (
   , DBTx -- opaque
   , DBUpdate
   , DBQuery
+  , DBTxCmd
   -- * Executing queries and updates
   , runDBQuery
   , runDBTx
@@ -66,6 +67,11 @@ type DBQuery err r a    = DBTx err r a
 type DBUpdate err a     = DBTx err DBWrite a
 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
+
 instance Functor (DBTransactionOp err r) where
   fmap f = \case
     PGQuery   q params cont -> PGQuery   q params (f . cont)
@@ -102,7 +108,7 @@ withReadOnlyTransactionM conn action =
     tmode :: PG.TransactionMode
     tmode = PG.TransactionMode PG.DefaultIsolationLevel PG.ReadOnly
 
-runDBTx :: DBUpdate err a -> DBCmd err a
+runDBTx :: DBUpdate err a -> DBTxCmd err a
 runDBTx (DBTx m) = do
   pool <- view connPool
   withResourceM pool $ \conn -> withTransactionM conn $ foldFree (evalOp conn) m
@@ -110,14 +116,14 @@ runDBTx (DBTx m) = do
 -- | /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 -> DBCmd err a
+runDBQuery :: DBReadOnly err r a -> DBTxCmd err a
 runDBQuery (DBTx m) = do
   pool <- view connPool
   withResourceM pool $ \conn -> withReadOnlyTransactionM conn $ foldFree (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 -> DBCmd err a
+evalOp :: 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 (fromIntegral <$> PG.execute conn qr a)

test/Test/Database/Transactions.hs

+{-# LANGUAGE QuasiQuotes          #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE TupleSections        #-}
+
+{-| Tests for the transactional DB API -}
+
+module Test.Database.Transactions (
+     tests
+  ) where
+
+import Control.Exception.Safe
+import Control.Exception.Safe qualified as Safe
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Data.Pool
+import Data.String
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as TE
+import Database.PostgreSQL.Simple qualified as PG
+import Database.PostgreSQL.Simple.Options qualified as Client
+import Database.Postgres.Temp qualified as Tmp
+import Gargantext.Prelude
+import Prelude qualified
+import Shelly as SH
+import Test.Database.Types hiding (Counter)
+import Test.Hspec
+import Test.Tasty.HUnit hiding (assert)
+import Text.RawString.QQ
+import Gargantext.Database.Transactional
+import Database.PostgreSQL.Simple.FromField
+import Database.PostgreSQL.Simple.FromRow
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+
+--
+-- For these tests we do not want to test the normal GGTX database queries, but rather
+-- the foundational approach for the DBTx monad. Therefore we don't use the usual
+-- 'withTestDB' code, but we rely on something very simple, a single table representing
+-- counters with IDs, like so:
+--
+-- | ID | Counter_value |
+-- | 1  | 0
+-- | 2  | ...
+--
+
+newtype TestDBTxMonad a = TestDBTxMonad { _TestDBTxMonad :: TestMonadM DBHandle a }
+  deriving ( Functor, Applicative, Monad
+           , MonadReader DBHandle, MonadError IOException
+           , MonadBase IO
+           , MonadBaseControl IO
+           , MonadFail
+           , MonadIO
+           , MonadMask
+           , MonadCatch
+           , MonadThrow
+           )
+
+setup :: IO DBHandle
+setup = do
+  res <- Tmp.startConfig tmpPgConfig
+  case res of
+    Left err -> Prelude.fail $ show err
+    Right db -> do
+      let idleTime = 60.0
+      let maxResources = 2
+      let poolConfig = defaultPoolConfig (PG.connectPostgreSQL (Tmp.toConnectionString db))
+                                         PG.close
+                                         idleTime
+                                         maxResources
+      pool <- newPool (setNumStripes (Just 2) poolConfig)
+      bootstrapCounterDB db pool
+      pure $ DBHandle pool db
+  where
+    tmpPgConfig :: Tmp.Config
+    tmpPgConfig = Tmp.defaultConfig <>
+      Tmp.optionsToDefaultConfig mempty
+        { Client.dbname   = pure dbName
+        , Client.user     = pure dbUser
+        , Client.password = pure dbPassword
+        }
+
+dbUser, dbPassword, dbName, dbTable :: String
+dbUser = "ggtx_test_counter_db_user"
+dbPassword = "ggtx_test_counter_db_pwd"
+dbName = "ggtx_test_counter_db"
+dbTable = "public.ggtx_test_counter_table"
+
+bootstrapCounterDB :: Tmp.DB -> Pool PG.Connection -> IO ()
+bootstrapCounterDB tmpDB pool = withResource pool $ \conn -> do
+  void $ PG.execute_ conn (fromString $ "ALTER USER \"" <> dbUser <> "\" with PASSWORD '" <> dbPassword <> "'")
+  let schemaContent = counterDBSchema
+  let connString = Tmp.toConnectionString tmpDB
+  (res,ec) <- shelly $ silently $ escaping False $ do
+    withTmpDir $ \tdir -> do
+      let schemaPath = tdir <> "/schema.sql"
+      writefile schemaPath (T.pack schemaContent)
+      result <- SH.run "psql" ["-d", "\"" <> TE.decodeUtf8 connString <> "\"", "<", fromString schemaPath]
+      (result,) <$> lastExitCode
+  unless (ec == 0) $ Safe.throwIO (Prelude.userError $ show ec <> ": " <> T.unpack res)
+
+counterDBSchema :: String
+counterDBSchema = [r|
+  CREATE TABLE |] <> dbTable <> [r| (
+      id SERIAL,
+      counter_value INT NOT NULL DEFAULT 0,
+      PRIMARY KEY (id)
+  );
+  ALTER TABLE public.ggtx_test_counter_table OWNER TO |] <> dbUser <> ";" <> [r|
+  INSERT INTO public.ggtx_test_counter_table(counter_value) VALUES(42);
+|]
+
+withTestCounterDB :: (DBHandle -> IO ()) -> IO ()
+withTestCounterDB = Safe.bracket setup teardown
+
+teardown :: DBHandle -> IO ()
+teardown test_db = do
+  destroyAllResources $ _DBHandle test_db
+  Tmp.stop $ _DBTmp test_db
+
+--
+-- Helpers and transactions to work with counters
+--
+
+newtype CounterId = CounterId { _CounterId :: Int }
+  deriving (Show, Eq, FromField)
+
+data Counter = Counter
+  { counterId    :: !CounterId
+  , counterValue :: Int
+  }
+  deriving (Show, Eq)
+
+instance PG.FromRow Counter where
+  fromRow = Counter <$> field <*> field
+
+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 -> dbFail $ Prelude.userError ("getCounterId returned more than one result: " <> show rst)
+
+--
+-- MAIN TESTS
+--
+
+tests :: Spec
+tests = parallel $ around withTestCounterDB $
+  describe "Database Transactions" $ do
+    describe "Pure Queries" $ do
+      it "Simple query works" simpleQueryWorks
+
+simpleQueryWorks :: DBHandle -> Assertion
+simpleQueryWorks env = flip runReaderT env $ runTestMonad $ do
+  x <- runDBQuery $ getCounterById (CounterId 1)
+  liftIO $ counterValue x `shouldBe` 42

test/Test/Database/Types.hs

@@ -62,9 +62,9 @@ data TestEnv = TestEnv {
   , test_worker_tid          :: !ThreadId
   }
 
-newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
+newtype TestMonadM e a = TestMonad { runTestMonad :: ReaderT e IO a }
   deriving ( Functor, Applicative, Monad
-           , MonadReader TestEnv, MonadError IOException
+           , MonadReader e, MonadError IOException
            , MonadBase IO
            , MonadBaseControl IO
            , MonadFail
@@ -74,6 +74,7 @@ newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
            , MonadThrow
            )
 
+type TestMonad = TestMonadM TestEnv
 data TestJobHandle = TestNoJobHandle
 
 instance MonadJobStatus TestMonad where
@@ -97,6 +98,9 @@ data DBHandle = DBHandle {
   , _DBTmp    :: Tmp.DB
   }
 
+instance HasConnectionPool DBHandle where
+  connPool = to _DBHandle
+
 instance HasConnectionPool TestEnv where
   connPool = to (_DBHandle . test_db)
 

test/drivers/hspec/Main.hs

@@ -12,6 +12,7 @@ import System.Posix.Process
 import System.Posix.Signals
 import Test.API qualified as API
 import Test.Database.Operations qualified as DB
+import Test.Database.Transactions qualified as DBT
 import Test.Hspec
 import Test.Server.ReverseProxy qualified as ReverseProxy
 
@@ -67,5 +68,6 @@ main = do
       API.tests
       ReverseProxy.tests
       DB.tests
+      DBT.tests
       DB.nodeStoryTests
       runIO $ putText "tests finished"