{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Low-level SQLite primitives that turn every SQLite error into a
-- 'LeiosDbException'.
module Ouroboros.Consensus.Storage.LeiosDB.Impl.SQLite.Primitives
  ( useStmt
  , dbBindBlob
  , dbBindUtf8
  , dbBindInt64
  , dbExec
  , dbFinalize
  , dbPrepare
  , withStmt
  , orCloseOnError
  , dbWithTransaction
  , dbWithWriteTransactionRaw
  , dbWithTransactionAs
  , dbStep
  , dbStep1
  , dbStepSafe
  , dbStep1Safe
  , readSingleInt64
  , readReturningInt64
  , queryInt64
  , collectBlobs
  , execJson
  , dbStepInsert
  , dbStepInsertOrTrace
  , jsonHexArray
  , jsonIntArray
  , withDie
  , withDieStmt
  , withDieJust
  , withDieDoneStmt
  , throwDbException
  ) where

import Control.Exception (SomeException, throwIO)
import Control.Monad (unless, void)
import Control.Monad.Class.MonadThrow (bracket, catch, finally, generalBracket)
import Control.Tracer (Tracer, traceWith)
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BSL
import Data.Int (Int64)
import Data.String (fromString)
import qualified Database.SQLite3.Direct as DB
import GHC.Stack (HasCallStack)
import qualified GHC.Stack
import Ouroboros.Consensus.Storage.LeiosDB.Exception
  ( LeiosDbException (..)
  , LeiosDbFailure (..)
  , throwLeiosDbException
  )
import Ouroboros.Consensus.Storage.LeiosDB.Trace (TraceLeiosDb (..))
import Ouroboros.Consensus.Util.IOLike (ExitCase (..))

-- | Run an action on a pre-prepared statement and always @sqlite3_reset@
-- it afterwards, regardless of outcome. Reset uses raw 'DB.reset' (no
-- error re-throw) because SQLite reports the /previous/ step's error via
-- reset; we let the original exception propagate instead.
useStmt :: DB.Statement -> IO a -> IO a
useStmt :: forall a. Statement -> IO a -> IO a
useStmt Statement
stmt IO a
action =
  IO a
action IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` (IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> IO (Either Error ())
DB.reset Statement
stmt)

dbBindBlob :: HasCallStack => DB.Statement -> DB.ParamIndex -> ByteString -> IO ()
dbBindBlob :: HasCallStack => Statement -> ParamIndex -> ByteString -> IO ()
dbBindBlob Statement
q ParamIndex
p ByteString
v = Statement -> IO (Either Error ()) -> IO ()
forall a. HasCallStack => Statement -> IO (Either Error a) -> IO a
withDieStmt Statement
q (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> ParamIndex -> ByteString -> IO (Either Error ())
DB.bindBlob Statement
q ParamIndex
p ByteString
v

-- | Bind as TEXT. Needed for JSON1 payloads: 'json_each' interprets BLOB
-- arguments as JSONB (SQLite ≥ 3.45), our payload is ASCII JSON.
dbBindUtf8 :: HasCallStack => DB.Statement -> DB.ParamIndex -> ByteString -> IO ()
dbBindUtf8 :: HasCallStack => Statement -> ParamIndex -> ByteString -> IO ()
dbBindUtf8 Statement
q ParamIndex
p ByteString
v = Statement -> IO (Either Error ()) -> IO ()
forall a. HasCallStack => Statement -> IO (Either Error a) -> IO a
withDieStmt Statement
q (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> ParamIndex -> Utf8 -> IO (Either Error ())
DB.bindText Statement
q ParamIndex
p (ByteString -> Utf8
DB.Utf8 ByteString
v)

dbBindInt64 :: HasCallStack => DB.Statement -> DB.ParamIndex -> Int64 -> IO ()
dbBindInt64 :: HasCallStack => Statement -> ParamIndex -> Int64 -> IO ()
dbBindInt64 Statement
q ParamIndex
p Int64
v = Statement -> IO (Either Error ()) -> IO ()
forall a. HasCallStack => Statement -> IO (Either Error a) -> IO a
withDieStmt Statement
q (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> ParamIndex -> Int64 -> IO (Either Error ())
DB.bindInt64 Statement
q ParamIndex
p Int64
v

dbExec :: HasCallStack => DB.Database -> DB.Utf8 -> IO ()
dbExec :: HasCallStack => Database -> Utf8 -> IO ()
dbExec Database
db Utf8
q = Database -> IO (Either Error ()) -> IO ()
forall a. HasCallStack => Database -> IO (Either Error a) -> IO a
withDie Database
db (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Either (Error, Utf8) () -> Either Error ())
-> IO (Either (Error, Utf8) ()) -> IO (Either Error ())
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Error, Utf8) -> Error)
-> Either (Error, Utf8) () -> Either Error ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Error, Utf8) -> Error
forall a b. (a, b) -> a
fst) (IO (Either (Error, Utf8) ()) -> IO (Either Error ()))
-> IO (Either (Error, Utf8) ()) -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ Database -> Utf8 -> IO (Either (Error, Utf8) ())
DB.exec Database
db Utf8
q

-- | Finalize a statement, exactly once, ignoring the return code.
--
-- @sqlite3_finalize@ always frees the statement; its return code merely
-- replays the most recent evaluation's error (sticky, like 'DB.reset' -- see
-- 'useStmt'). Neither retrying nor throwing is ever right here: a busy-retry
-- would call @sqlite3_finalize@ on freed memory (the use-after-free behind
-- the devnet segfaults of 2026-08-31), and a throw would propagate from
-- bracket cleanup.
dbFinalize :: DB.Statement -> IO ()
dbFinalize :: Statement -> IO ()
dbFinalize Statement
q = IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> IO (Either Error ())
DB.finalize Statement
q

dbPrepare :: HasCallStack => DB.Database -> DB.Utf8 -> IO DB.Statement
dbPrepare :: HasCallStack => Database -> Utf8 -> IO Statement
dbPrepare Database
db Utf8
q = Database -> IO (Either Error (Maybe Statement)) -> IO Statement
forall a.
HasCallStack =>
Database -> IO (Either Error (Maybe a)) -> IO a
withDieJust Database
db (IO (Either Error (Maybe Statement)) -> IO Statement)
-> IO (Either Error (Maybe Statement)) -> IO Statement
forall a b. (a -> b) -> a -> b
$ Database -> Utf8 -> IO (Either Error (Maybe Statement))
DB.prepare Database
db Utf8
q

-- | Prepare a statement, run the action, finalize.
withStmt :: HasCallStack => DB.Database -> String -> (DB.Statement -> IO a) -> IO a
withStmt :: forall a.
HasCallStack =>
Database -> String -> (Statement -> IO a) -> IO a
withStmt Database
db String
sql = IO Statement -> (Statement -> IO ()) -> (Statement -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (HasCallStack => Database -> Utf8 -> IO Statement
Database -> Utf8 -> IO Statement
dbPrepare Database
db (String -> Utf8
forall a. IsString a => String -> a
fromString String
sql)) Statement -> IO ()
dbFinalize

-- | Close the connection if the action throws, then rethrow. For whatever
-- is acquired on a fresh connection -- an attach, a schema, a statement --
-- after the open succeeded and before anything owns the close.
orCloseOnError :: DB.Database -> IO a -> IO a
orCloseOnError :: forall a. Database -> IO a -> IO a
orCloseOnError Database
db IO a
act =
  IO a
act IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
e :: SomeException) -> do
    _ <- Database -> IO (Either Error ())
DB.close Database
db
    throwIO e

-- TODO: alternative: bind and use https://www.sqlite.org/c3ref/busy_handler.html

-- | A read-only transaction: @BEGIN DEFERRED@, so readers do not exclude each
-- other. Any transaction that writes must use @dbWithWriteTransaction@.
dbWithTransaction :: HasCallStack => DB.Database -> IO a -> IO a
dbWithTransaction :: forall a. HasCallStack => Database -> IO a -> IO a
dbWithTransaction = String -> Database -> IO a -> IO a
forall a. HasCallStack => String -> Database -> IO a -> IO a
dbWithTransactionAs String
"BEGIN"

-- | @dbWithWriteTransaction@ for the maintenance paths (promotion to immutable, GC), which hold
-- a raw 'DB.Database' rather than a 'Conn'.
dbWithWriteTransactionRaw :: HasCallStack => DB.Database -> IO a -> IO a
dbWithWriteTransactionRaw :: forall a. HasCallStack => Database -> IO a -> IO a
dbWithWriteTransactionRaw = String -> Database -> IO a -> IO a
forall a. HasCallStack => String -> Database -> IO a -> IO a
dbWithTransactionAs String
"BEGIN IMMEDIATE"

dbWithTransactionAs :: HasCallStack => String -> DB.Database -> IO a -> IO a
dbWithTransactionAs :: forall a. HasCallStack => String -> Database -> IO a -> IO a
dbWithTransactionAs String
begin Database
db IO a
k =
  do
    ((a, ()) -> a) -> IO (a, ()) -> IO a
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, ()) -> a
forall a b. (a, b) -> a
fst
    (IO (a, ()) -> IO a) -> IO (a, ()) -> IO a
forall a b. (a -> b) -> a -> b
$ IO () -> (() -> ExitCase a -> IO ()) -> (() -> IO a) -> IO (a, ())
forall a b c.
IO a -> (a -> ExitCase b -> IO c) -> (a -> IO b) -> IO (b, c)
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
      (HasCallStack => Database -> Utf8 -> IO ()
Database -> Utf8 -> IO ()
dbExec Database
db (String -> Utf8
forall a. IsString a => String -> a
fromString String
begin))
      ( \() -> \case
          ExitCaseSuccess a
_ -> HasCallStack => Database -> Utf8 -> IO ()
Database -> Utf8 -> IO ()
dbExec Database
db (String -> Utf8
forall a. IsString a => String -> a
fromString String
"COMMIT")
          ExitCaseException SomeException
_ -> HasCallStack => Database -> Utf8 -> IO ()
Database -> Utf8 -> IO ()
dbExec Database
db (String -> Utf8
forall a. IsString a => String -> a
fromString String
"ROLLBACK")
          ExitCase a
ExitCaseAbort -> HasCallStack => Database -> Utf8 -> IO ()
Database -> Utf8 -> IO ()
dbExec Database
db (String -> Utf8
forall a. IsString a => String -> a
fromString String
"ROLLBACK")
      )
      (\() -> IO a
k)

dbStep :: HasCallStack => DB.Statement -> IO DB.StepResult
dbStep :: HasCallStack => Statement -> IO StepResult
dbStep Statement
stmt = Statement -> IO (Either Error StepResult) -> IO StepResult
forall a. HasCallStack => Statement -> IO (Either Error a) -> IO a
withDieStmt Statement
stmt (IO (Either Error StepResult) -> IO StepResult)
-> IO (Either Error StepResult) -> IO StepResult
forall a b. (a -> b) -> a -> b
$ Statement -> IO (Either Error StepResult)
DB.stepNoCB Statement
stmt

dbStep1 :: HasCallStack => DB.Statement -> IO ()
dbStep1 :: HasCallStack => Statement -> IO ()
dbStep1 Statement
stmt = HasCallStack => Statement -> IO (Either Error StepResult) -> IO ()
Statement -> IO (Either Error StepResult) -> IO ()
withDieDoneStmt Statement
stmt (IO (Either Error StepResult) -> IO ())
-> IO (Either Error StepResult) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> IO (Either Error StepResult)
DB.stepNoCB Statement
stmt

-- | 'dbStep' through the safe FFI call ('DB.step' rather than
-- 'DB.stepNoCB'): a safe call does not block its RTS capability, so the
-- potentially long-running maintenance statements (copy, GC) must use it.
dbStepSafe :: HasCallStack => DB.Statement -> IO DB.StepResult
dbStepSafe :: HasCallStack => Statement -> IO StepResult
dbStepSafe Statement
stmt = Statement -> IO (Either Error StepResult) -> IO StepResult
forall a. HasCallStack => Statement -> IO (Either Error a) -> IO a
withDieStmt Statement
stmt (IO (Either Error StepResult) -> IO StepResult)
-> IO (Either Error StepResult) -> IO StepResult
forall a b. (a -> b) -> a -> b
$ Statement -> IO (Either Error StepResult)
DB.step Statement
stmt

-- | 'dbStep1' through the safe FFI call; see 'dbStepSafe'.
dbStep1Safe :: HasCallStack => DB.Statement -> IO ()
dbStep1Safe :: HasCallStack => Statement -> IO ()
dbStep1Safe Statement
stmt = HasCallStack => Statement -> IO (Either Error StepResult) -> IO ()
Statement -> IO (Either Error StepResult) -> IO ()
withDieDoneStmt Statement
stmt (IO (Either Error StepResult) -> IO ())
-> IO (Either Error StepResult) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> IO (Either Error StepResult)
DB.step Statement
stmt

-- | Read a single-row, single-column integer result, stepping (safe FFI)
-- through to completion -- which also suits @RETURNING@ statements, whose
-- write only certainly happened once they report 'DB.Done'.
readSingleInt64 :: HasCallStack => DB.Statement -> IO Int64
readSingleInt64 :: HasCallStack => Statement -> IO Int64
readSingleInt64 Statement
stmt =
  HasCallStack => Statement -> IO StepResult
Statement -> IO StepResult
dbStepSafe Statement
stmt IO StepResult -> (StepResult -> IO Int64) -> IO Int64
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
DB.Done -> String -> IO Int64
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
throwLeiosDbException String
"readSingleInt64: expected a row"
    StepResult
DB.Row -> do
      n <- Statement -> ColumnIndex -> IO Int64
DB.columnInt64 Statement
stmt ColumnIndex
0
      dbStepSafe stmt >>= \case
        StepResult
DB.Done -> Int64 -> IO Int64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
n
        StepResult
DB.Row -> String -> IO Int64
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
throwLeiosDbException String
"readSingleInt64: expected exactly one row"

-- | Read a single-column @Int64@ from a statement that uses a
-- @RETURNING@ clause on a PK-scoped @UPDATE@ (i.e. produces exactly one
-- row followed by 'DB.Done'). Any other shape is a programmer error.
readReturningInt64 :: DB.Statement -> IO Int64
readReturningInt64 :: Statement -> IO Int64
readReturningInt64 Statement
stmt =
  HasCallStack => Statement -> IO StepResult
Statement -> IO StepResult
dbStep Statement
stmt IO StepResult -> (StepResult -> IO Int64) -> IO Int64
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
DB.Done ->
      String -> IO Int64
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
throwLeiosDbException String
"readReturningInt64: expected one row from RETURNING, got Done"
    StepResult
DB.Row -> do
      n <- Statement -> ColumnIndex -> IO Int64
DB.columnInt64 Statement
stmt ColumnIndex
0
      dbStep stmt >>= \case
        StepResult
DB.Done -> Int64 -> IO Int64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
n
        StepResult
DB.Row -> String -> IO Int64
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
throwLeiosDbException String
"readReturningInt64: expected exactly one row from RETURNING"

-- | Run a query that yields exactly one integer column.
queryInt64 :: HasCallStack => DB.Database -> String -> IO Int64
queryInt64 :: HasCallStack => Database -> String -> IO Int64
queryInt64 Database
db String
sql =
  IO Statement
-> (Statement -> IO ()) -> (Statement -> IO Int64) -> IO Int64
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (HasCallStack => Database -> Utf8 -> IO Statement
Database -> Utf8 -> IO Statement
dbPrepare Database
db (String -> Utf8
forall a. IsString a => String -> a
fromString String
sql)) Statement -> IO ()
dbFinalize ((Statement -> IO Int64) -> IO Int64)
-> (Statement -> IO Int64) -> IO Int64
forall a b. (a -> b) -> a -> b
$ \Statement
stmt ->
    HasCallStack => Statement -> IO StepResult
Statement -> IO StepResult
dbStep Statement
stmt IO StepResult -> (StepResult -> IO Int64) -> IO Int64
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
DB.Row -> Statement -> ColumnIndex -> IO Int64
DB.columnInt64 Statement
stmt ColumnIndex
0
      StepResult
DB.Done -> String -> IO Int64
forall a. HasCallStack => String -> a
error (String
"queryInt64: expected a row: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
sql)

-- | Step a statement (safe FFI) to completion, collecting blob column 0.
collectBlobs :: HasCallStack => DB.Statement -> IO [ByteString]
collectBlobs :: HasCallStack => Statement -> IO [ByteString]
collectBlobs Statement
stmt = [ByteString] -> IO [ByteString]
loop []
 where
  loop :: [ByteString] -> IO [ByteString]
loop [ByteString]
acc =
    HasCallStack => Statement -> IO StepResult
Statement -> IO StepResult
dbStepSafe Statement
stmt IO StepResult -> (StepResult -> IO [ByteString]) -> IO [ByteString]
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
DB.Done -> [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
acc)
      StepResult
DB.Row -> do
        b <- Statement -> ColumnIndex -> IO ByteString
DB.columnBlob Statement
stmt ColumnIndex
0
        loop (b : acc)

-- | Bind a JSON payload ('jsonHexArray') to parameter 1 and execute the statement
--   via non-blocking Safe FFI.
execJson :: HasCallStack => DB.Statement -> ByteString -> IO ()
execJson :: HasCallStack => Statement -> ByteString -> IO ()
execJson Statement
stmt ByteString
json =
  Statement -> IO () -> IO ()
forall a. Statement -> IO a -> IO a
useStmt Statement
stmt (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    HasCallStack => Statement -> ParamIndex -> ByteString -> IO ()
Statement -> ParamIndex -> ByteString -> IO ()
dbBindUtf8 Statement
stmt ParamIndex
1 ByteString
json
    HasCallStack => Statement -> IO ()
Statement -> IO ()
dbStep1Safe Statement
stmt

-- | Like 'dbStep1' but returns 'True' on success and 'False' on constraint
-- violation (duplicate key). Other errors are thrown as usual.
dbStepInsert :: HasCallStack => DB.Statement -> IO Bool
dbStepInsert :: HasCallStack => Statement -> IO Bool
dbStepInsert Statement
stmt =
  Statement -> IO (Either Error StepResult)
DB.stepNoCB Statement
stmt IO (Either Error StepResult)
-> (Either Error StepResult -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Error
DB.ErrorConstraint -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Left Error
e -> Statement -> IO Database
DB.getStatementDatabase Statement
stmt IO Database -> (Database -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Database
db -> Database -> Error -> IO Bool
forall a. HasCallStack => Database -> Error -> IO a
throwDbException Database
db Error
e
    Right StepResult
DB.Done -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Right StepResult
DB.Row -> String -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
throwLeiosDbException String
"dbStepInsert: unexpected Row result"

-- | Step an INSERT statement, absorbing UNIQUE/PRIMARY KEY violations and
-- emitting a 'TraceLeiosDbInsertCollision' for each one. The caller supplies a
-- table label and a key description for the trace.
--
-- After a constraint error, sqlite3_reset reports the same error code; the
-- normal 'dbReset' would re-throw it, so we use raw 'DB.reset' and discard the
-- return value. This also leaves the statement in a clean state for the
-- subsequent bracket-time 'dbFinalize' to succeed.
dbStepInsertOrTrace ::
  HasCallStack =>
  Tracer IO TraceLeiosDb ->
  String ->
  String ->
  DB.Statement ->
  IO ()
dbStepInsertOrTrace :: HasCallStack =>
Tracer IO TraceLeiosDb -> String -> String -> Statement -> IO ()
dbStepInsertOrTrace Tracer IO TraceLeiosDb
tracer String
table String
key Statement
stmt = do
  novel <- HasCallStack => Statement -> IO Bool
Statement -> IO Bool
dbStepInsert Statement
stmt
  _ <- DB.reset stmt
  unless novel $
    traceWith tracer (TraceLeiosDbInsertCollision table key)

-- ** JSON payloads

-- | Build a JSON array of hex-encoded blobs: @["aabb...","1234...",...]@.
-- Consumed on the SQL side via @json_each(?)@ + @unhex(je.value)@.
jsonHexArray :: [ByteString] -> ByteString
jsonHexArray :: [ByteString] -> ByteString
jsonHexArray [ByteString]
xs =
  LazyByteString -> ByteString
BSL.toStrict (LazyByteString -> ByteString)
-> (Builder -> LazyByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
    Char -> Builder
BB.char7 Char
'[' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
commaSep ((ByteString -> Builder) -> [ByteString] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Builder
hexElem [ByteString]
xs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BB.char7 Char
']'
 where
  hexElem :: ByteString -> Builder
hexElem ByteString
b = Char -> Builder
BB.char7 Char
'"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BB.byteStringHex ByteString
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BB.char7 Char
'"'
  commaSep :: [Builder] -> Builder
commaSep = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Builder] -> [Builder]) -> [Builder] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperseB (Char -> Builder
BB.char7 Char
',')
  intersperseB :: t -> [t] -> [t]
intersperseB t
_ [] = []
  intersperseB t
_ [t
x] = [t
x]
  intersperseB t
s (t
x : [t]
rest) = t
x t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t
s t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [t] -> [t]
intersperseB t
s [t]
rest

-- | Build a JSON array of integers: @[1,2,3,...]@. Same consumer pattern
-- as 'jsonHexArray' (values are already ints, so no decoding step).
jsonIntArray :: [Int] -> ByteString
jsonIntArray :: [Int] -> ByteString
jsonIntArray [Int]
xs =
  LazyByteString -> ByteString
BSL.toStrict (LazyByteString -> ByteString)
-> (Builder -> LazyByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
    Char -> Builder
BB.char7 Char
'[' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
commaSep ((Int -> Builder) -> [Int] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Builder
BB.intDec [Int]
xs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BB.char7 Char
']'
 where
  commaSep :: [Builder] -> Builder
commaSep = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Builder] -> [Builder]) -> [Builder] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperseB (Char -> Builder
BB.char7 Char
',')
  intersperseB :: t -> [t] -> [t]
intersperseB t
_ [] = []
  intersperseB t
_ [t
x] = [t
x]
  intersperseB t
s (t
x : [t]
rest) = t
x t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t
s t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [t] -> [t]
intersperseB t
s [t]
rest

-- ** Error "handling"

-- | Run a database action that may return an error, and throw a
-- 'LeiosDbException' if it does.
--
-- Including 'DB.ErrorBusy': the connections set a 'busy_timeout', so SQLite
-- has already waited that long in C before reporting it. Waiting again on
-- top of that only converts a lock nobody is going to release into an
-- unbounded stall -- and with one writer per partition, a lock nobody is
-- going to release means another process has the file.
withDie :: HasCallStack => DB.Database -> IO (Either DB.Error a) -> IO a
withDie :: forall a. HasCallStack => Database -> IO (Either Error a) -> IO a
withDie Database
db IO (Either Error a)
io =
  IO (Either Error a)
io IO (Either Error a) -> (Either Error a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Error
e -> Database -> Error -> IO a
forall a. HasCallStack => Database -> Error -> IO a
throwDbException Database
db Error
e
    Right a
x -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

withDieStmt :: HasCallStack => DB.Statement -> IO (Either DB.Error a) -> IO a
withDieStmt :: forall a. HasCallStack => Statement -> IO (Either Error a) -> IO a
withDieStmt Statement
stmt IO (Either Error a)
io = do
  db <- Statement -> IO Database
DB.getStatementDatabase Statement
stmt
  withDie db io

withDieJust :: HasCallStack => DB.Database -> IO (Either DB.Error (Maybe a)) -> IO a
withDieJust :: forall a.
HasCallStack =>
Database -> IO (Either Error (Maybe a)) -> IO a
withDieJust Database
db IO (Either Error (Maybe a))
io =
  Database -> IO (Either Error (Maybe a)) -> IO (Maybe a)
forall a. HasCallStack => Database -> IO (Either Error a) -> IO a
withDie Database
db IO (Either Error (Maybe a))
io IO (Maybe a) -> (Maybe a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe a
Nothing ->
      LeiosDbException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (LeiosDbException -> IO a) -> LeiosDbException -> IO a
forall a b. (a -> b) -> a -> b
$
        LeiosDbFailure -> LeiosDbException
LeiosDbException
          LeiosDbFailure
            { ldfErrorMessage :: String
ldfErrorMessage = String
"unexpected Nothing"
            , ldfCallStack :: String
ldfCallStack = CallStack -> String
GHC.Stack.prettyCallStack CallStack
HasCallStack => CallStack
GHC.Stack.callStack
            }
    Just a
x -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

withDieDoneStmt :: HasCallStack => DB.Statement -> IO (Either DB.Error DB.StepResult) -> IO ()
withDieDoneStmt :: HasCallStack => Statement -> IO (Either Error StepResult) -> IO ()
withDieDoneStmt Statement
stmt IO (Either Error StepResult)
io = do
  db <- Statement -> IO Database
DB.getStatementDatabase Statement
stmt
  withDie db io >>= \case
    StepResult
DB.Row ->
      LeiosDbException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (LeiosDbException -> IO ()) -> LeiosDbException -> IO ()
forall a b. (a -> b) -> a -> b
$
        LeiosDbFailure -> LeiosDbException
LeiosDbException
          LeiosDbFailure
            { ldfErrorMessage :: String
ldfErrorMessage = String
"unexpected Row"
            , ldfCallStack :: String
ldfCallStack = CallStack -> String
GHC.Stack.prettyCallStack CallStack
HasCallStack => CallStack
GHC.Stack.callStack
            }
    StepResult
DB.Done -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

throwDbException :: HasCallStack => DB.Database -> DB.Error -> IO a
throwDbException :: forall a. HasCallStack => Database -> Error -> IO a
throwDbException Database
db Error
e = do
  reason <- Database -> IO Utf8
DB.errmsg Database
db
  throwIO $
    LeiosDbException
      LeiosDbFailure
        { ldfErrorMessage = show e <> ": " <> show reason
        , ldfCallStack = GHC.Stack.prettyCallStack GHC.Stack.callStack
        }