{-# 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.Ledger.SupportsProtocol
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 (LedgerDbBackendArgs)
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as LedgerDB
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory
import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.IOLike
import System.FS.API

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

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
  }

-- | Arguments specific to the ChainDB, not to the ImmutableDB, VolatileDB, or
-- LedgerDB.
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
  -- ^ Size of the queue used to store asynchronously added blocks. This
  -- is the maximum number of blocks that could be kept in memory at the
  -- same time when the background thread processing the blocks can't keep
  -- up.
  , forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> DiffTime
cdbsGcDelay :: DiffTime
  -- ^ Delay between copying a block to the ImmutableDB and triggering a
  -- garbage collection for the corresponding slot on the VolatileDB.
  --
  -- The goal of the delay is to ensure that the write to the ImmutableDB
  -- has been flushed to disk before deleting the block from the
  -- VolatileDB, so that a crash won't result in the loss of the block.
  , forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> DiffTime
cdbsGcInterval :: DiffTime
  -- ^ Batch all scheduled GCs so that at most one GC happens every
  -- 'cdbsGcInterval'.
  , 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)
  , -- Limit on Eagerness
    forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> GetLoEFragment m blk
cdbsLoE :: GetLoEFragment m blk
  -- ^ If this is 'LoEEnabled', it contains an action that returns the
  -- current LoE fragment.
  }

-- | Default arguments
--
-- The following fields must still be defined:
--
-- * 'cdbsTracer'
-- * 'cdbsRegistry'
--
-- We a 'cdbsGcDelay' of 60 seconds and a 'cdbsGcInterval' of 10 seconds, this
-- means (see the properties in "Test.Ouroboros.Storage.ChainDB.GcSchedule"):
--
-- * The length of the 'GcSchedule' queue is @<= ⌈gcDelay / gcInterval⌉ + 1@,
--   i.e., @<= 7@.
-- * The overlap (number of blocks in both the VolatileDB and the ImmutableDB)
--   is the number of blocks synced in @gcDelay + gcInterval@ = 70s. E.g, when
--   bulk syncing at 1k-2k blocks/s, this means 70k-140k blocks. During normal
--   operation, we receive 1 block/20s (for Byron /and/ for Shelley), meaning
--   at most 4 blocks.
-- * The unnecessary overlap (the blocks that we haven't GC'ed yet but could
--   have, because of batching) < the number of blocks sync in @gcInterval@.
--   E.g., when syncing at 1k-2k blocks/s, this means 10k-20k blocks. During
--   normal operation, we receive 1 block/20s, meaning at most 1 block.
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
    }

-- | Default arguments
--
-- See 'ImmutableDB.defaultArgs', 'VolatileDB.defaultArgs', 'LgrDB.defaultArgs',
-- and 'defaultSpecificArgs' for a list of which fields are not given a default
-- and must therefore be set explicitly.
defaultArgs ::
  forall m blk.
  ( IOLike m
  , LedgerDB.LedgerDbSerialiseConstraints blk
  , LedgerSupportsProtocol blk
  , LedgerDB.LedgerSupportsInMemoryLedgerDB (LedgerState blk)
  ) =>
  Incomplete ChainDbArgs m blk
defaultArgs :: forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk,
 LedgerSupportsInMemoryLedgerDB (LedgerState blk)) =>
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
    (SomeBackendArgs m blk -> LedgerDbArgs Defaults m blk
forall (m :: * -> *) blk.
Applicative m =>
SomeBackendArgs m blk -> Incomplete LedgerDbArgs m blk
LedgerDB.defaultArgs (SomeBackendArgs m blk -> LedgerDbArgs Defaults m blk)
-> SomeBackendArgs m blk -> LedgerDbArgs Defaults m blk
forall a b. (a -> b) -> a -> b
$ Args m Mem -> SomeBackendArgs m blk
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Args m backend -> SomeBackendArgs m blk
LedgerDB.SomeBackendArgs Args m Mem
forall (m :: * -> *). Args m Mem
InMemory.InMemArgs)
    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 ->
  -- | Initial ledger
  ExtLedgerState blk ValuesMK ->
  ImmutableDB.ChunkInfo ->
  -- | Check integrity
  (blk -> Bool) ->
  -- | Immutable FS, see 'NodeDatabasePaths'
  (RelativeMountPoint -> SomeHasFS m) ->
  -- | Volatile  FS, see 'NodeDatabasePaths'
  (RelativeMountPoint -> SomeHasFS m) ->
  LedgerDbBackendArgs m blk ->
  -- | A set of incomplete arguments, possibly modified wrt @defaultArgs@
  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)
-> LedgerDbBackendArgs m blk
-> 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
  LedgerDbBackendArgs m blk
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.lgrBackendArgs = 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}
            }
    }

{-------------------------------------------------------------------------------
  Relative mount points
-------------------------------------------------------------------------------}

-- | A relative path for a 'MountPoint'
--
-- The root is determined by context.
newtype RelativeMountPoint = RelativeMountPoint FilePath