Commit 81d8568f authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

Tighten up the interface and module exports

parent 41ad6f5d
Pipeline #7548 passed with stages
in 68 minutes and 2 seconds
......@@ -24,6 +24,7 @@ module Gargantext.Database.Query.Table.Node.Error (
, nodeCreationError
, nodeLookupError
, catchNodeError
, dbFailWith
) where
import Control.Lens (Prism', (#), (^?))
......@@ -34,6 +35,7 @@ import Gargantext.Database.Admin.Types.Node (ListId, NodeId(..), ContextId, User
import Gargantext.Prelude hiding (sum, head)
import Prelude hiding (null, id, map, sum, show)
import Prelude qualified
import Gargantext.Database.Transactional
data NodeCreationError
= UserParentAlreadyExists UserId ParentId
......@@ -155,3 +157,7 @@ nodeLookupError ne = throwError $ _NodeError # NodeLookupFailed ne
catchNodeError :: (MonadError e m, HasNodeError e) => m a -> (NodeError -> m a) -> m a
catchNodeError f g = catchError f (\e -> maybe (throwError e) g (e ^? _NodeError))
dbFailWith :: HasNodeError err => T.Text -> DBTx err r b
dbFailWith x = dbFail $ _NodeError # (NodeError $ toException $ userError $ T.unpack x)
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
module Gargantext.Database.Transactional where
module Gargantext.Database.Transactional (
DBOperation
, DBTransactionOp -- opaque
, DBTx -- opaque
, DBUpdate
, DBQuery
-- * Executing queries and updates
, runDBQuery
, runDBTx
-- * Smart constructors
, mkPGQuery
, mkPGUpdate
, mkOpaQuery
, mkOpaUpdate
, mkOpaInsert
-- * Throwing errors (which allow rollbacks)
, dbFail
) where
import Control.Exception
import Control.Lens
import Control.Monad.Base
import Control.Monad.Error.Class
......@@ -15,11 +29,9 @@ 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
import Prelude
......@@ -54,12 +66,6 @@ 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 f = \case
PGQuery q params cont -> PGQuery q params (f . cont)
......@@ -96,7 +102,7 @@ withReadOnlyTransactionM conn action =
tmode :: PG.TransactionMode
tmode = PG.TransactionMode PG.DefaultIsolationLevel PG.ReadOnly
runDBTx :: HasNodeError err => DBUpdate err a -> DBCmd err a
runDBTx :: DBUpdate err a -> DBCmd err a
runDBTx (DBTx m) = do
pool <- view connPool
withResourceM pool $ \conn -> withTransactionM conn $ foldFree (evalOp conn) m
......@@ -104,12 +110,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 :: HasNodeError err => DBReadOnly err r a -> DBCmd err a
runDBQuery :: DBReadOnly err r a -> DBCmd err a
runDBQuery (DBTx m) = do
pool <- view connPool
withResourceM pool $ \conn -> withReadOnlyTransactionM conn $ foldFree (evalOp conn) m
evalOp :: HasNodeError err => PG.Connection -> DBTransactionOp err r a -> DBCmd err a
-- | 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 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)
......@@ -118,6 +126,13 @@ evalOp conn = \case
OpaUpdate upd cc -> cc <$> liftBase (runUpdate conn upd)
DBFail err -> throwError err
--
-- Smart constructors
--
dbFail :: err -> DBTx err r b
dbFail = DBTx . liftF . DBFail
mkPGQuery :: (PG.ToRow q, PG.FromRow a)
=> PG.Query
-> q
......
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