{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE TypeApplications   #-}
{-# LANGUAGE ViewPatterns       #-}
{-| A node client that applies a fold to the stream of blocks.
Unlike 'foldBlocks' from 'Cardano.Api', this one supports rollbacks.
-}
module Convex.NodeClient.Fold(
  CatchingUp(..),
  catchingUpWithNode,
  caughtUpWithNode,
  resumingFrom,
  catchingUp,
  caughtUp,
  getClientPoint,
  shouldLog,
  foldClient,
  foldClient'
  ) where

import           Cardano.Api                                           (Block (..),
                                                                        BlockHeader (..),
                                                                        BlockInMode (..),
                                                                        BlockNo (..),
                                                                        CardanoMode,
                                                                        ChainPoint (..),
                                                                        ChainTip (..),
                                                                        Env,
                                                                        SlotNo,
                                                                        chainTipToChainPoint,
                                                                        envSecurityParam)
import           Cardano.Slotting.Slot                                 (WithOrigin (At))
import           Convex.NodeClient.ChainTip                            (JSONBlockNo (..),
                                                                        JSONChainPoint (..),
                                                                        JSONChainTip (..),
                                                                        blockHeaderPoint)
import           Convex.NodeClient.Resuming                            (ResumingFrom)
import qualified Convex.NodeClient.Resuming                            as R
import           Convex.NodeClient.Types                               (ClientBlock,
                                                                        PipelinedLedgerStateClient (..),
                                                                        fromChainTip)
import           Data.Aeson                                            (FromJSON,
                                                                        ToJSON)
import           Data.Sequence                                         (Seq)
import qualified Data.Sequence                                         as Seq
import           GHC.Generics                                          (Generic)
import           Network.TypedProtocol.Pipelined                       (Nat (..))
import           Ouroboros.Consensus.Block.Abstract                    (WithOrigin (..))
import           Ouroboros.Network.Protocol.ChainSync.ClientPipelined  (ClientPipelinedStIdle (..),
                                                                        ClientStNext (..))
import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined  as CSP
import           Ouroboros.Network.Protocol.ChainSync.PipelineDecision (PipelineDecision (..),
                                                                        pipelineDecisionMax)

{-| Whether we have fully caught up with the node
-}
data CatchingUp =
  CatchingUpWithNode{ CatchingUp -> JSONChainPoint
clientPoint :: JSONChainPoint, CatchingUp -> Maybe JSONBlockNo
clientBlockNo :: Maybe JSONBlockNo, CatchingUp -> Maybe JSONChainPoint
serverTip :: Maybe JSONChainPoint} -- ^ Client is still catching up
  | CaughtUpWithNode{ CatchingUp -> JSONChainTip
tip :: JSONChainTip } -- ^ Client fully caught up (client tip == server tip)
  deriving stock (CatchingUp -> CatchingUp -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CatchingUp -> CatchingUp -> Bool
$c/= :: CatchingUp -> CatchingUp -> Bool
== :: CatchingUp -> CatchingUp -> Bool
$c== :: CatchingUp -> CatchingUp -> Bool
Eq, Int -> CatchingUp -> ShowS
[CatchingUp] -> ShowS
CatchingUp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CatchingUp] -> ShowS
$cshowList :: [CatchingUp] -> ShowS
show :: CatchingUp -> String
$cshow :: CatchingUp -> String
showsPrec :: Int -> CatchingUp -> ShowS
$cshowsPrec :: Int -> CatchingUp -> ShowS
Show, forall x. Rep CatchingUp x -> CatchingUp
forall x. CatchingUp -> Rep CatchingUp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CatchingUp x -> CatchingUp
$cfrom :: forall x. CatchingUp -> Rep CatchingUp x
Generic)
  deriving anyclass (Value -> Parser [CatchingUp]
Value -> Parser CatchingUp
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CatchingUp]
$cparseJSONList :: Value -> Parser [CatchingUp]
parseJSON :: Value -> Parser CatchingUp
$cparseJSON :: Value -> Parser CatchingUp
FromJSON, [CatchingUp] -> Encoding
[CatchingUp] -> Value
CatchingUp -> Encoding
CatchingUp -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CatchingUp] -> Encoding
$ctoEncodingList :: [CatchingUp] -> Encoding
toJSONList :: [CatchingUp] -> Value
$ctoJSONList :: [CatchingUp] -> Value
toEncoding :: CatchingUp -> Encoding
$ctoEncoding :: CatchingUp -> Encoding
toJSON :: CatchingUp -> Value
$ctoJSON :: CatchingUp -> Value
ToJSON)

getClientPoint :: CatchingUp -> JSONChainPoint
getClientPoint :: CatchingUp -> JSONChainPoint
getClientPoint = \case
  CatchingUpWithNode{JSONChainPoint
clientPoint :: JSONChainPoint
clientPoint :: CatchingUp -> JSONChainPoint
clientPoint} -> JSONChainPoint
clientPoint
  CaughtUpWithNode{JSONChainTip
tip :: JSONChainTip
tip :: CatchingUp -> JSONChainTip
tip}           -> ChainPoint -> JSONChainPoint
JSONChainPoint forall a b. (a -> b) -> a -> b
$ ChainTip -> ChainPoint
chainTipToChainPoint forall a b. (a -> b) -> a -> b
$ JSONChainTip -> ChainTip
unJSONChainTip JSONChainTip
tip

catchingUpWithNode :: ChainPoint -> Maybe BlockNo -> Maybe ChainPoint -> CatchingUp
catchingUpWithNode :: ChainPoint -> Maybe BlockNo -> Maybe ChainPoint -> CatchingUp
catchingUpWithNode (ChainPoint -> JSONChainPoint
JSONChainPoint -> JSONChainPoint
clientPoint) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockNo -> JSONBlockNo
JSONBlockNo -> Maybe JSONBlockNo
clientBlockNo) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChainPoint -> JSONChainPoint
JSONChainPoint -> Maybe JSONChainPoint
serverTip) =
  CatchingUpWithNode{JSONChainPoint
clientPoint :: JSONChainPoint
clientPoint :: JSONChainPoint
clientPoint, Maybe JSONChainPoint
serverTip :: Maybe JSONChainPoint
serverTip :: Maybe JSONChainPoint
serverTip, Maybe JSONBlockNo
clientBlockNo :: Maybe JSONBlockNo
clientBlockNo :: Maybe JSONBlockNo
clientBlockNo}

caughtUpWithNode :: ChainTip -> CatchingUp
caughtUpWithNode :: ChainTip -> CatchingUp
caughtUpWithNode (ChainTip -> JSONChainTip
JSONChainTip -> JSONChainTip
tip) = CaughtUpWithNode{JSONChainTip
tip :: JSONChainTip
tip :: JSONChainTip
tip}

catchingUp :: CatchingUp -> Bool
catchingUp :: CatchingUp -> Bool
catchingUp = \case
  CatchingUpWithNode{} -> Bool
True
  CaughtUpWithNode{}   -> Bool
False

{-| Whether it is a good time to log something. Returns true if

* The client has fully caught up with the node, OR
* The client is catching up and the block number is a multiple of 10.000

-}
shouldLog :: CatchingUp -> Bool
shouldLog :: CatchingUp -> Bool
shouldLog = \case
  CaughtUpWithNode{} -> Bool
True
  CatchingUpWithNode JSONChainPoint
_ (Just (JSONBlockNo -> BlockNo
unJSONBlockNo -> BlockNo Word64
n)) Maybe JSONChainPoint
_ -> Word64
n forall a. Integral a => a -> a -> a
`mod` Word64
10_000 forall a. Eq a => a -> a -> Bool
== Word64
0
  CatchingUpWithNode{} -> Bool
False

caughtUp :: CatchingUp -> Bool
caughtUp :: CatchingUp -> Bool
caughtUp = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. CatchingUp -> Bool
catchingUp

resumingFrom :: ResumingFrom -> CatchingUp
resumingFrom :: ResumingFrom -> CatchingUp
resumingFrom = \case
  R.ResumingFromChainPoint ChainPoint
cp ChainTip
st ->
    ChainPoint -> Maybe BlockNo -> Maybe ChainPoint -> CatchingUp
catchingUpWithNode ChainPoint
cp forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ChainTip -> ChainPoint
chainTipToChainPoint ChainTip
st)
  R.ResumingFromOrigin ChainTip
st        ->
    ChainPoint -> Maybe BlockNo -> Maybe ChainPoint -> CatchingUp
catchingUpWithNode ChainPoint
ChainPointAtGenesis forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ChainTip -> ChainPoint
chainTipToChainPoint ChainTip
st)

{-| Run the client until 'Nothing' is returned
-}
foldClient ::
  forall s.
  -- | Initial state
  s ->
  -- | Node connection data
  Env ->
  -- | Fold
  (CatchingUp -> s -> BlockInMode CardanoMode -> IO (Maybe s)) ->
  PipelinedLedgerStateClient
foldClient :: forall s.
s
-> Env
-> (CatchingUp -> s -> BlockInMode CardanoMode -> IO (Maybe s))
-> PipelinedLedgerStateClient
foldClient s
initialState Env
env CatchingUp -> s -> BlockInMode CardanoMode -> IO (Maybe s)
applyBlock =
  forall s w.
Monoid w =>
s
-> Env
-> (ChainPoint -> w -> s -> IO (w, s))
-> (CatchingUp
    -> s -> BlockInMode CardanoMode -> IO (Maybe (w, s)))
-> PipelinedLedgerStateClient
foldClient' @s @()
    s
initialState
    Env
env
    (\ChainPoint
_ ()
_ !s
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), s
s))
    (\CatchingUp
c !s
s -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CatchingUp -> s -> BlockInMode CardanoMode -> IO (Maybe s)
applyBlock CatchingUp
c s
s)

{-| A variant of 'foldClient' with more detailed control over rollbacks.
-}
foldClient' ::
  forall s w.
  Monoid w =>
  -- | Initial state
  s ->
  -- | Node connection data
  Env ->
  -- | Rollback
  (ChainPoint -> w -> s -> IO (w, s)) ->
  -- | Fold
  (CatchingUp -> s -> BlockInMode CardanoMode -> IO (Maybe (w, s))) -> -- ^ Fold
  PipelinedLedgerStateClient
foldClient' :: forall s w.
Monoid w =>
s
-> Env
-> (ChainPoint -> w -> s -> IO (w, s))
-> (CatchingUp
    -> s -> BlockInMode CardanoMode -> IO (Maybe (w, s)))
-> PipelinedLedgerStateClient
foldClient' s
initialState Env
env ChainPoint -> w -> s -> IO (w, s)
applyRollback CatchingUp -> s -> BlockInMode CardanoMode -> IO (Maybe (w, s))
applyBlock = ChainSyncClientPipelined
  (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> PipelinedLedgerStateClient
PipelinedLedgerStateClient forall a b. (a -> b) -> a -> b
$ forall header point tip (m :: * -> *) a.
m (ClientPipelinedStIdle 'Z header point tip m a)
-> ChainSyncClientPipelined header point tip m a
CSP.ChainSyncClientPipelined forall a b. (a -> b) -> a -> b
$ do

-- NB: The code below was adapted from https://input-output-hk.github.io/cardano-node/cardano-api/src/Cardano.Api.LedgerState.html#foldBlocks

  let
    pipelineSize :: Word32
pipelineSize = Word32
10 -- TODO: Configurable

    initialHistory :: History (w, s)
initialHistory = forall a. a -> History a
initialStateHistory (forall a. Monoid a => a
mempty, s
initialState)

    clientIdle_RequestMoreN
      :: forall n. WithOrigin BlockNo
      -> WithOrigin BlockNo
      -> Nat n -- Number of requests inflight.
      -> History (w, s)
      -> CSP.ClientPipelinedStIdle n ClientBlock ChainPoint ChainTip IO ()
    clientIdle_RequestMoreN :: forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History (w, s)
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
clientTip_ WithOrigin BlockNo
serverTip_ Nat n
n History (w, s)
history
      = case forall (n :: N).
Word32
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> PipelineDecision n
pipelineDecisionMax Word32
pipelineSize Nat n
n WithOrigin BlockNo
clientTip_ WithOrigin BlockNo
serverTip_  of
          PipelineDecision n
Collect -> case Nat n
n of
            Succ Nat n
predN -> forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CSP.CollectResponse forall a. Maybe a
Nothing (forall (n :: N).
Nat n
-> History (w, s)
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientNextN Nat n
predN History (w, s)
history)
          PipelineDecision n
_ -> forall (n :: N) header point tip (m :: * -> *) a.
ClientPipelinedStIdle ('S n) header point tip m a
-> ClientPipelinedStIdle n header point tip m a
CSP.SendMsgRequestNextPipelined (forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History (w, s)
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
clientTip_ WithOrigin BlockNo
serverTip_ (forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
n) History (w, s)
history)

    clientNextN
      :: Nat n
      -> History (w, s)
      -> ClientStNext n ClientBlock ChainPoint ChainTip IO ()
    clientNextN :: forall (n :: N).
Nat n
-> History (w, s)
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientNextN Nat n
n History (w, s)
history =
      ClientStNext {
          recvMsgRollForward :: BlockInMode CardanoMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
recvMsgRollForward = \BlockInMode CardanoMode
newBlock ChainTip
serverChainTip -> do
              let BlockInMode (Block bh :: BlockHeader
bh@(BlockHeader SlotNo
slotNo Hash BlockHeader
_blockHash BlockNo
currBlockNo) [Tx era]
_) EraInMode era CardanoMode
_ = BlockInMode CardanoMode
newBlock
                  newClientTip :: WithOrigin BlockNo
newClientTip = forall t. t -> WithOrigin t
At BlockNo
currBlockNo
                  newServerTip :: WithOrigin BlockNo
newServerTip = ChainTip -> WithOrigin BlockNo
fromChainTip ChainTip
serverChainTip
                  cu :: CatchingUp
cu = if WithOrigin BlockNo
newClientTip forall a. Eq a => a -> a -> Bool
== WithOrigin BlockNo
newServerTip
                        then ChainTip -> CatchingUp
caughtUpWithNode ChainTip
serverChainTip
                        else ChainPoint -> Maybe BlockNo -> Maybe ChainPoint -> CatchingUp
catchingUpWithNode (BlockHeader -> ChainPoint
blockHeaderPoint BlockHeader
bh) (forall a. a -> Maybe a
Just BlockNo
currBlockNo) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ChainTip -> ChainPoint
chainTipToChainPoint ChainTip
serverChainTip)
                  currentState :: s
currentState =
                    case forall a. Seq a -> ViewL a
Seq.viewl History (w, s)
history of
                      (SlotNo
_, (w
_, s
x)) Seq.:< History (w, s)
_ -> s
x
                      ViewL (SlotNo, (w, s))
Seq.EmptyL           -> forall a. HasCallStack => String -> a
error String
"foldClient: clientNextN: Impossible - empty history!"

              Maybe (w, s)
newState <- CatchingUp -> s -> BlockInMode CardanoMode -> IO (Maybe (w, s))
applyBlock CatchingUp
cu s
currentState BlockInMode CardanoMode
newBlock
              case Maybe (w, s)
newState of
                Maybe (w, s)
Nothing -> do
                  forall (n :: N).
Nat n
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n
                Just !(w, s)
s' -> do
                  let (History (w, s)
newHistory, History (w, s)
_) = forall a. Env -> History a -> SlotNo -> a -> (History a, History a)
pushHistoryState Env
env History (w, s)
history SlotNo
slotNo (w, s)
s'
                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History (w, s)
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
newClientTip WithOrigin BlockNo
newServerTip Nat n
n History (w, s)
newHistory)
        , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
recvMsgRollBackward = \ChainPoint
chainPoint ChainTip
serverChainTip -> do
            let newClientTip :: WithOrigin t
newClientTip = forall t. WithOrigin t
Origin
                newServerTip :: WithOrigin BlockNo
newServerTip = ChainTip -> WithOrigin BlockNo
fromChainTip ChainTip
serverChainTip
                (History (w, s)
rolledBack, History (w, s)
truncatedHistory) = case ChainPoint
chainPoint of
                    ChainPoint
ChainPointAtGenesis -> (forall a. Seq a
Seq.empty, History (w, s)
initialHistory)
                    ChainPoint SlotNo
slotNo Hash BlockHeader
_ -> forall a. History a -> SlotNo -> (History a, History a)
rollbackStateHistory History (w, s)
history SlotNo
slotNo
                (SlotNo
lastSlotNo, s
currentState) =
                    case forall a. Seq a -> ViewL a
Seq.viewl History (w, s)
truncatedHistory of
                      (SlotNo
n', (w
_, s
x)) Seq.:< History (w, s)
_ -> (SlotNo
n', s
x)
                      ViewL (SlotNo, (w, s))
Seq.EmptyL      -> forall a. HasCallStack => String -> a
error String
"foldClient: clientNextN: Impossible - empty history after rollback!"
            !(w, s)
rolledBackState <- ChainPoint -> w -> s -> IO (w, s)
applyRollback ChainPoint
chainPoint (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) History (w, s)
rolledBack) s
currentState
            let (History (w, s)
newHistory, History (w, s)
_) = forall a. Env -> History a -> SlotNo -> a -> (History a, History a)
pushHistoryState Env
env History (w, s)
truncatedHistory SlotNo
lastSlotNo (w, s)
rolledBackState
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History (w, s)
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN forall t. WithOrigin t
newClientTip WithOrigin BlockNo
newServerTip Nat n
n History (w, s)
newHistory)
        }

    clientIdle_DoneN
      :: Nat n
      -> IO (ClientPipelinedStIdle n ClientBlock ChainPoint ChainTip IO ())
    clientIdle_DoneN :: forall (n :: N).
Nat n
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n = case Nat n
n of
      Succ Nat n
predN -> do
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CollectResponse forall a. Maybe a
Nothing (forall (n :: N).
Nat n
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientNext_DoneN Nat n
predN) -- Ignore remaining message responses
      Nat n
Zero -> do
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a header point tip (m :: * -> *).
a -> ClientPipelinedStIdle 'Z header point tip m a
SendMsgDone ()

    clientNext_DoneN
      :: Nat n
      -> ClientStNext n ClientBlock ChainPoint ChainTip IO ()
    clientNext_DoneN :: forall (n :: N).
Nat n
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientNext_DoneN Nat n
n =
      ClientStNext {
          recvMsgRollForward :: BlockInMode CardanoMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
recvMsgRollForward = \BlockInMode CardanoMode
_ ChainTip
_ -> forall (n :: N).
Nat n
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n
        , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
recvMsgRollBackward = \ChainPoint
_ ChainTip
_ -> forall (n :: N).
Nat n
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n
        }

  forall (m :: * -> *) a. Monad m => a -> m a
return (forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History (w, s)
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN forall t. WithOrigin t
Origin forall t. WithOrigin t
Origin forall (n :: N). ('Z ~ n) => Nat n
Zero History (w, s)
initialHistory)

-- | A history of the last @k@ states
type History a = Seq (SlotNo, a)

-- | Add a new state to the history
pushHistoryState
  :: -- | Environement used to get the security param, k.
    Env
     -- | History of k items.
  -> History a
     -- | Slot number of the new item.
  -> SlotNo
     -- | New item to add to the history
  -> a
  -- | ( The new history with the new item appended
  --   , Any exisiting items that are now past the security parameter
  --      and hence can no longer be rolled back.
  --   )
  -> (History a, History a)

pushHistoryState :: forall a. Env -> History a -> SlotNo -> a -> (History a, History a)
pushHistoryState Env
env History a
hist SlotNo
ix a
st
  = forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Env -> Word64
envSecurityParam Env
env forall a. Num a => a -> a -> a
+ Word64
1)
      ((SlotNo
ix, a
st) forall a. a -> Seq a -> Seq a
Seq.:<| History a
hist)

-- | Split the history into bits that have been rolled back (1st elemnt) and
--   bits that have not been rolled back (2nd element)
rollbackStateHistory :: History a -> SlotNo -> (History a, History a)
rollbackStateHistory :: forall a. History a -> SlotNo -> (History a, History a)
rollbackStateHistory History a
hist SlotNo
maxInc = forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.spanl ((forall a. Ord a => a -> a -> Bool
> SlotNo
maxInc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(SlotNo
x,a
_) -> SlotNo
x)) History a
hist

initialStateHistory :: a -> History a
initialStateHistory :: forall a. a -> History a
initialStateHistory a
a = forall a. a -> Seq a
Seq.singleton (SlotNo
0, a
a)