{-# LANGUAGE OverloadedStrings #-}

-- | Offline maintenance of a LeiosDB partition file, for internal tooling.
--
-- These open the file directly, not through a
-- 'Ouroboros.Consensus.Storage.LeiosDB.API.LeiosDbHandle', so they
-- must not run against a file that a node has open.
module Ouroboros.Consensus.Storage.LeiosDB.Impl.SQLite.Tooling
  ( truncateLeiosDbAfterSlot
  , deleteDanglingTxs
  , vacuumLeiosDb
  ) where

import Cardano.Slotting.Slot (SlotNo (..))
import Control.Monad (void)
import Control.Monad.Class.MonadThrow (bracket)
import Data.String (fromString)
import Database.SQLite3
  ( SQLOpenFlag (..)
  , SQLVFS (..)
  , open2
  )
import qualified Database.SQLite3.Direct as DB
import GHC.Stack (HasCallStack)
import Ouroboros.Consensus.Storage.LeiosDB.Impl.SQLite.Primitives

-- | Delete the EBs announced after the given slot.
--
-- For internal tooling.
--
-- Note: this function works for both the volatile and the immutable partition
--       files. The immutable one has no 'ebsMissingTxs' table (see
--       'Ouroboros.Consensus.Storage.LeiosDB.Impl.SQLite.Schema.sql_schema_imm'),
--       so the rows there are deleted only if the table exists.
truncateLeiosDbAfterSlot :: HasCallStack => FilePath -> SlotNo -> IO ()
truncateLeiosDbAfterSlot :: HasCallStack => FilePath -> SlotNo -> IO ()
truncateLeiosDbAfterSlot FilePath
dbPath (SlotNo Word64
slot) =
  FilePath -> (Database -> IO ()) -> IO ()
forall a. FilePath -> (Database -> IO a) -> IO a
withExistingLeiosDbFile FilePath
dbPath ((Database -> IO ()) -> IO ()) -> (Database -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Database
db ->
    -- One transaction, so a crash cannot leave an EB that is still announced
    -- but has no body.
    FilePath -> Database -> IO () -> IO ()
forall a. HasCallStack => FilePath -> Database -> IO a -> IO a
dbWithTransactionAs FilePath
"BEGIN IMMEDIATE" Database
db (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      hasMissingTxs <-
        (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
0)
          (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => Database -> FilePath -> IO Int64
Database -> FilePath -> IO Int64
queryInt64
            Database
db
            FilePath
"SELECT COUNT(*) FROM sqlite_master WHERE type = 'table' AND name = 'ebsMissingTxs'"
      dbExec db (fromString (deletes hasMissingTxs))
 where
  deletes :: Bool -> FilePath
deletes Bool
hasMissingTxs =
    [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
      [FilePath
"DELETE FROM ebTxs WHERE ebHashBytes IN (" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
droppedHashes FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
");"]
        [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [ FilePath
"DELETE FROM ebsMissingTxs WHERE ebHashBytes IN (" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
droppedHashes FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
");"
           | Bool
hasMissingTxs
           ]
        [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath
"DELETE FROM ebs WHERE ebSlot > " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Word64 -> FilePath
forall a. Show a => a -> FilePath
show Word64
slot FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
";"]

  -- The EBs whose bodies the truncation drops.
  --
  -- 'ebs' holds one row per announcement, so the same EB hash can appear at
  -- several slots. 'ebTxs' and 'ebsMissingTxs' hold one copy per hash and carry
  -- no slot. So an EB announced at slot 5 and again at slot 15 keeps its body
  -- when the cut is at slot 10. That is what the EXCEPT does: take the hashes
  -- announced after the cut, then remove the ones also announced at or before
  -- it.
  droppedHashes :: FilePath
droppedHashes =
    FilePath
"SELECT ebHashBytes FROM ebs WHERE ebSlot > "
      FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Word64 -> FilePath
forall a. Show a => a -> FilePath
show Word64
slot
      FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" EXCEPT SELECT ebHashBytes FROM ebs WHERE ebSlot <= "
      FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Word64 -> FilePath
forall a. Show a => a -> FilePath
show Word64
slot

-- | Delete the transactions that no EB references.
--
-- Used in tests.
deleteDanglingTxs :: HasCallStack => FilePath -> IO ()
deleteDanglingTxs :: HasCallStack => FilePath -> IO ()
deleteDanglingTxs FilePath
dbPath =
  FilePath -> (Database -> IO ()) -> IO ()
forall a. FilePath -> (Database -> IO a) -> IO a
withExistingLeiosDbFile FilePath
dbPath ((Database -> IO ()) -> IO ()) -> (Database -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Database
db ->
    HasCallStack => Database -> Utf8 -> IO ()
Database -> Utf8 -> IO ()
dbExec Database
db (Utf8 -> IO ()) -> (FilePath -> Utf8) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Utf8
forall a. IsString a => FilePath -> a
fromString (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath
"DELETE FROM txs WHERE txHashBytes NOT IN (SELECT txHashBytes FROM ebTxs)"

-- | Shrink a LeiosDb file to the space its rows need.
--
-- A delete frees pages inside the file without returning them to the
-- filesystem. This rewrites the file, so it needs free space of about the size
-- of the file. For internal tooling.
vacuumLeiosDb :: HasCallStack => FilePath -> IO ()
vacuumLeiosDb :: HasCallStack => FilePath -> IO ()
vacuumLeiosDb FilePath
dbPath =
  FilePath -> (Database -> IO ()) -> IO ()
forall a. FilePath -> (Database -> IO a) -> IO a
withExistingLeiosDbFile FilePath
dbPath ((Database -> IO ()) -> IO ()) -> (Database -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Database
db ->
    HasCallStack => Database -> Utf8 -> IO ()
Database -> Utf8 -> IO ()
dbExec Database
db (FilePath -> Utf8
forall a. IsString a => FilePath -> a
fromString FilePath
"VACUUM")

-- | Open the LeiosDb file at the given path, which must already exist.
--
-- Unrelated to 'withReader', which brackets a 'LeiosDbReader' that a
-- 'LeiosDbHandle' opens.
--
-- No 'SQLOpenCreate', unlike 'initialiseLeiosDbFiles': a wrong path must fail
-- rather than gain an empty database. No 'busy_timeout' either, so a write that
-- meets the node's own write lock gives up after the retries in 'withDie'
-- rather than block.
withExistingLeiosDbFile :: FilePath -> (DB.Database -> IO a) -> IO a
withExistingLeiosDbFile :: forall a. FilePath -> (Database -> IO a) -> IO a
withExistingLeiosDbFile 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
    (Text -> [SQLOpenFlag] -> SQLVFS -> IO Database
open2 (FilePath -> Text
forall a. IsString a => FilePath -> a
fromString FilePath
dbPath) [SQLOpenFlag
SQLOpenReadWrite] 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)