{-# 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

{-------------------------------------------------------------------------------
  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.
  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 ->
  -- | 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) ->
  Complete LedgerDbFlavorArgs m ->
  -- | 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)
-> 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}
            }
    }

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

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