{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Consensus.Node.Genesis (
    -- * 'GenesisConfig'
    GenesisConfig (..)
  , LoEAndGDDConfig (..)
  , disableGenesisConfig
  , enableGenesisConfigDefault
    -- * NodeKernel helpers
  , GenesisNodeKernelArgs (..)
  , mkGenesisNodeKernelArgs
  , setGetLoEFragment
  ) where

import           Control.Monad (join)
import           Data.Traversable (for)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                     (CSJConfig (..), CSJEnabledConfig (..),
                     ChainSyncLoPBucketConfig (..),
                     ChainSyncLoPBucketEnabledConfig (..))
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck
                     (HistoricityCutoff (..))
import qualified Ouroboros.Consensus.Node.GsmState as GSM
import           Ouroboros.Consensus.Storage.ChainDB (ChainDbArgs)
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
import           Ouroboros.Consensus.Util.Args
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF

-- | Whether to en-/disable the Limit on Eagerness and the Genesis Density
-- Disconnector.
data LoEAndGDDConfig a =
    LoEAndGDDEnabled !a
  | LoEAndGDDDisabled
  deriving stock (Int -> LoEAndGDDConfig a -> ShowS
[LoEAndGDDConfig a] -> ShowS
LoEAndGDDConfig a -> String
(Int -> LoEAndGDDConfig a -> ShowS)
-> (LoEAndGDDConfig a -> String)
-> ([LoEAndGDDConfig a] -> ShowS)
-> Show (LoEAndGDDConfig a)
forall a. Show a => Int -> LoEAndGDDConfig a -> ShowS
forall a. Show a => [LoEAndGDDConfig a] -> ShowS
forall a. Show a => LoEAndGDDConfig a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> LoEAndGDDConfig a -> ShowS
showsPrec :: Int -> LoEAndGDDConfig a -> ShowS
$cshow :: forall a. Show a => LoEAndGDDConfig a -> String
show :: LoEAndGDDConfig a -> String
$cshowList :: forall a. Show a => [LoEAndGDDConfig a] -> ShowS
showList :: [LoEAndGDDConfig a] -> ShowS
Show, (forall a b. (a -> b) -> LoEAndGDDConfig a -> LoEAndGDDConfig b)
-> (forall a b. a -> LoEAndGDDConfig b -> LoEAndGDDConfig a)
-> Functor LoEAndGDDConfig
forall a b. a -> LoEAndGDDConfig b -> LoEAndGDDConfig a
forall a b. (a -> b) -> LoEAndGDDConfig a -> LoEAndGDDConfig b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> LoEAndGDDConfig a -> LoEAndGDDConfig b
fmap :: forall a b. (a -> b) -> LoEAndGDDConfig a -> LoEAndGDDConfig b
$c<$ :: forall a b. a -> LoEAndGDDConfig b -> LoEAndGDDConfig a
<$ :: forall a b. a -> LoEAndGDDConfig b -> LoEAndGDDConfig a
Functor, (forall m. Monoid m => LoEAndGDDConfig m -> m)
-> (forall m a. Monoid m => (a -> m) -> LoEAndGDDConfig a -> m)
-> (forall m a. Monoid m => (a -> m) -> LoEAndGDDConfig a -> m)
-> (forall a b. (a -> b -> b) -> b -> LoEAndGDDConfig a -> b)
-> (forall a b. (a -> b -> b) -> b -> LoEAndGDDConfig a -> b)
-> (forall b a. (b -> a -> b) -> b -> LoEAndGDDConfig a -> b)
-> (forall b a. (b -> a -> b) -> b -> LoEAndGDDConfig a -> b)
-> (forall a. (a -> a -> a) -> LoEAndGDDConfig a -> a)
-> (forall a. (a -> a -> a) -> LoEAndGDDConfig a -> a)
-> (forall a. LoEAndGDDConfig a -> [a])
-> (forall a. LoEAndGDDConfig a -> Bool)
-> (forall a. LoEAndGDDConfig a -> Int)
-> (forall a. Eq a => a -> LoEAndGDDConfig a -> Bool)
-> (forall a. Ord a => LoEAndGDDConfig a -> a)
-> (forall a. Ord a => LoEAndGDDConfig a -> a)
-> (forall a. Num a => LoEAndGDDConfig a -> a)
-> (forall a. Num a => LoEAndGDDConfig a -> a)
-> Foldable LoEAndGDDConfig
forall a. Eq a => a -> LoEAndGDDConfig a -> Bool
forall a. Num a => LoEAndGDDConfig a -> a
forall a. Ord a => LoEAndGDDConfig a -> a
forall m. Monoid m => LoEAndGDDConfig m -> m
forall a. LoEAndGDDConfig a -> Bool
forall a. LoEAndGDDConfig a -> Int
forall a. LoEAndGDDConfig a -> [a]
forall a. (a -> a -> a) -> LoEAndGDDConfig a -> a
forall m a. Monoid m => (a -> m) -> LoEAndGDDConfig a -> m
forall b a. (b -> a -> b) -> b -> LoEAndGDDConfig a -> b
forall a b. (a -> b -> b) -> b -> LoEAndGDDConfig a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => LoEAndGDDConfig m -> m
fold :: forall m. Monoid m => LoEAndGDDConfig m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> LoEAndGDDConfig a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> LoEAndGDDConfig a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> LoEAndGDDConfig a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> LoEAndGDDConfig a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> LoEAndGDDConfig a -> b
foldr :: forall a b. (a -> b -> b) -> b -> LoEAndGDDConfig a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> LoEAndGDDConfig a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> LoEAndGDDConfig a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> LoEAndGDDConfig a -> b
foldl :: forall b a. (b -> a -> b) -> b -> LoEAndGDDConfig a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> LoEAndGDDConfig a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> LoEAndGDDConfig a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> LoEAndGDDConfig a -> a
foldr1 :: forall a. (a -> a -> a) -> LoEAndGDDConfig a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> LoEAndGDDConfig a -> a
foldl1 :: forall a. (a -> a -> a) -> LoEAndGDDConfig a -> a
$ctoList :: forall a. LoEAndGDDConfig a -> [a]
toList :: forall a. LoEAndGDDConfig a -> [a]
$cnull :: forall a. LoEAndGDDConfig a -> Bool
null :: forall a. LoEAndGDDConfig a -> Bool
$clength :: forall a. LoEAndGDDConfig a -> Int
length :: forall a. LoEAndGDDConfig a -> Int
$celem :: forall a. Eq a => a -> LoEAndGDDConfig a -> Bool
elem :: forall a. Eq a => a -> LoEAndGDDConfig a -> Bool
$cmaximum :: forall a. Ord a => LoEAndGDDConfig a -> a
maximum :: forall a. Ord a => LoEAndGDDConfig a -> a
$cminimum :: forall a. Ord a => LoEAndGDDConfig a -> a
minimum :: forall a. Ord a => LoEAndGDDConfig a -> a
$csum :: forall a. Num a => LoEAndGDDConfig a -> a
sum :: forall a. Num a => LoEAndGDDConfig a -> a
$cproduct :: forall a. Num a => LoEAndGDDConfig a -> a
product :: forall a. Num a => LoEAndGDDConfig a -> a
Foldable, Functor LoEAndGDDConfig
Foldable LoEAndGDDConfig
(Functor LoEAndGDDConfig, Foldable LoEAndGDDConfig) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> LoEAndGDDConfig a -> f (LoEAndGDDConfig b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    LoEAndGDDConfig (f a) -> f (LoEAndGDDConfig a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> LoEAndGDDConfig a -> m (LoEAndGDDConfig b))
-> (forall (m :: * -> *) a.
    Monad m =>
    LoEAndGDDConfig (m a) -> m (LoEAndGDDConfig a))
-> Traversable LoEAndGDDConfig
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
LoEAndGDDConfig (m a) -> m (LoEAndGDDConfig a)
forall (f :: * -> *) a.
Applicative f =>
LoEAndGDDConfig (f a) -> f (LoEAndGDDConfig a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LoEAndGDDConfig a -> m (LoEAndGDDConfig b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LoEAndGDDConfig a -> f (LoEAndGDDConfig b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LoEAndGDDConfig a -> f (LoEAndGDDConfig b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LoEAndGDDConfig a -> f (LoEAndGDDConfig b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
LoEAndGDDConfig (f a) -> f (LoEAndGDDConfig a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
LoEAndGDDConfig (f a) -> f (LoEAndGDDConfig a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LoEAndGDDConfig a -> m (LoEAndGDDConfig b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LoEAndGDDConfig a -> m (LoEAndGDDConfig b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
LoEAndGDDConfig (m a) -> m (LoEAndGDDConfig a)
sequence :: forall (m :: * -> *) a.
Monad m =>
LoEAndGDDConfig (m a) -> m (LoEAndGDDConfig a)
Traversable)

-- | Aggregating the various configs for Genesis-related subcomponents.
data GenesisConfig = GenesisConfig {
    GenesisConfig -> ChainSyncLoPBucketConfig
gcChainSyncLoPBucketConfig :: !ChainSyncLoPBucketConfig
  , GenesisConfig -> CSJConfig
gcCSJConfig                :: !CSJConfig
  , GenesisConfig -> LoEAndGDDConfig ()
gcLoEAndGDDConfig          :: !(LoEAndGDDConfig ())
  , GenesisConfig -> Maybe HistoricityCutoff
gcHistoricityCutoff        :: !(Maybe HistoricityCutoff)
  }

-- TODO justification/derivation from other parameters
enableGenesisConfigDefault :: GenesisConfig
enableGenesisConfigDefault :: GenesisConfig
enableGenesisConfigDefault = GenesisConfig {
      gcChainSyncLoPBucketConfig :: ChainSyncLoPBucketConfig
gcChainSyncLoPBucketConfig = ChainSyncLoPBucketEnabledConfig -> ChainSyncLoPBucketConfig
ChainSyncLoPBucketEnabled ChainSyncLoPBucketEnabledConfig {
          $sel:csbcCapacity:ChainSyncLoPBucketEnabledConfig :: Integer
csbcCapacity = Integer
100_000 -- number of tokens
        , $sel:csbcRate:ChainSyncLoPBucketEnabledConfig :: Rational
csbcRate     = Rational
500 -- tokens per second leaking, 1/2ms
        }
    , gcCSJConfig :: CSJConfig
gcCSJConfig = CSJEnabledConfig -> CSJConfig
CSJEnabled CSJEnabledConfig {
          $sel:csjcJumpSize:CSJEnabledConfig :: SlotNo
csjcJumpSize = SlotNo
3 SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
* SlotNo
2160 SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
* SlotNo
20 -- mainnet forecast range
        }
    , gcLoEAndGDDConfig :: LoEAndGDDConfig ()
gcLoEAndGDDConfig = () -> LoEAndGDDConfig ()
forall a. a -> LoEAndGDDConfig a
LoEAndGDDEnabled ()
      -- Duration in seconds of one Cardano mainnet Shelley stability window
      -- (3k/f slots times one second per slot) plus one extra hour as a
      -- safety margin.
    , gcHistoricityCutoff :: Maybe HistoricityCutoff
gcHistoricityCutoff = HistoricityCutoff -> Maybe HistoricityCutoff
forall a. a -> Maybe a
Just (HistoricityCutoff -> Maybe HistoricityCutoff)
-> HistoricityCutoff -> Maybe HistoricityCutoff
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> HistoricityCutoff
HistoricityCutoff (NominalDiffTime -> HistoricityCutoff)
-> NominalDiffTime -> HistoricityCutoff
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
3 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
2160 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
3600
    }

-- | Disable all Genesis components, yielding Praos behavior.
disableGenesisConfig :: GenesisConfig
disableGenesisConfig :: GenesisConfig
disableGenesisConfig = GenesisConfig {
      gcChainSyncLoPBucketConfig :: ChainSyncLoPBucketConfig
gcChainSyncLoPBucketConfig = ChainSyncLoPBucketConfig
ChainSyncLoPBucketDisabled
    , gcCSJConfig :: CSJConfig
gcCSJConfig                = CSJConfig
CSJDisabled
    , gcLoEAndGDDConfig :: LoEAndGDDConfig ()
gcLoEAndGDDConfig          = LoEAndGDDConfig ()
forall a. LoEAndGDDConfig a
LoEAndGDDDisabled
    , gcHistoricityCutoff :: Maybe HistoricityCutoff
gcHistoricityCutoff        = Maybe HistoricityCutoff
forall a. Maybe a
Nothing
    }

-- | Genesis-related arguments needed by the NodeKernel initialization logic.
data GenesisNodeKernelArgs m blk = GenesisNodeKernelArgs {
    -- | A TVar containing an action that returns the 'ChainDB.GetLoEFragment'
    -- action. We use this extra indirection to update this action after we
    -- opened the ChainDB (which happens before we initialize the NodeKernel).
    -- After that, this TVar will not be modified again.
    forall (m :: * -> *) blk.
GenesisNodeKernelArgs m blk
-> LoEAndGDDConfig (StrictTVar m (GetLoEFragment m blk))
gnkaGetLoEFragment :: !(LoEAndGDDConfig (StrictTVar m (ChainDB.GetLoEFragment m blk)))
  }

-- | Create the initial 'GenesisNodeKernelArgs" (with a temporary
-- 'ChainDB.GetLoEFragment' that will be replaced via 'setGetLoEFragment') and a
-- function to update the 'ChainDbArgs' accordingly.
mkGenesisNodeKernelArgs ::
     forall m blk. (IOLike m, GetHeader blk)
  => GenesisConfig
  -> m ( GenesisNodeKernelArgs m blk
       , Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
       )
mkGenesisNodeKernelArgs :: forall (m :: * -> *) blk.
(IOLike m, GetHeader blk) =>
GenesisConfig
-> m (GenesisNodeKernelArgs m blk,
      Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk)
mkGenesisNodeKernelArgs GenesisConfig
gcfg = do
    LoEAndGDDConfig
  (StrictTVar
     m
     (m (LoE
           (AnchoredSeq
              (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))))
gnkaGetLoEFragment <- LoEAndGDDConfig ()
-> (()
    -> m (StrictTVar
            m
            (m (LoE
                  (AnchoredSeq
                     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))))
-> m (LoEAndGDDConfig
        (StrictTVar
           m
           (m (LoE
                 (AnchoredSeq
                    (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (GenesisConfig -> LoEAndGDDConfig ()
gcLoEAndGDDConfig GenesisConfig
gcfg) ((()
  -> m (StrictTVar
          m
          (m (LoE
                (AnchoredSeq
                   (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))))
 -> m (LoEAndGDDConfig
         (StrictTVar
            m
            (m (LoE
                  (AnchoredSeq
                     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))))))
-> (()
    -> m (StrictTVar
            m
            (m (LoE
                  (AnchoredSeq
                     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))))
-> m (LoEAndGDDConfig
        (StrictTVar
           m
           (m (LoE
                 (AnchoredSeq
                    (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))))
forall a b. (a -> b) -> a -> b
$ \() ->
        m (LoE
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
-> m (StrictTVar
        m
        (m (LoE
              (AnchoredSeq
                 (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (m (LoE
      (AnchoredSeq
         (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
 -> m (StrictTVar
         m
         (m (LoE
               (AnchoredSeq
                  (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))))
-> m (LoE
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
-> m (StrictTVar
        m
        (m (LoE
              (AnchoredSeq
                 (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))))
forall a b. (a -> b) -> a -> b
$ LoE
  (AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
-> m (LoE
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoE
   (AnchoredSeq
      (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
 -> m (LoE
         (AnchoredSeq
            (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))
-> LoE
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
-> m (LoE
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
forall a b. (a -> b) -> a -> b
$
          -- Use the most conservative LoE fragment until 'setGetLoEFragment'
          -- is called.
          AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> LoE
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
forall a. a -> LoE a
ChainDB.LoEEnabled (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
 -> LoE
      (AnchoredSeq
         (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> LoE
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
forall a b. (a -> b) -> a -> b
$ Anchor (Header blk)
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header blk)
forall block. Anchor block
AF.AnchorGenesis
    let updateChainDbArgs :: ChainDbArgs f m blk -> ChainDbArgs f m blk
updateChainDbArgs = case LoEAndGDDConfig
  (StrictTVar
     m
     (m (LoE
           (AnchoredSeq
              (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))))
gnkaGetLoEFragment of
          LoEAndGDDConfig
  (StrictTVar
     m
     (m (LoE
           (AnchoredSeq
              (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))))
LoEAndGDDDisabled -> ChainDbArgs f m blk -> ChainDbArgs f m blk
forall a. a -> a
id
          LoEAndGDDEnabled StrictTVar
  m
  (m (LoE
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))
varGetLoEFragment -> \ChainDbArgs f m blk
cfg ->
            ChainDbArgs f m blk
cfg { ChainDB.cdbsArgs =
                  (ChainDB.cdbsArgs cfg) { ChainDB.cdbsLoE = getLoEFragment }
                }
            where
              getLoEFragment :: m (LoE
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
getLoEFragment = m (m (LoE
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))
-> m (LoE
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m (LoE
         (AnchoredSeq
            (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))
 -> m (LoE
         (AnchoredSeq
            (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))
-> m (m (LoE
           (AnchoredSeq
              (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))
-> m (LoE
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
forall a b. (a -> b) -> a -> b
$ StrictTVar
  m
  (m (LoE
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))
-> m (m (LoE
           (AnchoredSeq
              (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar
  m
  (m (LoE
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))
varGetLoEFragment
    (GenesisNodeKernelArgs m blk,
 Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk)
-> m (GenesisNodeKernelArgs m blk,
      Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenesisNodeKernelArgs {LoEAndGDDConfig
  (StrictTVar
     m
     (m (LoE
           (AnchoredSeq
              (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))))
gnkaGetLoEFragment :: LoEAndGDDConfig
  (StrictTVar
     m
     (m (LoE
           (AnchoredSeq
              (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))))
gnkaGetLoEFragment :: LoEAndGDDConfig
  (StrictTVar
     m
     (m (LoE
           (AnchoredSeq
              (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))))
gnkaGetLoEFragment}, Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
forall {f :: * -> *}. ChainDbArgs f m blk -> ChainDbArgs f m blk
updateChainDbArgs)

-- | Set 'gnkaGetLoEFragment' to the actual logic for determining the current
-- LoE fragment.
setGetLoEFragment ::
     forall m blk. (IOLike m, GetHeader blk)
  => STM m GSM.GsmState
  -> STM m (AnchoredFragment (Header blk))
     -- ^ The LoE fragment.
  -> StrictTVar m (ChainDB.GetLoEFragment m blk)
  -> m ()
setGetLoEFragment :: forall (m :: * -> *) blk.
(IOLike m, GetHeader blk) =>
STM m GsmState
-> STM m (AnchoredFragment (Header blk))
-> StrictTVar m (GetLoEFragment m blk)
-> m ()
setGetLoEFragment STM m GsmState
readGsmState STM m (AnchoredFragment (Header blk))
readLoEFragment StrictTVar m (GetLoEFragment m blk)
varGetLoEFragment =
    STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (GetLoEFragment m blk)
-> GetLoEFragment m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (GetLoEFragment m blk)
varGetLoEFragment GetLoEFragment m blk
getLoEFragment
  where
    getLoEFragment :: ChainDB.GetLoEFragment m blk
    getLoEFragment :: GetLoEFragment m blk
getLoEFragment = STM m (LoE (AnchoredFragment (Header blk))) -> GetLoEFragment m blk
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LoE (AnchoredFragment (Header blk)))
 -> GetLoEFragment m blk)
-> STM m (LoE (AnchoredFragment (Header blk)))
-> GetLoEFragment m blk
forall a b. (a -> b) -> a -> b
$ STM m GsmState
readGsmState STM m GsmState
-> (GsmState -> STM m (LoE (AnchoredFragment (Header blk))))
-> STM m (LoE (AnchoredFragment (Header blk)))
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- When the Honest Availability Assumption cannot currently be guaranteed, we should not select
        -- any blocks that would cause our immutable tip to advance, so we
        -- return the most conservative LoE fragment.
        GsmState
GSM.PreSyncing ->
          LoE (AnchoredFragment (Header blk))
-> STM m (LoE (AnchoredFragment (Header blk)))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoE (AnchoredFragment (Header blk))
 -> STM m (LoE (AnchoredFragment (Header blk))))
-> LoE (AnchoredFragment (Header blk))
-> STM m (LoE (AnchoredFragment (Header blk)))
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk)
-> LoE (AnchoredFragment (Header blk))
forall a. a -> LoE a
ChainDB.LoEEnabled (AnchoredFragment (Header blk)
 -> LoE (AnchoredFragment (Header blk)))
-> AnchoredFragment (Header blk)
-> LoE (AnchoredFragment (Header blk))
forall a b. (a -> b) -> a -> b
$ Anchor (Header blk) -> AnchoredFragment (Header blk)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header blk)
forall block. Anchor block
AF.AnchorGenesis
        -- When we are syncing, return the current LoE fragment.
        GsmState
GSM.Syncing    ->
          AnchoredFragment (Header blk)
-> LoE (AnchoredFragment (Header blk))
forall a. a -> LoE a
ChainDB.LoEEnabled (AnchoredFragment (Header blk)
 -> LoE (AnchoredFragment (Header blk)))
-> STM m (AnchoredFragment (Header blk))
-> STM m (LoE (AnchoredFragment (Header blk)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (AnchoredFragment (Header blk))
readLoEFragment
        -- When we are caught up, the LoE is disabled.
        GsmState
GSM.CaughtUp   ->
          LoE (AnchoredFragment (Header blk))
-> STM m (LoE (AnchoredFragment (Header blk)))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoE (AnchoredFragment (Header blk))
forall a. LoE a
ChainDB.LoEDisabled