{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoFieldSelectors #-}
module Sq.Connection
( Connection
, connection
, Transaction (smode)
, Settings (..)
, settings
, connectionReadTransaction
, connectionWriteTransaction
, foldIO
, streamIO
, ConnectionId (..)
, TransactionId (..)
, SavepointId (..)
, Savepoint
, savepoint
, savepointRollback
, savepointRelease
, ErrRows (..)
, ErrStatement (..)
) where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.Async qualified as Async
import Control.Concurrent.STM
import Control.DeepSeq
import Control.Exception.Safe qualified as Ex
import Control.Foldl qualified as F
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Resource qualified as R hiding (runResourceT)
import Control.Monad.Trans.Resource.Extra qualified as R
import Data.Acquire qualified as A
import Data.Foldable
import Data.Function (fix)
import Data.Functor
import Data.IORef
import Data.Int
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Monoid
import Data.Text qualified as T
import Data.Tuple
import Data.Word
import Database.SQLite3 qualified as S
import Database.SQLite3.Bindings qualified as S (CDatabase, CStatement)
import Database.SQLite3.Direct qualified as S (Database (..), Statement (..))
import Di.Df1 qualified as Di
import Foreign.C.Types (CInt (..))
import Foreign.Marshal.Alloc (free, malloc)
import Foreign.Ptr (FunPtr, Ptr, freeHaskellFunPtr)
import Foreign.Storable
import GHC.IO (unsafeUnmask)
import GHC.Records
import GHC.Show
import Streaming qualified as Z
import Streaming.Prelude qualified as Z
import System.Clock qualified as Clock
import System.Timeout (timeout)
import Prelude hiding (Read, log)
import Sq.Input
import Sq.Mode
import Sq.Names
import Sq.Output
import Sq.Statement
import Sq.Support
modeFlags :: Mode -> [S.SQLOpenFlag]
modeFlags :: Mode -> [SQLOpenFlag]
modeFlags = \case
Mode
Read ->
[ SQLOpenFlag
S.SQLOpenReadOnly
, SQLOpenFlag
S.SQLOpenWAL
, SQLOpenFlag
S.SQLOpenNoMutex
, SQLOpenFlag
S.SQLOpenExResCode
]
Mode
Write ->
[ SQLOpenFlag
S.SQLOpenReadWrite
, SQLOpenFlag
S.SQLOpenCreate
, SQLOpenFlag
S.SQLOpenWAL
, SQLOpenFlag
S.SQLOpenNoMutex
, SQLOpenFlag
S.SQLOpenExResCode
]
data Settings = Settings
{ Settings -> String
file :: FilePath
, Settings -> SQLVFS
vfs :: S.SQLVFS
, Settings -> Word32
timeout :: Word32
}
deriving stock (Settings -> Settings -> Bool
(Settings -> Settings -> Bool)
-> (Settings -> Settings -> Bool) -> Eq Settings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Settings -> Settings -> Bool
== :: Settings -> Settings -> Bool
$c/= :: Settings -> Settings -> Bool
/= :: Settings -> Settings -> Bool
Eq, Int -> Settings -> ShowS
[Settings] -> ShowS
Settings -> String
(Int -> Settings -> ShowS)
-> (Settings -> String) -> ([Settings] -> ShowS) -> Show Settings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Settings -> ShowS
showsPrec :: Int -> Settings -> ShowS
$cshow :: Settings -> String
show :: Settings -> String
$cshowList :: [Settings] -> ShowS
showList :: [Settings] -> ShowS
Show)
instance NFData Settings where
rnf :: Settings -> ()
rnf (Settings !String
_ !SQLVFS
_ !Word32
_) = ()
settings
:: FilePath
-> Settings
settings :: String -> Settings
settings String
file =
Settings
{ String
file :: String
file :: String
file
, vfs :: SQLVFS
vfs = SQLVFS
S.SQLVFSDefault
, timeout :: Word32
timeout = Word32
120_000
}
data Connection (c :: Mode) = Connection
{ forall (c :: Mode). Connection c -> ConnectionId
_id :: ConnectionId
, forall (c :: Mode). Connection c -> Word32
timeout :: Word32
, forall (c :: Mode). Connection c -> Di Level Path Message
di :: Di.Df1
, forall (c :: Mode).
Connection c -> TMVar (Maybe (ExclusiveConnection c))
xconn :: TMVar (Maybe (ExclusiveConnection c))
}
instance HasField "id" (Connection c) ConnectionId where
getField :: Connection c -> ConnectionId
getField = (._id)
instance NFData (Connection c) where
rnf :: Connection c -> ()
rnf (Connection !ConnectionId
_ !Word32
_ !Di Level Path Message
_ !TMVar (Maybe (ExclusiveConnection c))
_) = ()
instance Show (Connection c) where
showsPrec :: Int -> Connection c -> ShowS
showsPrec Int
_ Connection c
c = String -> ShowS
showString String
"Connection{id = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionId -> ShowS
forall a. Show a => a -> ShowS
shows Connection c
c.id ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'
connection :: SMode mode -> Di.Df1 -> Settings -> A.Acquire (Connection c)
connection :: forall (mode :: Mode) (c :: Mode).
SMode mode
-> Di Level Path Message -> Settings -> Acquire (Connection c)
connection SMode mode
smode Di Level Path Message
di0 Settings
s = do
(Di Level Path Message
di1, ExclusiveConnection c
xc) <- SMode mode
-> Di Level Path Message
-> Settings
-> Acquire (Di Level Path Message, ExclusiveConnection c)
forall (mode :: Mode) (c :: Mode).
SMode mode
-> Di Level Path Message
-> Settings
-> Acquire (Di Level Path Message, ExclusiveConnection c)
exclusiveConnection SMode mode
smode Di Level Path Message
di0 Settings
s
TMVar (Maybe (ExclusiveConnection c))
xconn <- IO (TMVar (Maybe (ExclusiveConnection c)))
-> (TMVar (Maybe (ExclusiveConnection c)) -> IO ())
-> Acquire (TMVar (Maybe (ExclusiveConnection c)))
forall a. IO a -> (a -> IO ()) -> Acquire a
R.mkAcquire1 (Maybe (ExclusiveConnection c)
-> IO (TMVar (Maybe (ExclusiveConnection c)))
forall a. a -> IO (TMVar a)
newTMVarIO (ExclusiveConnection c -> Maybe (ExclusiveConnection c)
forall a. a -> Maybe a
Just ExclusiveConnection c
xc)) \TMVar (Maybe (ExclusiveConnection c))
t ->
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe (ExclusiveConnection c))
-> STM (Maybe (Maybe (ExclusiveConnection c)))
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar (Maybe (ExclusiveConnection c))
t STM (Maybe (Maybe (ExclusiveConnection c))) -> STM () -> STM ()
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TMVar (Maybe (ExclusiveConnection c))
-> Maybe (ExclusiveConnection c) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Maybe (ExclusiveConnection c))
t Maybe (ExclusiveConnection c)
forall a. Maybe a
Nothing
Connection c -> Acquire (Connection c)
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection{TMVar (Maybe (ExclusiveConnection c))
xconn :: TMVar (Maybe (ExclusiveConnection c))
xconn :: TMVar (Maybe (ExclusiveConnection c))
xconn, _id :: ConnectionId
_id = ExclusiveConnection c
xc.id, di :: Di Level Path Message
di = Di Level Path Message
di1, timeout :: Word32
timeout = Settings
s.timeout}
data ExclusiveConnection (mode :: Mode) = ExclusiveConnection
{ forall (mode :: Mode). ExclusiveConnection mode -> ConnectionId
id :: ConnectionId
, forall (mode :: Mode).
ExclusiveConnection mode -> forall x. (Database -> IO x) -> IO x
run :: forall x. (S.Database -> IO x) -> IO x
, forall (mode :: Mode).
ExclusiveConnection mode -> IORef (Map SQL PreparedStatement)
statements :: IORef (Map SQL PreparedStatement)
}
instance Show (ExclusiveConnection m) where
showsPrec :: Int -> ExclusiveConnection m -> ShowS
showsPrec Int
_ ExclusiveConnection m
x =
String -> ShowS
showString String
"ExclusiveConnection{id = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionId -> ShowS
forall a. Show a => a -> ShowS
shows ExclusiveConnection m
x.id ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'
run :: (MonadIO m) => ExclusiveConnection c -> (S.Database -> IO x) -> m x
run :: forall (m :: * -> *) (c :: Mode) x.
MonadIO m =>
ExclusiveConnection c -> (Database -> IO x) -> m x
run ExclusiveConnection{run :: forall (mode :: Mode).
ExclusiveConnection mode -> forall x. (Database -> IO x) -> IO x
run = forall x. (Database -> IO x) -> IO x
r} Database -> IO x
k = IO x -> m x
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO x -> m x) -> IO x -> m x
forall a b. (a -> b) -> a -> b
$ (Database -> IO x) -> IO x
forall x. (Database -> IO x) -> IO x
r Database -> IO x
k
lockConnection :: Connection c -> A.Acquire (ExclusiveConnection c)
lockConnection :: forall (c :: Mode). Connection c -> Acquire (ExclusiveConnection c)
lockConnection Connection c
c =
IO (ExclusiveConnection c)
-> (ExclusiveConnection c -> IO ())
-> Acquire (ExclusiveConnection c)
forall a. IO a -> (a -> IO ()) -> Acquire a
R.mkAcquire1
( Di Level Path Message
-> IO (ExclusiveConnection c) -> IO (ExclusiveConnection c)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Di Level Path Message -> m a -> m a
warningOnException (Segment -> Di Level Path Message -> Di Level Path Message
forall level msg. Segment -> Di level Path msg -> Di level Path msg
Di.push Segment
"lock" Connection c
c.di) do
Maybe (ExclusiveConnection c)
y <- Int
-> IO (ExclusiveConnection c) -> IO (Maybe (ExclusiveConnection c))
forall a. Int -> IO a -> IO (Maybe a)
timeout (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Connection c
c.timeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) (IO (ExclusiveConnection c) -> IO (Maybe (ExclusiveConnection c)))
-> IO (ExclusiveConnection c) -> IO (Maybe (ExclusiveConnection c))
forall a b. (a -> b) -> a -> b
$ STM (ExclusiveConnection c) -> IO (ExclusiveConnection c)
forall a. STM a -> IO a
atomically do
TMVar (Maybe (ExclusiveConnection c))
-> STM (Maybe (ExclusiveConnection c))
forall a. TMVar a -> STM a
takeTMVar Connection c
c.xconn STM (Maybe (ExclusiveConnection c))
-> (Maybe (ExclusiveConnection c) -> STM (ExclusiveConnection c))
-> STM (ExclusiveConnection c)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just ExclusiveConnection c
x -> ExclusiveConnection c -> STM (ExclusiveConnection c)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExclusiveConnection c
x
Maybe (ExclusiveConnection c)
Nothing ->
IOError -> STM (ExclusiveConnection c)
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM (IOError -> STM (ExclusiveConnection c))
-> IOError -> STM (ExclusiveConnection c)
forall a b. (a -> b) -> a -> b
$
HasCallStack => String -> IOError
String -> IOError
resourceVanishedWithCallStack
String
"lockConnection"
case Maybe (ExclusiveConnection c)
y of
Just ExclusiveConnection c
xc -> ExclusiveConnection c -> IO (ExclusiveConnection c)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExclusiveConnection c
xc
Maybe (ExclusiveConnection c)
Nothing -> String -> IO (ExclusiveConnection c)
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
Ex.throwString String
"Timeout"
)
(STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (ExclusiveConnection c -> STM ())
-> ExclusiveConnection c
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bool -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bool -> STM ())
-> (ExclusiveConnection c -> STM Bool)
-> ExclusiveConnection c
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (Maybe (ExclusiveConnection c))
-> Maybe (ExclusiveConnection c) -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar Connection c
c.xconn (Maybe (ExclusiveConnection c) -> STM Bool)
-> (ExclusiveConnection c -> Maybe (ExclusiveConnection c))
-> ExclusiveConnection c
-> STM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExclusiveConnection c -> Maybe (ExclusiveConnection c)
forall a. a -> Maybe a
Just)
data DatabaseMessage
= forall x.
DatabaseMessage
(S.Database -> IO x)
(Either Ex.SomeException x -> IO ())
warningOnException
:: (MonadIO m, Ex.MonadMask m)
=> Di.Df1
-> m a
-> m a
warningOnException :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Di Level Path Message -> m a -> m a
warningOnException Di Level Path Message
di m a
act = m a -> (SomeException -> m ()) -> m a
forall (m :: * -> *) e a b.
(HasCallStack, MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
Ex.withException m a
act \SomeException
e ->
Di Level Path Message -> SomeException -> m ()
forall (m :: * -> *) msg path.
(MonadIO m, ToMessage msg) =>
Di Level path Message -> msg -> m ()
Di.warning Di Level Path Message
di (SomeException
e :: Ex.SomeException)
exclusiveConnection
:: SMode mode
-> Di.Df1
-> Settings
-> A.Acquire (Di.Df1, ExclusiveConnection c)
exclusiveConnection :: forall (mode :: Mode) (c :: Mode).
SMode mode
-> Di Level Path Message
-> Settings
-> Acquire (Di Level Path Message, ExclusiveConnection c)
exclusiveConnection SMode mode
smode Di Level Path Message
di0 Settings
cs = do
ConnectionId
cId :: ConnectionId <- Acquire ConnectionId
forall (m :: * -> *). MonadIO m => m ConnectionId
newConnectionId
let di1 :: Di Level Path Message
di1 = Key -> SMode mode -> Di Level Path Message -> Di Level Path Message
forall value level msg.
ToValue value =>
Key -> value -> Di level Path msg -> Di level Path msg
Di.attr Key
"connection-mode" SMode mode
smode (Di Level Path Message -> Di Level Path Message)
-> Di Level Path Message -> Di Level Path Message
forall a b. (a -> b) -> a -> b
$ Key
-> ConnectionId -> Di Level Path Message -> Di Level Path Message
forall value level msg.
ToValue value =>
Key -> value -> Di level Path msg -> Di level Path msg
Di.attr Key
"connection" ConnectionId
cId Di Level Path Message
di0
MVar DatabaseMessage
dms :: MVar DatabaseMessage <-
IO (MVar DatabaseMessage)
-> (MVar DatabaseMessage -> IO ())
-> Acquire (MVar DatabaseMessage)
forall a. IO a -> (a -> IO ()) -> Acquire a
R.mkAcquire1 IO (MVar DatabaseMessage)
forall a. IO (MVar a)
newEmptyMVar ((Maybe DatabaseMessage -> ())
-> IO (Maybe DatabaseMessage) -> IO ()
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Maybe DatabaseMessage -> ()
forall a b. a -> b -> a
const ()) (IO (Maybe DatabaseMessage) -> IO ())
-> (MVar DatabaseMessage -> IO (Maybe DatabaseMessage))
-> MVar DatabaseMessage
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar DatabaseMessage -> IO (Maybe DatabaseMessage)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar)
Async ()
abackground :: Async.Async () <-
IO (Async ()) -> (Async () -> IO ()) -> Acquire (Async ())
forall a. IO a -> (a -> IO ()) -> Acquire a
R.mkAcquire1
(IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (Di Level Path Message -> IO DatabaseMessage -> IO ()
forall x. Di Level Path Message -> IO DatabaseMessage -> IO x
background Di Level Path Message
di1 (MVar DatabaseMessage -> IO DatabaseMessage
forall a. MVar a -> IO a
takeMVar MVar DatabaseMessage
dms)))
Async () -> IO ()
forall a. Async a -> IO ()
Async.uninterruptibleCancel
IO () -> Acquire ()
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Acquire ()) -> IO () -> Acquire ()
forall a b. (a -> b) -> a -> b
$ ((SomeException -> Bool) -> Async () -> IO ())
-> Async () -> (SomeException -> Bool) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SomeException -> Bool) -> Async () -> IO ()
forall a. (SomeException -> Bool) -> Async a -> IO ()
Async.linkOnly Async ()
abackground \SomeException
se ->
AsyncCancelled -> Maybe AsyncCancelled
forall a. a -> Maybe a
Just AsyncCancelled
Async.AsyncCancelled Maybe AsyncCancelled -> Maybe AsyncCancelled -> Bool
forall a. Eq a => a -> a -> Bool
== SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
Ex.fromException SomeException
se
IORef (Map SQL PreparedStatement)
statements :: IORef (Map SQL PreparedStatement) <-
IO (IORef (Map SQL PreparedStatement))
-> (IORef (Map SQL PreparedStatement) -> IO ())
-> Acquire (IORef (Map SQL PreparedStatement))
forall a. IO a -> (a -> IO ()) -> Acquire a
R.mkAcquire1 (Map SQL PreparedStatement -> IO (IORef (Map SQL PreparedStatement))
forall a. a -> IO (IORef a)
newIORef Map SQL PreparedStatement
forall a. Monoid a => a
mempty) \IORef (Map SQL PreparedStatement)
r ->
IORef (Map SQL PreparedStatement)
-> (Map SQL PreparedStatement
-> (Map SQL PreparedStatement, Map SQL PreparedStatement))
-> IO (Map SQL PreparedStatement)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map SQL PreparedStatement)
r (Map SQL PreparedStatement
forall a. Monoid a => a
mempty,) IO (Map SQL PreparedStatement)
-> (Map SQL PreparedStatement -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PreparedStatement -> IO (Either SomeException ()))
-> Map SQL PreparedStatement -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \PreparedStatement
ps ->
IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
Ex.tryAny (Statement -> IO ()
S.finalize PreparedStatement
ps.handle)
(Di Level Path Message, ExclusiveConnection c)
-> Acquire (Di Level Path Message, ExclusiveConnection c)
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Di Level Path Message
di1
, ExclusiveConnection
{ IORef (Map SQL PreparedStatement)
statements :: IORef (Map SQL PreparedStatement)
statements :: IORef (Map SQL PreparedStatement)
statements
, id :: ConnectionId
id = ConnectionId
cId
, run :: forall x. (Database -> IO x) -> IO x
run = \ !Database -> IO x
act -> do
MVar (Either SomeException x)
mv <- IO (MVar (Either SomeException x))
forall a. IO (MVar a)
newEmptyMVar
MVar DatabaseMessage -> DatabaseMessage -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar DatabaseMessage
dms (DatabaseMessage -> IO ()) -> DatabaseMessage -> IO ()
forall a b. (a -> b) -> a -> b
$! (Database -> IO x)
-> (Either SomeException x -> IO ()) -> DatabaseMessage
forall x.
(Database -> IO x)
-> (Either SomeException x -> IO ()) -> DatabaseMessage
DatabaseMessage Database -> IO x
act ((Either SomeException x -> IO ()) -> DatabaseMessage)
-> (Either SomeException x -> IO ()) -> DatabaseMessage
forall a b. (a -> b) -> a -> b
$ MVar (Either SomeException x) -> Either SomeException x -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException x)
mv
MVar (Either SomeException x) -> IO (Either SomeException x)
forall a. MVar a -> IO a
takeMVar MVar (Either SomeException x)
mv IO (Either SomeException x)
-> (Either SomeException x -> IO x) -> IO x
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO x)
-> (x -> IO x) -> Either SomeException x -> IO x
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO x
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM x -> IO x
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
}
)
where
background :: forall x. Di.Df1 -> IO DatabaseMessage -> IO x
background :: forall x. Di Level Path Message -> IO DatabaseMessage -> IO x
background Di Level Path Message
di1 IO DatabaseMessage
next = ResourceT IO x -> IO x
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ResourceT m a -> m a
R.runResourceT do
(ReleaseKey
_, Database
db) <-
IO Database
-> (Database -> IO ()) -> ResourceT IO (ReleaseKey, Database)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
R.allocate
( do
let di2 :: Di Level Path Message
di2 = Segment -> Di Level Path Message -> Di Level Path Message
forall level msg. Segment -> Di level Path msg -> Di level Path msg
Di.push Segment
"connect" Di Level Path Message
di1
Database
db <- Di Level Path Message -> IO Database -> IO Database
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Di Level Path Message -> m a -> m a
warningOnException Di Level Path Message
di2 do
Text -> [SQLOpenFlag] -> SQLVFS -> IO Database
S.open2 (String -> Text
T.pack Settings
cs.file) (Mode -> [SQLOpenFlag]
modeFlags (SMode mode -> Mode
forall (mode :: Mode). SMode mode -> Mode
fromSMode SMode mode
smode)) Settings
cs.vfs
Di Level Path Message -> Message -> IO ()
forall (m :: * -> *) path.
MonadIO m =>
Di Level path Message -> Message -> m ()
Di.debug_ Di Level Path Message
di2 Message
"OK"
Database -> IO Database
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Database
db
)
( \Database
db -> do
let di2 :: Di Level Path Message
di2 = Segment -> Di Level Path Message -> Di Level Path Message
forall level msg. Segment -> Di level Path msg -> Di level Path msg
Di.push Segment
"disconnect" Di Level Path Message
di1
Di Level Path Message -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Di Level Path Message -> m a -> m a
warningOnException Di Level Path Message
di1 do
IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
Ex.finally
(IO () -> IO ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
Ex.uninterruptibleMask_ (Database -> IO ()
S.interrupt Database
db))
(Database -> IO ()
S.close Database
db)
Di Level Path Message -> Message -> IO ()
forall (m :: * -> *) path.
MonadIO m =>
Di Level path Message -> Message -> m ()
Di.debug_ Di Level Path Message
di2 Message
"OK"
)
Di Level Path Message -> ResourceT IO () -> ResourceT IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Di Level Path Message -> m a -> m a
warningOnException (Segment -> Di Level Path Message -> Di Level Path Message
forall level msg. Segment -> Di level Path msg -> Di level Path msg
Di.push Segment
"set-busy-handler" Di Level Path Message
di1) do
Database -> Word32 -> ResourceT IO ()
forall (m :: * -> *). MonadResource m => Database -> Word32 -> m ()
setBusyHandler Database
db Settings
cs.timeout
IO () -> ResourceT IO ()
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT IO ()) -> IO () -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$
(Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
(Database -> Text -> IO ()
S.exec Database
db)
[ Text
"PRAGMA synchronous=NORMAL"
, Text
"PRAGMA journal_size_limit=67108864"
, Text
"PRAGMA mmap_size=134217728"
, Text
"PRAGMA cache_size=2000"
]
IO x -> ResourceT IO x
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO x -> ResourceT IO x) -> IO x -> ResourceT IO x
forall a b. (a -> b) -> a -> b
$ IO () -> IO x
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
DatabaseMessage Database -> IO x
act Either SomeException x -> IO ()
res <- IO DatabaseMessage
next
IO x -> IO (Either SomeException x)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
Ex.try (IO x -> IO x
forall a. IO a -> IO a
unsafeUnmask (Database -> IO x
act Database
db)) IO (Either SomeException x)
-> (Either SomeException x -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SomeException x -> IO ()
res
foreign import ccall unsafe "sqlite3_busy_handler"
c_sqlite3_busy_handler
:: Ptr S.CDatabase
-> FunPtr (Ptr a -> CInt -> IO CInt)
-> Ptr a
-> IO CInt
foreign import ccall safe "sqlite3_sleep"
c_sqlite3_sleep
:: CInt
-> IO CInt
foreign import ccall "wrapper"
createBusyHandlerPtr
:: (Ptr Clock.TimeSpec -> CInt -> IO CInt)
-> IO (FunPtr (Ptr Clock.TimeSpec -> CInt -> IO CInt))
setBusyHandler :: (R.MonadResource m) => S.Database -> Word32 -> m ()
setBusyHandler :: forall (m :: * -> *). MonadResource m => Database -> Word32 -> m ()
setBusyHandler (S.Database Ptr CDatabase
pDB) Word32
tmaxMS = do
(ReleaseKey
_, FunPtr (Ptr TimeSpec -> CInt -> IO CInt)
pHandler) <- IO (FunPtr (Ptr TimeSpec -> CInt -> IO CInt))
-> (FunPtr (Ptr TimeSpec -> CInt -> IO CInt) -> IO ())
-> m (ReleaseKey, FunPtr (Ptr TimeSpec -> CInt -> IO CInt))
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
R.allocate ((Ptr TimeSpec -> CInt -> IO CInt)
-> IO (FunPtr (Ptr TimeSpec -> CInt -> IO CInt))
createBusyHandlerPtr Ptr TimeSpec -> CInt -> IO CInt
handler) FunPtr (Ptr TimeSpec -> CInt -> IO CInt) -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr
(ReleaseKey
_, Ptr TimeSpec
pTimeSpec) <- IO (Ptr TimeSpec)
-> (Ptr TimeSpec -> IO ()) -> m (ReleaseKey, Ptr TimeSpec)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
R.allocate IO (Ptr TimeSpec)
forall a. Storable a => IO (Ptr a)
malloc Ptr TimeSpec -> IO ()
forall a. Ptr a -> IO ()
free
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
CInt
n <- Ptr CDatabase
-> FunPtr (Ptr TimeSpec -> CInt -> IO CInt)
-> Ptr TimeSpec
-> IO CInt
forall a.
Ptr CDatabase
-> FunPtr (Ptr a -> CInt -> IO CInt) -> Ptr a -> IO CInt
c_sqlite3_busy_handler Ptr CDatabase
pDB FunPtr (Ptr TimeSpec -> CInt -> IO CInt)
pHandler Ptr TimeSpec
pTimeSpec
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) do
String -> IO ()
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
Ex.throwString (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"sqlite3_busy_handler: return " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CInt -> String
forall a. Show a => a -> String
show CInt
n
where
tmaxNS :: Integer
!tmaxNS :: Integer
tmaxNS = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
tmaxMS Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1_000_000
handler :: Ptr Clock.TimeSpec -> CInt -> IO CInt
handler :: Ptr TimeSpec -> CInt -> IO CInt
handler Ptr TimeSpec
pt0 CInt
n = do
TimeSpec
t1 <- Clock -> IO TimeSpec
Clock.getTime Clock
Clock.Monotonic
TimeSpec
t0 <-
if CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0
then Ptr TimeSpec -> IO TimeSpec
forall a. Storable a => Ptr a -> IO a
peek Ptr TimeSpec
pt0
else Ptr TimeSpec -> TimeSpec -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr TimeSpec
pt0 TimeSpec
t1 IO () -> TimeSpec -> IO TimeSpec
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TimeSpec
t1
if TimeSpec -> Integer
Clock.toNanoSecs (TimeSpec -> TimeSpec -> TimeSpec
Clock.diffTimeSpec TimeSpec
t1 TimeSpec
t0) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
tmaxNS
then do
let ms :: CInt
ms = Double -> CInt
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> CInt) -> Double -> CInt
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2 (CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> CInt -> CInt
forall a. Ord a => a -> a -> a
max CInt
1 CInt
n) :: Double)
CInt -> IO CInt
c_sqlite3_sleep CInt
ms IO CInt -> CInt -> IO CInt
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> CInt
1
else CInt -> IO CInt
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CInt
0
data Transaction (t :: Mode) = forall c.
(SubMode c t) =>
Transaction
{ forall (t :: Mode). Transaction t -> TransactionId
_id :: TransactionId
, forall (t :: Mode). Transaction t -> Di Level Path Message
di :: Di.Df1
, ()
conn :: Connection c
, forall (t :: Mode). Transaction t -> Bool
commit :: Bool
, forall (t :: Mode). Transaction t -> SMode t
smode :: SMode t
}
instance Show (Transaction t) where
showsPrec :: Int -> Transaction t -> ShowS
showsPrec Int
_ Transaction t
t =
String -> ShowS
showString String
"Transaction{id = "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransactionId -> ShowS
forall a. Show a => a -> ShowS
shows Transaction t
t.id
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", commit = "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS
forall a. Show a => a -> ShowS
shows Transaction t
t.commit
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'
instance NFData (Transaction t) where
rnf :: Transaction t -> ()
rnf (Transaction !TransactionId
_ !Di Level Path Message
_ !Connection c
_ !Bool
_ !SMode t
_) = ()
instance HasField "id" (Transaction t) TransactionId where
getField :: Transaction t -> TransactionId
getField = (._id)
connectionReadTransaction
:: (SubMode c Read)
=> Connection c
-> A.Acquire (Transaction 'Read)
connectionReadTransaction :: forall (c :: Mode).
SubMode c 'Read =>
Connection c -> Acquire (Transaction 'Read)
connectionReadTransaction Connection c
c = do
ExclusiveConnection c
xc <- Connection c -> Acquire (ExclusiveConnection c)
forall (c :: Mode). Connection c -> Acquire (ExclusiveConnection c)
lockConnection Connection c
c
TransactionId
tId <- Acquire TransactionId
forall (m :: * -> *). MonadIO m => m TransactionId
newTransactionId
let di1 :: Di Level Path Message
di1 = Key -> Mode -> Di Level Path Message -> Di Level Path Message
forall value level msg.
ToValue value =>
Key -> value -> Di level Path msg -> Di level Path msg
Di.attr Key
"transaction-mode" Mode
Read (Di Level Path Message -> Di Level Path Message)
-> Di Level Path Message -> Di Level Path Message
forall a b. (a -> b) -> a -> b
$ Key
-> TransactionId -> Di Level Path Message -> Di Level Path Message
forall value level msg.
ToValue value =>
Key -> value -> Di level Path msg -> Di level Path msg
Di.attr Key
"transaction" TransactionId
tId Connection c
c.di
IO () -> (() -> ReleaseType -> IO ()) -> Acquire ()
forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
R.mkAcquireType1
( do
let di2 :: Di Level Path Message
di2 = Segment -> Di Level Path Message -> Di Level Path Message
forall level msg. Segment -> Di level Path msg -> Di level Path msg
Di.push Segment
"begin" Di Level Path Message
di1
Di Level Path Message -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Di Level Path Message -> m a -> m a
warningOnException Di Level Path Message
di2 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExclusiveConnection c -> (Database -> IO ()) -> IO ()
forall (m :: * -> *) (c :: Mode) x.
MonadIO m =>
ExclusiveConnection c -> (Database -> IO x) -> m x
run ExclusiveConnection c
xc ((Database -> Text -> IO ()) -> Text -> Database -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Database -> Text -> IO ()
S.exec Text
"BEGIN DEFERRED")
Di Level Path Message -> Message -> IO ()
forall (m :: * -> *) path.
MonadIO m =>
Di Level path Message -> Message -> m ()
Di.debug_ Di Level Path Message
di2 Message
"OK"
)
( \()
_ ReleaseType
rt -> do
let di2 :: Di Level Path Message
di2 = Segment -> Di Level Path Message -> Di Level Path Message
forall level msg. Segment -> Di level Path msg -> Di level Path msg
Di.push Segment
"rollback" Di Level Path Message
di1
Maybe SomeException -> (SomeException -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ReleaseType -> Maybe SomeException
releaseTypeException ReleaseType
rt) \SomeException
e ->
Di Level Path Message -> String -> IO ()
forall (m :: * -> *) msg path.
(MonadIO m, ToMessage msg) =>
Di Level path Message -> msg -> m ()
Di.notice Di Level Path Message
di2 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Will rollback due to: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e
Di Level Path Message -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Di Level Path Message -> m a -> m a
warningOnException Di Level Path Message
di2 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExclusiveConnection c -> (Database -> IO ()) -> IO ()
forall (m :: * -> *) (c :: Mode) x.
MonadIO m =>
ExclusiveConnection c -> (Database -> IO x) -> m x
run ExclusiveConnection c
xc ((Database -> Text -> IO ()) -> Text -> Database -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Database -> Text -> IO ()
S.exec Text
"ROLLBACK")
Di Level Path Message -> Message -> IO ()
forall (m :: * -> *) path.
MonadIO m =>
Di Level path Message -> Message -> m ()
Di.debug_ Di Level Path Message
di2 Message
"OK"
)
TMVar (Maybe (ExclusiveConnection c))
xconn <- IO (TMVar (Maybe (ExclusiveConnection c)))
-> (TMVar (Maybe (ExclusiveConnection c)) -> IO ())
-> Acquire (TMVar (Maybe (ExclusiveConnection c)))
forall a. IO a -> (a -> IO ()) -> Acquire a
R.mkAcquire1 (Maybe (ExclusiveConnection c)
-> IO (TMVar (Maybe (ExclusiveConnection c)))
forall a. a -> IO (TMVar a)
newTMVarIO (ExclusiveConnection c -> Maybe (ExclusiveConnection c)
forall a. a -> Maybe a
Just ExclusiveConnection c
xc)) \TMVar (Maybe (ExclusiveConnection c))
t ->
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe (ExclusiveConnection c))
-> STM (Maybe (Maybe (ExclusiveConnection c)))
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar (Maybe (ExclusiveConnection c))
t STM (Maybe (Maybe (ExclusiveConnection c))) -> STM () -> STM ()
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TMVar (Maybe (ExclusiveConnection c))
-> Maybe (ExclusiveConnection c) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Maybe (ExclusiveConnection c))
t Maybe (ExclusiveConnection c)
forall a. Maybe a
Nothing
Transaction 'Read -> Acquire (Transaction 'Read)
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transaction 'Read -> Acquire (Transaction 'Read))
-> Transaction 'Read -> Acquire (Transaction 'Read)
forall a b. (a -> b) -> a -> b
$
Transaction
{ _id :: TransactionId
_id = TransactionId
tId
, di :: Di Level Path Message
di = Di Level Path Message
di1
, conn :: Connection c
conn = Connection c
c{xconn}
, commit :: Bool
commit = Bool
False
, smode :: SMode 'Read
smode = SMode 'Read
SRead
}
connectionWriteTransaction
:: Bool
-> Connection 'Write
-> A.Acquire (Transaction 'Write)
connectionWriteTransaction :: Bool -> Connection 'Write -> Acquire (Transaction 'Write)
connectionWriteTransaction Bool
commit Connection 'Write
c = do
ExclusiveConnection 'Write
xc <- Connection 'Write -> Acquire (ExclusiveConnection 'Write)
forall (c :: Mode). Connection c -> Acquire (ExclusiveConnection c)
lockConnection Connection 'Write
c
TransactionId
tId <- Acquire TransactionId
forall (m :: * -> *). MonadIO m => m TransactionId
newTransactionId
let di1 :: Di Level Path Message
di1 =
Key -> Value -> Di Level Path Message -> Di Level Path Message
forall level msg.
Key -> Value -> Di level Path msg -> Di level Path msg
Di.attr_ Key
"transaction-mode" (if Bool
commit then Value
"commit" else Value
"rollback") (Di Level Path Message -> Di Level Path Message)
-> Di Level Path Message -> Di Level Path Message
forall a b. (a -> b) -> a -> b
$
Key
-> TransactionId -> Di Level Path Message -> Di Level Path Message
forall value level msg.
ToValue value =>
Key -> value -> Di level Path msg -> Di level Path msg
Di.attr Key
"transaction" TransactionId
tId Connection 'Write
c.di
rollback :: Maybe SomeException -> IO ()
rollback (Maybe SomeException
ye :: Maybe Ex.SomeException) = do
let di2 :: Di Level Path Message
di2 = Segment -> Di Level Path Message -> Di Level Path Message
forall level msg. Segment -> Di level Path msg -> Di level Path msg
Di.push Segment
"rollback" Di Level Path Message
di1
Maybe SomeException -> (SomeException -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe SomeException
ye \SomeException
e -> Di Level Path Message -> String -> IO ()
forall (m :: * -> *) msg path.
(MonadIO m, ToMessage msg) =>
Di Level path Message -> msg -> m ()
Di.notice Di Level Path Message
di2 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Will rollback due to: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e
Di Level Path Message -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Di Level Path Message -> m a -> m a
warningOnException Di Level Path Message
di2 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExclusiveConnection 'Write -> (Database -> IO ()) -> IO ()
forall (m :: * -> *) (c :: Mode) x.
MonadIO m =>
ExclusiveConnection c -> (Database -> IO x) -> m x
run ExclusiveConnection 'Write
xc ((Database -> Text -> IO ()) -> Text -> Database -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Database -> Text -> IO ()
S.exec Text
"ROLLBACK")
Di Level Path Message -> Message -> IO ()
forall (m :: * -> *) path.
MonadIO m =>
Di Level path Message -> Message -> m ()
Di.debug_ Di Level Path Message
di2 Message
"OK"
IO () -> (() -> ReleaseType -> IO ()) -> Acquire ()
forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
R.mkAcquireType1
( do
let di2 :: Di Level Path Message
di2 = Segment -> Di Level Path Message -> Di Level Path Message
forall level msg. Segment -> Di level Path msg -> Di level Path msg
Di.push Segment
"begin" Di Level Path Message
di1
Di Level Path Message -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Di Level Path Message -> m a -> m a
warningOnException Di Level Path Message
di2 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExclusiveConnection 'Write -> (Database -> IO ()) -> IO ()
forall (m :: * -> *) (c :: Mode) x.
MonadIO m =>
ExclusiveConnection c -> (Database -> IO x) -> m x
run ExclusiveConnection 'Write
xc ((Database -> Text -> IO ()) -> Text -> Database -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Database -> Text -> IO ()
S.exec Text
"BEGIN IMMEDIATE")
Di Level Path Message -> Message -> IO ()
forall (m :: * -> *) path.
MonadIO m =>
Di Level path Message -> Message -> m ()
Di.debug_ Di Level Path Message
di2 Message
"OK"
)
( \()
_ ReleaseType
rt -> case ReleaseType -> Maybe SomeException
releaseTypeException ReleaseType
rt of
Maybe SomeException
Nothing
| Bool
commit -> do
let di2 :: Di Level Path Message
di2 = Segment -> Di Level Path Message -> Di Level Path Message
forall level msg. Segment -> Di level Path msg -> Di level Path msg
Di.push Segment
"commit" Di Level Path Message
di1
Di Level Path Message -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Di Level Path Message -> m a -> m a
warningOnException Di Level Path Message
di2 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExclusiveConnection 'Write -> (Database -> IO ()) -> IO ()
forall (m :: * -> *) (c :: Mode) x.
MonadIO m =>
ExclusiveConnection c -> (Database -> IO x) -> m x
run ExclusiveConnection 'Write
xc ((Database -> Text -> IO ()) -> Text -> Database -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Database -> Text -> IO ()
S.exec Text
"COMMIT")
Di Level Path Message -> Message -> IO ()
forall (m :: * -> *) path.
MonadIO m =>
Di Level path Message -> Message -> m ()
Di.debug_ Di Level Path Message
di2 Message
"OK"
| Bool
otherwise -> Maybe SomeException -> IO ()
rollback Maybe SomeException
forall a. Maybe a
Nothing
Just SomeException
e -> Maybe SomeException -> IO ()
rollback (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e)
)
TMVar (Maybe (ExclusiveConnection 'Write))
xconn <- IO (TMVar (Maybe (ExclusiveConnection 'Write)))
-> (TMVar (Maybe (ExclusiveConnection 'Write)) -> IO ())
-> Acquire (TMVar (Maybe (ExclusiveConnection 'Write)))
forall a. IO a -> (a -> IO ()) -> Acquire a
R.mkAcquire1 (Maybe (ExclusiveConnection 'Write)
-> IO (TMVar (Maybe (ExclusiveConnection 'Write)))
forall a. a -> IO (TMVar a)
newTMVarIO (ExclusiveConnection 'Write -> Maybe (ExclusiveConnection 'Write)
forall a. a -> Maybe a
Just ExclusiveConnection 'Write
xc)) \TMVar (Maybe (ExclusiveConnection 'Write))
t ->
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe (ExclusiveConnection 'Write))
-> STM (Maybe (Maybe (ExclusiveConnection 'Write)))
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar (Maybe (ExclusiveConnection 'Write))
t STM (Maybe (Maybe (ExclusiveConnection 'Write)))
-> STM () -> STM ()
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TMVar (Maybe (ExclusiveConnection 'Write))
-> Maybe (ExclusiveConnection 'Write) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Maybe (ExclusiveConnection 'Write))
t Maybe (ExclusiveConnection 'Write)
forall a. Maybe a
Nothing
Transaction 'Write -> Acquire (Transaction 'Write)
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transaction 'Write -> Acquire (Transaction 'Write))
-> Transaction 'Write -> Acquire (Transaction 'Write)
forall a b. (a -> b) -> a -> b
$
Transaction
{ _id :: TransactionId
_id = TransactionId
tId
, di :: Di Level Path Message
di = Di Level Path Message
di1
, conn :: Connection 'Write
conn = Connection 'Write
c{xconn}
, Bool
commit :: Bool
commit :: Bool
commit
, smode :: SMode 'Write
smode = SMode 'Write
SWrite
}
data PreparedStatement = PreparedStatement
{ PreparedStatement -> Statement
handle :: S.Statement
, PreparedStatement -> Map BindingName ColumnIndex
columns :: Map BindingName S.ColumnIndex
, PreparedStatement -> StatementId
id :: StatementId
, PreparedStatement -> Int
reprepares :: Int
}
acquirePreparedStatement
:: Di.Df1
-> SQL
-> ExclusiveConnection c
-> A.Acquire PreparedStatement
acquirePreparedStatement :: forall (c :: Mode).
Di Level Path Message
-> SQL -> ExclusiveConnection c -> Acquire PreparedStatement
acquirePreparedStatement Di Level Path Message
di0 SQL
raw ExclusiveConnection c
xconn = IO PreparedStatement
-> (PreparedStatement -> IO ()) -> Acquire PreparedStatement
forall a. IO a -> (a -> IO ()) -> Acquire a
R.mkAcquire1
( do
Maybe PreparedStatement
yps <- IORef (Map SQL PreparedStatement)
-> (Map SQL PreparedStatement
-> (Map SQL PreparedStatement, Maybe PreparedStatement))
-> IO (Maybe PreparedStatement)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' ExclusiveConnection c
xconn.statements \Map SQL PreparedStatement
m ->
(Maybe PreparedStatement, Map SQL PreparedStatement)
-> (Map SQL PreparedStatement, Maybe PreparedStatement)
forall a b. (a, b) -> (b, a)
swap ((Maybe PreparedStatement, Map SQL PreparedStatement)
-> (Map SQL PreparedStatement, Maybe PreparedStatement))
-> (Maybe PreparedStatement, Map SQL PreparedStatement)
-> (Map SQL PreparedStatement, Maybe PreparedStatement)
forall a b. (a -> b) -> a -> b
$ (SQL -> PreparedStatement -> Maybe PreparedStatement)
-> SQL
-> Map SQL PreparedStatement
-> (Maybe PreparedStatement, Map SQL PreparedStatement)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\SQL
_ PreparedStatement
_ -> Maybe PreparedStatement
forall a. Maybe a
Nothing) SQL
raw Map SQL PreparedStatement
m
case Maybe PreparedStatement
yps of
Just PreparedStatement
ps -> do
Int
reprepares <- Statement -> IO Int
getStatementStatusReprepare PreparedStatement
ps.handle
if Int
reprepares Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== PreparedStatement
ps.reprepares
then PreparedStatement -> IO PreparedStatement
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PreparedStatement
ps
else do
let di1 :: Di Level Path Message
di1 = Key
-> StatementId -> Di Level Path Message -> Di Level Path Message
forall value level msg.
ToValue value =>
Key -> value -> Di level Path msg -> Di level Path msg
Di.attr Key
"stmt" PreparedStatement
ps.id Di Level Path Message
di0
Di Level Path Message -> Message -> IO ()
forall (m :: * -> *) path.
MonadIO m =>
Di Level path Message -> Message -> m ()
Di.debug_ Di Level Path Message
di1 Message
"Reprepared"
Map BindingName ColumnIndex
columns <- Statement -> IO (Map BindingName ColumnIndex)
getStatementColumnIndexes PreparedStatement
ps.handle
Di Level Path Message -> String -> IO ()
forall (m :: * -> *) msg path.
(MonadIO m, ToMessage msg) =>
Di Level path Message -> msg -> m ()
Di.debug Di Level Path Message
di1 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Columns: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(BindingName, ColumnIndex)] -> String
forall a. Show a => a -> String
show (Map BindingName ColumnIndex -> [(BindingName, ColumnIndex)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map BindingName ColumnIndex
columns)
PreparedStatement -> IO PreparedStatement
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PreparedStatement
ps{reprepares, columns}
Maybe PreparedStatement
Nothing -> do
StatementId
stId <- IO StatementId
forall (m :: * -> *). MonadIO m => m StatementId
newStatementId
let di1 :: Di Level Path Message
di1 = Key
-> StatementId -> Di Level Path Message -> Di Level Path Message
forall value level msg.
ToValue value =>
Key -> value -> Di level Path msg -> Di level Path msg
Di.attr Key
"stmt" StatementId
stId Di Level Path Message
di0
Di Level Path Message -> String -> IO ()
forall (m :: * -> *) msg path.
(MonadIO m, ToMessage msg) =>
Di Level path Message -> msg -> m ()
Di.debug Di Level Path Message
di1 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Preparing " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SQL -> String
forall a. Show a => a -> String
show SQL
raw
Statement
handle <- ExclusiveConnection c -> (Database -> IO Statement) -> IO Statement
forall (m :: * -> *) (c :: Mode) x.
MonadIO m =>
ExclusiveConnection c -> (Database -> IO x) -> m x
run ExclusiveConnection c
xconn ((Database -> IO Statement) -> IO Statement)
-> (Database -> IO Statement) -> IO Statement
forall a b. (a -> b) -> a -> b
$ (Database -> Text -> IO Statement)
-> Text -> Database -> IO Statement
forall a b c. (a -> b -> c) -> b -> a -> c
flip Database -> Text -> IO Statement
S.prepare SQL
raw.text
Int
reprepares <- Statement -> IO Int
getStatementStatusReprepare Statement
handle
Map BindingName ColumnIndex
columns <- Statement -> IO (Map BindingName ColumnIndex)
getStatementColumnIndexes Statement
handle
Di Level Path Message -> String -> IO ()
forall (m :: * -> *) msg path.
(MonadIO m, ToMessage msg) =>
Di Level path Message -> msg -> m ()
Di.debug Di Level Path Message
di1 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Columns: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(BindingName, ColumnIndex)] -> String
forall a. Show a => a -> String
show (Map BindingName ColumnIndex -> [(BindingName, ColumnIndex)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map BindingName ColumnIndex
columns)
PreparedStatement -> IO PreparedStatement
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PreparedStatement{id :: StatementId
id = StatementId
stId, Statement
handle :: Statement
handle :: Statement
handle, Int
reprepares :: Int
reprepares :: Int
reprepares, Map BindingName ColumnIndex
columns :: Map BindingName ColumnIndex
columns :: Map BindingName ColumnIndex
columns}
)
\PreparedStatement
ps -> (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
Ex.onException (Statement -> IO ()
S.finalize PreparedStatement
ps.handle) do
Statement -> IO ()
S.reset PreparedStatement
ps.handle
IORef (Map SQL PreparedStatement)
-> (Map SQL PreparedStatement -> (Map SQL PreparedStatement, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' ExclusiveConnection c
xconn.statements \Map SQL PreparedStatement
m ->
(SQL
-> PreparedStatement
-> Map SQL PreparedStatement
-> Map SQL PreparedStatement
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert SQL
raw PreparedStatement
ps Map SQL PreparedStatement
m, ())
getStatementStatusReprepare :: S.Statement -> IO Int
getStatementStatusReprepare :: Statement -> IO Int
getStatementStatusReprepare (S.Statement Ptr CStatement
p) = do
CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CStatement -> CInt -> CInt -> IO CInt
c_sqlite3_stmt_status Ptr CStatement
p CInt
c_SQLITE_STMTSTATUS_REPREPARE CInt
0
foreign import ccall unsafe "sqlite3_stmt_status"
c_sqlite3_stmt_status
:: Ptr S.CStatement
-> CInt
-> CInt
-> IO CInt
c_SQLITE_STMTSTATUS_REPREPARE :: CInt
c_SQLITE_STMTSTATUS_REPREPARE :: CInt
c_SQLITE_STMTSTATUS_REPREPARE = CInt
5
getStatementColumnIndexes :: S.Statement -> IO (Map BindingName S.ColumnIndex)
getStatementColumnIndexes :: Statement -> IO (Map BindingName ColumnIndex)
getStatementColumnIndexes Statement
st = do
S.ColumnIndex (Int
ncols :: Int) <- Statement -> IO ColumnIndex
S.columnCount Statement
st
(Map BindingName ColumnIndex
-> ColumnIndex -> IO (Map BindingName ColumnIndex))
-> Map BindingName ColumnIndex
-> [ColumnIndex]
-> IO (Map BindingName ColumnIndex)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Control.Monad.foldM
( \ !Map BindingName ColumnIndex
m ColumnIndex
i -> do
Just Text
t <- Statement -> ColumnIndex -> IO (Maybe Text)
S.columnName Statement
st ColumnIndex
i
case Text -> Either String BindingName
parseOutputBindingName Text
t of
Right BindingName
n ->
(Maybe ColumnIndex -> IO (Maybe ColumnIndex))
-> BindingName
-> Map BindingName ColumnIndex
-> IO (Map BindingName ColumnIndex)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF
( \case
Maybe ColumnIndex
Nothing -> Maybe ColumnIndex -> IO (Maybe ColumnIndex)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ColumnIndex -> IO (Maybe ColumnIndex))
-> Maybe ColumnIndex -> IO (Maybe ColumnIndex)
forall a b. (a -> b) -> a -> b
$ ColumnIndex -> Maybe ColumnIndex
forall a. a -> Maybe a
Just ColumnIndex
i
Just ColumnIndex
_ -> ErrStatement -> IO (Maybe ColumnIndex)
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM (ErrStatement -> IO (Maybe ColumnIndex))
-> ErrStatement -> IO (Maybe ColumnIndex)
forall a b. (a -> b) -> a -> b
$ BindingName -> ErrStatement
ErrStatement_DuplicateColumnName BindingName
n
)
BindingName
n
Map BindingName ColumnIndex
m
Left String
_ ->
Map BindingName ColumnIndex -> IO (Map BindingName ColumnIndex)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map BindingName ColumnIndex
m
)
Map BindingName ColumnIndex
forall k a. Map k a
Map.empty
(Int -> ColumnIndex
S.ColumnIndex (Int -> ColumnIndex) -> [Int] -> [ColumnIndex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int
ncols Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
data ErrStatement
=
ErrStatement_DuplicateColumnName BindingName
deriving stock (ErrStatement -> ErrStatement -> Bool
(ErrStatement -> ErrStatement -> Bool)
-> (ErrStatement -> ErrStatement -> Bool) -> Eq ErrStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrStatement -> ErrStatement -> Bool
== :: ErrStatement -> ErrStatement -> Bool
$c/= :: ErrStatement -> ErrStatement -> Bool
/= :: ErrStatement -> ErrStatement -> Bool
Eq, Int -> ErrStatement -> ShowS
[ErrStatement] -> ShowS
ErrStatement -> String
(Int -> ErrStatement -> ShowS)
-> (ErrStatement -> String)
-> ([ErrStatement] -> ShowS)
-> Show ErrStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrStatement -> ShowS
showsPrec :: Int -> ErrStatement -> ShowS
$cshow :: ErrStatement -> String
show :: ErrStatement -> String
$cshowList :: [ErrStatement] -> ShowS
showList :: [ErrStatement] -> ShowS
Show)
deriving anyclass (Show ErrStatement
Typeable ErrStatement
(Typeable ErrStatement, Show ErrStatement) =>
(ErrStatement -> SomeException)
-> (SomeException -> Maybe ErrStatement)
-> (ErrStatement -> String)
-> Exception ErrStatement
SomeException -> Maybe ErrStatement
ErrStatement -> String
ErrStatement -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ErrStatement -> SomeException
toException :: ErrStatement -> SomeException
$cfromException :: SomeException -> Maybe ErrStatement
fromException :: SomeException -> Maybe ErrStatement
$cdisplayException :: ErrStatement -> String
displayException :: ErrStatement -> String
Ex.Exception)
data ErrRows
=
ErrRows_TooFew
|
ErrRows_TooMany
deriving stock (ErrRows -> ErrRows -> Bool
(ErrRows -> ErrRows -> Bool)
-> (ErrRows -> ErrRows -> Bool) -> Eq ErrRows
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrRows -> ErrRows -> Bool
== :: ErrRows -> ErrRows -> Bool
$c/= :: ErrRows -> ErrRows -> Bool
/= :: ErrRows -> ErrRows -> Bool
Eq, Int -> ErrRows -> ShowS
[ErrRows] -> ShowS
ErrRows -> String
(Int -> ErrRows -> ShowS)
-> (ErrRows -> String) -> ([ErrRows] -> ShowS) -> Show ErrRows
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrRows -> ShowS
showsPrec :: Int -> ErrRows -> ShowS
$cshow :: ErrRows -> String
show :: ErrRows -> String
$cshowList :: [ErrRows] -> ShowS
showList :: [ErrRows] -> ShowS
Show)
deriving anyclass (Show ErrRows
Typeable ErrRows
(Typeable ErrRows, Show ErrRows) =>
(ErrRows -> SomeException)
-> (SomeException -> Maybe ErrRows)
-> (ErrRows -> String)
-> Exception ErrRows
SomeException -> Maybe ErrRows
ErrRows -> String
ErrRows -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ErrRows -> SomeException
toException :: ErrRows -> SomeException
$cfromException :: SomeException -> Maybe ErrRows
fromException :: SomeException -> Maybe ErrRows
$cdisplayException :: ErrRows -> String
displayException :: ErrRows -> String
Ex.Exception)
foldIO
:: forall o z i t s m
. (MonadIO m, Ex.MonadMask m, SubMode t s)
=> F.FoldM m o z
-> A.Acquire (Transaction t)
-> Statement s i o
-> i
-> m z
foldIO :: forall o z i (t :: Mode) (s :: Mode) (m :: * -> *).
(MonadIO m, MonadMask m, SubMode t s) =>
FoldM m o z
-> Acquire (Transaction t) -> Statement s i o -> i -> m z
foldIO (F.FoldM x -> o -> m x
fstep m x
finit x -> m z
fext) Acquire (Transaction t)
atx Statement s i o
st i
i = do
!BoundStatement s o
bs <- Either ErrInput (BoundStatement s o) -> m (BoundStatement s o)
forall e (m :: * -> *) b.
(Exception e, MonadThrow m) =>
Either e b -> m b
hushThrow (Either ErrInput (BoundStatement s o) -> m (BoundStatement s o))
-> Either ErrInput (BoundStatement s o) -> m (BoundStatement s o)
forall a b. (a -> b) -> a -> b
$ Statement s i o -> i -> Either ErrInput (BoundStatement s o)
forall (s :: Mode) i o.
Statement s i o -> i -> Either ErrInput (BoundStatement s o)
bindStatement Statement s i o
st i
i
!x
acc0 <- m x
finit
Acquire (IO (Maybe o)) -> (IO (Maybe o) -> m z) -> m z
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m) =>
Acquire a -> (a -> m b) -> m b
R.withAcquire (Acquire (Transaction t)
atx Acquire (Transaction t)
-> (Transaction t -> Acquire (IO (Maybe o)))
-> Acquire (IO (Maybe o))
forall a b. Acquire a -> (a -> Acquire b) -> Acquire b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BoundStatement s o -> Transaction t -> Acquire (IO (Maybe o))
forall (t :: Mode) (s :: Mode) o.
SubMode t s =>
BoundStatement s o -> Transaction t -> Acquire (IO (Maybe o))
rowPopper BoundStatement s o
bs) \IO (Maybe o)
pop ->
(((x -> m z) -> x -> m z) -> x -> m z)
-> x -> ((x -> m z) -> x -> m z) -> m z
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((x -> m z) -> x -> m z) -> x -> m z
forall a. (a -> a) -> a
fix x
acc0 \x -> m z
k !x
acc ->
IO (Maybe o) -> m (Maybe o)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe o)
pop m (Maybe o) -> (Maybe o -> m z) -> m z
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m z -> (o -> m z) -> Maybe o -> m z
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (x -> m z
fext x
acc) (x -> o -> m x
fstep x
acc (o -> m x) -> (x -> m z) -> o -> m z
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> x -> m z
k)
streamIO
:: forall o i t s m
. (R.MonadResource m, SubMode t s)
=> A.Acquire (Transaction t)
-> Statement s i o
-> i
-> Z.Stream (Z.Of o) m ()
streamIO :: forall o i (t :: Mode) (s :: Mode) (m :: * -> *).
(MonadResource m, SubMode t s) =>
Acquire (Transaction t)
-> Statement s i o -> i -> Stream (Of o) m ()
streamIO Acquire (Transaction t)
atx Statement s i o
st i
i = do
BoundStatement s o
bs <- IO (BoundStatement s o) -> Stream (Of o) m (BoundStatement s o)
forall a. IO a -> Stream (Of o) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (BoundStatement s o) -> Stream (Of o) m (BoundStatement s o))
-> IO (BoundStatement s o) -> Stream (Of o) m (BoundStatement s o)
forall a b. (a -> b) -> a -> b
$ Either ErrInput (BoundStatement s o) -> IO (BoundStatement s o)
forall e (m :: * -> *) b.
(Exception e, MonadThrow m) =>
Either e b -> m b
hushThrow (Either ErrInput (BoundStatement s o) -> IO (BoundStatement s o))
-> Either ErrInput (BoundStatement s o) -> IO (BoundStatement s o)
forall a b. (a -> b) -> a -> b
$ Statement s i o -> i -> Either ErrInput (BoundStatement s o)
forall (s :: Mode) i o.
Statement s i o -> i -> Either ErrInput (BoundStatement s o)
bindStatement Statement s i o
st i
i
(ReleaseKey
k, TMVar (Maybe (IO (Maybe o)))
typop) <- m (ReleaseKey, TMVar (Maybe (IO (Maybe o))))
-> Stream (Of o) m (ReleaseKey, TMVar (Maybe (IO (Maybe o))))
forall (m :: * -> *) a. Monad m => m a -> Stream (Of o) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ReleaseKey, TMVar (Maybe (IO (Maybe o))))
-> Stream (Of o) m (ReleaseKey, TMVar (Maybe (IO (Maybe o)))))
-> m (ReleaseKey, TMVar (Maybe (IO (Maybe o))))
-> Stream (Of o) m (ReleaseKey, TMVar (Maybe (IO (Maybe o))))
forall a b. (a -> b) -> a -> b
$ Acquire (TMVar (Maybe (IO (Maybe o))))
-> m (ReleaseKey, TMVar (Maybe (IO (Maybe o))))
forall (m :: * -> *) a.
MonadResource m =>
Acquire a -> m (ReleaseKey, a)
A.allocateAcquire do
IO (Maybe o)
pop <- BoundStatement s o -> Transaction t -> Acquire (IO (Maybe o))
forall (t :: Mode) (s :: Mode) o.
SubMode t s =>
BoundStatement s o -> Transaction t -> Acquire (IO (Maybe o))
rowPopper BoundStatement s o
bs (Transaction t -> Acquire (IO (Maybe o)))
-> Acquire (Transaction t) -> Acquire (IO (Maybe o))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Acquire (Transaction t)
atx
IO (TMVar (Maybe (IO (Maybe o))))
-> (TMVar (Maybe (IO (Maybe o))) -> IO ())
-> Acquire (TMVar (Maybe (IO (Maybe o))))
forall a. IO a -> (a -> IO ()) -> Acquire a
R.mkAcquire1 (Maybe (IO (Maybe o)) -> IO (TMVar (Maybe (IO (Maybe o))))
forall a. a -> IO (TMVar a)
newTMVarIO (IO (Maybe o) -> Maybe (IO (Maybe o))
forall a. a -> Maybe a
Just IO (Maybe o)
pop)) \TMVar (Maybe (IO (Maybe o)))
tmv -> do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe (IO (Maybe o))) -> STM (Maybe (Maybe (IO (Maybe o))))
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar (Maybe (IO (Maybe o)))
tmv STM (Maybe (Maybe (IO (Maybe o)))) -> STM () -> STM ()
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TMVar (Maybe (IO (Maybe o))) -> Maybe (IO (Maybe o)) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Maybe (IO (Maybe o)))
tmv Maybe (IO (Maybe o))
forall a. Maybe a
Nothing
m (Either () o) -> Stream (Of o) m ()
forall (m :: * -> *) r a.
Monad m =>
m (Either r a) -> Stream (Of a) m r
Z.untilLeft (m (Either () o) -> Stream (Of o) m ())
-> m (Either () o) -> Stream (Of o) m ()
forall a b. (a -> b) -> a -> b
$ IO (Either () o) -> m (Either () o)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either () o) -> m (Either () o))
-> IO (Either () o) -> m (Either () o)
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO (Either () o)) -> IO (Either () o)
forall b.
HasCallStack =>
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
Ex.mask \forall a. IO a -> IO a
restore ->
IO (IO (Maybe o))
-> (IO (Maybe o) -> IO Bool)
-> (IO (Maybe o) -> IO (Either () o))
-> IO (Either () o)
forall (m :: * -> *) a b c.
(HasCallStack, MonadMask m) =>
m a -> (a -> m b) -> (a -> m c) -> m c
Ex.bracket
( STM (IO (Maybe o)) -> IO (IO (Maybe o))
forall a. STM a -> IO a
atomically do
TMVar (Maybe (IO (Maybe o))) -> STM (Maybe (IO (Maybe o)))
forall a. TMVar a -> STM a
takeTMVar TMVar (Maybe (IO (Maybe o)))
typop STM (Maybe (IO (Maybe o)))
-> (Maybe (IO (Maybe o)) -> STM (IO (Maybe o)))
-> STM (IO (Maybe o))
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just IO (Maybe o)
pop -> IO (Maybe o) -> STM (IO (Maybe o))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IO (Maybe o)
pop
Maybe (IO (Maybe o))
Nothing -> IOError -> STM (IO (Maybe o))
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM (IOError -> STM (IO (Maybe o))) -> IOError -> STM (IO (Maybe o))
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> IOError
String -> IOError
resourceVanishedWithCallStack String
"streamIO"
)
(STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool)
-> (IO (Maybe o) -> STM Bool) -> IO (Maybe o) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (Maybe (IO (Maybe o))) -> Maybe (IO (Maybe o)) -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Maybe (IO (Maybe o)))
typop (Maybe (IO (Maybe o)) -> STM Bool)
-> (IO (Maybe o) -> Maybe (IO (Maybe o)))
-> IO (Maybe o)
-> STM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe o) -> Maybe (IO (Maybe o))
forall a. a -> Maybe a
Just)
( IO (Maybe o) -> IO (Maybe o)
forall a. IO a -> IO a
restore (IO (Maybe o) -> IO (Maybe o))
-> (Maybe o -> IO (Either () o))
-> IO (Maybe o)
-> IO (Either () o)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
Just o
o -> Either () o -> IO (Either () o)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either () o -> IO (Either () o))
-> Either () o -> IO (Either () o)
forall a b. (a -> b) -> a -> b
$ o -> Either () o
forall a b. b -> Either a b
Right o
o
Maybe o
Nothing -> () -> Either () o
forall a b. a -> Either a b
Left (() -> Either () o) -> IO () -> IO (Either () o)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReleaseKey -> ReleaseType -> IO ()
forall (m :: * -> *).
MonadIO m =>
ReleaseKey -> ReleaseType -> m ()
R.releaseType ReleaseKey
k ReleaseType
A.ReleaseEarly
)
rowPopper
:: (SubMode t s)
=> BoundStatement s o
-> Transaction t
-> A.Acquire (IO (Maybe o))
rowPopper :: forall (t :: Mode) (s :: Mode) o.
SubMode t s =>
BoundStatement s o -> Transaction t -> Acquire (IO (Maybe o))
rowPopper !BoundStatement s o
bs Transaction{Connection c
conn :: ()
conn :: Connection c
conn, di :: forall (t :: Mode). Transaction t -> Di Level Path Message
di = Di Level Path Message
di0} = do
ExclusiveConnection c
xconn <- Connection c -> Acquire (ExclusiveConnection c)
forall (c :: Mode). Connection c -> Acquire (ExclusiveConnection c)
lockConnection Connection c
conn
QueryId
qId <- Acquire QueryId
forall (m :: * -> *). MonadIO m => m QueryId
newQueryId
let di1 :: Di Level Path Message
di1 = Key -> QueryId -> Di Level Path Message -> Di Level Path Message
forall value level msg.
ToValue value =>
Key -> value -> Di level Path msg -> Di level Path msg
Di.attr Key
"query" QueryId
qId Di Level Path Message
di0
PreparedStatement
ps <- Di Level Path Message
-> SQL -> ExclusiveConnection c -> Acquire PreparedStatement
forall (c :: Mode).
Di Level Path Message
-> SQL -> ExclusiveConnection c -> Acquire PreparedStatement
acquirePreparedStatement Di Level Path Message
di1 BoundStatement s o
bs.sql ExclusiveConnection c
xconn
let di2 :: Di Level Path Message
di2 = Key
-> StatementId -> Di Level Path Message -> Di Level Path Message
forall value level msg.
ToValue value =>
Key -> value -> Di level Path msg -> Di level Path msg
Di.attr Key
"statement" PreparedStatement
ps.id Di Level Path Message
di1
!kvs :: [(Text, SQLData)]
kvs = Map Text SQLData -> [(Text, SQLData)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map Text SQLData -> [(Text, SQLData)])
-> Map Text SQLData -> [(Text, SQLData)]
forall a b. (a -> b) -> a -> b
$ BoundInput -> Map Text SQLData
rawBoundInput BoundStatement s o
bs.input
IO () -> (() -> IO ()) -> Acquire ()
forall a. IO a -> (a -> IO ()) -> Acquire a
R.mkAcquire1 (Statement -> [(Text, SQLData)] -> IO ()
S.bindNamed PreparedStatement
ps.handle [(Text, SQLData)]
kvs) \()
_ -> Statement -> IO ()
S.clearBindings PreparedStatement
ps.handle
Di Level Path Message -> String -> Acquire ()
forall (m :: * -> *) msg path.
(MonadIO m, ToMessage msg) =>
Di Level path Message -> msg -> m ()
Di.debug Di Level Path Message
di2 (String -> Acquire ()) -> String -> Acquire ()
forall a b. (a -> b) -> a -> b
$ String
"Bound " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(Text, SQLData)] -> String
forall a. Show a => a -> String
show [(Text, SQLData)]
kvs
IO (Maybe o) -> Acquire (IO (Maybe o))
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
Statement -> IO StepResult
S.step PreparedStatement
ps.handle IO StepResult -> (StepResult -> IO (Maybe o)) -> IO (Maybe o)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
StepResult
S.Row -> (o -> Maybe o) -> IO o -> IO (Maybe o)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap o -> Maybe o
forall a. a -> Maybe a
Just do
Either ErrOutput o -> IO o
forall e (m :: * -> *) b.
(Exception e, MonadThrow m) =>
Either e b -> m b
hushThrow (Either ErrOutput o -> IO o) -> IO (Either ErrOutput o) -> IO o
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((BindingName -> IO (Maybe SQLData))
-> Output o -> IO (Either ErrOutput o))
-> Output o
-> (BindingName -> IO (Maybe SQLData))
-> IO (Either ErrOutput o)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (BindingName -> IO (Maybe SQLData))
-> Output o -> IO (Either ErrOutput o)
forall (m :: * -> *) o.
Monad m =>
(BindingName -> m (Maybe SQLData))
-> Output o -> m (Either ErrOutput o)
runOutput BoundStatement s o
bs.output \BindingName
n ->
(ColumnIndex -> IO SQLData)
-> Maybe ColumnIndex -> IO (Maybe SQLData)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Statement -> ColumnIndex -> IO SQLData
S.column PreparedStatement
ps.handle) (BindingName -> Map BindingName ColumnIndex -> Maybe ColumnIndex
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BindingName
n PreparedStatement
ps.columns)
StepResult
S.Done -> Maybe o -> IO (Maybe o)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe o
forall a. Maybe a
Nothing
data Savepoint = Savepoint
{ Savepoint -> SavepointId
id :: SavepointId
, Savepoint -> IO ()
rollback :: IO ()
, Savepoint -> IO ()
release :: IO ()
}
instance NFData Savepoint where
rnf :: Savepoint -> ()
rnf (Savepoint !SavepointId
_ !IO ()
_ !IO ()
_) = ()
instance Show Savepoint where
showsPrec :: Int -> Savepoint -> ShowS
showsPrec Int
_ Savepoint
x = String -> ShowS
showString String
"Savepoint{id = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavepointId -> ShowS
forall a. Show a => a -> ShowS
shows Savepoint
x.id ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'
savepoint :: (MonadIO m) => Transaction Write -> m Savepoint
savepoint :: forall (m :: * -> *).
MonadIO m =>
Transaction 'Write -> m Savepoint
savepoint Transaction{Connection c
conn :: ()
conn :: Connection c
conn} = IO Savepoint -> m Savepoint
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
SavepointId
spId <- IO SavepointId
forall (m :: * -> *). MonadIO m => m SavepointId
newSavepointId
let run' :: Text -> IO ()
run' Text
raw = Acquire (ExclusiveConnection c)
-> (ExclusiveConnection c -> IO ()) -> IO ()
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m) =>
Acquire a -> (a -> m b) -> m b
R.withAcquire (Connection c -> Acquire (ExclusiveConnection c)
forall (c :: Mode). Connection c -> Acquire (ExclusiveConnection c)
lockConnection Connection c
conn) \ExclusiveConnection c
xc ->
ExclusiveConnection c -> (Database -> IO ()) -> IO ()
forall (m :: * -> *) (c :: Mode) x.
MonadIO m =>
ExclusiveConnection c -> (Database -> IO x) -> m x
run ExclusiveConnection c
xc ((Database -> IO ()) -> IO ()) -> (Database -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Database -> Text -> IO ()) -> Text -> Database -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Database -> Text -> IO ()
S.exec Text
raw
Text -> IO ()
run' (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"SAVEPOINT s" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SavepointId -> Text
forall b a. (IsString b, Show a) => a -> b
show' SavepointId
spId
Savepoint -> IO Savepoint
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Savepoint -> IO Savepoint) -> Savepoint -> IO Savepoint
forall a b. (a -> b) -> a -> b
$
Savepoint
{ id :: SavepointId
id = SavepointId
spId
, rollback :: IO ()
rollback = Text -> IO ()
run' (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"ROLLBACK TO s" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SavepointId -> Text
forall b a. (IsString b, Show a) => a -> b
show' SavepointId
spId
, release :: IO ()
release = Text -> IO ()
run' (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"RELEASE s" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SavepointId -> Text
forall b a. (IsString b, Show a) => a -> b
show' SavepointId
spId
}
savepointRollback :: (MonadIO m) => Savepoint -> m ()
savepointRollback :: forall (m :: * -> *). MonadIO m => Savepoint -> m ()
savepointRollback Savepoint
s = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO Savepoint
s.rollback
savepointRelease :: (MonadIO m) => Savepoint -> m ()
savepointRelease :: forall (m :: * -> *). MonadIO m => Savepoint -> m ()
savepointRelease Savepoint
s = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO Savepoint
s.release
newtype SavepointId = SavepointId Word64
deriving newtype (SavepointId -> SavepointId -> Bool
(SavepointId -> SavepointId -> Bool)
-> (SavepointId -> SavepointId -> Bool) -> Eq SavepointId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SavepointId -> SavepointId -> Bool
== :: SavepointId -> SavepointId -> Bool
$c/= :: SavepointId -> SavepointId -> Bool
/= :: SavepointId -> SavepointId -> Bool
Eq, Eq SavepointId
Eq SavepointId =>
(SavepointId -> SavepointId -> Ordering)
-> (SavepointId -> SavepointId -> Bool)
-> (SavepointId -> SavepointId -> Bool)
-> (SavepointId -> SavepointId -> Bool)
-> (SavepointId -> SavepointId -> Bool)
-> (SavepointId -> SavepointId -> SavepointId)
-> (SavepointId -> SavepointId -> SavepointId)
-> Ord SavepointId
SavepointId -> SavepointId -> Bool
SavepointId -> SavepointId -> Ordering
SavepointId -> SavepointId -> SavepointId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SavepointId -> SavepointId -> Ordering
compare :: SavepointId -> SavepointId -> Ordering
$c< :: SavepointId -> SavepointId -> Bool
< :: SavepointId -> SavepointId -> Bool
$c<= :: SavepointId -> SavepointId -> Bool
<= :: SavepointId -> SavepointId -> Bool
$c> :: SavepointId -> SavepointId -> Bool
> :: SavepointId -> SavepointId -> Bool
$c>= :: SavepointId -> SavepointId -> Bool
>= :: SavepointId -> SavepointId -> Bool
$cmax :: SavepointId -> SavepointId -> SavepointId
max :: SavepointId -> SavepointId -> SavepointId
$cmin :: SavepointId -> SavepointId -> SavepointId
min :: SavepointId -> SavepointId -> SavepointId
Ord, Int -> SavepointId -> ShowS
[SavepointId] -> ShowS
SavepointId -> String
(Int -> SavepointId -> ShowS)
-> (SavepointId -> String)
-> ([SavepointId] -> ShowS)
-> Show SavepointId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SavepointId -> ShowS
showsPrec :: Int -> SavepointId -> ShowS
$cshow :: SavepointId -> String
show :: SavepointId -> String
$cshowList :: [SavepointId] -> ShowS
showList :: [SavepointId] -> ShowS
Show, SavepointId -> ()
(SavepointId -> ()) -> NFData SavepointId
forall a. (a -> ()) -> NFData a
$crnf :: SavepointId -> ()
rnf :: SavepointId -> ()
NFData, SavepointId -> Value
(SavepointId -> Value) -> ToValue SavepointId
forall a. (a -> Value) -> ToValue a
$cvalue :: SavepointId -> Value
value :: SavepointId -> Value
Di.ToValue)
newSavepointId :: (MonadIO m) => m SavepointId
newSavepointId :: forall (m :: * -> *). MonadIO m => m SavepointId
newSavepointId = Word64 -> SavepointId
SavepointId (Word64 -> SavepointId) -> m Word64 -> m SavepointId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Word64
forall (m :: * -> *). MonadIO m => m Word64
newUnique
newtype StatementId = StatementId Word64
deriving newtype (StatementId -> StatementId -> Bool
(StatementId -> StatementId -> Bool)
-> (StatementId -> StatementId -> Bool) -> Eq StatementId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StatementId -> StatementId -> Bool
== :: StatementId -> StatementId -> Bool
$c/= :: StatementId -> StatementId -> Bool
/= :: StatementId -> StatementId -> Bool
Eq, Eq StatementId
Eq StatementId =>
(StatementId -> StatementId -> Ordering)
-> (StatementId -> StatementId -> Bool)
-> (StatementId -> StatementId -> Bool)
-> (StatementId -> StatementId -> Bool)
-> (StatementId -> StatementId -> Bool)
-> (StatementId -> StatementId -> StatementId)
-> (StatementId -> StatementId -> StatementId)
-> Ord StatementId
StatementId -> StatementId -> Bool
StatementId -> StatementId -> Ordering
StatementId -> StatementId -> StatementId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StatementId -> StatementId -> Ordering
compare :: StatementId -> StatementId -> Ordering
$c< :: StatementId -> StatementId -> Bool
< :: StatementId -> StatementId -> Bool
$c<= :: StatementId -> StatementId -> Bool
<= :: StatementId -> StatementId -> Bool
$c> :: StatementId -> StatementId -> Bool
> :: StatementId -> StatementId -> Bool
$c>= :: StatementId -> StatementId -> Bool
>= :: StatementId -> StatementId -> Bool
$cmax :: StatementId -> StatementId -> StatementId
max :: StatementId -> StatementId -> StatementId
$cmin :: StatementId -> StatementId -> StatementId
min :: StatementId -> StatementId -> StatementId
Ord, Int -> StatementId -> ShowS
[StatementId] -> ShowS
StatementId -> String
(Int -> StatementId -> ShowS)
-> (StatementId -> String)
-> ([StatementId] -> ShowS)
-> Show StatementId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StatementId -> ShowS
showsPrec :: Int -> StatementId -> ShowS
$cshow :: StatementId -> String
show :: StatementId -> String
$cshowList :: [StatementId] -> ShowS
showList :: [StatementId] -> ShowS
Show, StatementId -> ()
(StatementId -> ()) -> NFData StatementId
forall a. (a -> ()) -> NFData a
$crnf :: StatementId -> ()
rnf :: StatementId -> ()
NFData, StatementId -> Value
(StatementId -> Value) -> ToValue StatementId
forall a. (a -> Value) -> ToValue a
$cvalue :: StatementId -> Value
value :: StatementId -> Value
Di.ToValue)
newStatementId :: (MonadIO m) => m StatementId
newStatementId :: forall (m :: * -> *). MonadIO m => m StatementId
newStatementId = Word64 -> StatementId
StatementId (Word64 -> StatementId) -> m Word64 -> m StatementId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Word64
forall (m :: * -> *). MonadIO m => m Word64
newUnique
newtype TransactionId = TransactionId Word64
deriving newtype (TransactionId -> TransactionId -> Bool
(TransactionId -> TransactionId -> Bool)
-> (TransactionId -> TransactionId -> Bool) -> Eq TransactionId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransactionId -> TransactionId -> Bool
== :: TransactionId -> TransactionId -> Bool
$c/= :: TransactionId -> TransactionId -> Bool
/= :: TransactionId -> TransactionId -> Bool
Eq, Eq TransactionId
Eq TransactionId =>
(TransactionId -> TransactionId -> Ordering)
-> (TransactionId -> TransactionId -> Bool)
-> (TransactionId -> TransactionId -> Bool)
-> (TransactionId -> TransactionId -> Bool)
-> (TransactionId -> TransactionId -> Bool)
-> (TransactionId -> TransactionId -> TransactionId)
-> (TransactionId -> TransactionId -> TransactionId)
-> Ord TransactionId
TransactionId -> TransactionId -> Bool
TransactionId -> TransactionId -> Ordering
TransactionId -> TransactionId -> TransactionId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TransactionId -> TransactionId -> Ordering
compare :: TransactionId -> TransactionId -> Ordering
$c< :: TransactionId -> TransactionId -> Bool
< :: TransactionId -> TransactionId -> Bool
$c<= :: TransactionId -> TransactionId -> Bool
<= :: TransactionId -> TransactionId -> Bool
$c> :: TransactionId -> TransactionId -> Bool
> :: TransactionId -> TransactionId -> Bool
$c>= :: TransactionId -> TransactionId -> Bool
>= :: TransactionId -> TransactionId -> Bool
$cmax :: TransactionId -> TransactionId -> TransactionId
max :: TransactionId -> TransactionId -> TransactionId
$cmin :: TransactionId -> TransactionId -> TransactionId
min :: TransactionId -> TransactionId -> TransactionId
Ord, Int -> TransactionId -> ShowS
[TransactionId] -> ShowS
TransactionId -> String
(Int -> TransactionId -> ShowS)
-> (TransactionId -> String)
-> ([TransactionId] -> ShowS)
-> Show TransactionId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransactionId -> ShowS
showsPrec :: Int -> TransactionId -> ShowS
$cshow :: TransactionId -> String
show :: TransactionId -> String
$cshowList :: [TransactionId] -> ShowS
showList :: [TransactionId] -> ShowS
Show, TransactionId -> ()
(TransactionId -> ()) -> NFData TransactionId
forall a. (a -> ()) -> NFData a
$crnf :: TransactionId -> ()
rnf :: TransactionId -> ()
NFData, TransactionId -> Value
(TransactionId -> Value) -> ToValue TransactionId
forall a. (a -> Value) -> ToValue a
$cvalue :: TransactionId -> Value
value :: TransactionId -> Value
Di.ToValue)
newTransactionId :: (MonadIO m) => m TransactionId
newTransactionId :: forall (m :: * -> *). MonadIO m => m TransactionId
newTransactionId = Word64 -> TransactionId
TransactionId (Word64 -> TransactionId) -> m Word64 -> m TransactionId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Word64
forall (m :: * -> *). MonadIO m => m Word64
newUnique
newtype ConnectionId = ConnectionId Word64
deriving newtype (ConnectionId -> ConnectionId -> Bool
(ConnectionId -> ConnectionId -> Bool)
-> (ConnectionId -> ConnectionId -> Bool) -> Eq ConnectionId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConnectionId -> ConnectionId -> Bool
== :: ConnectionId -> ConnectionId -> Bool
$c/= :: ConnectionId -> ConnectionId -> Bool
/= :: ConnectionId -> ConnectionId -> Bool
Eq, Eq ConnectionId
Eq ConnectionId =>
(ConnectionId -> ConnectionId -> Ordering)
-> (ConnectionId -> ConnectionId -> Bool)
-> (ConnectionId -> ConnectionId -> Bool)
-> (ConnectionId -> ConnectionId -> Bool)
-> (ConnectionId -> ConnectionId -> Bool)
-> (ConnectionId -> ConnectionId -> ConnectionId)
-> (ConnectionId -> ConnectionId -> ConnectionId)
-> Ord ConnectionId
ConnectionId -> ConnectionId -> Bool
ConnectionId -> ConnectionId -> Ordering
ConnectionId -> ConnectionId -> ConnectionId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ConnectionId -> ConnectionId -> Ordering
compare :: ConnectionId -> ConnectionId -> Ordering
$c< :: ConnectionId -> ConnectionId -> Bool
< :: ConnectionId -> ConnectionId -> Bool
$c<= :: ConnectionId -> ConnectionId -> Bool
<= :: ConnectionId -> ConnectionId -> Bool
$c> :: ConnectionId -> ConnectionId -> Bool
> :: ConnectionId -> ConnectionId -> Bool
$c>= :: ConnectionId -> ConnectionId -> Bool
>= :: ConnectionId -> ConnectionId -> Bool
$cmax :: ConnectionId -> ConnectionId -> ConnectionId
max :: ConnectionId -> ConnectionId -> ConnectionId
$cmin :: ConnectionId -> ConnectionId -> ConnectionId
min :: ConnectionId -> ConnectionId -> ConnectionId
Ord, Int -> ConnectionId -> ShowS
[ConnectionId] -> ShowS
ConnectionId -> String
(Int -> ConnectionId -> ShowS)
-> (ConnectionId -> String)
-> ([ConnectionId] -> ShowS)
-> Show ConnectionId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConnectionId -> ShowS
showsPrec :: Int -> ConnectionId -> ShowS
$cshow :: ConnectionId -> String
show :: ConnectionId -> String
$cshowList :: [ConnectionId] -> ShowS
showList :: [ConnectionId] -> ShowS
Show, ConnectionId -> ()
(ConnectionId -> ()) -> NFData ConnectionId
forall a. (a -> ()) -> NFData a
$crnf :: ConnectionId -> ()
rnf :: ConnectionId -> ()
NFData, ConnectionId -> Value
(ConnectionId -> Value) -> ToValue ConnectionId
forall a. (a -> Value) -> ToValue a
$cvalue :: ConnectionId -> Value
value :: ConnectionId -> Value
Di.ToValue)
newConnectionId :: (MonadIO m) => m ConnectionId
newConnectionId :: forall (m :: * -> *). MonadIO m => m ConnectionId
newConnectionId = Word64 -> ConnectionId
ConnectionId (Word64 -> ConnectionId) -> m Word64 -> m ConnectionId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Word64
forall (m :: * -> *). MonadIO m => m Word64
newUnique
newtype QueryId = QueryId Word64
deriving newtype (QueryId -> QueryId -> Bool
(QueryId -> QueryId -> Bool)
-> (QueryId -> QueryId -> Bool) -> Eq QueryId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QueryId -> QueryId -> Bool
== :: QueryId -> QueryId -> Bool
$c/= :: QueryId -> QueryId -> Bool
/= :: QueryId -> QueryId -> Bool
Eq, Eq QueryId
Eq QueryId =>
(QueryId -> QueryId -> Ordering)
-> (QueryId -> QueryId -> Bool)
-> (QueryId -> QueryId -> Bool)
-> (QueryId -> QueryId -> Bool)
-> (QueryId -> QueryId -> Bool)
-> (QueryId -> QueryId -> QueryId)
-> (QueryId -> QueryId -> QueryId)
-> Ord QueryId
QueryId -> QueryId -> Bool
QueryId -> QueryId -> Ordering
QueryId -> QueryId -> QueryId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: QueryId -> QueryId -> Ordering
compare :: QueryId -> QueryId -> Ordering
$c< :: QueryId -> QueryId -> Bool
< :: QueryId -> QueryId -> Bool
$c<= :: QueryId -> QueryId -> Bool
<= :: QueryId -> QueryId -> Bool
$c> :: QueryId -> QueryId -> Bool
> :: QueryId -> QueryId -> Bool
$c>= :: QueryId -> QueryId -> Bool
>= :: QueryId -> QueryId -> Bool
$cmax :: QueryId -> QueryId -> QueryId
max :: QueryId -> QueryId -> QueryId
$cmin :: QueryId -> QueryId -> QueryId
min :: QueryId -> QueryId -> QueryId
Ord, Int -> QueryId -> ShowS
[QueryId] -> ShowS
QueryId -> String
(Int -> QueryId -> ShowS)
-> (QueryId -> String) -> ([QueryId] -> ShowS) -> Show QueryId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QueryId -> ShowS
showsPrec :: Int -> QueryId -> ShowS
$cshow :: QueryId -> String
show :: QueryId -> String
$cshowList :: [QueryId] -> ShowS
showList :: [QueryId] -> ShowS
Show, QueryId -> ()
(QueryId -> ()) -> NFData QueryId
forall a. (a -> ()) -> NFData a
$crnf :: QueryId -> ()
rnf :: QueryId -> ()
NFData, QueryId -> Value
(QueryId -> Value) -> ToValue QueryId
forall a. (a -> Value) -> ToValue a
$cvalue :: QueryId -> Value
value :: QueryId -> Value
Di.ToValue)
newQueryId :: (MonadIO m) => m QueryId
newQueryId :: forall (m :: * -> *). MonadIO m => m QueryId
newQueryId = Word64 -> QueryId
QueryId (Word64 -> QueryId) -> m Word64 -> m QueryId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Word64
forall (m :: * -> *). MonadIO m => m Word64
newUnique