{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Arguments for LedgerDB initialization.
module Ouroboros.Consensus.Storage.LedgerDB.Args
  ( LedgerDbArgs (..)
  , LedgerDbFlavorArgs (..)
  , QueryBatchSize (..)
  , defaultArgs
  , defaultQueryBatchSize

    -- * 'GetVolatileSuffix'
  , GetVolatileSuffix (..)
  , praosGetVolatileSuffix
  ) where

import Cardano.Ledger.BaseTypes (unNonZero)
import Control.ResourceRegistry
import Control.Tracer
import Data.Kind
import Data.Word
import GHC.Generics (Generic)
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config.SecurityParam
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Storage.LedgerDB.API
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.AnchoredSeq (AnchoredSeq)
import qualified Ouroboros.Network.AnchoredSeq as AS
import System.FS.API

{-------------------------------------------------------------------------------
  Arguments
-------------------------------------------------------------------------------}

-- | Arguments required to initialize a LedgerDB.
type LedgerDbArgs ::
  (Type -> Type) ->
  (Type -> Type) ->
  Type ->
  Type
data LedgerDbArgs f m blk = LedgerDbArgs
  { forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> SnapshotPolicyArgs
lgrSnapshotPolicyArgs :: SnapshotPolicyArgs
  , forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (m (ExtLedgerState blk ValuesMK))
lgrGenesis :: HKD f (m (ExtLedgerState blk ValuesMK))
  , forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (SomeHasFS m)
lgrHasFS :: HKD f (SomeHasFS m)
  , forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbCfgF f (ExtLedgerState blk)
lgrConfig :: LedgerDbCfgF f (ExtLedgerState blk)
  , forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Tracer m (TraceEvent blk)
lgrTracer :: Tracer m (TraceEvent blk)
  , forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbFlavorArgs f m
lgrFlavorArgs :: LedgerDbFlavorArgs f m
  , forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (ResourceRegistry m)
lgrRegistry :: HKD f (ResourceRegistry m)
  , forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> QueryBatchSize
lgrQueryBatchSize :: QueryBatchSize
  , forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Maybe DiskSnapshot
lgrStartSnapshot :: Maybe DiskSnapshot
  -- ^ If provided, the ledgerdb will start using said snapshot and fallback
  -- to genesis. It will ignore any other existing snapshots. Useful for
  -- db-analyser.
  }

-- | Default arguments
defaultArgs ::
  Applicative m =>
  Incomplete LedgerDbArgs m blk
defaultArgs :: forall (m :: * -> *) blk.
Applicative m =>
Incomplete LedgerDbArgs m blk
defaultArgs =
  LedgerDbArgs
    { lgrSnapshotPolicyArgs :: SnapshotPolicyArgs
lgrSnapshotPolicyArgs = SnapshotPolicyArgs
defaultSnapshotPolicyArgs
    , lgrGenesis :: HKD Defaults (m (ExtLedgerState blk ValuesMK))
lgrGenesis = HKD Defaults (m (ExtLedgerState blk ValuesMK))
Defaults (m (ExtLedgerState blk ValuesMK))
forall {k} (t :: k). Defaults t
NoDefault
    , lgrHasFS :: HKD Defaults (SomeHasFS m)
lgrHasFS = HKD Defaults (SomeHasFS m)
Defaults (SomeHasFS m)
forall {k} (t :: k). Defaults t
NoDefault
    , lgrConfig :: LedgerDbCfgF Defaults (ExtLedgerState blk)
lgrConfig = HKD Defaults SecurityParam
-> HKD Defaults (LedgerCfg (ExtLedgerState blk))
-> ComputeLedgerEvents
-> LedgerDbCfgF Defaults (ExtLedgerState blk)
forall (f :: * -> *) (l :: LedgerStateKind).
HKD f SecurityParam
-> HKD f (LedgerCfg l) -> ComputeLedgerEvents -> LedgerDbCfgF f l
LedgerDbCfg HKD Defaults SecurityParam
Defaults SecurityParam
forall {k} (t :: k). Defaults t
NoDefault HKD Defaults (LedgerCfg (ExtLedgerState blk))
Defaults (ExtLedgerCfg blk)
forall {k} (t :: k). Defaults t
NoDefault ComputeLedgerEvents
OmitLedgerEvents
    , lgrQueryBatchSize :: QueryBatchSize
lgrQueryBatchSize = QueryBatchSize
DefaultQueryBatchSize
    , lgrTracer :: Tracer m (TraceEvent blk)
lgrTracer = Tracer m (TraceEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , -- This value is the closest thing to a pre-UTxO-HD node, and as such it
      -- will be the default for end-users.
      lgrFlavorArgs :: LedgerDbFlavorArgs Defaults m
lgrFlavorArgs = LedgerDbFlavorArgs Defaults m -> LedgerDbFlavorArgs Defaults m
forall (f :: * -> *) (m :: * -> *).
LedgerDbFlavorArgs f m -> LedgerDbFlavorArgs f m
LedgerDbFlavorArgsV2 (HandleArgs Defaults m -> LedgerDbFlavorArgs Defaults m
forall {k} {k1} (f :: k) (m :: k1).
HandleArgs f m -> LedgerDbFlavorArgs f m
V2.V2Args HandleArgs Defaults m
forall {k} {k1} (f :: k) (m :: k1). HandleArgs f m
V2.InMemoryHandleArgs)
    , lgrRegistry :: HKD Defaults (ResourceRegistry m)
lgrRegistry = HKD Defaults (ResourceRegistry m)
Defaults (ResourceRegistry m)
forall {k} (t :: k). Defaults t
NoDefault
    , lgrStartSnapshot :: Maybe DiskSnapshot
lgrStartSnapshot = Maybe DiskSnapshot
forall a. Maybe a
Nothing
    }

data LedgerDbFlavorArgs f m
  = LedgerDbFlavorArgsV1 (V1.LedgerDbFlavorArgs f m)
  | LedgerDbFlavorArgsV2 (V2.LedgerDbFlavorArgs f m)

{-------------------------------------------------------------------------------
  QueryBatchSize
-------------------------------------------------------------------------------}

-- | The /maximum/ number of keys to read in a backing store range query.
--
-- When performing a ledger state query that involves on-disk parts of the
-- ledger state, we might have to read ranges of key-value pair data (e.g.,
-- UTxO) from disk using backing store range queries. Instead of reading all
-- data in one go, we read it in batches. 'QueryBatchSize' determines the size
-- of these batches.
--
-- INVARIANT: Should be at least 1.
--
-- It is fine if the result of a range read contains less than this number of
-- keys, but it should never return more.
data QueryBatchSize
  = -- | A default value, which is determined by a specific
    -- 'QueryBatchSize'. See 'defaultQueryBatchSize' as an example.
    DefaultQueryBatchSize
  | -- | A requested value: the number of keys to read from disk in each batch.
    RequestedQueryBatchSize Word64
  deriving (Int -> QueryBatchSize -> ShowS
[QueryBatchSize] -> ShowS
QueryBatchSize -> String
(Int -> QueryBatchSize -> ShowS)
-> (QueryBatchSize -> String)
-> ([QueryBatchSize] -> ShowS)
-> Show QueryBatchSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QueryBatchSize -> ShowS
showsPrec :: Int -> QueryBatchSize -> ShowS
$cshow :: QueryBatchSize -> String
show :: QueryBatchSize -> String
$cshowList :: [QueryBatchSize] -> ShowS
showList :: [QueryBatchSize] -> ShowS
Show, QueryBatchSize -> QueryBatchSize -> Bool
(QueryBatchSize -> QueryBatchSize -> Bool)
-> (QueryBatchSize -> QueryBatchSize -> Bool) -> Eq QueryBatchSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QueryBatchSize -> QueryBatchSize -> Bool
== :: QueryBatchSize -> QueryBatchSize -> Bool
$c/= :: QueryBatchSize -> QueryBatchSize -> Bool
/= :: QueryBatchSize -> QueryBatchSize -> Bool
Eq, (forall x. QueryBatchSize -> Rep QueryBatchSize x)
-> (forall x. Rep QueryBatchSize x -> QueryBatchSize)
-> Generic QueryBatchSize
forall x. Rep QueryBatchSize x -> QueryBatchSize
forall x. QueryBatchSize -> Rep QueryBatchSize x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. QueryBatchSize -> Rep QueryBatchSize x
from :: forall x. QueryBatchSize -> Rep QueryBatchSize x
$cto :: forall x. Rep QueryBatchSize x -> QueryBatchSize
to :: forall x. Rep QueryBatchSize x -> QueryBatchSize
Generic)
  deriving anyclass Context -> QueryBatchSize -> IO (Maybe ThunkInfo)
Proxy QueryBatchSize -> String
(Context -> QueryBatchSize -> IO (Maybe ThunkInfo))
-> (Context -> QueryBatchSize -> IO (Maybe ThunkInfo))
-> (Proxy QueryBatchSize -> String)
-> NoThunks QueryBatchSize
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> QueryBatchSize -> IO (Maybe ThunkInfo)
noThunks :: Context -> QueryBatchSize -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> QueryBatchSize -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> QueryBatchSize -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy QueryBatchSize -> String
showTypeOf :: Proxy QueryBatchSize -> String
NoThunks

defaultQueryBatchSize :: QueryBatchSize -> Word64
defaultQueryBatchSize :: QueryBatchSize -> Word64
defaultQueryBatchSize QueryBatchSize
requestedQueryBatchSize = case QueryBatchSize
requestedQueryBatchSize of
  RequestedQueryBatchSize Word64
value -> Word64
value
  -- Experiments showed that 100_000 is a reasonable value, which yields
  -- acceptable performance. We might want to tweak this further, but for now
  -- this default seems good enough.
  QueryBatchSize
DefaultQueryBatchSize -> Word64
100_000

{-------------------------------------------------------------------------------
  GetVolatileSuffix
-------------------------------------------------------------------------------}

-- | Get the volatile suffix of the given 'AnchoredSeq' of states that the
-- LedgerDB maintains.
newtype GetVolatileSuffix m blk = GetVolatileSuffix
  { forall {k} (m :: * -> *) (blk :: k).
GetVolatileSuffix m blk
-> forall s.
   Anchorable (WithOrigin SlotNo) s s =>
   STM
     m
     (AnchoredSeq (WithOrigin SlotNo) s s
      -> AnchoredSeq (WithOrigin SlotNo) s s)
getVolatileSuffix ::
      forall s.
      AS.Anchorable (WithOrigin SlotNo) s s =>
      STM
        m
        ( AnchoredSeq (WithOrigin SlotNo) s s ->
          AnchoredSeq (WithOrigin SlotNo) s s
        )
  }
  deriving Context -> GetVolatileSuffix m blk -> IO (Maybe ThunkInfo)
Proxy (GetVolatileSuffix m blk) -> String
(Context -> GetVolatileSuffix m blk -> IO (Maybe ThunkInfo))
-> (Context -> GetVolatileSuffix m blk -> IO (Maybe ThunkInfo))
-> (Proxy (GetVolatileSuffix m blk) -> String)
-> NoThunks (GetVolatileSuffix m blk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) k (blk :: k).
Context -> GetVolatileSuffix m blk -> IO (Maybe ThunkInfo)
forall (m :: * -> *) k (blk :: k).
Proxy (GetVolatileSuffix m blk) -> String
$cnoThunks :: forall (m :: * -> *) k (blk :: k).
Context -> GetVolatileSuffix m blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> GetVolatileSuffix m blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) k (blk :: k).
Context -> GetVolatileSuffix m blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> GetVolatileSuffix m blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) k (blk :: k).
Proxy (GetVolatileSuffix m blk) -> String
showTypeOf :: Proxy (GetVolatileSuffix m blk) -> String
NoThunks via OnlyCheckWhnfNamed "GetVolatileSuffix" (GetVolatileSuffix m blk)

-- | Return the the most recent @k@ blocks, which is the rule mandated by Praos.
praosGetVolatileSuffix :: IOLike m => SecurityParam -> GetVolatileSuffix m blk
praosGetVolatileSuffix :: forall {k} (m :: * -> *) (blk :: k).
IOLike m =>
SecurityParam -> GetVolatileSuffix m blk
praosGetVolatileSuffix SecurityParam
secParam =
  (forall s.
 Anchorable (WithOrigin SlotNo) s s =>
 STM
   m
   (AnchoredSeq (WithOrigin SlotNo) s s
    -> AnchoredSeq (WithOrigin SlotNo) s s))
-> GetVolatileSuffix m blk
forall {k} (m :: * -> *) (blk :: k).
(forall s.
 Anchorable (WithOrigin SlotNo) s s =>
 STM
   m
   (AnchoredSeq (WithOrigin SlotNo) s s
    -> AnchoredSeq (WithOrigin SlotNo) s s))
-> GetVolatileSuffix m blk
GetVolatileSuffix ((forall s.
  Anchorable (WithOrigin SlotNo) s s =>
  STM
    m
    (AnchoredSeq (WithOrigin SlotNo) s s
     -> AnchoredSeq (WithOrigin SlotNo) s s))
 -> GetVolatileSuffix m blk)
-> (forall s.
    Anchorable (WithOrigin SlotNo) s s =>
    STM
      m
      (AnchoredSeq (WithOrigin SlotNo) s s
       -> AnchoredSeq (WithOrigin SlotNo) s s))
-> GetVolatileSuffix m blk
forall a b. (a -> b) -> a -> b
$ (AnchoredSeq (WithOrigin SlotNo) s s
 -> AnchoredSeq (WithOrigin SlotNo) s s)
-> STM
     m
     (AnchoredSeq (WithOrigin SlotNo) s s
      -> AnchoredSeq (WithOrigin SlotNo) s s)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((AnchoredSeq (WithOrigin SlotNo) s s
  -> AnchoredSeq (WithOrigin SlotNo) s s)
 -> STM
      m
      (AnchoredSeq (WithOrigin SlotNo) s s
       -> AnchoredSeq (WithOrigin SlotNo) s s))
-> (AnchoredSeq (WithOrigin SlotNo) s s
    -> AnchoredSeq (WithOrigin SlotNo) s s)
-> STM
     m
     (AnchoredSeq (WithOrigin SlotNo) s s
      -> AnchoredSeq (WithOrigin SlotNo) s s)
forall a b. (a -> b) -> a -> b
$ Word64
-> AnchoredSeq (WithOrigin SlotNo) s s
-> AnchoredSeq (WithOrigin SlotNo) s s
forall v a b.
Anchorable v a b =>
Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
AS.anchorNewest Word64
k
 where
  k :: Word64
k = NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64) -> NonZero Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ SecurityParam -> NonZero Word64
maxRollbacks SecurityParam
secParam