{-# 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
, ensureValidateAll
, updateDiskPolicyArgs
, updateTracer
) where
import Control.Tracer (Tracer, nullTracer)
import Data.Functor.Contravariant ((>$<))
import Data.Kind
import Data.Time.Clock (secondsToDiffTime)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Fragment.InFuture (CheckInFuture)
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Storage.ChainDB.API (GetLoEFragment,
LoE (LoEDisabled))
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB as LedgerDB
import Ouroboros.Consensus.Storage.ChainDB.Impl.Types
(TraceEvent (..))
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)
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 -> LgrDbArgs f m blk
cdbLgrDbArgs :: LedgerDB.LgrDbArgs 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 -> HKD f (CheckInFuture m blk)
cdbsCheckInFuture :: HKD f (CheckInFuture m blk)
, 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
, cdbsCheckInFuture :: HKD Defaults (CheckInFuture m blk)
cdbsCheckInFuture = HKD Defaults (CheckInFuture m blk)
Defaults (CheckInFuture m blk)
forall {k} (t :: k). Defaults t
noDefault
, 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 (Header blk)) -> GetLoEFragment m blk
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoE (AnchoredFragment (Header 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
-> LgrDbArgs Defaults m blk
-> ChainDbSpecificArgs Defaults m blk
-> ChainDbArgs Defaults m blk
forall (f :: * -> *) (m :: * -> *) blk.
ImmutableDbArgs f m blk
-> VolatileDbArgs f m blk
-> LgrDbArgs 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
LgrDbArgs Defaults m blk
forall (m :: * -> *) blk.
Applicative m =>
Incomplete LgrDbArgs 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
-> CheckInFuture m blk
-> TopLevelConfig blk
-> ExtLedgerState blk
-> ImmutableDB.ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> Incomplete ChainDbArgs m blk
-> Complete ChainDbArgs m blk
completeChainDbArgs :: forall (m :: * -> *) blk.
(ConsensusProtocol (BlockProtocol blk), IOLike m) =>
ResourceRegistry m
-> CheckInFuture m blk
-> TopLevelConfig blk
-> ExtLedgerState blk
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> Incomplete ChainDbArgs m blk
-> Complete ChainDbArgs m blk
completeChainDbArgs
ResourceRegistry m
registry
CheckInFuture m blk
cdbsCheckInFuture
TopLevelConfig blk
cdbsTopLevelConfig
ExtLedgerState blk
initLedger
ChunkInfo
immChunkInfo
blk -> Bool
checkIntegrity
RelativeMountPoint -> SomeHasFS m
mkImmFS
RelativeMountPoint -> SomeHasFS m
mkVolFS
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
}
, cdbsArgs = (cdbsArgs defArgs) {
cdbsCheckInFuture
, 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 = TraceSnapshotEvent >$< trcr }
, cdbsArgs = (cdbsArgs args) { cdbsTracer = trcr }
}
updateDiskPolicyArgs ::
DiskPolicyArgs
-> ChainDbArgs f m blk
-> ChainDbArgs f m blk
updateDiskPolicyArgs :: forall (f :: * -> *) (m :: * -> *) blk.
DiskPolicyArgs -> ChainDbArgs f m blk -> ChainDbArgs f m blk
updateDiskPolicyArgs DiskPolicyArgs
spa ChainDbArgs f m blk
args =
ChainDbArgs f m blk
args { cdbLgrDbArgs = (cdbLgrDbArgs args) { LedgerDB.lgrDiskPolicyArgs = spa } }
newtype RelativeMountPoint = RelativeMountPoint FilePath