module Polysemy.Hasql.Interpreter.Database where
import Conc (Lock, interpretAtomic, interpretLockReentrant, lock)
import qualified Database.PostgreSQL.LibPQ as LibPQ
import Exon (exon)
import Hasql.Connection (Connection, withLibPQConnection)
import qualified Log
import Polysemy.Db.Data.DbConfig (DbConfig)
import Polysemy.Db.Data.DbConnectionError (DbConnectionError)
import qualified Polysemy.Db.Data.DbError as DbError
import Polysemy.Db.Data.DbError (DbError)
import qualified Time
import Time (NanoSeconds (NanoSeconds))
import qualified Polysemy.Hasql.Data.ConnectionState as ConnectionState
import Polysemy.Hasql.Data.ConnectionState (ConnectionState (ConnectionState), ConnectionsState (ConnectionsState))
import Polysemy.Hasql.Data.ConnectionTag (ConnectionTag (GlobalTag, SerialTag))
import Polysemy.Hasql.Data.InitDb (InitDb (InitDb), hoistInitDb)
import Polysemy.Hasql.Effect.Database (
ConnectionSource (Global, Supplied, Unique),
Database (Release, ResetInit, Retry, Session, Tag, Use, WithInit),
withDatabaseGlobal,
)
import qualified Polysemy.Hasql.Effect.DbConnectionPool as DbConnectionPool
import Polysemy.Hasql.Effect.DbConnectionPool (DbConnectionPool)
import Polysemy.Hasql.Interpreter.DbConnectionPool (interpretDbConnectionPool)
import Polysemy.Hasql.Session (runSession)
genTag ::
Member (AtomicState ConnectionsState) r =>
Sem r ConnectionTag
genTag :: forall (r :: EffectRow).
Member (AtomicState ConnectionsState) r =>
Sem r ConnectionTag
genTag =
Integer -> ConnectionTag
SerialTag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a (r :: EffectRow).
Member (AtomicState s) r =>
(s -> (s, a)) -> Sem r a
atomicState' \ ConnectionsState {Integer
Map ClientTag Int
$sel:clientInits:ConnectionsState :: ConnectionsState -> Map ClientTag Int
$sel:counter:ConnectionsState :: ConnectionsState -> Integer
clientInits :: Map ClientTag Int
counter :: Integer
..} ->
let new :: Integer
new = Integer
counter forall a. Num a => a -> a -> a
+ Integer
1
in (ConnectionsState {$sel:counter:ConnectionsState :: Integer
counter = Integer
new, Map ClientTag Int
$sel:clientInits:ConnectionsState :: Map ClientTag Int
clientInits :: Map ClientTag Int
..}, Integer
new)
tagForSource ::
Member (AtomicState ConnectionsState) r =>
ConnectionSource ->
Sem r (Either Connection ConnectionTag)
tagForSource :: forall (r :: EffectRow).
Member (AtomicState ConnectionsState) r =>
ConnectionSource -> Sem r (Either Connection ConnectionTag)
tagForSource = \case
ConnectionSource
Global -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ConnectionTag
GlobalTag)
Unique Maybe ConnectionTag
t -> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => m a -> Maybe a -> m a
fromMaybeA forall (r :: EffectRow).
Member (AtomicState ConnectionsState) r =>
Sem r ConnectionTag
genTag Maybe ConnectionTag
t
Supplied ConnectionTag
_ Connection
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left Connection
c)
needsInit ::
Member (AtomicState ConnectionsState) r =>
InitDb m ->
Int ->
Sem r Bool
needsInit :: forall (r :: EffectRow) (m :: * -> *).
Member (AtomicState ConnectionsState) r =>
InitDb m -> Int -> Sem r Bool
needsInit (InitDb ClientTag
clientId Bool
once Connection -> m ()
_) Int
count =
forall s (r :: EffectRow) a.
Member (AtomicState s) r =>
Lens' s a -> Sem r a
atomicView (forall a. IsLabel "clientInits" a => a
#clientInits forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at ClientTag
clientId) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Just Int
lastConnection ->
Bool -> Bool
not Bool
once Bool -> Bool -> Bool
&& Int
lastConnection forall a. Ord a => a -> a -> Bool
< Int
count
Maybe Int
Nothing ->
Bool
True
runInit ::
Members [AtomicState ConnectionsState, Log, Embed IO] r =>
InitDb (Sem r) ->
Int ->
Connection ->
Sem r ()
runInit :: forall (r :: EffectRow).
Members '[AtomicState ConnectionsState, Log, Embed IO] r =>
InitDb (Sem r) -> Int -> Connection -> Sem r ()
runInit (InitDb ClientTag
clientId Bool
_ Connection -> Sem r ()
initDb) Int
count Connection
connection = do
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.trace [exon|Running init for '##{clientId}'|]
Connection -> Sem r ()
initDb Connection
connection
forall s (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' (forall a. IsLabel "clientInits" a => a
#clientInits forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at ClientTag
clientId forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Int
count)
acquireConnection ::
Members [DbConnectionPool !! DbConnectionError, AtomicState ConnectionState, Stop DbError, Lock] r =>
ConnectionTag ->
Sem r (Int, Connection)
acquireConnection :: forall (r :: EffectRow).
Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionState, Stop DbError, Lock]
r =>
ConnectionTag -> Sem r (Int, Connection)
acquireConnection ConnectionTag
ctag =
forall (r :: EffectRow) a. Member Lock r => Sem r a -> Sem r a
lock do
forall s (r :: EffectRow). Member (AtomicState s) r => Sem r s
atomicGet forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ConnectionState Int
count Maybe Connection
Nothing Map ThreadId Int
tids -> do
Connection
conn <- forall err (eff :: (* -> *) -> * -> *) err' (r :: EffectRow) a.
Members '[Resumable err eff, Stop err'] r =>
(err -> err') -> Sem (eff : r) a -> Sem r a
resumeHoist DbConnectionError -> DbError
DbError.Connection (forall (r :: EffectRow).
Member DbConnectionPool r =>
ConnectionTag -> Sem r Connection
DbConnectionPool.acquire ConnectionTag
ctag)
forall s (r :: EffectRow).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut (Int -> Maybe Connection -> Map ThreadId Int -> ConnectionState
ConnectionState (Int
count forall a. Num a => a -> a -> a
+ Int
1) (forall a. a -> Maybe a
Just Connection
conn) Map ThreadId Int
tids)
pure (Int
count forall a. Num a => a -> a -> a
+ Int
1, Connection
conn)
ConnectionState Int
count (Just Connection
conn) Map ThreadId Int
_ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
count, Connection
conn)
releaseConnection ::
Members [DbConnectionPool !! DbConnectionError, AtomicState ConnectionState, Log] r =>
ConnectionTag ->
Sem r ()
releaseConnection :: forall (r :: EffectRow).
Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionState, Log]
r =>
ConnectionTag -> Sem r ()
releaseConnection ConnectionTag
ctag = do
forall s (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' (forall a. IsLabel "connection" a => a
#connection forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Maybe a
Nothing)
forall (r :: EffectRow).
Member DbConnectionPool r =>
ConnectionTag -> Sem r ()
DbConnectionPool.release ConnectionTag
ctag forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Resumable err eff) r =>
Sem (eff : r) a -> (err -> Sem r a) -> Sem r a
!! \ DbConnectionError
e ->
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.error [exon|Releasing connection failed: #{show e}|]
releaseBadConnection ::
Members [DbConnectionPool !! DbConnectionError, AtomicState ConnectionState, Stop DbError, Log, Lock, Embed IO] r =>
ConnectionTag ->
Connection ->
Sem r ()
releaseBadConnection :: forall (r :: EffectRow).
Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionState, Stop DbError, Log, Lock, Embed IO]
r =>
ConnectionTag -> Connection -> Sem r ()
releaseBadConnection ConnectionTag
ctag Connection
conn =
forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Either Text a)
tryIOError (forall a. Connection -> (Connection -> IO a) -> IO a
withLibPQConnection Connection
conn Connection -> IO ConnStatus
LibPQ.status) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right ConnStatus
LibPQ.ConnectionBad -> do
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [exon|Releasing bad connection ##{ctag}|]
forall (r :: EffectRow).
Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionState, Log]
r =>
ConnectionTag -> Sem r ()
releaseConnection ConnectionTag
ctag
Left Text
err ->
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.error [exon|Releasing bad connection failed: #{err}|]
Either Text ConnStatus
_ ->
forall (f :: * -> *). Applicative f => f ()
unit
bracketConnection ::
Member Resource r =>
Members [DbConnectionPool !! DbConnectionError, AtomicState ConnectionState, Stop DbError, Log, Lock, Embed IO] r =>
ConnectionTag ->
(Int -> Connection -> Sem r a) ->
Sem r a
bracketConnection :: forall (r :: EffectRow) a.
(Member Resource r,
Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionState, Stop DbError, Log, Lock, Embed IO]
r) =>
ConnectionTag -> (Int -> Connection -> Sem r a) -> Sem r a
bracketConnection ConnectionTag
ctag Int -> Connection -> Sem r a
use =
forall err (eff :: (* -> *) -> * -> *) err' (r :: EffectRow) a.
Members '[Resumable err eff, Stop err'] r =>
(err -> err') -> Sem (eff : r) a -> Sem r a
resumeHoist DbConnectionError -> DbError
DbError.Connection forall a b. (a -> b) -> a -> b
$ forall (r :: EffectRow) a.
Member DbConnectionPool r =>
ConnectionTag -> Sem r a -> Sem r a
DbConnectionPool.use ConnectionTag
ctag forall a b. (a -> b) -> a -> b
$
forall (r :: EffectRow) a c b.
Member Resource r =>
Sem r a -> (a -> Sem r c) -> (a -> Sem r b) -> Sem r b
bracketOnError (forall (r :: EffectRow).
Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionState, Stop DbError, Lock]
r =>
ConnectionTag -> Sem r (Int, Connection)
acquireConnection ConnectionTag
ctag) (Int, Connection) -> Sem (DbConnectionPool : r) ()
onError (forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Connection -> Sem r a
use)
where
onError :: (Int, Connection) -> Sem (DbConnectionPool : r) ()
onError (Int
_, Connection
conn) = forall (r :: EffectRow).
Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionState, Stop DbError, Log, Lock, Embed IO]
r =>
ConnectionTag -> Connection -> Sem r ()
releaseBadConnection ConnectionTag
ctag Connection
conn
withInit ::
Members [AtomicState ConnectionsState, Stop DbError, Log, Embed IO] r =>
Int ->
Connection ->
InitDb (Sem r) ->
Sem r a ->
Sem r a
withInit :: forall (r :: EffectRow) a.
Members
'[AtomicState ConnectionsState, Stop DbError, Log, Embed IO] r =>
Int -> Connection -> InitDb (Sem r) -> Sem r a -> Sem r a
withInit Int
count Connection
connection InitDb (Sem r)
initDb Sem r a
main = do
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (r :: EffectRow) (m :: * -> *).
Member (AtomicState ConnectionsState) r =>
InitDb m -> Int -> Sem r Bool
needsInit InitDb (Sem r)
initDb Int
count) do
forall (r :: EffectRow).
Members '[AtomicState ConnectionsState, Log, Embed IO] r =>
InitDb (Sem r) -> Int -> Connection -> Sem r ()
runInit InitDb (Sem r)
initDb Int
count Connection
connection
Sem r a
main
withInitManaged ::
Members [AtomicState ConnectionState, AtomicState ConnectionsState, DbConnectionPool !! DbConnectionError] r =>
Members [Stop DbError, Lock, Resource, Log, Embed IO] r =>
ConnectionTag ->
InitDb (Sem r) ->
(Connection -> Sem r a) ->
Sem r a
withInitManaged :: forall (r :: EffectRow) a.
(Members
'[AtomicState ConnectionState, AtomicState ConnectionsState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Stop DbError, Lock, Resource, Log, Embed IO] r) =>
ConnectionTag
-> InitDb (Sem r) -> (Connection -> Sem r a) -> Sem r a
withInitManaged ConnectionTag
ctag InitDb (Sem r)
initDb Connection -> Sem r a
use = do
forall (r :: EffectRow) a.
(Member Resource r,
Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionState, Stop DbError, Log, Lock, Embed IO]
r) =>
ConnectionTag -> (Int -> Connection -> Sem r a) -> Sem r a
bracketConnection ConnectionTag
ctag \ Int
count Connection
connection -> do
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.trace [exon|Client '##{clientTag}' uses database connection '##{ctag}'|]
forall (r :: EffectRow) a.
Members
'[AtomicState ConnectionsState, Stop DbError, Log, Embed IO] r =>
Int -> Connection -> InitDb (Sem r) -> Sem r a -> Sem r a
withInit Int
count Connection
connection InitDb (Sem r)
initDb (Connection -> Sem r a
use Connection
connection)
where
clientTag :: ClientTag
clientTag = InitDb (Sem r)
initDb forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "tag" a => a
#tag
retrying ::
Members [DbConnectionPool !! DbConnectionError, Time t d, Stop DbError, Resource, Embed IO] r =>
(Int, NanoSeconds) ->
Sem (Stop DbError : r) a ->
Sem r a
retrying :: forall t d (r :: EffectRow) a.
Members
'[DbConnectionPool !! DbConnectionError, Time t d, Stop DbError,
Resource, Embed IO]
r =>
(Int, NanoSeconds) -> Sem (Stop DbError : r) a -> Sem r a
retrying (Int
total, NanoSeconds
interval) Sem (Stop DbError : r) a
action =
Int -> Sem r a
spin Int
total
where
spin :: Int -> Sem r a
spin Int
0 = forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member e r =>
Sem (e : r) a -> Sem r a
subsume Sem (Stop DbError : r) a
action
spin Int
count =
forall err (r :: EffectRow) a.
Sem (Stop err : r) a -> Sem r (Either err a)
runStop Sem (Stop DbError : r) a
action forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> Either a b -> m b
leftA \case
DbError.Connection DbConnectionError
_ -> do
forall t d u (r :: EffectRow).
(TimeUnit u, Member (Time t d) r) =>
u -> Sem r ()
Time.sleep NanoSeconds
interval
Int -> Sem r a
spin (Int
count forall a. Num a => a -> a -> a
- Int
1)
DbError
e ->
forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop DbError
e
managedConnection ::
∀ r m t d a .
Members [AtomicState ConnectionsState, AtomicState ConnectionState, DbConnectionPool !! DbConnectionError] r =>
Members [Time t d, Resource, Lock, Log, Embed IO] r =>
ConnectionTag ->
InitDb (Sem r) ->
Maybe (Int, NanoSeconds) ->
Database m a ->
Tactical (Database !! DbError) m (Stop DbError : r) a
managedConnection :: forall (r :: EffectRow) (m :: * -> *) t d a.
(Members
'[AtomicState ConnectionsState, AtomicState ConnectionState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Time t d, Resource, Lock, Log, Embed IO] r) =>
ConnectionTag
-> InitDb (Sem r)
-> Maybe (Int, NanoSeconds)
-> Database m a
-> Tactical (Database !! DbError) m (Stop DbError : r) a
managedConnection ConnectionTag
ctag InitDb (Sem r)
initDb Maybe (Int, NanoSeconds)
retryMay = \case
WithInit (InitDb ClientTag
t Bool
o Connection -> m ()
new) m a
ma -> do
f ()
s <- forall (f :: * -> *) (m :: * -> *) (r :: EffectRow)
(e :: (* -> *) -> * -> *).
Sem (WithTactics e f m r) (f ())
getInitialStateT
f Connection
-> Sem ((Database !! DbError) : Stop DbError : r) (f ())
newT <- forall a (m :: * -> *) b (e :: (* -> *) -> * -> *) (f :: * -> *)
(r :: EffectRow).
(a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT Connection -> m ()
new
let new' :: Connection -> Sem (Stop DbError : r) ()
new' Connection
c = forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
(forall x (r0 :: EffectRow).
eff (Sem r0) x
-> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x)
-> InterpreterFor (Resumable err eff) r
interpretResumableH (forall (r :: EffectRow) (m :: * -> *) t d a.
(Members
'[AtomicState ConnectionsState, AtomicState ConnectionState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Time t d, Resource, Lock, Log, Embed IO] r) =>
ConnectionTag
-> InitDb (Sem r)
-> Maybe (Int, NanoSeconds)
-> Database m a
-> Tactical (Database !! DbError) m (Stop DbError : r) a
managedConnection ConnectionTag
ctag forall a. Default a => a
def forall a. Maybe a
Nothing) (f Connection
-> Sem ((Database !! DbError) : Stop DbError : r) (f ())
newT (Connection
c forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)))
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
(forall x (r0 :: EffectRow).
eff (Sem r0) x
-> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x)
-> InterpreterFor (Resumable err eff) r
interpretResumableH (forall (r :: EffectRow) (m :: * -> *) t d a.
(Members
'[AtomicState ConnectionsState, AtomicState ConnectionState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Time t d, Resource, Lock, Log, Embed IO] r) =>
ConnectionTag
-> InitDb (Sem r)
-> Maybe (Int, NanoSeconds)
-> Database m a
-> Tactical (Database !! DbError) m (Stop DbError : r) a
managedConnection ConnectionTag
ctag (forall (m :: * -> *).
ClientTag -> Bool -> (Connection -> m ()) -> InitDb m
InitDb ClientTag
t Bool
o Connection -> Sem (Stop DbError : r) ()
new') Maybe (Int, NanoSeconds)
retryMay) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
(r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT m a
ma
Session Session a
ma -> do
a
result <- forall t d (r :: EffectRow) a.
Members
'[DbConnectionPool !! DbConnectionError, Time t d, Stop DbError,
Resource, Embed IO]
r =>
(Int, NanoSeconds) -> Sem (Stop DbError : r) a -> Sem r a
retrying (Int, NanoSeconds)
retry forall a b. (a -> b) -> a -> b
$ forall (r :: EffectRow) a.
(Members
'[AtomicState ConnectionState, AtomicState ConnectionsState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Stop DbError, Lock, Resource, Log, Embed IO] r) =>
ConnectionTag
-> InitDb (Sem r) -> (Connection -> Sem r a) -> Sem r a
withInitManaged ConnectionTag
ctag (forall (m :: * -> *) (n :: * -> *).
(m () -> n ()) -> InitDb m -> InitDb n
hoistInitDb (forall (index :: Nat) (inserted :: EffectRow) (head :: EffectRow)
(oldTail :: EffectRow) (tail :: EffectRow) (old :: EffectRow)
(full :: EffectRow) a.
(ListOfLength index head, WhenStuck index InsertAtUnprovidedIndex,
old ~ Append head oldTail, tail ~ Append inserted oldTail,
full ~ Append head tail,
InsertAtIndex index head tail oldTail full inserted) =>
Sem old a -> Sem full a
insertAt @0) InitDb (Sem r)
initDb) \ Connection
connection ->
forall (r :: EffectRow) a.
Members '[Stop DbError, Embed IO] r =>
Connection -> Session a -> Sem r a
runSession Connection
connection Session a
ma
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
(r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT a
result
Use Connection -> m a
use ->
forall (r :: EffectRow) a.
(Members
'[AtomicState ConnectionState, AtomicState ConnectionsState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Stop DbError, Lock, Resource, Log, Embed IO] r) =>
ConnectionTag
-> InitDb (Sem r) -> (Connection -> Sem r a) -> Sem r a
withInitManaged ConnectionTag
ctag (forall (m :: * -> *) (n :: * -> *).
(m () -> n ()) -> InitDb m -> InitDb n
hoistInitDb (forall (index :: Nat) (inserted :: EffectRow) (head :: EffectRow)
(oldTail :: EffectRow) (tail :: EffectRow) (old :: EffectRow)
(full :: EffectRow) a.
(ListOfLength index head, WhenStuck index InsertAtUnprovidedIndex,
old ~ Append head oldTail, tail ~ Append inserted oldTail,
full ~ Append head tail,
InsertAtIndex index head tail oldTail full inserted) =>
Sem old a -> Sem full a
insertAt @0) InitDb (Sem r)
initDb) \ Connection
connection ->
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple (Connection -> m a
use Connection
connection)
Database m a
Release ->
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
(r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (r :: EffectRow).
Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionState, Log]
r =>
ConnectionTag -> Sem r ()
releaseConnection ConnectionTag
ctag
Retry t
interval Maybe Int
count m a
ma -> do
let r :: Maybe (Int, NanoSeconds)
r = forall a. a -> Maybe a
Just (forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
count, forall a b. (TimeUnit a, TimeUnit b) => a -> b
Time.convert t
interval)
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
(forall x (r0 :: EffectRow).
eff (Sem r0) x
-> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x)
-> InterpreterFor (Resumable err eff) r
interpretResumableH (forall (r :: EffectRow) (m :: * -> *) t d a.
(Members
'[AtomicState ConnectionsState, AtomicState ConnectionState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Time t d, Resource, Lock, Log, Embed IO] r) =>
ConnectionTag
-> InitDb (Sem r)
-> Maybe (Int, NanoSeconds)
-> Database m a
-> Tactical (Database !! DbError) m (Stop DbError : r) a
managedConnection ConnectionTag
ctag (forall (m :: * -> *) (n :: * -> *).
(m () -> n ()) -> InitDb m -> InitDb n
hoistInitDb forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise InitDb (Sem r)
initDb) Maybe (Int, NanoSeconds)
r) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
(r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT m a
ma
Database m a
Tag ->
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
(r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT ConnectionTag
ctag
Database m a
ResetInit ->
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
(r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' @ConnectionsState (forall a. IsLabel "clientInits" a => a
#clientInits forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => a
mempty)
where
retry :: (Int, NanoSeconds)
retry = forall a. a -> Maybe a -> a
fromMaybe (Int
0, Int64 -> NanoSeconds
NanoSeconds Int64
0) Maybe (Int, NanoSeconds)
retryMay
unmanagedConnection ::
∀ r m a .
Members [AtomicState ConnectionsState, AtomicState ConnectionState, DbConnectionPool !! DbConnectionError] r =>
Members [Resource, Lock, Log, Embed IO, Final IO] r =>
Connection ->
InitDb (Sem r) ->
Database m a ->
Tactical (Database !! DbError) m (Stop DbError : r) a
unmanagedConnection :: forall (r :: EffectRow) (m :: * -> *) a.
(Members
'[AtomicState ConnectionsState, AtomicState ConnectionState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Resource, Lock, Log, Embed IO, Final IO] r) =>
Connection
-> InitDb (Sem r)
-> Database m a
-> Tactical (Database !! DbError) m (Stop DbError : r) a
unmanagedConnection Connection
connection InitDb (Sem r)
initDb = \case
WithInit (InitDb ClientTag
t Bool
o Connection -> m ()
new) m a
ma -> do
f ()
s <- forall (f :: * -> *) (m :: * -> *) (r :: EffectRow)
(e :: (* -> *) -> * -> *).
Sem (WithTactics e f m r) (f ())
getInitialStateT
f Connection
-> Sem ((Database !! DbError) : Stop DbError : r) (f ())
newT <- forall a (m :: * -> *) b (e :: (* -> *) -> * -> *) (f :: * -> *)
(r :: EffectRow).
(a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT Connection -> m ()
new
let new' :: Connection -> Sem (Stop DbError : r) ()
new' Connection
c = forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
(forall x (r0 :: EffectRow).
eff (Sem r0) x
-> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x)
-> InterpreterFor (Resumable err eff) r
interpretResumableH (forall (r :: EffectRow) (m :: * -> *) a.
(Members
'[AtomicState ConnectionsState, AtomicState ConnectionState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Resource, Lock, Log, Embed IO, Final IO] r) =>
Connection
-> InitDb (Sem r)
-> Database m a
-> Tactical (Database !! DbError) m (Stop DbError : r) a
unmanagedConnection Connection
connection forall a. Default a => a
def) (f Connection
-> Sem ((Database !! DbError) : Stop DbError : r) (f ())
newT (Connection
c forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)))
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
(forall x (r0 :: EffectRow).
eff (Sem r0) x
-> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x)
-> InterpreterFor (Resumable err eff) r
interpretResumableH (forall (r :: EffectRow) (m :: * -> *) a.
(Members
'[AtomicState ConnectionsState, AtomicState ConnectionState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Resource, Lock, Log, Embed IO, Final IO] r) =>
Connection
-> InitDb (Sem r)
-> Database m a
-> Tactical (Database !! DbError) m (Stop DbError : r) a
unmanagedConnection Connection
connection (forall (m :: * -> *).
ClientTag -> Bool -> (Connection -> m ()) -> InitDb m
InitDb ClientTag
t Bool
o Connection -> Sem (Stop DbError : r) ()
new')) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
(r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT m a
ma
Session Session a
ma ->
forall (r :: EffectRow) a.
Members
'[AtomicState ConnectionsState, Stop DbError, Log, Embed IO] r =>
Int -> Connection -> InitDb (Sem r) -> Sem r a -> Sem r a
withInit Int
0 Connection
connection (forall (m :: * -> *) (n :: * -> *).
(m () -> n ()) -> InitDb m -> InitDb n
hoistInitDb (forall (index :: Nat) (inserted :: EffectRow) (head :: EffectRow)
(oldTail :: EffectRow) (tail :: EffectRow) (old :: EffectRow)
(full :: EffectRow) a.
(ListOfLength index head, WhenStuck index InsertAtUnprovidedIndex,
old ~ Append head oldTail, tail ~ Append inserted oldTail,
full ~ Append head tail,
InsertAtIndex index head tail oldTail full inserted) =>
Sem old a -> Sem full a
insertAt @0) InitDb (Sem r)
initDb) do
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
(r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (r :: EffectRow) a.
Members '[Stop DbError, Embed IO] r =>
Connection -> Session a -> Sem r a
runSession Connection
connection Session a
ma
Use Connection -> m a
use ->
forall (r :: EffectRow) a.
Members
'[AtomicState ConnectionsState, Stop DbError, Log, Embed IO] r =>
Int -> Connection -> InitDb (Sem r) -> Sem r a -> Sem r a
withInit Int
0 Connection
connection (forall (m :: * -> *) (n :: * -> *).
(m () -> n ()) -> InitDb m -> InitDb n
hoistInitDb (forall (index :: Nat) (inserted :: EffectRow) (head :: EffectRow)
(oldTail :: EffectRow) (tail :: EffectRow) (old :: EffectRow)
(full :: EffectRow) a.
(ListOfLength index head, WhenStuck index InsertAtUnprovidedIndex,
old ~ Append head oldTail, tail ~ Append inserted oldTail,
full ~ Append head tail,
InsertAtIndex index head tail oldTail full inserted) =>
Sem old a -> Sem full a
insertAt @0) InitDb (Sem r)
initDb) do
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple (Connection -> m a
use Connection
connection)
Database m a
Release ->
forall (f :: * -> *) (e :: (* -> *) -> * -> *) (m :: * -> *)
(r :: EffectRow).
Functor f =>
Sem (WithTactics e f m r) (f ())
unitT
Retry t
_ Maybe Int
_ m a
ma ->
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple m a
ma
Database m a
Tag ->
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
(r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT a
"unmanaged"
Database m a
ResetInit ->
forall (f :: * -> *) (e :: (* -> *) -> * -> *) (m :: * -> *)
(r :: EffectRow).
Functor f =>
Sem (WithTactics e f m r) (f ())
unitT
handleDatabase ::
∀ r m a t d .
Members [AtomicState ConnectionsState, AtomicState ConnectionState, DbConnectionPool !! DbConnectionError] r =>
Members [Time t d, Resource, Lock, Log, Embed IO, Final IO] r =>
Either Connection ConnectionTag ->
Database m a ->
Tactical (Database !! DbError) m (Stop DbError : r) a
handleDatabase :: forall (r :: EffectRow) (m :: * -> *) a t d.
(Members
'[AtomicState ConnectionsState, AtomicState ConnectionState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Time t d, Resource, Lock, Log, Embed IO, Final IO] r) =>
Either Connection ConnectionTag
-> Database m a
-> Tactical (Database !! DbError) m (Stop DbError : r) a
handleDatabase = \case
Right ConnectionTag
t -> forall (r :: EffectRow) (m :: * -> *) t d a.
(Members
'[AtomicState ConnectionsState, AtomicState ConnectionState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Time t d, Resource, Lock, Log, Embed IO] r) =>
ConnectionTag
-> InitDb (Sem r)
-> Maybe (Int, NanoSeconds)
-> Database m a
-> Tactical (Database !! DbError) m (Stop DbError : r) a
managedConnection ConnectionTag
t forall a. Default a => a
def forall a. Maybe a
Nothing
Left Connection
c -> forall (r :: EffectRow) (m :: * -> *) a.
(Members
'[AtomicState ConnectionsState, AtomicState ConnectionState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Resource, Lock, Log, Embed IO, Final IO] r) =>
Connection
-> InitDb (Sem r)
-> Database m a
-> Tactical (Database !! DbError) m (Stop DbError : r) a
unmanagedConnection Connection
c forall a. Default a => a
def
type DatabaseScope =
[
AtomicState ConnectionState,
Lock
]
databaseScope ::
Members [DbConnectionPool !! DbConnectionError, AtomicState ConnectionsState, Resource, Mask, Race, Embed IO] r =>
(Either Connection ConnectionTag -> Sem (DatabaseScope ++ r) a) ->
ConnectionSource ->
Sem r a
databaseScope :: forall (r :: EffectRow) a.
Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionsState, Resource, Mask, Race, Embed IO]
r =>
(Either Connection ConnectionTag -> Sem (DatabaseScope ++ r) a)
-> ConnectionSource -> Sem r a
databaseScope Either Connection ConnectionTag -> Sem (DatabaseScope ++ r) a
use ConnectionSource
source =
forall (r :: EffectRow).
Members '[Resource, Race, Mask, Embed IO] r =>
InterpreterFor Lock r
interpretLockReentrant forall a b. (a -> b) -> a -> b
$ forall a (r :: EffectRow).
Member (Embed IO) r =>
a -> InterpreterFor (AtomicState a) r
interpretAtomic forall a. Default a => a
def do
Either Connection ConnectionTag
ctag <- forall (r :: EffectRow).
Member (AtomicState ConnectionsState) r =>
ConnectionSource -> Sem r (Either Connection ConnectionTag)
tagForSource ConnectionSource
source
forall (r :: EffectRow) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
finally (Either Connection ConnectionTag -> Sem (DatabaseScope ++ r) a
use Either Connection ConnectionTag
ctag) (forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
Member (Resumable err eff) r =>
Sem (eff : r) () -> Sem r ()
resume_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: EffectRow).
Member DbConnectionPool r =>
ConnectionTag -> Sem r ()
DbConnectionPool.free) Either Connection ConnectionTag
ctag)
interpretDatabases ::
∀ t d r .
Members [DbConnectionPool !! DbConnectionError, AtomicState ConnectionsState] r =>
Members [Time t d, Log, Resource, Mask, Race, Embed IO, Final IO] r =>
InterpreterFor (Scoped ConnectionSource (Database !! DbError)) r
interpretDatabases :: forall t d (r :: EffectRow).
(Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionsState]
r,
Members
'[Time t d, Log, Resource, Mask, Race, Embed IO, Final IO] r) =>
InterpreterFor (Scoped ConnectionSource (Database !! DbError)) r
interpretDatabases =
forall (extra :: EffectRow) param resource
(effect :: (* -> *) -> * -> *) err (r :: EffectRow).
KnownList extra =>
(forall (q :: (* -> *) -> * -> *) x.
param
-> (resource -> Sem (extra ++ (Opaque q : r)) x)
-> Sem (Opaque q : r) x)
-> (forall (q :: (* -> *) -> * -> *) (r0 :: EffectRow) x.
resource
-> effect (Sem r0) x
-> Tactical
(effect !! err) (Sem r0) (Stop err : (extra ++ (Opaque q : r))) x)
-> InterpreterFor (Scoped param (effect !! err)) r
interpretResumableScopedWithH @DatabaseScope (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (r :: EffectRow) a.
Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionsState, Resource, Mask, Race, Embed IO]
r =>
(Either Connection ConnectionTag -> Sem (DatabaseScope ++ r) a)
-> ConnectionSource -> Sem r a
databaseScope) forall (r :: EffectRow) (m :: * -> *) a t d.
(Members
'[AtomicState ConnectionsState, AtomicState ConnectionState,
DbConnectionPool !! DbConnectionError]
r,
Members '[Time t d, Resource, Lock, Log, Embed IO, Final IO] r) =>
Either Connection ConnectionTag
-> Database m a
-> Tactical (Database !! DbError) m (Stop DbError : r) a
handleDatabase
interpretDatabase ::
∀ t d r .
Members [DbConnectionPool !! DbConnectionError, Time t d, Resource, Log, Mask, Race, Embed IO, Final IO] r =>
InterpretersFor [Database !! DbError, Scoped ConnectionSource (Database !! DbError)] r
interpretDatabase :: forall t d (r :: EffectRow).
Members
'[DbConnectionPool !! DbConnectionError, Time t d, Resource, Log,
Mask, Race, Embed IO, Final IO]
r =>
InterpretersFor
'[Database !! DbError,
Scoped ConnectionSource (Database !! DbError)]
r
interpretDatabase =
forall a (r :: EffectRow).
Member (Embed IO) r =>
a -> InterpreterFor (AtomicState a) r
interpretAtomic (Integer -> Map ClientTag Int -> ConnectionsState
ConnectionsState Integer
0 forall a. Monoid a => a
mempty) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall t d (r :: EffectRow).
(Members
'[DbConnectionPool !! DbConnectionError,
AtomicState ConnectionsState]
r,
Members
'[Time t d, Log, Resource, Mask, Race, Embed IO, Final IO] r) =>
InterpreterFor (Scoped ConnectionSource (Database !! DbError)) r
interpretDatabases forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
(r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (r :: EffectRow).
Member (Scoped ConnectionSource (Database !! DbError)) r =>
InterpreterFor (Database !! DbError) r
withDatabaseGlobal
type HasqlStack =
[
Database !! DbError,
Scoped ConnectionSource (Database !! DbError),
DbConnectionPool !! DbConnectionError
]
interpretHasql ::
Members [Time t d, Log, Mask, Resource, Race, Embed IO, Final IO] r =>
DbConfig ->
Maybe Int ->
Maybe Int ->
InterpretersFor HasqlStack r
interpretHasql :: forall t d (r :: EffectRow).
Members
'[Time t d, Log, Mask, Resource, Race, Embed IO, Final IO] r =>
DbConfig -> Maybe Int -> Maybe Int -> InterpretersFor HasqlStack r
interpretHasql DbConfig
dbConfig Maybe Int
maxActive Maybe Int
maxAvailable =
forall (r :: EffectRow).
Members '[Log, Resource, Embed IO, Final IO] r =>
DbConfig
-> Maybe Int
-> Maybe Int
-> InterpreterFor (DbConnectionPool !! DbConnectionError) r
interpretDbConnectionPool DbConfig
dbConfig Maybe Int
maxActive Maybe Int
maxAvailable forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall t d (r :: EffectRow).
Members
'[DbConnectionPool !! DbConnectionError, Time t d, Resource, Log,
Mask, Race, Embed IO, Final IO]
r =>
InterpretersFor
'[Database !! DbError,
Scoped ConnectionSource (Database !! DbError)]
r
interpretDatabase