{-# 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
      ]

--------------------------------------------------------------------------------

-- | SQLite connection settings.
data Settings = Settings
   { Settings -> String
file :: FilePath
   -- ^ Database file path. Not an URI.
   --
   -- Note: To keep things simple, native @:memory:@ SQLite databases are not
   -- supported. Maybe use 'Sq.poolTemp' or @tmpfs@ if you need that?
   , Settings -> SQLVFS
vfs :: S.SQLVFS
   , Settings -> Word32
timeout :: Word32
   -- ^ SQLite busy Timeout in milliseconds.
   }
   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
_) = ()

-- | Default connection settings.
settings
   :: FilePath
   -- ^ Database file path. Not an URI, not @:memory:@
   -> 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 -- 2 minutes
      }

--------------------------------------------------------------------------------

-- | A 'Read' or 'Write' connection handle.
--
-- It is safe to attempt to use this connection concurrently without any
-- locking. The 'Connection' itself mantains an internal locking mechanism so
-- that transactions are always executed serially.
--
-- Note: We don't export 'Connection' directly to the public, because it's
-- easier to export just 'Sq.Pool'.
data Connection (c :: Mode) = Connection
   { forall (c :: Mode). Connection c -> ConnectionId
_id :: ConnectionId
   , forall (c :: Mode). Connection c -> Word32
timeout :: Word32
   -- ^ Same @timeout@ as in 'Settings'
   , 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))
   -- ^ 'Nothing' if the connection has vanished.
   }

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}

--------------------------------------------------------------------------------

-- | Internal. While a 'Connection' can be used concurrently, an
-- 'ExclusiveConnection' can't. If one has access to an 'ExclusiveConnection',
-- then one can assume that nobody else has access to the underlying
-- 'S.Database' connection handle at the moment.
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
         -- We reuse setBusyHandler's timeout because why not.
         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
   -- TODO:  Async.link should be sufficient. Figure out what I'm doing wrong.
   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" -- 64 MiB
            , Text
"PRAGMA mmap_size=134217728" -- 128 MiB
            , Text
"PRAGMA cache_size=2000" -- 2000 pages
            ]
      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

--------------------------------------------------------------------------------

-- | See <https://www.sqlite.org/c3ref/busy_handler.html>
foreign import ccall unsafe "sqlite3_busy_handler"
   c_sqlite3_busy_handler
      :: Ptr S.CDatabase
      -> FunPtr (Ptr a -> CInt -> IO CInt)
      -> Ptr a
      -> IO CInt

-- | Returns same as input.
foreign import ccall safe "sqlite3_sleep"
   c_sqlite3_sleep
      :: CInt
      -- ^ milliseconds.
      -> 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

--------------------------------------------------------------------------------

-- | A database transaction handle.
--
-- * @t@ indicates whether 'Read'-only or read-'Write' 'Statement's are
-- supported.
--
-- * Prefer to use a 'Read'-only 'Transaction' if you are solely performing
-- 'Read'-only 'Statement's. It will be more efficient in concurrent settings.
--
-- * Obtain with 'Sq.readTransaction' or 'Sq.commitTransaction'. Or, if you
-- are testing, with 'Sq.rollbackTransaction'.
--
-- * If you have access to a 'Transaction' within its intended scope, then you
-- can assume that a database transaction has started, and will eventually be
-- automatically commited or rolled back as requested when it was obtained.
--
-- * It's safe and efficient to use a 'Transaction' concurrently as is.
-- Concurrency is handled internally.

-- While the 'Transaction' is active, an exclusive lock is held on the
-- underlying 'Connection'.
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
   -- ^ Whether to finally @COMMIT@ the transaction.
   -- Otherwise, it will @ROLLBACK@.
   -> 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
         }

--------------------------------------------------------------------------------

-- Note: If you have access to a PreparedStatement, you can assume that
-- you are within a Transaction, and that nobody else has access to this
-- PreparedStatement at the moment.
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
   -- ^ The @SQLITE_STMTSTATUS_REPREPARE@ when @columns@ was generated.
   }

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

-- | See <https://www.sqlite.org/c3ref/stmt_status.html>
foreign import ccall unsafe "sqlite3_stmt_status"
   c_sqlite3_stmt_status
      :: Ptr S.CStatement
      -> CInt
      -- ^ op
      -> CInt
      -- ^ resetFlg
      -> IO CInt

-- | See <https://www.sqlite.org/c3ref/c_stmtstatus_counter.html>
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
   -- Despite the type name, ncols is a length.
   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
         -- Pattern never fails because `i` is in range.
         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
_ ->
               -- If `t` is not binding name as understood by
               -- `parseOutputBindingName`, we ignore it.
               -- It just won't be available for lookup later on.
               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
   = -- | A same column name appears twice or more in the raw 'SQL'.
     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
   = -- | Fewer rows than requested were available.
     ErrRows_TooFew
   | -- | More rows than requested were available.
     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)

-- | __Fold__ the output rows from a 'Statement' in a way that allows
-- interleaving 'IO' actions.
--
-- * This is simpler alternative to 'streamIO' for when all you need to do
-- is fold.
--
-- * If you don't need to interleave 'IO' actions, then consider
-- using 'Sq.fold'.

-- Note: This could be defined in terms of 'streamIO', but this implementation
-- is faster because we avoid per-row resource management.
foldIO
   :: (MonadIO m, Ex.MonadMask m, SubMode t s)
   => F.FoldM m o z
   -> A.Acquire (Transaction t)
   -- ^ How to acquire the 'Transaction' once the @m@ is executed,
   -- and how to release it when it's not needed anymore.
   --
   -- If you want this 'Statement' to be the only one in the 'Transaction',
   -- then use one of 'Sq.readTransaction', 'Sq.commitTransaction' or
   -- 'Sq.rollbackTransaction'.
   --
   -- Otherwise, if you already obtained a 'Transaction' by other means, then
   -- simply use 'pure' to wrap a 'Transaction' in 'A.Acquire'.
   -> Statement s i o
   -> i
   -> m z
foldIO :: forall (m :: * -> *) (t :: Mode) (s :: Mode) o z i.
(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)

-- | __Stream__ the output rows from a 'Statement' in a way that allows
-- interleaving 'IO' actions.
--
-- * An exclusive lock will be held on the 'Transaction' while the 'Z.Stream'
-- is producing rows.
--
-- * The 'Transaction' lock is released automatically if the 'Z.Stream' is
-- consumed until exhaustion.
--
-- * If you won't consume the 'Z.Stream' until exhaustion, then be sure to exit
-- @m@ by means of 'R.runResourceT' or similar as soon as possible in order to
-- release the 'Transaction' lock.
streamIO
   :: (R.MonadResource m, SubMode t s)
   => A.Acquire (Transaction t)
   -- ^ How to acquire the 'Transaction' once the 'Z.Stream' starts
   -- being consumed, and how to release it when it's not needed anymore.
   --
   -- If you want this 'Statement' to be the only one in the 'Transaction',
   -- then use one of 'Sq.readTransaction', 'Sq.commitTransaction or
   -- 'Sq.rollbackTransaction'.
   --
   -- Otherwise, if you already obtained a 'Transaction' by other means, then
   -- simply use 'pure' to wrap a 'Transaction' in 'A.Acquire'.
   -> Statement s i o
   -> i
   -> Z.Stream (Z.Of o) m ()
   -- ^ A 'Z.Stream' from the @streaming@ library.
   --
   -- We use the @streaming@ library because it is fast and doesn't
   -- add any transitive dependencies to this project.
streamIO :: forall (m :: * -> *) (t :: Mode) (s :: Mode) i o.
(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
         )

-- | Acquires an 'IO' action that will yield the next output row each time it
-- is called, if any. Among other 'IO' exceptions, 'ErrOutput' may be thrown.
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
   -- TODO: Could we safely prepare and bind a raw statement before
   -- lockConnection? That would be more efficient.
   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

--------------------------------------------------------------------------------

-- | See 'savepoint', 'savepointRollback' and 'savepointRelease'.
--
-- * __WARNING__ safely dealing with 'Savepoint's can be tricky. Consider using
-- 'Ex.catch' on 'Sq.Transactional', which is implemented using 'Savepoint' and
-- does the right thing.
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
'}'

-- | Obtain savepoint to which one can later 'savepointRollback' or
-- 'savepointRelease'.
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
         }

-- | Disregard all the changes that happened to the 'Transaction'
-- related to this 'Savepoint' since the time it was obtained
-- through 'savepoint'.
--
-- * Trying to 'savepointRollback' a 'Savepoint' that isn't reachable anymore
-- throws an exception.
--
-- * A 'Savepoint' stops being reachable when the relevant 'Transaction' ends,
-- or when a 'savepointRollback' to an earlier 'Savepoint' on the same
-- 'Transaction' is performed, or when it or a later 'Savepoint' is
-- explicitely released through 'savepointRelease'.
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

-- | Release a 'Savepoint' so that it, together with any previous 'Savepoint's
-- on the same 'Transaction', become unreachable to future uses of
-- 'savepointRollback' or 'savepointRelease'.
--
-- * Trying to 'savepointRelease' a 'Savepoint' that isn't reachable anymore
-- throws an exception.
--
-- * A 'Savepoint' stops being reachable when the relevant 'Transaction' ends,
-- or when a 'savepointRollback' to an earlier 'Savepoint' on the same
-- 'Transaction' is performed, or when it or a later 'Savepoint' is
-- explicitely released through 'savepointRelease'.
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