Add to FoldStatus

cardano-api/internal/Cardano/Api/LedgerState.hs

@@ -347,6 +347,14 @@ renderFoldBlocksError fbe = case fbe of
   FoldBlocksInitialLedgerStateError err -> renderInitialLedgerStateError err
   FoldBlocksApplyBlockError err -> "Failed when applying a block: " <> renderLedgerStateError err
 
+-- Type that lets us decide whether to continue or stop
+-- the fold from within our accumulation function.
+data FoldStatus
+  = ContinueFold
+  | StopFold
+  | DebugFold
+  deriving (Show, Eq)
+
 -- | Monadic fold over all blocks and ledger states. Stopping @k@ blocks before
 -- the node's tip where @k@ is the security parameter.
 foldBlocks
@@ -359,7 +367,7 @@ foldBlocks
   -> ValidationMode
   -> a
   -- ^ The initial accumulator state.
-  -> (Env -> LedgerState -> [LedgerEvent] -> BlockInMode CardanoMode -> a -> IO (a, Bool))
+  -> (Env -> LedgerState -> [LedgerEvent] -> BlockInMode CardanoMode -> a -> IO (a, FoldStatus))
   -- ^ Accumulator function Takes:
   --
   --  * Environment (this is a constant over the whole fold).
@@ -495,11 +503,11 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do
                       let (knownLedgerStates', committedStates) = pushLedgerState env knownLedgerStates slotNo newLedgerState blockInMode
                           newClientTip = At currBlockNo
                           newServerTip = fromChainTip serverChainTip
-                      -- TODO: The issue is you are mapping over all the commited states
-                      -- and at the end updating your IORef. So your IORef contains whatever the last
-                      -- known ledger state was.
-                      terminations <- forM knownLedgerStates' $ \(_, (ledgerState, ledgerEvents), currBlockMay) -> case currBlockMay of
-                          Origin -> pure False
+                      -- TODO: We are constantly overwriting an IORef which isn't ideal.
+                      -- We should be writing to a TChan so that we don't have to return the
+                      -- concatenation of all the ledger events in the accumulation function.
+                      foldStatuses <- forM knownLedgerStates' $ \(_, (ledgerState, ledgerEvents), currBlockMay) -> case currBlockMay of
+                          Origin -> pure ContinueFold
                           At currBlock -> do
                             (newState, terminate) <- accumulate
                               env
@@ -509,15 +517,19 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do
                               =<< readIORef stateIORef
                             atomicWriteIORef stateIORef newState
                             return terminate
-                      if or $ toList terminations
-                        -- We return True in our accumulate function if we want to terminate the fold.
-                        -- This allow us to check for a specific condition in our accumulate function
-                        -- and then terminate e.g a specific stake pool was registered
-                        then do
+                      case foldDecision foldStatuses of
+                        StopFold ->
+                          -- We return StopFold in our accumulate function if we want to terminate the fold.
+                          -- This allow us to check for a specific condition in our accumulate function
+                          -- and then terminate e.g a specific stake pool was registered
+                          let noError = Nothing
+                          in clientIdle_DoneNwithMaybeError n noError
+
+                        DebugFold -> do
                           currentIORefState <- readIORef stateIORef
 
                           -- Useful for debugging:
-                          let _ioRefErr = Just $ PlaceHolderError $ unlines [ "newClientTip: " <> show newClientTip
+                          let ioRefErr = Just $ PlaceHolderError $ unlines [ "newClientTip: " <> show newClientTip
                                                                            , "newServerTip: " <> show newServerTip
                                                                            , "newLedgerState: " <> show (snd newLedgerState)
                                                                            , "knownLedgerStates: " <> show (extractHistory knownLedgerStates)
@@ -526,9 +538,10 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do
                                                                            , "k: " <> show (envSecurityParam env)
                                                                            , "Current IORef State: " <> show currentIORefState
                                                                            ]
-                              noError = Nothing
-                          clientIdle_DoneNwithMaybeError n noError
-                        else return (clientIdle_RequestMoreN newClientTip newServerTip n knownLedgerStates')
+                          clientIdle_DoneNwithMaybeError n ioRefErr
+
+                        ContinueFold -> return $ clientIdle_RequestMoreN newClientTip newServerTip n knownLedgerStates'
+
               , CSP.recvMsgRollBackward = \chainPoint serverChainTip -> do
                   let newClientTip = Origin -- We don't actually keep track of blocks so we temporarily "forget" the tip.
                       newServerTip = fromChainTip serverChainTip
@@ -563,6 +576,12 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do
             ChainTipAtGenesis -> Origin
             ChainTip _ _ bno -> At bno
 
+foldDecision :: Seq FoldStatus -> FoldStatus
+foldDecision foldStatuses
+  | StopFold `List.elem` toList foldStatuses = StopFold
+  | DebugFold `List.elem` toList foldStatuses = DebugFold
+  | otherwise = ContinueFold
+
 -- | Wrap a 'ChainSyncClient' with logic that tracks the ledger state.
 chainSyncClientWithLedgerState
   :: forall m a.