{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# 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
  ) where

import Control.ResourceRegistry
import Control.Tracer
import Data.Kind
import Data.Word
import GHC.Generics (Generic)
import NoThunks.Class
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 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 -> LedgerDbFlavorArgs Defaults m
forall {k} {k1} (f :: k) (m :: k1).
HandleArgs -> LedgerDbFlavorArgs f m
V2.V2Args HandleArgs
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