{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Opening, configuring and closing connections to the LeiosDB partition
-- files, and 'Conn': a reader's (or the writer's) pair of connections with
-- their prepared statements.
module Ouroboros.Consensus.Storage.LeiosDB.Impl.SQLite.Connection
  ( -- * Partition files
    initialiseLeiosDbFiles
  , openRawConnection
  , withReadOnlyConn
  , closeChecked

    -- * Connections with prepared statements
  , Conn (..)
  , mkConn
  , finalizeConnStmts
  , closeConn
  , dbWithWriteTransaction
  ) where

import Control.Concurrent.Class.MonadSTM.Strict (StrictTVar)
import Control.Exception (throwIO)
import Control.Monad (void)
import Control.Monad.Class.MonadThrow (bracket, onException)
import Control.Tracer (Tracer)
import Data.Foldable (traverse_)
import Data.String (fromString)
import Database.SQLite3
  ( SQLOpenFlag (..)
  , SQLVFS (..)
  , open2
  )
import qualified Database.SQLite3.Direct as DB
import GHC.Stack (HasCallStack)
import qualified GHC.Stack
import Ouroboros.Consensus.Storage.LeiosDB.Exception
  ( LeiosDbException (..)
  , LeiosDbFailure (..)
  )
import Ouroboros.Consensus.Storage.LeiosDB.Impl.SQLite.Primitives
import Ouroboros.Consensus.Storage.LeiosDB.Impl.SQLite.Schema
import Ouroboros.Consensus.Storage.LeiosDB.Impl.SQLite.Statements
import Ouroboros.Consensus.Storage.LeiosDB.Trace (LeiosDbStats (..), TraceLeiosDb (..))

-- | Open a strictly read-only connection, for seeding DB statistics.
withReadOnlyConn :: HasCallStack => FilePath -> (DB.Database -> IO a) -> IO a
withReadOnlyConn :: forall a. HasCallStack => FilePath -> (Database -> IO a) -> IO a
withReadOnlyConn FilePath
dbPath =
  IO Database -> (Database -> IO ()) -> (Database -> 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 => FilePath -> IO Database
FilePath -> IO Database
openReadOnlyRawConnection FilePath
dbPath) (IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ())
-> (Database -> IO (Either Error ())) -> Database -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Database -> IO (Either Error ())
DB.close)

-- | Open an existing file read-only: no create, no DDL.
openReadOnlyRawConnection :: HasCallStack => FilePath -> IO DB.Database
openReadOnlyRawConnection :: HasCallStack => FilePath -> IO Database
openReadOnlyRawConnection FilePath
dbPath = do
  db <- Text -> [SQLOpenFlag] -> SQLVFS -> IO Database
open2 (FilePath -> Text
forall a. IsString a => FilePath -> a
fromString FilePath
dbPath) [SQLOpenFlag
SQLOpenReadOnly] SQLVFS
SQLVFSDefault
  -- Only mmap_size: journal_mode and page_size need write access.
  dbExec db "pragma mmap_size = 268435500;"
  pure db

-- | Create the volatile and immutable LeiosDB partition files
--   if missing and apply their schemas.
initialiseLeiosDbFiles :: HasCallStack => FilePath -> FilePath -> IO ()
initialiseLeiosDbFiles :: HasCallStack => FilePath -> FilePath -> IO ()
initialiseLeiosDbFiles FilePath
volPath FilePath
immPath = do
  FilePath -> FilePath -> IO ()
initialiseFile FilePath
volPath FilePath
sql_schema_vol
  FilePath -> FilePath -> IO ()
initialiseFile FilePath
immPath FilePath
sql_schema_imm
 where
  initialiseFile :: FilePath -> FilePath -> IO ()
initialiseFile FilePath
path FilePath
ddl =
    IO Database -> (Database -> IO ()) -> (Database -> IO ()) -> IO ()
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
      (Text -> [SQLOpenFlag] -> SQLVFS -> IO Database
open2 (FilePath -> Text
forall a. IsString a => FilePath -> a
fromString FilePath
path) [SQLOpenFlag
SQLOpenReadWrite, SQLOpenFlag
SQLOpenCreate] SQLVFS
SQLVFSDefault)
      (IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ())
-> (Database -> IO (Either Error ())) -> Database -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Database -> IO (Either Error ())
DB.close)
      ((Database -> IO ()) -> IO ()) -> (Database -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Database
db -> do
        (Utf8 -> IO ()) -> [Utf8] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (HasCallStack => Database -> Utf8 -> IO ()
Database -> Utf8 -> IO ()
dbExec Database
db) ([Utf8]
connectionPragmas [Utf8] -> [Utf8] -> [Utf8]
forall a. Semigroup a => a -> a -> a
<> [Utf8]
creationPragmas)
        Database -> IO () -> IO ()
forall a. HasCallStack => Database -> IO a -> IO a
dbWithWriteTransactionRaw Database
db (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Database -> Utf8 -> IO ()
Database -> Utf8 -> IO ()
dbExec Database
db (FilePath -> Utf8
forall a. IsString a => FilePath -> a
fromString FilePath
ddl)

-- | Open a read-write connection to an existing partition file, whose schema
-- 'initialiseLeiosDbFiles' has already applied.
openRawConnection :: HasCallStack => FilePath -> IO DB.Database
openRawConnection :: HasCallStack => FilePath -> IO Database
openRawConnection FilePath
path = do
  db <- Text -> [SQLOpenFlag] -> SQLVFS -> IO Database
open2 (FilePath -> Text
forall a. IsString a => FilePath -> a
fromString FilePath
path) [SQLOpenFlag
SQLOpenReadWrite] SQLVFS
SQLVFSDefault
  orCloseOnError db $ traverse_ (dbExec db) connectionPragmas
  pure db

-- | Pragmas every connection sets.
connectionPragmas :: [DB.Utf8]
connectionPragmas :: [Utf8]
connectionPragmas =
  [ -- First, before any pragma that takes a lock -- 'journal_mode' does. Until
    -- this runs the timeout is zero, so a contended lock is refused outright
    -- rather than waited for, and opening a second connection to a busy
    -- database fails where it should merely be slow.
    --
    -- Let SQLite do that waiting in C, retrying tightly rather than sleeping
    -- through the window it is waiting for. Safe because writers take the lock
    -- at BEGIN, so nothing waits here holding a snapshot; see
    -- 'dbWithWriteTransaction'.
    Utf8
"pragma busy_timeout = 1000;"
  , Utf8
"pragma synchronous = normal;"
  , Utf8
"pragma mmap_size = 268435500;"
  , -- SQLite's own default, spelled out because it is what keeps the log
    -- bounded: passive checkpoints reset the WAL every 1000 frames, provided
    -- no connection is sitting on a stale read snapshot. One that is will
    -- freeze back-fill indefinitely; see 'dbWithWriteTransaction'.
    Utf8
"pragma wal_autocheckpoint = 1000;"
  ]

-- | Persistent pragmas, set once by 'initialiseLeiosDbFiles' after
-- 'connectionPragmas'.
creationPragmas :: [DB.Utf8]
creationPragmas :: [Utf8]
creationPragmas =
  [ -- Must precede 'journal_mode': SQLite cannot change the page size of a
    -- database already in WAL mode, so the order this list used to have left
    -- the setting a silent no-op and every run so far on the 4096 default.
    -- Which is where it belongs anyway. Measured: a devnet run with 32768
    -- actually in effect reached 35x WAL amplification (34 GiB of log for 0.97
    -- GiB of data) against ~18x for the same workload at 4096. The WAL is a
    -- page-level redo log, so a commit rewrites each dirtied page whole, and
    -- both hot indexes are keyed by hash, so writes scatter -- the page count
    -- barely falls as the page grows, the bytes just multiply.
    Utf8
"pragma page_size = 4096;"
  , Utf8
"pragma journal_mode = WAL;"
  ]

data Conn = Conn
  { Conn -> Database
conVolDb :: !DB.Database
  -- ^ The connection to the volatile partition.
  , Conn -> VolStmts
connVolStmts :: !VolStmts
  -- ^ Precompiled statements used with the volatile partition.
  , Conn -> Tracer IO TraceLeiosDb
connTracer :: !(Tracer IO TraceLeiosDb)
  -- ^ So the write path can report exhausting SQLite's own busy timeout.
  , Conn -> StrictTVar IO LeiosDbStats
connStats :: !(StrictTVar IO LeiosDbStats)
  -- ^ Usage stats for this connection.
  , Conn -> Database
conImmDb :: !DB.Database
  -- ^ The connection to the immutable partition.
  , Conn -> ImmStmts
connImmStmts :: !ImmStmts
  -- ^ Precompiled statements used with the immutable partition.
  }

-- | Build a 'Conn' over two open partition connections, preparing every
-- statement; 'closeConn' undoes it. If preparing the immutable statements
-- throws, the volatile ones are finalized first.
mkConn ::
  Tracer IO TraceLeiosDb ->
  StrictTVar IO LeiosDbStats ->
  DB.Database ->
  DB.Database ->
  IO Conn
mkConn :: Tracer IO TraceLeiosDb
-> StrictTVar IO LeiosDbStats -> Database -> Database -> IO Conn
mkConn Tracer IO TraceLeiosDb
tracer StrictTVar IO LeiosDbStats
statsVar Database
volDb Database
immDb = do
  stmts <- Database -> IO VolStmts
prepareVolStmts Database
volDb
  immStmts <- prepareImmStmts immDb `onException` finalizeVolStmts stmts
  pure
    Conn
      { conVolDb = volDb
      , connVolStmts = stmts
      , connTracer = tracer
      , connStats = statsVar
      , conImmDb = immDb
      , connImmStmts = immStmts
      }

-- | Finalize the statements of a 'Conn', leaving its connections open, for a
-- caller that closes those itself.
finalizeConnStmts :: Conn -> IO ()
finalizeConnStmts :: Conn -> IO ()
finalizeConnStmts Conn
conn = do
  ImmStmts -> IO ()
finalizeImmStmts (Conn -> ImmStmts
connImmStmts Conn
conn)
  VolStmts -> IO ()
finalizeVolStmts (Conn -> VolStmts
connVolStmts Conn
conn)

-- | Finalize the statements of a 'Conn', then close both its connections.
closeConn :: Conn -> IO ()
closeConn :: Conn -> IO ()
closeConn Conn
conn = do
  Conn -> IO ()
finalizeConnStmts Conn
conn
  HasCallStack => Database -> IO ()
Database -> IO ()
closeChecked (Conn -> Database
conImmDb Conn
conn)
  HasCallStack => Database -> IO ()
Database -> IO ()
closeChecked (Conn -> Database
conVolDb Conn
conn)

-- | @sqlite3_close@ refuses -- and would silently leak the connection -- if
-- statements are still open; a caller that failed to finalize must hear it.
closeChecked :: HasCallStack => DB.Database -> IO ()
closeChecked :: HasCallStack => Database -> IO ()
closeChecked Database
db =
  Database -> IO (Either Error ())
DB.close Database
db IO (Either Error ()) -> (Either Error () -> 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
>>= \case
    Left Error
err ->
      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 :: FilePath
ldfErrorMessage = FilePath
"failed to close the connection: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Error -> FilePath
forall a. Show a => a -> FilePath
show Error
err
            , ldfCallStack :: FilePath
ldfCallStack = CallStack -> FilePath
GHC.Stack.prettyCallStack CallStack
HasCallStack => CallStack
GHC.Stack.callStack
            }
    Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | A writing transaction: @BEGIN IMMEDIATE@, taking the write lock up front.
--
-- A deferred transaction that reads before it writes has to upgrade its lock,
-- and in WAL mode that upgrade fails with @SQLITE_BUSY_SNAPSHOT@ whenever
-- another connection committed in between. That status is not serviced by the
-- busy handler and cannot be retried at the statement level, because the
-- transaction's snapshot is stale for good: the only remedy is to roll back and
-- start over. Taking the lock at BEGIN removes the upgrade, so contention
-- surfaces here instead, where waiting actually resolves it.
dbWithWriteTransaction :: HasCallStack => Conn -> IO a -> IO a
dbWithWriteTransaction :: forall a. HasCallStack => Conn -> IO a -> IO a
dbWithWriteTransaction Conn{Database
conVolDb :: Conn -> Database
conVolDb :: Database
conVolDb} = Database -> IO a -> IO a
forall a. HasCallStack => Database -> IO a -> IO a
dbWithWriteTransactionRaw Database
conVolDb