{-# 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.ResourceRegistry (ResourceRegistry)
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.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           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 -> 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
  }

-- | 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 (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
    }

-- | 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
-> 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
  -> TopLevelConfig blk
  -> ExtLedgerState blk
     -- ^ Initial ledger
  -> ImmutableDB.ChunkInfo
  -> (blk -> Bool)
     -- ^ Check integrity
  -> (RelativeMountPoint -> SomeHasFS m)
     -- ^ Immutable FS, see 'NodeDatabasePaths'
  -> (RelativeMountPoint -> SomeHasFS m)
     -- ^ Volatile  FS, see 'NodeDatabasePaths'
  -> Incomplete ChainDbArgs m blk
     -- ^ A set of incomplete arguments, possibly modified wrt @defaultArgs@
  -> Complete ChainDbArgs m blk
completeChainDbArgs :: forall (m :: * -> *) blk.
(ConsensusProtocol (BlockProtocol blk), IOLike m) =>
ResourceRegistry m
-> 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
  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) {
            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 } }

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

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