{-# LANGUAGE RankNTypes #-}
module Orville.PostgreSQL.Internal.OrvilleState
( OrvilleState
, newOrvilleState
, resetOrvilleState
, orvilleConnectionPool
, orvilleConnectionState
, orvilleErrorDetailLevel
, orvilleTransactionCallback
, orvilleSqlCommenterAttributes
, addTransactionCallback
, TransactionEvent (BeginTransaction, NewSavepoint, ReleaseSavepoint, RollbackToSavepoint, CommitTransaction, RollbackTransaction)
, openTransactionEvent
, rollbackTransactionEvent
, transactionSuccessEvent
, ConnectionState (NotConnected, Connected)
, ConnectedState (ConnectedState, connectedConnection, connectedTransaction)
, connectState
, TransactionState (OutermostTransaction, SavepointTransaction)
, newTransaction
, Savepoint
, savepointNestingLevel
, initialSavepoint
, nextSavepoint
, orvilleSqlExecutionCallback
, addSqlExecutionCallback
, orvilleBeginTransactionExpr
, setBeginTransactionExpr
, setSqlCommenterAttributes
, addSqlCommenterAttributes
)
where
import qualified Data.Map.Strict as Map
import Orville.PostgreSQL.ErrorDetailLevel (ErrorDetailLevel)
import Orville.PostgreSQL.Execution.QueryType (QueryType)
import qualified Orville.PostgreSQL.Expr as Expr
import Orville.PostgreSQL.Raw.Connection (Connection, ConnectionPool)
import qualified Orville.PostgreSQL.Raw.RawSql as RawSql
import qualified Orville.PostgreSQL.Raw.SqlCommenter as SqlCommenter
data OrvilleState = OrvilleState
{ OrvilleState -> ConnectionPool
_orvilleConnectionPool :: ConnectionPool
, OrvilleState -> ConnectionState
_orvilleConnectionState :: ConnectionState
, OrvilleState -> ErrorDetailLevel
_orvilleErrorDetailLevel :: ErrorDetailLevel
, OrvilleState -> TransactionEvent -> IO ()
_orvilleTransactionCallback :: TransactionEvent -> IO ()
, OrvilleState -> forall a. QueryType -> RawSql -> IO a -> IO a
_orvilleSqlExecutionCallback :: forall a. QueryType -> RawSql.RawSql -> IO a -> IO a
, OrvilleState -> BeginTransactionExpr
_orvilleBeginTransactionExpr :: Expr.BeginTransactionExpr
, :: Maybe SqlCommenter.SqlCommenterAttributes
}
orvilleConnectionPool :: OrvilleState -> ConnectionPool
orvilleConnectionPool :: OrvilleState -> ConnectionPool
orvilleConnectionPool =
OrvilleState -> ConnectionPool
_orvilleConnectionPool
orvilleConnectionState :: OrvilleState -> ConnectionState
orvilleConnectionState :: OrvilleState -> ConnectionState
orvilleConnectionState =
OrvilleState -> ConnectionState
_orvilleConnectionState
orvilleErrorDetailLevel :: OrvilleState -> ErrorDetailLevel
orvilleErrorDetailLevel :: OrvilleState -> ErrorDetailLevel
orvilleErrorDetailLevel =
OrvilleState -> ErrorDetailLevel
_orvilleErrorDetailLevel
orvilleTransactionCallback :: OrvilleState -> TransactionEvent -> IO ()
orvilleTransactionCallback :: OrvilleState -> TransactionEvent -> IO ()
orvilleTransactionCallback =
OrvilleState -> TransactionEvent -> IO ()
_orvilleTransactionCallback
orvilleBeginTransactionExpr :: OrvilleState -> Expr.BeginTransactionExpr
orvilleBeginTransactionExpr :: OrvilleState -> BeginTransactionExpr
orvilleBeginTransactionExpr =
OrvilleState -> BeginTransactionExpr
_orvilleBeginTransactionExpr
orvilleSqlCommenterAttributes :: OrvilleState -> Maybe SqlCommenter.SqlCommenterAttributes
=
OrvilleState -> Maybe SqlCommenterAttributes
_orvilleSqlCommenterAttributes
addTransactionCallback ::
(TransactionEvent -> IO ()) ->
OrvilleState ->
OrvilleState
addTransactionCallback :: (TransactionEvent -> IO ()) -> OrvilleState -> OrvilleState
addTransactionCallback TransactionEvent -> IO ()
newCallback OrvilleState
state =
let
originalCallback :: TransactionEvent -> IO ()
originalCallback =
OrvilleState -> TransactionEvent -> IO ()
_orvilleTransactionCallback OrvilleState
state
wrappedCallback :: TransactionEvent -> IO ()
wrappedCallback TransactionEvent
event = do
TransactionEvent -> IO ()
originalCallback TransactionEvent
event
TransactionEvent -> IO ()
newCallback TransactionEvent
event
in
OrvilleState
state {_orvilleTransactionCallback :: TransactionEvent -> IO ()
_orvilleTransactionCallback = TransactionEvent -> IO ()
wrappedCallback}
newOrvilleState :: ErrorDetailLevel -> ConnectionPool -> OrvilleState
newOrvilleState :: ErrorDetailLevel -> ConnectionPool -> OrvilleState
newOrvilleState ErrorDetailLevel
errorDetailLevel ConnectionPool
pool =
OrvilleState
{ _orvilleConnectionPool :: ConnectionPool
_orvilleConnectionPool = ConnectionPool
pool
, _orvilleConnectionState :: ConnectionState
_orvilleConnectionState = ConnectionState
NotConnected
, _orvilleErrorDetailLevel :: ErrorDetailLevel
_orvilleErrorDetailLevel = ErrorDetailLevel
errorDetailLevel
, _orvilleTransactionCallback :: TransactionEvent -> IO ()
_orvilleTransactionCallback = TransactionEvent -> IO ()
defaultTransactionCallback
, _orvilleSqlExecutionCallback :: forall a. QueryType -> RawSql -> IO a -> IO a
_orvilleSqlExecutionCallback = QueryType -> RawSql -> IO a -> IO a
forall a. QueryType -> RawSql -> IO a -> IO a
defaultSqlExectionCallback
, _orvilleBeginTransactionExpr :: BeginTransactionExpr
_orvilleBeginTransactionExpr = BeginTransactionExpr
defaultBeginTransactionExpr
, _orvilleSqlCommenterAttributes :: Maybe SqlCommenterAttributes
_orvilleSqlCommenterAttributes = Maybe SqlCommenterAttributes
forall a. Maybe a
Nothing
}
resetOrvilleState :: OrvilleState -> OrvilleState
resetOrvilleState :: OrvilleState -> OrvilleState
resetOrvilleState =
ErrorDetailLevel -> ConnectionPool -> OrvilleState
newOrvilleState
(ErrorDetailLevel -> ConnectionPool -> OrvilleState)
-> (OrvilleState -> ErrorDetailLevel)
-> OrvilleState
-> ConnectionPool
-> OrvilleState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OrvilleState -> ErrorDetailLevel
_orvilleErrorDetailLevel
(OrvilleState -> ConnectionPool -> OrvilleState)
-> (OrvilleState -> ConnectionPool) -> OrvilleState -> OrvilleState
forall a b.
(OrvilleState -> a -> b)
-> (OrvilleState -> a) -> OrvilleState -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> OrvilleState -> ConnectionPool
_orvilleConnectionPool
connectState :: ConnectedState -> OrvilleState -> OrvilleState
connectState :: ConnectedState -> OrvilleState -> OrvilleState
connectState ConnectedState
connectedState OrvilleState
state =
OrvilleState
state
{ _orvilleConnectionState :: ConnectionState
_orvilleConnectionState = ConnectedState -> ConnectionState
Connected ConnectedState
connectedState
}
data ConnectionState
= NotConnected
| Connected ConnectedState
data ConnectedState = ConnectedState
{ ConnectedState -> Connection
connectedConnection :: Connection
, ConnectedState -> Maybe TransactionState
connectedTransaction :: Maybe TransactionState
}
data TransactionState
= OutermostTransaction
| SavepointTransaction Savepoint
newTransaction :: Maybe TransactionState -> TransactionState
newTransaction :: Maybe TransactionState -> TransactionState
newTransaction Maybe TransactionState
maybeTransactionState =
case Maybe TransactionState
maybeTransactionState of
Maybe TransactionState
Nothing ->
TransactionState
OutermostTransaction
Just TransactionState
OutermostTransaction ->
Savepoint -> TransactionState
SavepointTransaction Savepoint
initialSavepoint
Just (SavepointTransaction Savepoint
savepoint) ->
Savepoint -> TransactionState
SavepointTransaction (Savepoint -> Savepoint
nextSavepoint Savepoint
savepoint)
newtype Savepoint
= Savepoint Int
deriving (Savepoint -> Savepoint -> Bool
(Savepoint -> Savepoint -> Bool)
-> (Savepoint -> Savepoint -> Bool) -> Eq Savepoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Savepoint -> Savepoint -> Bool
== :: Savepoint -> Savepoint -> Bool
$c/= :: Savepoint -> Savepoint -> Bool
/= :: Savepoint -> Savepoint -> Bool
Eq, Int -> Savepoint -> ShowS
[Savepoint] -> ShowS
Savepoint -> String
(Int -> Savepoint -> ShowS)
-> (Savepoint -> String)
-> ([Savepoint] -> ShowS)
-> Show Savepoint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Savepoint -> ShowS
showsPrec :: Int -> Savepoint -> ShowS
$cshow :: Savepoint -> String
show :: Savepoint -> String
$cshowList :: [Savepoint] -> ShowS
showList :: [Savepoint] -> ShowS
Show)
initialSavepoint :: Savepoint
initialSavepoint :: Savepoint
initialSavepoint =
Int -> Savepoint
Savepoint Int
1
nextSavepoint :: Savepoint -> Savepoint
nextSavepoint :: Savepoint -> Savepoint
nextSavepoint (Savepoint Int
n) =
Int -> Savepoint
Savepoint (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
savepointNestingLevel :: Savepoint -> Int
savepointNestingLevel :: Savepoint -> Int
savepointNestingLevel (Savepoint Int
n) = Int
n
data TransactionEvent
=
BeginTransaction
|
NewSavepoint Savepoint
|
ReleaseSavepoint Savepoint
|
RollbackToSavepoint Savepoint
|
CommitTransaction
|
RollbackTransaction
deriving (TransactionEvent -> TransactionEvent -> Bool
(TransactionEvent -> TransactionEvent -> Bool)
-> (TransactionEvent -> TransactionEvent -> Bool)
-> Eq TransactionEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransactionEvent -> TransactionEvent -> Bool
== :: TransactionEvent -> TransactionEvent -> Bool
$c/= :: TransactionEvent -> TransactionEvent -> Bool
/= :: TransactionEvent -> TransactionEvent -> Bool
Eq, Int -> TransactionEvent -> ShowS
[TransactionEvent] -> ShowS
TransactionEvent -> String
(Int -> TransactionEvent -> ShowS)
-> (TransactionEvent -> String)
-> ([TransactionEvent] -> ShowS)
-> Show TransactionEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransactionEvent -> ShowS
showsPrec :: Int -> TransactionEvent -> ShowS
$cshow :: TransactionEvent -> String
show :: TransactionEvent -> String
$cshowList :: [TransactionEvent] -> ShowS
showList :: [TransactionEvent] -> ShowS
Show)
defaultTransactionCallback :: TransactionEvent -> IO ()
defaultTransactionCallback :: TransactionEvent -> IO ()
defaultTransactionCallback = IO () -> TransactionEvent -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
openTransactionEvent :: TransactionState -> TransactionEvent
openTransactionEvent :: TransactionState -> TransactionEvent
openTransactionEvent TransactionState
txnState =
case TransactionState
txnState of
TransactionState
OutermostTransaction -> TransactionEvent
BeginTransaction
SavepointTransaction Savepoint
savepoint -> Savepoint -> TransactionEvent
NewSavepoint Savepoint
savepoint
rollbackTransactionEvent :: TransactionState -> TransactionEvent
rollbackTransactionEvent :: TransactionState -> TransactionEvent
rollbackTransactionEvent TransactionState
txnState =
case TransactionState
txnState of
TransactionState
OutermostTransaction -> TransactionEvent
RollbackTransaction
SavepointTransaction Savepoint
savepoint -> Savepoint -> TransactionEvent
RollbackToSavepoint Savepoint
savepoint
transactionSuccessEvent :: TransactionState -> TransactionEvent
transactionSuccessEvent :: TransactionState -> TransactionEvent
transactionSuccessEvent TransactionState
txnState =
case TransactionState
txnState of
TransactionState
OutermostTransaction -> TransactionEvent
CommitTransaction
SavepointTransaction Savepoint
savepoint -> Savepoint -> TransactionEvent
ReleaseSavepoint Savepoint
savepoint
orvilleSqlExecutionCallback ::
OrvilleState ->
forall a.
QueryType ->
RawSql.RawSql ->
IO a ->
IO a
orvilleSqlExecutionCallback :: OrvilleState -> forall a. QueryType -> RawSql -> IO a -> IO a
orvilleSqlExecutionCallback =
OrvilleState -> QueryType -> RawSql -> IO a -> IO a
OrvilleState -> forall a. QueryType -> RawSql -> IO a -> IO a
_orvilleSqlExecutionCallback
defaultSqlExectionCallback :: QueryType -> RawSql.RawSql -> IO a -> IO a
defaultSqlExectionCallback :: forall a. QueryType -> RawSql -> IO a -> IO a
defaultSqlExectionCallback QueryType
_ RawSql
_ IO a
io = IO a
io
addSqlExecutionCallback ::
(forall a. QueryType -> RawSql.RawSql -> IO a -> IO a) ->
OrvilleState ->
OrvilleState
addSqlExecutionCallback :: (forall a. QueryType -> RawSql -> IO a -> IO a)
-> OrvilleState -> OrvilleState
addSqlExecutionCallback forall a. QueryType -> RawSql -> IO a -> IO a
outerCallback OrvilleState
state =
let
layeredCallback, innerCallback :: QueryType -> RawSql.RawSql -> IO a -> IO a
layeredCallback :: forall a. QueryType -> RawSql -> IO a -> IO a
layeredCallback QueryType
queryType RawSql
sql IO a
action =
QueryType -> RawSql -> IO a -> IO a
forall a. QueryType -> RawSql -> IO a -> IO a
outerCallback QueryType
queryType RawSql
sql (QueryType -> RawSql -> IO a -> IO a
forall a. QueryType -> RawSql -> IO a -> IO a
innerCallback QueryType
queryType RawSql
sql IO a
action)
innerCallback :: forall a. QueryType -> RawSql -> IO a -> IO a
innerCallback = OrvilleState -> forall a. QueryType -> RawSql -> IO a -> IO a
_orvilleSqlExecutionCallback OrvilleState
state
in
OrvilleState
state {_orvilleSqlExecutionCallback :: forall a. QueryType -> RawSql -> IO a -> IO a
_orvilleSqlExecutionCallback = QueryType -> RawSql -> IO a -> IO a
forall a. QueryType -> RawSql -> IO a -> IO a
layeredCallback}
defaultBeginTransactionExpr :: Expr.BeginTransactionExpr
defaultBeginTransactionExpr :: BeginTransactionExpr
defaultBeginTransactionExpr =
Maybe TransactionMode -> BeginTransactionExpr
Expr.beginTransaction Maybe TransactionMode
forall a. Maybe a
Nothing
setBeginTransactionExpr ::
Expr.BeginTransactionExpr ->
OrvilleState ->
OrvilleState
setBeginTransactionExpr :: BeginTransactionExpr -> OrvilleState -> OrvilleState
setBeginTransactionExpr BeginTransactionExpr
expr OrvilleState
state =
OrvilleState
state
{ _orvilleBeginTransactionExpr :: BeginTransactionExpr
_orvilleBeginTransactionExpr = BeginTransactionExpr
expr
}
setSqlCommenterAttributes ::
SqlCommenter.SqlCommenterAttributes ->
OrvilleState ->
OrvilleState
SqlCommenterAttributes
comments OrvilleState
state =
OrvilleState
state
{ _orvilleSqlCommenterAttributes :: Maybe SqlCommenterAttributes
_orvilleSqlCommenterAttributes = SqlCommenterAttributes -> Maybe SqlCommenterAttributes
forall a. a -> Maybe a
Just SqlCommenterAttributes
comments
}
addSqlCommenterAttributes ::
SqlCommenter.SqlCommenterAttributes ->
OrvilleState ->
OrvilleState
SqlCommenterAttributes
comments OrvilleState
state =
case OrvilleState -> Maybe SqlCommenterAttributes
orvilleSqlCommenterAttributes OrvilleState
state of
Maybe SqlCommenterAttributes
Nothing ->
OrvilleState
state
{ _orvilleSqlCommenterAttributes :: Maybe SqlCommenterAttributes
_orvilleSqlCommenterAttributes = SqlCommenterAttributes -> Maybe SqlCommenterAttributes
forall a. a -> Maybe a
Just SqlCommenterAttributes
comments
}
Just SqlCommenterAttributes
existingAttrs ->
OrvilleState
state
{ _orvilleSqlCommenterAttributes :: Maybe SqlCommenterAttributes
_orvilleSqlCommenterAttributes = SqlCommenterAttributes -> Maybe SqlCommenterAttributes
forall a. a -> Maybe a
Just (SqlCommenterAttributes -> Maybe SqlCommenterAttributes)
-> SqlCommenterAttributes -> Maybe SqlCommenterAttributes
forall a b. (a -> b) -> a -> b
$ SqlCommenterAttributes
-> SqlCommenterAttributes -> SqlCommenterAttributes
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union SqlCommenterAttributes
comments SqlCommenterAttributes
existingAttrs
}