{-# 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
  , 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. Works for both the volatile and the immutable
-- partition files.
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
$
      HasCallStack => Database -> Utf8 -> IO ()
Database -> Utf8 -> IO ()
dbExec Database
db (FilePath -> Utf8
forall a. IsString a => FilePath -> a
fromString FilePath
deletes)
 where
  deletes :: FilePath
deletes =
    [FilePath] -> FilePath
unlines
      [ FilePath
"DELETE FROM ebTxBytes 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
"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
"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 'ebTxBytes' 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

-- | 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)