{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
module Ouroboros.Consensus.Storage.ChainDB.Impl.Args (
ChainDbArgs (..)
, ChainDbSpecificArgs (..)
, RelativeMountPoint (..)
, completeChainDbArgs
, defaultArgs
, enableLedgerEvents
, ensureValidateAll
, updateQueryBatchSize
, updateSnapshotPolicyArgs
, updateTracer
) where
import Control.ResourceRegistry (ResourceRegistry)
import Control.Tracer (Tracer, nullTracer)
import Data.Function ((&))
import Data.Functor.Contravariant ((>$<))
import Data.Kind
import Data.Time.Clock (secondsToDiffTime)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Storage.ChainDB.API (GetLoEFragment,
LoE (LoEDisabled))
import Ouroboros.Consensus.Storage.ChainDB.Impl.Types
(TraceEvent (..))
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import Ouroboros.Consensus.Storage.LedgerDB (LedgerDbFlavorArgs)
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.IOLike
import System.FS.API
data ChainDbArgs f m blk = ChainDbArgs {
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ImmutableDbArgs f m blk
cdbImmDbArgs :: ImmutableDB.ImmutableDbArgs f m blk
, forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> VolatileDbArgs f m blk
cdbVolDbArgs :: VolatileDB.VolatileDbArgs f m blk
, forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> LedgerDbArgs f m blk
cdbLgrDbArgs :: LedgerDB.LedgerDbArgs f m blk
, forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ChainDbSpecificArgs f m blk
cdbsArgs :: ChainDbSpecificArgs f m blk
}
type ChainDbSpecificArgs ::
(Type -> Type)
-> (Type -> Type)
-> Type
-> Type
data ChainDbSpecificArgs f m blk = ChainDbSpecificArgs {
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> Word
cdbsBlocksToAddSize :: Word
, forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> DiffTime
cdbsGcDelay :: DiffTime
, forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> DiffTime
cdbsGcInterval :: DiffTime
, forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> HKD f (ResourceRegistry m)
cdbsRegistry :: HKD f (ResourceRegistry m)
, forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> Tracer m (TraceEvent blk)
cdbsTracer :: Tracer m (TraceEvent blk)
, forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> HKD f (SomeHasFS m)
cdbsHasFSGsmDB :: HKD f (SomeHasFS m)
, forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> HKD f (TopLevelConfig blk)
cdbsTopLevelConfig :: HKD f (TopLevelConfig blk)
, forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> GetLoEFragment m blk
cdbsLoE :: GetLoEFragment m blk
}
defaultSpecificArgs :: Monad m => Incomplete ChainDbSpecificArgs m blk
defaultSpecificArgs :: forall (m :: * -> *) blk.
Monad m =>
Incomplete ChainDbSpecificArgs m blk
defaultSpecificArgs = ChainDbSpecificArgs {
cdbsBlocksToAddSize :: Word
cdbsBlocksToAddSize = Word
10
, cdbsGcDelay :: DiffTime
cdbsGcDelay = Integer -> DiffTime
secondsToDiffTime Integer
60
, cdbsGcInterval :: DiffTime
cdbsGcInterval = Integer -> DiffTime
secondsToDiffTime Integer
10
, cdbsRegistry :: HKD Defaults (ResourceRegistry m)
cdbsRegistry = HKD Defaults (ResourceRegistry m)
Defaults (ResourceRegistry m)
forall {k} (t :: k). Defaults t
noDefault
, cdbsTracer :: Tracer m (TraceEvent blk)
cdbsTracer = Tracer m (TraceEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
, cdbsHasFSGsmDB :: HKD Defaults (SomeHasFS m)
cdbsHasFSGsmDB = HKD Defaults (SomeHasFS m)
Defaults (SomeHasFS m)
forall {k} (t :: k). Defaults t
noDefault
, cdbsTopLevelConfig :: HKD Defaults (TopLevelConfig blk)
cdbsTopLevelConfig = HKD Defaults (TopLevelConfig blk)
Defaults (TopLevelConfig blk)
forall {k} (t :: k). Defaults t
noDefault
, cdbsLoE :: GetLoEFragment m blk
cdbsLoE = LoE (AnchoredFragment (HeaderWithTime blk)) -> GetLoEFragment m blk
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoE (AnchoredFragment (HeaderWithTime blk))
forall a. LoE a
LoEDisabled
}
defaultArgs ::
forall m blk .
Monad m
=> Incomplete ChainDbArgs m blk
defaultArgs :: forall (m :: * -> *) blk. Monad m => Incomplete ChainDbArgs m blk
defaultArgs =
ImmutableDbArgs Defaults m blk
-> VolatileDbArgs Defaults m blk
-> LedgerDbArgs Defaults m blk
-> ChainDbSpecificArgs Defaults m blk
-> ChainDbArgs Defaults m blk
forall (f :: * -> *) (m :: * -> *) blk.
ImmutableDbArgs f m blk
-> VolatileDbArgs f m blk
-> LedgerDbArgs f m blk
-> ChainDbSpecificArgs f m blk
-> ChainDbArgs f m blk
ChainDbArgs ImmutableDbArgs Defaults m blk
forall (m :: * -> *) blk.
Applicative m =>
Incomplete ImmutableDbArgs m blk
ImmutableDB.defaultArgs
VolatileDbArgs Defaults m blk
forall (m :: * -> *) blk.
Applicative m =>
Incomplete VolatileDbArgs m blk
VolatileDB.defaultArgs
LedgerDbArgs Defaults m blk
forall (m :: * -> *) blk.
Applicative m =>
Incomplete LedgerDbArgs m blk
LedgerDB.defaultArgs
ChainDbSpecificArgs Defaults m blk
forall (m :: * -> *) blk.
Monad m =>
Incomplete ChainDbSpecificArgs m blk
defaultSpecificArgs
ensureValidateAll ::
ChainDbArgs f m blk
-> ChainDbArgs f m blk
ensureValidateAll :: forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ChainDbArgs f m blk
ensureValidateAll ChainDbArgs f m blk
args =
ChainDbArgs f m blk
args { cdbImmDbArgs = (cdbImmDbArgs args) {
ImmutableDB.immValidationPolicy = ImmutableDB.ValidateAllChunks
}
, cdbVolDbArgs = (cdbVolDbArgs args) {
VolatileDB.volValidationPolicy = VolatileDB.ValidateAll
}
}
completeChainDbArgs ::
forall m blk. (ConsensusProtocol (BlockProtocol blk), IOLike m)
=> ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> ImmutableDB.ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> Complete LedgerDbFlavorArgs m
-> Incomplete ChainDbArgs m blk
-> Complete ChainDbArgs m blk
completeChainDbArgs :: forall (m :: * -> *) blk.
(ConsensusProtocol (BlockProtocol blk), IOLike m) =>
ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> Complete LedgerDbFlavorArgs m
-> Incomplete ChainDbArgs m blk
-> Complete ChainDbArgs m blk
completeChainDbArgs
ResourceRegistry m
registry
TopLevelConfig blk
cdbsTopLevelConfig
ExtLedgerState blk ValuesMK
initLedger
ChunkInfo
immChunkInfo
blk -> Bool
checkIntegrity
RelativeMountPoint -> SomeHasFS m
mkImmFS
RelativeMountPoint -> SomeHasFS m
mkVolFS
Complete LedgerDbFlavorArgs m
flavorArgs
Incomplete ChainDbArgs m blk
defArgs
= Incomplete ChainDbArgs m blk
defArgs {
cdbImmDbArgs = (cdbImmDbArgs defArgs) {
ImmutableDB.immChunkInfo
, ImmutableDB.immCheckIntegrity = checkIntegrity
, ImmutableDB.immRegistry = registry
, ImmutableDB.immCodecConfig = configCodec cdbsTopLevelConfig
, ImmutableDB.immHasFS = mkImmFS $ RelativeMountPoint "immutable"
}
, cdbVolDbArgs = (cdbVolDbArgs defArgs) {
VolatileDB.volHasFS = mkVolFS $ RelativeMountPoint "volatile"
, VolatileDB.volCheckIntegrity = checkIntegrity
, VolatileDB.volCodecConfig = configCodec cdbsTopLevelConfig
}
, cdbLgrDbArgs = (cdbLgrDbArgs defArgs) {
LedgerDB.lgrGenesis = pure initLedger
, LedgerDB.lgrHasFS = mkVolFS $ RelativeMountPoint "ledger"
, LedgerDB.lgrConfig =
LedgerDB.configLedgerDb
cdbsTopLevelConfig
(LedgerDB.ledgerDbCfgComputeLedgerEvents $ LedgerDB.lgrConfig (cdbLgrDbArgs defArgs))
, LedgerDB.lgrFlavorArgs = flavorArgs
, LedgerDB.lgrRegistry = registry
}
, cdbsArgs = (cdbsArgs defArgs) {
cdbsRegistry = registry
, cdbsTopLevelConfig
, cdbsHasFSGsmDB = mkVolFS $ RelativeMountPoint "gsm"
}
}
updateTracer ::
Tracer m (TraceEvent blk)
-> ChainDbArgs f m blk
-> ChainDbArgs f m blk
updateTracer :: forall (m :: * -> *) blk (f :: * -> *).
Tracer m (TraceEvent blk)
-> ChainDbArgs f m blk -> ChainDbArgs f m blk
updateTracer Tracer m (TraceEvent blk)
trcr ChainDbArgs f m blk
args =
ChainDbArgs f m blk
args {
cdbImmDbArgs = (cdbImmDbArgs args) { ImmutableDB.immTracer = TraceImmutableDBEvent >$< trcr }
, cdbVolDbArgs = (cdbVolDbArgs args) { VolatileDB.volTracer = TraceVolatileDBEvent >$< trcr }
, cdbLgrDbArgs = (cdbLgrDbArgs args) { LedgerDB.lgrTracer = TraceLedgerDBEvent >$< trcr }
, cdbsArgs = (cdbsArgs args) { cdbsTracer = trcr }
}
updateSnapshotPolicyArgs ::
SnapshotPolicyArgs
-> ChainDbArgs f m blk
-> ChainDbArgs f m blk
updateSnapshotPolicyArgs :: forall (f :: * -> *) (m :: * -> *) blk.
SnapshotPolicyArgs -> ChainDbArgs f m blk -> ChainDbArgs f m blk
updateSnapshotPolicyArgs SnapshotPolicyArgs
spa ChainDbArgs f m blk
args =
ChainDbArgs f m blk
args { cdbLgrDbArgs = (cdbLgrDbArgs args) { LedgerDB.lgrSnapshotPolicyArgs = spa } }
updateQueryBatchSize ::
LedgerDB.QueryBatchSize
-> ChainDbArgs f m blk
-> ChainDbArgs f m blk
updateQueryBatchSize :: forall (f :: * -> *) (m :: * -> *) blk.
QueryBatchSize -> ChainDbArgs f m blk -> ChainDbArgs f m blk
updateQueryBatchSize QueryBatchSize
qbs ChainDbArgs f m blk
args =
ChainDbArgs f m blk
args { cdbLgrDbArgs = (cdbLgrDbArgs args) { LedgerDB.lgrQueryBatchSize = qbs } }
enableLedgerEvents ::
Complete ChainDbArgs m blk
-> Complete ChainDbArgs m blk
enableLedgerEvents :: forall (m :: * -> *) blk.
Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
enableLedgerEvents Complete ChainDbArgs m blk
args =
Complete ChainDbArgs m blk
args { cdbLgrDbArgs = (cdbLgrDbArgs args) & \LedgerDbArgs Identity m blk
x ->
LedgerDbArgs Identity m blk
x { LedgerDB.lgrConfig =
(LedgerDB.lgrConfig x) { LedgerDB.ledgerDbCfgComputeLedgerEvents = ComputeLedgerEvents }
}
}
newtype RelativeMountPoint = RelativeMountPoint FilePath