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}|]

-- | After a computation failed, the Postgres connection needs to be health-checked.
-- If the status is 'LibPQ.ConnectionBad', remove the connection from the state and release it, causing the next call to
-- 'acquireConnection' to request a new one.
--
-- It is conceivable for the connection to be stuck in a startup phase like 'LibPQ.ConnectionSSLStartup', but since
-- hasql only uses a connection that is fully established, it shouldn't happen.
--
-- TODO Can't hurt to investigate this anyway.
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
  -- TODO
  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"
  -- TODO
  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