Implement DBTx in terms of a 'Free' monad.

gargantext.cabal

@@ -546,6 +546,7 @@ library
     , filepath ^>= 1.4.2.2
     , fmt
     , formatting ^>= 7.2.0
+    , free >= 0.5.0
     , fullstop ^>= 0.1.4
     , gargantext-graph-core >= 0.2.0.0
     , gargantext-prelude

src/Gargantext/Database/Transactional.hs

@@ -10,11 +10,14 @@ module Gargantext.Database.Transactional where
 import Control.Exception
 import Control.Lens
 import Control.Monad.Base
+import Control.Monad.Error.Class
+import Control.Monad.Free
 import Control.Monad.Trans.Control (MonadBaseControl, control)
 import Data.Pool (withResource, Pool)
 import Data.Profunctor.Product.Default
 import Data.Text qualified as T
 import Database.PostgreSQL.Simple qualified as PG
+import Database.PostgreSQL.Simple.Transaction qualified as PG
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node.Error
 import Opaleye
@@ -22,73 +25,115 @@ import Prelude
 
 data DBOperation = DBRead | DBWrite
 
-type DBQuery err r a = DBTransactionOp err r a
-type DBUpdate err a = DBTransactionOp err DBWrite a
-
-data DBTransactionOp err (r :: DBOperation) a where
-  PGQuery   :: (PG.ToRow q, PG.FromRow a) => PG.Query -> q -> DBTransactionOp err r [a]
-  PGUpdate  :: PG.ToRow a => PG.Query -> a -> DBTransactionOp err DBWrite Int
-  OpaQuery  :: Default FromFields fields a => Select fields -> DBTransactionOp err r [a]
-  OpaUpdate :: Insert a -> DBTransactionOp err DBWrite a
-  PureOp    :: a -> DBTransactionOp err r a
-  BindOp    :: DBTransactionOp err r a -> (a -> DBTransactionOp err r b) -> DBTransactionOp err r b
-  DBFail    :: err -> DBTransactionOp err r b
-
-dbFail :: HasNodeError err => err -> DBTransactionOp err r b
-dbFail = DBFail
-
-dbFailWith :: HasNodeError err => T.Text -> DBTransactionOp err r b
+-- | A functor describing a single operation on the database. Each constructor takes a continuation
+-- argument which can be used to derive a sound 'Functor' instance, making this viable to be applied
+-- in a monadic/free context.
+data DBTransactionOp err (r :: DBOperation) next where
+  -- | A Postgres /read/, returning a list of results. The 'r' in the result is polymorphic
+  -- so that reads can be embedded in updates transactions.
+  PGQuery   :: (PG.ToRow q, PG.FromRow a) => PG.Query -> q -> ([a] -> next) -> DBTransactionOp err r next
+  -- | A Postgres /write/, returning the number of affected rows. It can be used only in
+  -- 'DBWrite' transactions.
+  PGUpdate  :: PG.ToRow a => PG.Query -> a -> (Int -> next) -> DBTransactionOp err DBWrite next
+  -- | An Opaleye /read/, returning a list of results. The 'r' in the result is polymorphic
+  -- so that reads can be embedded in updates transactions.
+  OpaQuery  :: Default FromFields fields a => Select fields -> ([a] -> next) -> DBTransactionOp err r next
+  -- | An Opaleye /write/, returning a result depending on the input 'Insert'. It can be used only in
+  -- 'DBWrite' transactions.
+  OpaInsert :: Insert a -> (a -> next) -> DBTransactionOp err DBWrite next
+  -- | An Opaleye /write/, returning a result depending on the input 'Update'. It can be used only in
+  -- 'DBWrite' transactions.
+  OpaUpdate :: Update a -> (a -> next) -> DBTransactionOp err DBWrite next
+  -- | Monadic failure for DB transactions.
+  DBFail    :: err -> DBTransactionOp err r next
+
+newtype DBTx err r a = DBTx { _DBTx :: Free (DBTransactionOp err r) a }
+  deriving (Functor, Applicative, Monad)
+
+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
+
+dbFail :: HasNodeError err => err -> DBTx err r b
+dbFail = DBTx . liftF . DBFail
+
+dbFailWith :: HasNodeError err => T.Text -> DBTx err r b
 dbFailWith x = dbFail $ _NodeError # (NodeError $ toException $ userError $ T.unpack x)
 
 instance Functor (DBTransactionOp err r) where
-  fmap _ _ = undefined
-
-instance Applicative (DBTransactionOp err r) where
-  pure _ = undefined
-  _ <*> _ = undefined
-
-instance Monad (DBTransactionOp err r) where
-  _ >>= _  = undefined
+  fmap f = \case
+    PGQuery   q params cont -> PGQuery   q params (f . cont)
+    PGUpdate  q a cont      -> PGUpdate  q a      (f . cont)
+    OpaQuery  sel cont      -> OpaQuery  sel      (f . cont)
+    OpaInsert ins cont      -> OpaInsert ins      (f . cont)
+    OpaUpdate upd cont      -> OpaUpdate upd      (f . cont)
+    DBFail    err           -> DBFail err
 
 -- | Generalised version of 'withResource' to work over any unlifted monad.
 -- For some reason 'resource-pool' removed this from version 0.3.0.0 onwards.
 withResourceM :: MonadBaseControl IO m => Pool a -> (a -> m b) -> m b
 withResourceM pool func = control $ \run -> withResource pool (run . func)
 
-withTransactionM :: forall m a. MonadBaseControl IO m => m a -> m a
-withTransactionM _act = undefined
+withTransactionM
+  :: forall m a.
+     MonadBaseControl IO m
+  => PG.Connection
+  -> m a
+  -> m a
+withTransactionM conn action = control $ \runInIO -> PG.withTransaction conn $ runInIO action
+
+-- | Run a PostgreSQL "read-only" transaction, suitable for read-only queries.
+withReadOnlyTransactionM
+  :: forall m a.
+     MonadBaseControl IO m
+  => PG.Connection
+  -> m a
+  -> m a
+withReadOnlyTransactionM conn action =
+  control $ \runInIO ->
+    PG.withTransactionMode tmode conn (runInIO action)
+  where
+    tmode :: PG.TransactionMode
+    tmode = PG.TransactionMode PG.DefaultIsolationLevel PG.ReadOnly
 
 runDBTx :: HasNodeError err => DBUpdate err a -> DBCmd err a
-runDBTx m = do
+runDBTx (DBTx m) = do
   pool <- view connPool
-  withResourceM pool $ \conn -> evalOp conn m
+  withResourceM pool $ \conn -> withTransactionM conn $ foldFree (evalOp conn) m
 
-runDBQuery :: HasNodeError err => DBQuery err r a -> DBCmd err a
-runDBQuery 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 :: HasNodeError err => DBReadOnly err r a -> DBCmd err a
+runDBQuery (DBTx m) = do
   pool <- view connPool
-  withResourceM pool $ \conn -> evalOp conn m
+  withResourceM pool $ \conn -> withReadOnlyTransactionM conn $ foldFree (evalOp conn) m
 
 evalOp :: HasNodeError err => PG.Connection -> DBTransactionOp err r a -> DBCmd err a
 evalOp conn = \case
-  PGQuery   qr q -> liftBase (PG.query conn qr q)
-  PGUpdate  qr a -> liftBase (fromIntegral <$> PG.execute conn qr a)
-  OpaQuery  sel  -> liftBase (runSelect conn sel)
-  OpaUpdate ins  -> liftBase (runInsert conn ins)
-  _ -> error "todo"
+  PGQuery   qr q cc -> cc <$> liftBase (PG.query conn qr q)
+  PGUpdate  qr a cc -> cc <$> liftBase (fromIntegral <$> PG.execute conn qr a)
+  OpaQuery  sel  cc -> cc <$> liftBase (runSelect conn sel)
+  OpaInsert ins  cc -> cc <$> liftBase (runInsert conn ins)
+  OpaUpdate upd  cc -> cc <$> liftBase (runUpdate conn upd)
+  DBFail    err  -> throwError err
 
 mkPGQuery :: (PG.ToRow q, PG.FromRow a)
            => PG.Query
            -> q
            -> DBQuery err r [a]
-mkPGQuery q s = PGQuery q s
+mkPGQuery q a = DBTx $ liftF (PGQuery q a id)
 
 mkPGUpdate :: PG.ToRow a => PG.Query -> a -> DBUpdate err Int
-mkPGUpdate q s = PGUpdate q s
+mkPGUpdate q a = DBTx $ liftF (PGUpdate q a id)
 
 mkOpaQuery :: Default FromFields fields a
            => Select fields
            -> DBQuery err x [a]
-mkOpaQuery = OpaQuery
+mkOpaQuery s = DBTx $ liftF (OpaQuery s id)
+
+mkOpaUpdate :: Update a -> DBUpdate err a
+mkOpaUpdate a = DBTx $ liftF (OpaUpdate a id)
 
-mkOpaUpdate :: Insert a -> DBUpdate err a
-mkOpaUpdate = OpaUpdate
+mkOpaInsert :: Insert a -> DBUpdate err a
+mkOpaInsert a = DBTx $ liftF (OpaInsert a id)

src/Gargantext/Database/Transactional/Example.hs

@@ -97,7 +97,7 @@ getRootId u = do
     Just  r -> pure (_node_id r)
 
 insertNodeNode :: [GGTX.NodeNode] -> DBUpdate err Int
-insertNodeNode ns = fromIntegral <$> mkOpaUpdate (Insert nodeNodeTable ns' rCount (Just doNothing))
+insertNodeNode ns = fromIntegral <$> mkOpaInsert (Insert nodeNodeTable ns' rCount (Just doNothing))
   where
     ns' :: [GGTX.NodeNodeWrite]
     ns' = map (\(NodeNode n1 n2 x y)