Commit 41ad6f5d authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

Implement DBTx in terms of a 'Free' monad.

parent 1eca6e88
...@@ -546,6 +546,7 @@ library ...@@ -546,6 +546,7 @@ library
, filepath ^>= 1.4.2.2 , filepath ^>= 1.4.2.2
, fmt , fmt
, formatting ^>= 7.2.0 , formatting ^>= 7.2.0
, free >= 0.5.0
, fullstop ^>= 0.1.4 , fullstop ^>= 0.1.4
, gargantext-graph-core >= 0.2.0.0 , gargantext-graph-core >= 0.2.0.0
, gargantext-prelude , gargantext-prelude
......
...@@ -10,11 +10,14 @@ module Gargantext.Database.Transactional where ...@@ -10,11 +10,14 @@ module Gargantext.Database.Transactional where
import Control.Exception import Control.Exception
import Control.Lens import Control.Lens
import Control.Monad.Base import Control.Monad.Base
import Control.Monad.Error.Class
import Control.Monad.Free
import Control.Monad.Trans.Control (MonadBaseControl, control) import Control.Monad.Trans.Control (MonadBaseControl, control)
import Data.Pool (withResource, Pool) import Data.Pool (withResource, Pool)
import Data.Profunctor.Product.Default import Data.Profunctor.Product.Default
import Data.Text qualified as T import Data.Text qualified as T
import Database.PostgreSQL.Simple qualified as PG import Database.PostgreSQL.Simple qualified as PG
import Database.PostgreSQL.Simple.Transaction qualified as PG
import Gargantext.Database.Prelude import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error import Gargantext.Database.Query.Table.Node.Error
import Opaleye import Opaleye
...@@ -22,73 +25,115 @@ import Prelude ...@@ -22,73 +25,115 @@ import Prelude
data DBOperation = DBRead | DBWrite data DBOperation = DBRead | DBWrite
type DBQuery err r a = DBTransactionOp err r a -- | A functor describing a single operation on the database. Each constructor takes a continuation
type DBUpdate err a = DBTransactionOp err DBWrite a -- 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) a where data DBTransactionOp err (r :: DBOperation) next where
PGQuery :: (PG.ToRow q, PG.FromRow a) => PG.Query -> q -> DBTransactionOp err r [a] -- | A Postgres /read/, returning a list of results. The 'r' in the result is polymorphic
PGUpdate :: PG.ToRow a => PG.Query -> a -> DBTransactionOp err DBWrite Int -- so that reads can be embedded in updates transactions.
OpaQuery :: Default FromFields fields a => Select fields -> DBTransactionOp err r [a] PGQuery :: (PG.ToRow q, PG.FromRow a) => PG.Query -> q -> ([a] -> next) -> DBTransactionOp err r next
OpaUpdate :: Insert a -> DBTransactionOp err DBWrite a -- | A Postgres /write/, returning the number of affected rows. It can be used only in
PureOp :: a -> DBTransactionOp err r a -- 'DBWrite' transactions.
BindOp :: DBTransactionOp err r a -> (a -> DBTransactionOp err r b) -> DBTransactionOp err r b PGUpdate :: PG.ToRow a => PG.Query -> a -> (Int -> next) -> DBTransactionOp err DBWrite next
DBFail :: err -> DBTransactionOp err r b -- | An Opaleye /read/, returning a list of results. The 'r' in the result is polymorphic
-- so that reads can be embedded in updates transactions.
dbFail :: HasNodeError err => err -> DBTransactionOp err r b OpaQuery :: Default FromFields fields a => Select fields -> ([a] -> next) -> DBTransactionOp err r next
dbFail = DBFail -- | An Opaleye /write/, returning a result depending on the input 'Insert'. It can be used only in
-- 'DBWrite' transactions.
dbFailWith :: HasNodeError err => T.Text -> DBTransactionOp err r b 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) dbFailWith x = dbFail $ _NodeError # (NodeError $ toException $ userError $ T.unpack x)
instance Functor (DBTransactionOp err r) where instance Functor (DBTransactionOp err r) where
fmap _ _ = undefined fmap f = \case
PGQuery q params cont -> PGQuery q params (f . cont)
instance Applicative (DBTransactionOp err r) where PGUpdate q a cont -> PGUpdate q a (f . cont)
pure _ = undefined OpaQuery sel cont -> OpaQuery sel (f . cont)
_ <*> _ = undefined OpaInsert ins cont -> OpaInsert ins (f . cont)
OpaUpdate upd cont -> OpaUpdate upd (f . cont)
instance Monad (DBTransactionOp err r) where DBFail err -> DBFail err
_ >>= _ = undefined
-- | Generalised version of 'withResource' to work over any unlifted monad. -- | Generalised version of 'withResource' to work over any unlifted monad.
-- For some reason 'resource-pool' removed this from version 0.3.0.0 onwards. -- 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 :: MonadBaseControl IO m => Pool a -> (a -> m b) -> m b
withResourceM pool func = control $ \run -> withResource pool (run . func) withResourceM pool func = control $ \run -> withResource pool (run . func)
withTransactionM :: forall m a. MonadBaseControl IO m => m a -> m a withTransactionM
withTransactionM _act = undefined :: 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 :: HasNodeError err => DBUpdate err a -> DBCmd err a
runDBTx m = do runDBTx (DBTx m) = do
pool <- view connPool 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 -- | /NOTE/ the input type is 'DBReadOnly', i.e. a transaction where /all/
runDBQuery m = do -- 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 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 :: HasNodeError err => PG.Connection -> DBTransactionOp err r a -> DBCmd err a
evalOp conn = \case evalOp conn = \case
PGQuery qr q -> liftBase (PG.query conn qr q) PGQuery qr q cc -> cc <$> liftBase (PG.query conn qr q)
PGUpdate qr a -> liftBase (fromIntegral <$> PG.execute conn qr a) PGUpdate qr a cc -> cc <$> liftBase (fromIntegral <$> PG.execute conn qr a)
OpaQuery sel -> liftBase (runSelect conn sel) OpaQuery sel cc -> cc <$> liftBase (runSelect conn sel)
OpaUpdate ins -> liftBase (runInsert conn ins) OpaInsert ins cc -> cc <$> liftBase (runInsert conn ins)
_ -> error "todo" OpaUpdate upd cc -> cc <$> liftBase (runUpdate conn upd)
DBFail err -> throwError err
mkPGQuery :: (PG.ToRow q, PG.FromRow a) mkPGQuery :: (PG.ToRow q, PG.FromRow a)
=> PG.Query => PG.Query
-> q -> q
-> DBQuery err r [a] -> 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 :: 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 mkOpaQuery :: Default FromFields fields a
=> Select fields => Select fields
-> DBQuery err x [a] -> 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 mkOpaInsert :: Insert a -> DBUpdate err a
mkOpaUpdate = OpaUpdate mkOpaInsert a = DBTx $ liftF (OpaInsert a id)
...@@ -97,7 +97,7 @@ getRootId u = do ...@@ -97,7 +97,7 @@ getRootId u = do
Just r -> pure (_node_id r) Just r -> pure (_node_id r)
insertNodeNode :: [GGTX.NodeNode] -> DBUpdate err Int 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 where
ns' :: [GGTX.NodeNodeWrite] ns' :: [GGTX.NodeNodeWrite]
ns' = map (\(NodeNode n1 n2 x y) ns' = map (\(NodeNode n1 n2 x y)
......
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