{-# LANGUAGE BangPatterns           #-}
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE DeriveAnyClass         #-}
{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE QuantifiedConstraints  #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE UndecidableInstances   #-}

module Ouroboros.Consensus.Storage.LedgerDB.InMemory (
     -- * LedgerDB proper
     LedgerDB
   , LedgerDbParams(..)
   , ledgerDbDefaultParams
   , ledgerDbWithAnchor
   , ledgerDbFromGenesis
     -- ** ChainSummary
   , ChainSummary(..)
   , encodeChainSummary
   , decodeChainSummary
     -- ** Queries
   , ledgerDbCurrent
   , ledgerDbTip
   , ledgerDbAnchor
     -- ** Past ledger states
   , ledgerDbPast
   , ledgerDbPastLedgers
     -- ** Running updates
   , Ap(..)
   , AnnLedgerError(..)
   , ResolveBlock
   , ResolvesBlocks(..)
   , ThrowsLedgerError(..)
   , defaultThrowLedgerErrors
   , defaultResolveBlocks
   , defaultResolveWithErrors
     -- ** Updates
   , ExceededRollback(..)
   , ledgerDbPush
   , ledgerDbSwitch
     -- * Exports for the benefit of tests
     -- ** Additional queries
   , ledgerDbChainLength
   , ledgerDbToList
   , ledgerDbMaxRollback
   , ledgerDbSnapshots
   , ledgerDbIsSaturated
   , ledgerDbCountToPrune
   , ledgerDbPastSpec
     -- ** Pure API
   , ledgerDbPush'
   , ledgerDbPushMany'
   , ledgerDbSwitch'
   ) where

import           Codec.Serialise (Serialise (..))
import           Codec.Serialise.Decoding (Decoder)
import qualified Codec.Serialise.Decoding as Dec
import           Codec.Serialise.Encoding (Encoding)
import qualified Codec.Serialise.Encoding as Enc
import           Control.Monad.Except hiding (ap)
import           Control.Monad.Reader hiding (ap)
import           Data.Foldable (find, toList)
import           Data.Function (on)
import           Data.Functor.Identity
import           Data.Kind (Constraint, Type)
import           Data.Proxy
import qualified Data.Sequence as LazySeq
import           Data.Sequence.Strict (StrictSeq ((:|>), Empty), (|>))
import qualified Data.Sequence.Strict as Seq
import           Data.Word
import           GHC.Generics (Generic)
import           GHC.Stack (HasCallStack)
import           NoThunks.Class (NoThunks)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ticked
import           Ouroboros.Consensus.Util
import           Ouroboros.Consensus.Util.CBOR (decodeWithOrigin,
                     encodeWithOrigin)

{-------------------------------------------------------------------------------
  Ledger DB types
-------------------------------------------------------------------------------}

-- | Internal state of the ledger DB
--
-- The ledger DB looks like
--
-- > anchor |> snapshots <| current
--
-- where @anchor@ records the oldest known snapshot and @current@ the most
-- recent. The anchor is the oldest point we can roll back to.
--
-- We take a snapshot after each block is applied and keep in memory a window
-- of the last @k@ snapshots. We have verified empirically (#1936) that the
-- overhead of keeping @k snapshots in memory is small, i.e., about 5%
-- compared to keeping a snapshot every 100 blocks. This is thanks to sharing
-- between consecutive snapshots.
--
-- As an example, suppose we have @k = 6@. The ledger DB grows as illustrated
-- below, where we indicate the anchor number of blocks, the stored snapshots,
-- and the current ledger.
--
-- > anchor |> #   [ snapshots ]                   <| tip
-- > ---------------------------------------------------------------------------
-- > G      |> (0) [ ]                             <| G
-- > G      |> (1) [ L1]                           <| L1
-- > G      |> (2) [ L1,  L2]                      <| L2
-- > G      |> (3) [ L1,  L2,  L3]                 <| L3
-- > G      |> (4) [ L1,  L2,  L3,  L4]            <| L4
-- > G      |> (5) [ L1,  L2,  L3,  L4,  L5]       <| L5
-- > G      |> (6) [ L1,  L2,  L3,  L4,  L5,  L6]  <| L6
-- > L1     |> (6) [ L2,  L3,  L4,  L5,  L6,  L7]  <| L7
-- > L2     |> (6) [ L3,  L4,  L5,  L6,  L7,  L8]  <| L8
-- > L3     |> (6) [ L4,  L5,  L6,  L7,  L8,  L9]  <| L9   (*)
-- > L4     |> (6) [ L5,  L6,  L7,  L8,  L9,  L10] <| L10
-- > L5     |> (6) [*L6,  L7,  L8,  L9,  L10, L11] <| L11
-- > L6     |> (6) [ L7,  L8,  L9,  L10, L11, L12] <| L12
-- > L7     |> (6) [ L8,  L9,  L10, L12, L12, L13] <| L13
-- > L8     |> (6) [ L9,  L10, L12, L12, L13, L14] <| L14
--
-- The ledger DB must guarantee that at all times we are able to roll back @k@
-- blocks. For example, if we are on line (*), and roll back 6 blocks, we get
--
-- > L3 |> []
data LedgerDB l r = LedgerDB {
      -- | Older ledger states
      LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbCheckpoints :: !(StrictSeq (Checkpoint l r))

      -- | Information about the state of the ledger /before/
    , LedgerDB l r -> ChainSummary l r
ledgerDbAnchor      :: !(ChainSummary l r)

      -- | Ledger DB parameters
    , LedgerDB l r -> LedgerDbParams
ledgerDbParams      :: !LedgerDbParams
    }
  deriving (Int -> LedgerDB l r -> ShowS
[LedgerDB l r] -> ShowS
LedgerDB l r -> String
(Int -> LedgerDB l r -> ShowS)
-> (LedgerDB l r -> String)
-> ([LedgerDB l r] -> ShowS)
-> Show (LedgerDB l r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall l r. (Show r, Show l) => Int -> LedgerDB l r -> ShowS
forall l r. (Show r, Show l) => [LedgerDB l r] -> ShowS
forall l r. (Show r, Show l) => LedgerDB l r -> String
showList :: [LedgerDB l r] -> ShowS
$cshowList :: forall l r. (Show r, Show l) => [LedgerDB l r] -> ShowS
show :: LedgerDB l r -> String
$cshow :: forall l r. (Show r, Show l) => LedgerDB l r -> String
showsPrec :: Int -> LedgerDB l r -> ShowS
$cshowsPrec :: forall l r. (Show r, Show l) => Int -> LedgerDB l r -> ShowS
Show, LedgerDB l r -> LedgerDB l r -> Bool
(LedgerDB l r -> LedgerDB l r -> Bool)
-> (LedgerDB l r -> LedgerDB l r -> Bool) -> Eq (LedgerDB l r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall l r. (Eq r, Eq l) => LedgerDB l r -> LedgerDB l r -> Bool
/= :: LedgerDB l r -> LedgerDB l r -> Bool
$c/= :: forall l r. (Eq r, Eq l) => LedgerDB l r -> LedgerDB l r -> Bool
== :: LedgerDB l r -> LedgerDB l r -> Bool
$c== :: forall l r. (Eq r, Eq l) => LedgerDB l r -> LedgerDB l r -> Bool
Eq, (forall x. LedgerDB l r -> Rep (LedgerDB l r) x)
-> (forall x. Rep (LedgerDB l r) x -> LedgerDB l r)
-> Generic (LedgerDB l r)
forall x. Rep (LedgerDB l r) x -> LedgerDB l r
forall x. LedgerDB l r -> Rep (LedgerDB l r) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l r x. Rep (LedgerDB l r) x -> LedgerDB l r
forall l r x. LedgerDB l r -> Rep (LedgerDB l r) x
$cto :: forall l r x. Rep (LedgerDB l r) x -> LedgerDB l r
$cfrom :: forall l r x. LedgerDB l r -> Rep (LedgerDB l r) x
Generic, Context -> LedgerDB l r -> IO (Maybe ThunkInfo)
Proxy (LedgerDB l r) -> String
(Context -> LedgerDB l r -> IO (Maybe ThunkInfo))
-> (Context -> LedgerDB l r -> IO (Maybe ThunkInfo))
-> (Proxy (LedgerDB l r) -> String)
-> NoThunks (LedgerDB l r)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall l r.
(NoThunks r, NoThunks l) =>
Context -> LedgerDB l r -> IO (Maybe ThunkInfo)
forall l r.
(NoThunks r, NoThunks l) =>
Proxy (LedgerDB l r) -> String
showTypeOf :: Proxy (LedgerDB l r) -> String
$cshowTypeOf :: forall l r.
(NoThunks r, NoThunks l) =>
Proxy (LedgerDB l r) -> String
wNoThunks :: Context -> LedgerDB l r -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall l r.
(NoThunks r, NoThunks l) =>
Context -> LedgerDB l r -> IO (Maybe ThunkInfo)
noThunks :: Context -> LedgerDB l r -> IO (Maybe ThunkInfo)
$cnoThunks :: forall l r.
(NoThunks r, NoThunks l) =>
Context -> LedgerDB l r -> IO (Maybe ThunkInfo)
NoThunks)

newtype LedgerDbParams = LedgerDbParams {
      -- | Security parameter (maximum rollback)
      LedgerDbParams -> SecurityParam
ledgerDbSecurityParam :: SecurityParam
    }
  deriving (Int -> LedgerDbParams -> ShowS
[LedgerDbParams] -> ShowS
LedgerDbParams -> String
(Int -> LedgerDbParams -> ShowS)
-> (LedgerDbParams -> String)
-> ([LedgerDbParams] -> ShowS)
-> Show LedgerDbParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LedgerDbParams] -> ShowS
$cshowList :: [LedgerDbParams] -> ShowS
show :: LedgerDbParams -> String
$cshow :: LedgerDbParams -> String
showsPrec :: Int -> LedgerDbParams -> ShowS
$cshowsPrec :: Int -> LedgerDbParams -> ShowS
Show, LedgerDbParams -> LedgerDbParams -> Bool
(LedgerDbParams -> LedgerDbParams -> Bool)
-> (LedgerDbParams -> LedgerDbParams -> Bool) -> Eq LedgerDbParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LedgerDbParams -> LedgerDbParams -> Bool
$c/= :: LedgerDbParams -> LedgerDbParams -> Bool
== :: LedgerDbParams -> LedgerDbParams -> Bool
$c== :: LedgerDbParams -> LedgerDbParams -> Bool
Eq, (forall x. LedgerDbParams -> Rep LedgerDbParams x)
-> (forall x. Rep LedgerDbParams x -> LedgerDbParams)
-> Generic LedgerDbParams
forall x. Rep LedgerDbParams x -> LedgerDbParams
forall x. LedgerDbParams -> Rep LedgerDbParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LedgerDbParams x -> LedgerDbParams
$cfrom :: forall x. LedgerDbParams -> Rep LedgerDbParams x
Generic, Context -> LedgerDbParams -> IO (Maybe ThunkInfo)
Proxy LedgerDbParams -> String
(Context -> LedgerDbParams -> IO (Maybe ThunkInfo))
-> (Context -> LedgerDbParams -> IO (Maybe ThunkInfo))
-> (Proxy LedgerDbParams -> String)
-> NoThunks LedgerDbParams
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy LedgerDbParams -> String
$cshowTypeOf :: Proxy LedgerDbParams -> String
wNoThunks :: Context -> LedgerDbParams -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LedgerDbParams -> IO (Maybe ThunkInfo)
noThunks :: Context -> LedgerDbParams -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> LedgerDbParams -> IO (Maybe ThunkInfo)
NoThunks)

-- | Default parameters
ledgerDbDefaultParams :: SecurityParam -> LedgerDbParams
ledgerDbDefaultParams :: SecurityParam -> LedgerDbParams
ledgerDbDefaultParams SecurityParam
securityParam = LedgerDbParams :: SecurityParam -> LedgerDbParams
LedgerDbParams {
      ledgerDbSecurityParam :: SecurityParam
ledgerDbSecurityParam = SecurityParam
securityParam
    }

{-------------------------------------------------------------------------------
  Ticking
-------------------------------------------------------------------------------}

-- | Ticking the ledger DB just ticks the current state
--
-- We don't push the new state into the DB until we apply a block.
data instance Ticked (LedgerDB l r) = TickedLedgerDB {
      Ticked (LedgerDB l r) -> Ticked l
tickedLedgerDbTicked :: Ticked l
    , Ticked (LedgerDB l r) -> LedgerDB l r
tickedLedgerDbOrig   :: LedgerDB l r
    }

{-------------------------------------------------------------------------------
  Internal: checkpoints
-------------------------------------------------------------------------------}

-- | Checkpoint with a ledger state
data Checkpoint l r = Checkpoint {
      Checkpoint l r -> r
cpBlock :: !r
    , Checkpoint l r -> l
cpState :: !l
    }
  deriving (Int -> Checkpoint l r -> ShowS
[Checkpoint l r] -> ShowS
Checkpoint l r -> String
(Int -> Checkpoint l r -> ShowS)
-> (Checkpoint l r -> String)
-> ([Checkpoint l r] -> ShowS)
-> Show (Checkpoint l r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall l r. (Show r, Show l) => Int -> Checkpoint l r -> ShowS
forall l r. (Show r, Show l) => [Checkpoint l r] -> ShowS
forall l r. (Show r, Show l) => Checkpoint l r -> String
showList :: [Checkpoint l r] -> ShowS
$cshowList :: forall l r. (Show r, Show l) => [Checkpoint l r] -> ShowS
show :: Checkpoint l r -> String
$cshow :: forall l r. (Show r, Show l) => Checkpoint l r -> String
showsPrec :: Int -> Checkpoint l r -> ShowS
$cshowsPrec :: forall l r. (Show r, Show l) => Int -> Checkpoint l r -> ShowS
Show, Checkpoint l r -> Checkpoint l r -> Bool
(Checkpoint l r -> Checkpoint l r -> Bool)
-> (Checkpoint l r -> Checkpoint l r -> Bool)
-> Eq (Checkpoint l r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall l r.
(Eq r, Eq l) =>
Checkpoint l r -> Checkpoint l r -> Bool
/= :: Checkpoint l r -> Checkpoint l r -> Bool
$c/= :: forall l r.
(Eq r, Eq l) =>
Checkpoint l r -> Checkpoint l r -> Bool
== :: Checkpoint l r -> Checkpoint l r -> Bool
$c== :: forall l r.
(Eq r, Eq l) =>
Checkpoint l r -> Checkpoint l r -> Bool
Eq, (forall x. Checkpoint l r -> Rep (Checkpoint l r) x)
-> (forall x. Rep (Checkpoint l r) x -> Checkpoint l r)
-> Generic (Checkpoint l r)
forall x. Rep (Checkpoint l r) x -> Checkpoint l r
forall x. Checkpoint l r -> Rep (Checkpoint l r) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l r x. Rep (Checkpoint l r) x -> Checkpoint l r
forall l r x. Checkpoint l r -> Rep (Checkpoint l r) x
$cto :: forall l r x. Rep (Checkpoint l r) x -> Checkpoint l r
$cfrom :: forall l r x. Checkpoint l r -> Rep (Checkpoint l r) x
Generic, Context -> Checkpoint l r -> IO (Maybe ThunkInfo)
Proxy (Checkpoint l r) -> String
(Context -> Checkpoint l r -> IO (Maybe ThunkInfo))
-> (Context -> Checkpoint l r -> IO (Maybe ThunkInfo))
-> (Proxy (Checkpoint l r) -> String)
-> NoThunks (Checkpoint l r)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall l r.
(NoThunks r, NoThunks l) =>
Context -> Checkpoint l r -> IO (Maybe ThunkInfo)
forall l r.
(NoThunks r, NoThunks l) =>
Proxy (Checkpoint l r) -> String
showTypeOf :: Proxy (Checkpoint l r) -> String
$cshowTypeOf :: forall l r.
(NoThunks r, NoThunks l) =>
Proxy (Checkpoint l r) -> String
wNoThunks :: Context -> Checkpoint l r -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall l r.
(NoThunks r, NoThunks l) =>
Context -> Checkpoint l r -> IO (Maybe ThunkInfo)
noThunks :: Context -> Checkpoint l r -> IO (Maybe ThunkInfo)
$cnoThunks :: forall l r.
(NoThunks r, NoThunks l) =>
Context -> Checkpoint l r -> IO (Maybe ThunkInfo)
NoThunks)

cpToPair :: Checkpoint l r -> (r, l)
cpToPair :: Checkpoint l r -> (r, l)
cpToPair (Checkpoint r
r l
l) = (r
r, l
l)

{-------------------------------------------------------------------------------
  Chain summary
-------------------------------------------------------------------------------}

-- | Summary of the chain at a particular point in time
data ChainSummary l r = ChainSummary {
      -- | The tip of the chain
      ChainSummary l r -> WithOrigin r
csTip    :: !(WithOrigin r)

      -- | Length of the chain
    , ChainSummary l r -> Word64
csLength :: !Word64

      -- | Ledger state
    , ChainSummary l r -> l
csLedger :: !l
    }
  deriving (Int -> ChainSummary l r -> ShowS
[ChainSummary l r] -> ShowS
ChainSummary l r -> String
(Int -> ChainSummary l r -> ShowS)
-> (ChainSummary l r -> String)
-> ([ChainSummary l r] -> ShowS)
-> Show (ChainSummary l r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall l r. (Show r, Show l) => Int -> ChainSummary l r -> ShowS
forall l r. (Show r, Show l) => [ChainSummary l r] -> ShowS
forall l r. (Show r, Show l) => ChainSummary l r -> String
showList :: [ChainSummary l r] -> ShowS
$cshowList :: forall l r. (Show r, Show l) => [ChainSummary l r] -> ShowS
show :: ChainSummary l r -> String
$cshow :: forall l r. (Show r, Show l) => ChainSummary l r -> String
showsPrec :: Int -> ChainSummary l r -> ShowS
$cshowsPrec :: forall l r. (Show r, Show l) => Int -> ChainSummary l r -> ShowS
Show, ChainSummary l r -> ChainSummary l r -> Bool
(ChainSummary l r -> ChainSummary l r -> Bool)
-> (ChainSummary l r -> ChainSummary l r -> Bool)
-> Eq (ChainSummary l r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall l r.
(Eq r, Eq l) =>
ChainSummary l r -> ChainSummary l r -> Bool
/= :: ChainSummary l r -> ChainSummary l r -> Bool
$c/= :: forall l r.
(Eq r, Eq l) =>
ChainSummary l r -> ChainSummary l r -> Bool
== :: ChainSummary l r -> ChainSummary l r -> Bool
$c== :: forall l r.
(Eq r, Eq l) =>
ChainSummary l r -> ChainSummary l r -> Bool
Eq, (forall x. ChainSummary l r -> Rep (ChainSummary l r) x)
-> (forall x. Rep (ChainSummary l r) x -> ChainSummary l r)
-> Generic (ChainSummary l r)
forall x. Rep (ChainSummary l r) x -> ChainSummary l r
forall x. ChainSummary l r -> Rep (ChainSummary l r) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l r x. Rep (ChainSummary l r) x -> ChainSummary l r
forall l r x. ChainSummary l r -> Rep (ChainSummary l r) x
$cto :: forall l r x. Rep (ChainSummary l r) x -> ChainSummary l r
$cfrom :: forall l r x. ChainSummary l r -> Rep (ChainSummary l r) x
Generic, Context -> ChainSummary l r -> IO (Maybe ThunkInfo)
Proxy (ChainSummary l r) -> String
(Context -> ChainSummary l r -> IO (Maybe ThunkInfo))
-> (Context -> ChainSummary l r -> IO (Maybe ThunkInfo))
-> (Proxy (ChainSummary l r) -> String)
-> NoThunks (ChainSummary l r)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall l r.
(NoThunks r, NoThunks l) =>
Context -> ChainSummary l r -> IO (Maybe ThunkInfo)
forall l r.
(NoThunks r, NoThunks l) =>
Proxy (ChainSummary l r) -> String
showTypeOf :: Proxy (ChainSummary l r) -> String
$cshowTypeOf :: forall l r.
(NoThunks r, NoThunks l) =>
Proxy (ChainSummary l r) -> String
wNoThunks :: Context -> ChainSummary l r -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall l r.
(NoThunks r, NoThunks l) =>
Context -> ChainSummary l r -> IO (Maybe ThunkInfo)
noThunks :: Context -> ChainSummary l r -> IO (Maybe ThunkInfo)
$cnoThunks :: forall l r.
(NoThunks r, NoThunks l) =>
Context -> ChainSummary l r -> IO (Maybe ThunkInfo)
NoThunks)

genesisChainSummary :: l -> ChainSummary l r
genesisChainSummary :: l -> ChainSummary l r
genesisChainSummary l
l = WithOrigin r -> Word64 -> l -> ChainSummary l r
forall l r. WithOrigin r -> Word64 -> l -> ChainSummary l r
ChainSummary WithOrigin r
forall t. WithOrigin t
Origin Word64
0 l
l

{-------------------------------------------------------------------------------
  LedgerDB proper
-------------------------------------------------------------------------------}

-- | Ledger DB starting at the specified ledger state
ledgerDbWithAnchor :: LedgerDbParams -> ChainSummary l r -> LedgerDB l r
ledgerDbWithAnchor :: LedgerDbParams -> ChainSummary l r -> LedgerDB l r
ledgerDbWithAnchor LedgerDbParams
params ChainSummary l r
anchor = LedgerDB :: forall l r.
StrictSeq (Checkpoint l r)
-> ChainSummary l r -> LedgerDbParams -> LedgerDB l r
LedgerDB {
      ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbCheckpoints = StrictSeq (Checkpoint l r)
forall a. StrictSeq a
Seq.empty
    , ledgerDbAnchor :: ChainSummary l r
ledgerDbAnchor      = ChainSummary l r
anchor
    , ledgerDbParams :: LedgerDbParams
ledgerDbParams      = LedgerDbParams
params
    }

ledgerDbFromGenesis :: LedgerDbParams -> l -> LedgerDB l r
ledgerDbFromGenesis :: LedgerDbParams -> l -> LedgerDB l r
ledgerDbFromGenesis LedgerDbParams
params = LedgerDbParams -> ChainSummary l r -> LedgerDB l r
forall l r. LedgerDbParams -> ChainSummary l r -> LedgerDB l r
ledgerDbWithAnchor LedgerDbParams
params (ChainSummary l r -> LedgerDB l r)
-> (l -> ChainSummary l r) -> l -> LedgerDB l r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l -> ChainSummary l r
forall l r. l -> ChainSummary l r
genesisChainSummary

{-------------------------------------------------------------------------------
  Compute signature

  Depending on the parameters (apply by value or by reference, previously
  applied or not) we get different signatures.
-------------------------------------------------------------------------------}

-- | Resolve a block
--
-- Resolving a block reference to the actual block lives in @m@ because
-- it might need to read the block from disk (and can therefore not be
-- done inside an STM transaction).
--
-- NOTE: The ledger DB will only ask the 'ChainDB' for blocks it knows
-- must exist. If the 'ChainDB' is unable to fulfill the request, data
-- corruption must have happened and the 'ChainDB' should trigger
-- validation mode.
type ResolveBlock m r b = r -> m b

-- | Annotated ledger errors
data AnnLedgerError l r = AnnLedgerError {
      -- | The ledger DB just /before/ this block was applied
      AnnLedgerError l r -> LedgerDB l r
annLedgerState  :: LedgerDB l r

      -- | Reference to the block that had the error
    , AnnLedgerError l r -> r
annLedgerErrRef :: r

      -- | The ledger error itself
    , AnnLedgerError l r -> LedgerErr l
annLedgerErr    :: LedgerErr l
    }

-- | Monads in which we can resolve blocks
--
-- To guide type inference, we insist that we must be able to infer the type
-- of the block we are resolving from the type of the monad.
class Monad m => ResolvesBlocks r b m | m -> b where
  resolveBlock :: r -> m b

instance Monad m => ResolvesBlocks r b (ReaderT (ResolveBlock m r b) m) where
  resolveBlock :: r -> ReaderT (ResolveBlock m r b) m b
resolveBlock r
r = (ResolveBlock m r b -> m b) -> ReaderT (ResolveBlock m r b) m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((ResolveBlock m r b -> m b) -> ReaderT (ResolveBlock m r b) m b)
-> (ResolveBlock m r b -> m b) -> ReaderT (ResolveBlock m r b) m b
forall a b. (a -> b) -> a -> b
$ \ResolveBlock m r b
f -> ResolveBlock m r b
f r
r

defaultResolveBlocks :: ResolveBlock m r b
                     -> ReaderT (ResolveBlock m r b) m a
                     -> m a
defaultResolveBlocks :: ResolveBlock m r b -> ReaderT (ResolveBlock m r b) m a -> m a
defaultResolveBlocks = (ReaderT (ResolveBlock m r b) m a -> ResolveBlock m r b -> m a)
-> ResolveBlock m r b -> ReaderT (ResolveBlock m r b) m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (ResolveBlock m r b) m a -> ResolveBlock m r b -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT

-- Quite a specific instance so we can satisfy the fundep
instance Monad m
      => ResolvesBlocks r b (ExceptT e (ReaderT (ResolveBlock m r b) m)) where
  resolveBlock :: r -> ExceptT e (ReaderT (ResolveBlock m r b) m) b
resolveBlock = ReaderT (ResolveBlock m r b) m b
-> ExceptT e (ReaderT (ResolveBlock m r b) m) b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (ResolveBlock m r b) m b
 -> ExceptT e (ReaderT (ResolveBlock m r b) m) b)
-> (r -> ReaderT (ResolveBlock m r b) m b)
-> r
-> ExceptT e (ReaderT (ResolveBlock m r b) m) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> ReaderT (ResolveBlock m r b) m b
forall r b (m :: * -> *). ResolvesBlocks r b m => r -> m b
resolveBlock

class Monad m => ThrowsLedgerError l r m where
  throwLedgerError :: LedgerDB l r -> r -> LedgerErr l -> m a

defaultThrowLedgerErrors :: ExceptT (AnnLedgerError l r) m a
                         -> m (Either (AnnLedgerError l r) a)
defaultThrowLedgerErrors :: ExceptT (AnnLedgerError l r) m a
-> m (Either (AnnLedgerError l r) a)
defaultThrowLedgerErrors = ExceptT (AnnLedgerError l r) m a
-> m (Either (AnnLedgerError l r) a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

defaultResolveWithErrors :: ResolveBlock m r b
                         -> ExceptT (AnnLedgerError l r)
                                    (ReaderT (ResolveBlock m r b) m)
                                    a
                         -> m (Either (AnnLedgerError l r) a)
defaultResolveWithErrors :: ResolveBlock m r b
-> ExceptT (AnnLedgerError l r) (ReaderT (ResolveBlock m r b) m) a
-> m (Either (AnnLedgerError l r) a)
defaultResolveWithErrors ResolveBlock m r b
resolve =
      ResolveBlock m r b
-> ReaderT (ResolveBlock m r b) m (Either (AnnLedgerError l r) a)
-> m (Either (AnnLedgerError l r) a)
forall (m :: * -> *) r b a.
ResolveBlock m r b -> ReaderT (ResolveBlock m r b) m a -> m a
defaultResolveBlocks ResolveBlock m r b
resolve
    (ReaderT (ResolveBlock m r b) m (Either (AnnLedgerError l r) a)
 -> m (Either (AnnLedgerError l r) a))
-> (ExceptT (AnnLedgerError l r) (ReaderT (ResolveBlock m r b) m) a
    -> ReaderT (ResolveBlock m r b) m (Either (AnnLedgerError l r) a))
-> ExceptT (AnnLedgerError l r) (ReaderT (ResolveBlock m r b) m) a
-> m (Either (AnnLedgerError l r) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (AnnLedgerError l r) (ReaderT (ResolveBlock m r b) m) a
-> ReaderT (ResolveBlock m r b) m (Either (AnnLedgerError l r) a)
forall l r (m :: * -> *) a.
ExceptT (AnnLedgerError l r) m a
-> m (Either (AnnLedgerError l r) a)
defaultThrowLedgerErrors

instance Monad m => ThrowsLedgerError l r (ExceptT (AnnLedgerError l r) m) where
  throwLedgerError :: LedgerDB l r
-> r -> LedgerErr l -> ExceptT (AnnLedgerError l r) m a
throwLedgerError LedgerDB l r
l r
r LedgerErr l
e = AnnLedgerError l r -> ExceptT (AnnLedgerError l r) m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AnnLedgerError l r -> ExceptT (AnnLedgerError l r) m a)
-> AnnLedgerError l r -> ExceptT (AnnLedgerError l r) m a
forall a b. (a -> b) -> a -> b
$ LedgerDB l r -> r -> LedgerErr l -> AnnLedgerError l r
forall l r. LedgerDB l r -> r -> LedgerErr l -> AnnLedgerError l r
AnnLedgerError LedgerDB l r
l r
r LedgerErr l
e

-- | 'Ap' is used to pass information about blocks to ledger DB updates
--
-- The constructors serve two purposes:
--
-- * Specify the various parameters
--   a. Are we passing the block by value or by reference?
--   b. Are we applying or reapplying the block?
--
-- * Compute the constraint @c@ on the monad @m@ in order to run the query:
--   a. If we are passing a block by reference, we must be able to resolve it.
--   b. If we are applying rather than reapplying, we might have ledger errors.
data Ap :: (Type -> Type) -> Type -> Type -> Type -> Constraint -> Type where
  ReapplyVal :: r -> b -> Ap m l r b ()
  ApplyVal   :: r -> b -> Ap m l r b (                       ThrowsLedgerError l r m)
  ReapplyRef :: r      -> Ap m l r b (ResolvesBlocks  r b m)
  ApplyRef   :: r      -> Ap m l r b (ResolvesBlocks  r b m, ThrowsLedgerError l r m)

  -- | 'Weaken' increases the constraint on the monad @m@.
  --
  -- This is primarily useful when combining multiple 'Ap's in a single
  -- homogeneous structure.
  Weaken :: (c' => c) => Ap m l r b c -> Ap m l r b c'

{-------------------------------------------------------------------------------
  Internal utilities for 'Ap'
-------------------------------------------------------------------------------}

apRef :: Ap m l r b c -> r
apRef :: Ap m l r b c -> r
apRef (ReapplyVal r
r b
_) = r
r
apRef (ApplyVal   r
r b
_) = r
r
apRef (ReapplyRef r
r  ) = r
r
apRef (ApplyRef   r
r  ) = r
r
apRef (Weaken     Ap m l r b c
ap)  = Ap m l r b c -> r
forall (m :: * -> *) l r b (c :: Constraint). Ap m l r b c -> r
apRef Ap m l r b c
ap

-- | Apply block to the current ledger state
--
-- We take in the entire 'LedgerDB' because we record that as part of errors.
applyBlock :: forall m c l r b. (ApplyBlock l b, Monad m, c)
           => LedgerCfg l
           -> Ap m l r b c
           -> LedgerDB l r -> m l
applyBlock :: LedgerCfg l -> Ap m l r b c -> LedgerDB l r -> m l
applyBlock LedgerCfg l
cfg Ap m l r b c
ap LedgerDB l r
db = case Ap m l r b c
ap of
    ReapplyVal r
_r b
b ->
      l -> m l
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> m l) -> l -> m l
forall a b. (a -> b) -> a -> b
$
        LedgerCfg l -> b -> l -> l
forall l blk. ApplyBlock l blk => LedgerCfg l -> blk -> l -> l
tickThenReapply LedgerCfg l
cfg b
b l
l
    ApplyVal r
r b
b ->
      (LedgerErr l -> m l) -> (l -> m l) -> Either (LedgerErr l) l -> m l
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (LedgerDB l r -> r -> LedgerErr l -> m l
forall l r (m :: * -> *) a.
ThrowsLedgerError l r m =>
LedgerDB l r -> r -> LedgerErr l -> m a
throwLedgerError LedgerDB l r
db r
r) l -> m l
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (LedgerErr l) l -> m l) -> Either (LedgerErr l) l -> m l
forall a b. (a -> b) -> a -> b
$ Except (LedgerErr l) l -> Either (LedgerErr l) l
forall e a. Except e a -> Either e a
runExcept (Except (LedgerErr l) l -> Either (LedgerErr l) l)
-> Except (LedgerErr l) l -> Either (LedgerErr l) l
forall a b. (a -> b) -> a -> b
$
        LedgerCfg l -> b -> l -> Except (LedgerErr l) l
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
tickThenApply LedgerCfg l
cfg b
b l
l
    ReapplyRef r
r  -> do
      b
b <- r -> m b
forall r b (m :: * -> *). ResolvesBlocks r b m => r -> m b
resolveBlock r
r
      l -> m l
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> m l) -> l -> m l
forall a b. (a -> b) -> a -> b
$
        LedgerCfg l -> b -> l -> l
forall l blk. ApplyBlock l blk => LedgerCfg l -> blk -> l -> l
tickThenReapply LedgerCfg l
cfg b
b l
l
    ApplyRef r
r -> do
      b
b <- r -> m b
forall r b (m :: * -> *). ResolvesBlocks r b m => r -> m b
resolveBlock r
r
      (LedgerErr l -> m l) -> (l -> m l) -> Either (LedgerErr l) l -> m l
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (LedgerDB l r -> r -> LedgerErr l -> m l
forall l r (m :: * -> *) a.
ThrowsLedgerError l r m =>
LedgerDB l r -> r -> LedgerErr l -> m a
throwLedgerError LedgerDB l r
db r
r) l -> m l
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (LedgerErr l) l -> m l) -> Either (LedgerErr l) l -> m l
forall a b. (a -> b) -> a -> b
$ Except (LedgerErr l) l -> Either (LedgerErr l) l
forall e a. Except e a -> Either e a
runExcept (Except (LedgerErr l) l -> Either (LedgerErr l) l)
-> Except (LedgerErr l) l -> Either (LedgerErr l) l
forall a b. (a -> b) -> a -> b
$
        LedgerCfg l -> b -> l -> Except (LedgerErr l) l
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
tickThenApply LedgerCfg l
cfg b
b l
l
    Weaken Ap m l r b c
ap' ->
      LedgerCfg l -> Ap m l r b c -> LedgerDB l r -> m l
forall (m :: * -> *) (c :: Constraint) l r b.
(ApplyBlock l b, Monad m, c) =>
LedgerCfg l -> Ap m l r b c -> LedgerDB l r -> m l
applyBlock LedgerCfg l
cfg Ap m l r b c
ap' LedgerDB l r
db
  where
    l :: l
    l :: l
l = LedgerDB l r -> l
forall l r. LedgerDB l r -> l
ledgerDbCurrent LedgerDB l r
db

{-------------------------------------------------------------------------------
  Queries
-------------------------------------------------------------------------------}

-- | The ledger state at the tip of the chain
ledgerDbCurrent :: LedgerDB l r -> l
ledgerDbCurrent :: LedgerDB l r -> l
ledgerDbCurrent LedgerDB{StrictSeq (Checkpoint l r)
ChainSummary l r
LedgerDbParams
ledgerDbParams :: LedgerDbParams
ledgerDbAnchor :: ChainSummary l r
ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbParams :: forall l r. LedgerDB l r -> LedgerDbParams
ledgerDbCheckpoints :: forall l r. LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbAnchor :: forall l r. LedgerDB l r -> ChainSummary l r
..} = case StrictSeq (Checkpoint l r)
ledgerDbCheckpoints of
  StrictSeq (Checkpoint l r)
Empty                  -> ChainSummary l r -> l
forall l r. ChainSummary l r -> l
csLedger ChainSummary l r
ledgerDbAnchor
  (StrictSeq (Checkpoint l r)
_ :|> Checkpoint r
_ l
l) -> l
l

-- | Total length of the chain (in terms of number of blocks)
ledgerDbChainLength :: LedgerDB l r -> Word64
ledgerDbChainLength :: LedgerDB l r -> Word64
ledgerDbChainLength LedgerDB{StrictSeq (Checkpoint l r)
ChainSummary l r
LedgerDbParams
ledgerDbParams :: LedgerDbParams
ledgerDbAnchor :: ChainSummary l r
ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbParams :: forall l r. LedgerDB l r -> LedgerDbParams
ledgerDbCheckpoints :: forall l r. LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbAnchor :: forall l r. LedgerDB l r -> ChainSummary l r
..} =
    ChainSummary l r -> Word64
forall l r. ChainSummary l r -> Word64
csLength ChainSummary l r
ledgerDbAnchor Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StrictSeq (Checkpoint l r) -> Int
forall a. StrictSeq a -> Int
Seq.length StrictSeq (Checkpoint l r)
ledgerDbCheckpoints)

-- | References to blocks and corresponding ledger state (from old to new)
ledgerDbToList :: LedgerDB l r -> [(r, l)]
ledgerDbToList :: LedgerDB l r -> [(r, l)]
ledgerDbToList LedgerDB{StrictSeq (Checkpoint l r)
ChainSummary l r
LedgerDbParams
ledgerDbParams :: LedgerDbParams
ledgerDbAnchor :: ChainSummary l r
ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbParams :: forall l r. LedgerDB l r -> LedgerDbParams
ledgerDbCheckpoints :: forall l r. LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbAnchor :: forall l r. LedgerDB l r -> ChainSummary l r
..} = (Checkpoint l r -> (r, l)) -> [Checkpoint l r] -> [(r, l)]
forall a b. (a -> b) -> [a] -> [b]
map Checkpoint l r -> (r, l)
forall l r. Checkpoint l r -> (r, l)
cpToPair ([Checkpoint l r] -> [(r, l)]) -> [Checkpoint l r] -> [(r, l)]
forall a b. (a -> b) -> a -> b
$ StrictSeq (Checkpoint l r) -> [Checkpoint l r]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (Checkpoint l r)
ledgerDbCheckpoints

-- | All snapshots currently stored by the ledger DB (new to old)
--
-- This also includes the snapshot at the anchor. For each snapshot we also
-- return the distance from the tip.
ledgerDbSnapshots :: forall l r. LedgerDB l r -> [(Word64, l)]
ledgerDbSnapshots :: LedgerDB l r -> [(Word64, l)]
ledgerDbSnapshots LedgerDB{StrictSeq (Checkpoint l r)
ChainSummary l r
LedgerDbParams
ledgerDbParams :: LedgerDbParams
ledgerDbAnchor :: ChainSummary l r
ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbParams :: forall l r. LedgerDB l r -> LedgerDbParams
ledgerDbCheckpoints :: forall l r. LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbAnchor :: forall l r. LedgerDB l r -> ChainSummary l r
..} = Word64 -> StrictSeq (Checkpoint l r) -> [(Word64, l)]
go Word64
0 StrictSeq (Checkpoint l r)
ledgerDbCheckpoints
  where
    go :: Word64 -> StrictSeq (Checkpoint l r) -> [(Word64, l)]
    go :: Word64 -> StrictSeq (Checkpoint l r) -> [(Word64, l)]
go !Word64
offset StrictSeq (Checkpoint l r)
Empty                   = [(Word64
offset, ChainSummary l r -> l
forall l r. ChainSummary l r -> l
csLedger ChainSummary l r
ledgerDbAnchor)]
    go !Word64
offset (StrictSeq (Checkpoint l r)
ss :|> Checkpoint r
_ l
l) = (Word64
offset, l
l) (Word64, l) -> [(Word64, l)] -> [(Word64, l)]
forall a. a -> [a] -> [a]
: Word64 -> StrictSeq (Checkpoint l r) -> [(Word64, l)]
go (Word64
offset Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) StrictSeq (Checkpoint l r)
ss

-- | How many blocks can we currently roll back?
ledgerDbMaxRollback :: LedgerDB l r -> Word64
ledgerDbMaxRollback :: LedgerDB l r -> Word64
ledgerDbMaxRollback LedgerDB{StrictSeq (Checkpoint l r)
ChainSummary l r
LedgerDbParams
ledgerDbParams :: LedgerDbParams
ledgerDbAnchor :: ChainSummary l r
ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbParams :: forall l r. LedgerDB l r -> LedgerDbParams
ledgerDbCheckpoints :: forall l r. LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbAnchor :: forall l r. LedgerDB l r -> ChainSummary l r
..} = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StrictSeq (Checkpoint l r) -> Int
forall a. StrictSeq a -> Int
Seq.length StrictSeq (Checkpoint l r)
ledgerDbCheckpoints)

-- | Reference to the block at the tip of the chain
ledgerDbTip :: LedgerDB l r -> WithOrigin r
ledgerDbTip :: LedgerDB l r -> WithOrigin r
ledgerDbTip LedgerDB{StrictSeq (Checkpoint l r)
ChainSummary l r
LedgerDbParams
ledgerDbParams :: LedgerDbParams
ledgerDbAnchor :: ChainSummary l r
ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbParams :: forall l r. LedgerDB l r -> LedgerDbParams
ledgerDbCheckpoints :: forall l r. LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbAnchor :: forall l r. LedgerDB l r -> ChainSummary l r
..} =
    case StrictSeq (Checkpoint l r)
ledgerDbCheckpoints of
      StrictSeq (Checkpoint l r)
Empty    -> ChainSummary l r -> WithOrigin r
forall l r. ChainSummary l r -> WithOrigin r
csTip ChainSummary l r
ledgerDbAnchor
      StrictSeq (Checkpoint l r)
_ :|> Checkpoint l r
cp -> r -> WithOrigin r
forall t. t -> WithOrigin t
NotOrigin (Checkpoint l r -> r
forall l r. Checkpoint l r -> r
cpBlock Checkpoint l r
cp)

-- | Have we seen at least @k@ blocks?
ledgerDbIsSaturated :: LedgerDB l r -> Bool
ledgerDbIsSaturated :: LedgerDB l r -> Bool
ledgerDbIsSaturated LedgerDB{StrictSeq (Checkpoint l r)
ChainSummary l r
LedgerDbParams
ledgerDbParams :: LedgerDbParams
ledgerDbAnchor :: ChainSummary l r
ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbParams :: forall l r. LedgerDB l r -> LedgerDbParams
ledgerDbCheckpoints :: forall l r. LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbAnchor :: forall l r. LedgerDB l r -> ChainSummary l r
..} =
    Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StrictSeq (Checkpoint l r) -> Int
forall a. StrictSeq a -> Int
Seq.length StrictSeq (Checkpoint l r)
ledgerDbCheckpoints) Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
k
  where
    LedgerDbParams{SecurityParam
ledgerDbSecurityParam :: SecurityParam
ledgerDbSecurityParam :: LedgerDbParams -> SecurityParam
..} = LedgerDbParams
ledgerDbParams
    SecurityParam Word64
k    = SecurityParam
ledgerDbSecurityParam

{-------------------------------------------------------------------------------
  Internal updates
-------------------------------------------------------------------------------}

-- | Internal: shift the anchor given a bunch of checkpoints.
shiftAnchor :: forall r l. HasCallStack
            => StrictSeq (Checkpoint l r) -> ChainSummary l r -> ChainSummary l r
shiftAnchor :: StrictSeq (Checkpoint l r) -> ChainSummary l r -> ChainSummary l r
shiftAnchor StrictSeq (Checkpoint l r)
toRemove ChainSummary{l
Word64
WithOrigin r
csLedger :: l
csLength :: Word64
csTip :: WithOrigin r
csLedger :: forall l r. ChainSummary l r -> l
csLength :: forall l r. ChainSummary l r -> Word64
csTip :: forall l r. ChainSummary l r -> WithOrigin r
..} = ChainSummary :: forall l r. WithOrigin r -> Word64 -> l -> ChainSummary l r
ChainSummary {
      csTip :: WithOrigin r
csTip    = r -> WithOrigin r
forall t. t -> WithOrigin t
NotOrigin r
csTip'
    , csLength :: Word64
csLength = Word64
csLength Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StrictSeq (Checkpoint l r) -> Int
forall a. StrictSeq a -> Int
Seq.length StrictSeq (Checkpoint l r)
toRemove)
    , csLedger :: l
csLedger = l
csLedger'
    }
  where
    csTip'    :: r
    csLedger' :: l
    (r
csTip', l
csLedger') =
        case StrictSeq (Checkpoint l r)
toRemove of
          StrictSeq (Checkpoint l r)
Empty                -> String -> (r, l)
forall a. HasCallStack => String -> a
error String
"shiftAnchor: empty list"
          StrictSeq (Checkpoint l r)
_ :|> Checkpoint r
r l
l -> (r
r, l
l)

-- | Internal: count number of checkpoints to prune, given total number of
-- checkpoints
--
-- This is exposed for the benefit of tests only.
ledgerDbCountToPrune :: LedgerDbParams -> Int -> Int
ledgerDbCountToPrune :: LedgerDbParams -> Int -> Int
ledgerDbCountToPrune LedgerDbParams{SecurityParam
ledgerDbSecurityParam :: SecurityParam
ledgerDbSecurityParam :: LedgerDbParams -> SecurityParam
..} Int
curSize'
  | Word64
curSize Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
k = Int
0
  | Bool
otherwise    = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64
curSize Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
k
  where
    SecurityParam Word64
k = SecurityParam
ledgerDbSecurityParam
    curSize :: Word64
curSize = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
curSize'

-- | Internal: drop unneeded snapshots from the head of the list
prune :: HasCallStack => LedgerDB l r -> LedgerDB l r
prune :: LedgerDB l r -> LedgerDB l r
prune db :: LedgerDB l r
db@LedgerDB{StrictSeq (Checkpoint l r)
ChainSummary l r
LedgerDbParams
ledgerDbParams :: LedgerDbParams
ledgerDbAnchor :: ChainSummary l r
ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbParams :: forall l r. LedgerDB l r -> LedgerDbParams
ledgerDbCheckpoints :: forall l r. LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbAnchor :: forall l r. LedgerDB l r -> ChainSummary l r
..} =
    if Int
toPrune Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      then LedgerDB l r
db
      else let (StrictSeq (Checkpoint l r)
removed, StrictSeq (Checkpoint l r)
kept) = Int
-> StrictSeq (Checkpoint l r)
-> (StrictSeq (Checkpoint l r), StrictSeq (Checkpoint l r))
forall a. Int -> StrictSeq a -> (StrictSeq a, StrictSeq a)
Seq.splitAt Int
toPrune StrictSeq (Checkpoint l r)
ledgerDbCheckpoints
               anchor' :: ChainSummary l r
anchor'         = StrictSeq (Checkpoint l r) -> ChainSummary l r -> ChainSummary l r
forall r l.
HasCallStack =>
StrictSeq (Checkpoint l r) -> ChainSummary l r -> ChainSummary l r
shiftAnchor StrictSeq (Checkpoint l r)
removed ChainSummary l r
ledgerDbAnchor
           in LedgerDB l r
db { ledgerDbAnchor :: ChainSummary l r
ledgerDbAnchor      = ChainSummary l r
anchor'
                 , ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbCheckpoints = StrictSeq (Checkpoint l r)
kept
                 }
  where
    -- Number of snapshots to remove (assuming curSize > maxSize)
    toPrune :: Int
    toPrune :: Int
toPrune =
      LedgerDbParams -> Int -> Int
ledgerDbCountToPrune LedgerDbParams
ledgerDbParams (StrictSeq (Checkpoint l r) -> Int
forall a. StrictSeq a -> Int
Seq.length StrictSeq (Checkpoint l r)
ledgerDbCheckpoints)

 -- NOTE: we must inline 'prune' otherwise we get unexplained thunks in
 -- 'LedgerDB' and thus a space leak. Alternatively, we could disable the
 -- @-fstrictness@ optimisation (enabled by default for -O1). See #2532.
{-# INLINE prune #-}

-- | Push an updated ledger state
pushLedgerState :: l  -- ^ Updated ledger state
                -> r  -- ^ Reference to the applied block
                -> LedgerDB l r -> LedgerDB l r
pushLedgerState :: l -> r -> LedgerDB l r -> LedgerDB l r
pushLedgerState l
current' r
ref db :: LedgerDB l r
db@LedgerDB{StrictSeq (Checkpoint l r)
ChainSummary l r
LedgerDbParams
ledgerDbParams :: LedgerDbParams
ledgerDbAnchor :: ChainSummary l r
ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbParams :: forall l r. LedgerDB l r -> LedgerDbParams
ledgerDbCheckpoints :: forall l r. LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbAnchor :: forall l r. LedgerDB l r -> ChainSummary l r
..}  = LedgerDB l r -> LedgerDB l r
forall l r. HasCallStack => LedgerDB l r -> LedgerDB l r
prune (LedgerDB l r -> LedgerDB l r) -> LedgerDB l r -> LedgerDB l r
forall a b. (a -> b) -> a -> b
$ LedgerDB l r
db {
      ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbCheckpoints = StrictSeq (Checkpoint l r)
snapshots
    }
  where
    snapshots :: StrictSeq (Checkpoint l r)
snapshots = StrictSeq (Checkpoint l r)
ledgerDbCheckpoints StrictSeq (Checkpoint l r)
-> Checkpoint l r -> StrictSeq (Checkpoint l r)
forall a. StrictSeq a -> a -> StrictSeq a
|> r -> l -> Checkpoint l r
forall l r. r -> l -> Checkpoint l r
Checkpoint r
ref l
current'

{-------------------------------------------------------------------------------
  Internal: rolling back
-------------------------------------------------------------------------------}

-- | Reconstruct ledger DB from a list of checkpoints
reconstructFrom :: forall l r.
                   LedgerDbParams
                -> ChainSummary l r
                -> StrictSeq (Checkpoint l r)
                -> LedgerDB l r
reconstructFrom :: LedgerDbParams
-> ChainSummary l r -> StrictSeq (Checkpoint l r) -> LedgerDB l r
reconstructFrom LedgerDbParams
params ChainSummary l r
anchor StrictSeq (Checkpoint l r)
snapshots =
    LedgerDB :: forall l r.
StrictSeq (Checkpoint l r)
-> ChainSummary l r -> LedgerDbParams -> LedgerDB l r
LedgerDB {
        ledgerDbCheckpoints :: StrictSeq (Checkpoint l r)
ledgerDbCheckpoints = StrictSeq (Checkpoint l r)
snapshots
      , ledgerDbParams :: LedgerDbParams
ledgerDbParams      = LedgerDbParams
params
      , ledgerDbAnchor :: ChainSummary l r
ledgerDbAnchor      = ChainSummary l r
anchor
      }

-- | Generalization of rollback using a function on the checkpoints
rollbackTo :: (   ChainSummary l r
               -> StrictSeq (Checkpoint l r)
               -> Maybe (StrictSeq (Checkpoint l r))
              )
           -> LedgerDB l r
           -> Maybe (LedgerDB l r)
rollbackTo :: (ChainSummary l r
 -> StrictSeq (Checkpoint l r)
 -> Maybe (StrictSeq (Checkpoint l r)))
-> LedgerDB l r -> Maybe (LedgerDB l r)
rollbackTo ChainSummary l r
-> StrictSeq (Checkpoint l r) -> Maybe (StrictSeq (Checkpoint l r))
f (LedgerDB StrictSeq (Checkpoint l r)
checkpoints ChainSummary l r
anchor LedgerDbParams
params) =
    LedgerDbParams
-> ChainSummary l r -> StrictSeq (Checkpoint l r) -> LedgerDB l r
forall l r.
LedgerDbParams
-> ChainSummary l r -> StrictSeq (Checkpoint l r) -> LedgerDB l r
reconstructFrom LedgerDbParams
params ChainSummary l r
anchor (StrictSeq (Checkpoint l r) -> LedgerDB l r)
-> Maybe (StrictSeq (Checkpoint l r)) -> Maybe (LedgerDB l r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSummary l r
-> StrictSeq (Checkpoint l r) -> Maybe (StrictSeq (Checkpoint l r))
f ChainSummary l r
anchor StrictSeq (Checkpoint l r)
checkpoints

-- | Rollback
--
-- Returns 'Nothing' if maximum rollback is exceeded.
rollback :: forall l r.
            Word64
         -> LedgerDB l r
         -> Maybe (LedgerDB l r)
rollback :: Word64 -> LedgerDB l r -> Maybe (LedgerDB l r)
rollback Word64
0 LedgerDB l r
db = LedgerDB l r -> Maybe (LedgerDB l r)
forall a. a -> Maybe a
Just LedgerDB l r
db
rollback Word64
n LedgerDB l r
db = (ChainSummary l r
 -> StrictSeq (Checkpoint l r)
 -> Maybe (StrictSeq (Checkpoint l r)))
-> LedgerDB l r -> Maybe (LedgerDB l r)
forall l r.
(ChainSummary l r
 -> StrictSeq (Checkpoint l r)
 -> Maybe (StrictSeq (Checkpoint l r)))
-> LedgerDB l r -> Maybe (LedgerDB l r)
rollbackTo (\ChainSummary l r
_anchor -> StrictSeq (Checkpoint l r) -> Maybe (StrictSeq (Checkpoint l r))
go) LedgerDB l r
db
  where
    go :: StrictSeq (Checkpoint l r) -> Maybe (StrictSeq (Checkpoint l r))
    go :: StrictSeq (Checkpoint l r) -> Maybe (StrictSeq (Checkpoint l r))
go StrictSeq (Checkpoint l r)
checkpoints =
        if StrictSeq (Checkpoint l r) -> Int
forall a. StrictSeq a -> Int
Seq.length StrictSeq (Checkpoint l r)
checkpoints Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n
          then StrictSeq (Checkpoint l r) -> Maybe (StrictSeq (Checkpoint l r))
forall a. a -> Maybe a
Just (StrictSeq (Checkpoint l r) -> Maybe (StrictSeq (Checkpoint l r)))
-> StrictSeq (Checkpoint l r) -> Maybe (StrictSeq (Checkpoint l r))
forall a b. (a -> b) -> a -> b
$
            Int -> StrictSeq (Checkpoint l r) -> StrictSeq (Checkpoint l r)
forall a. Int -> StrictSeq a -> StrictSeq a
Seq.take (StrictSeq (Checkpoint l r) -> Int
forall a. StrictSeq a -> Int
Seq.length StrictSeq (Checkpoint l r)
checkpoints Int -> Int -> Int
forall a. Num a => a -> a -> a
- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) StrictSeq (Checkpoint l r)
checkpoints
          else Maybe (StrictSeq (Checkpoint l r))
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  Get past ledger states
-------------------------------------------------------------------------------}

-- | Get a past ledger state
--
--  \( O(\log n * \log n) \).
--
-- When no 'Checkpoint' (or anchor) has the given @'WithOrigin' r@, 'Nothing' is
-- returned.
--
-- To avoid a linear search on the checkpoints (typically 2160 of them), we do a
-- binary search benefitting from the cheap splits of the underlying
-- 'StrictSeq' \( O(\log n) \).
--
-- For a binary search, the checkpoints have to be ordered by @r@. In practice,
-- we'll use 'RealPoint' for @r@, which, because of the existence of EBBs,
-- doesn't have a reliable ordering: it orders first on 'SlotNo', which is
-- correct. But in case of a tie, it will look at the hash, which is not what we
-- need: an EBB has the same slot as the block after it, so we'd want the
-- 'RealPoint' of an EBB to be /less/ than the 'RealPoint' of the regular block
-- in the same slot. But the decision is made based on the hash, so we won't get
-- a reliable answer.
--
-- Therefore, we take a projection @refOrder :: r -> ro@ as an argument. The
-- @ro@ type should have a correct ordering, so that the list below is correctly
-- ordered:
--
-- > map (refOrder . cpBlock) $ Seq.toList (ledgerDbCheckpoints db)
--
-- When instantiating @r@ to 'RealPoint', one should use 'realPointSlot' as
-- @refOrder@.
--
-- Note: we don't use @fingertree@ for the checkpoints (with its @search@
-- operation we could use here) because we'd have to impose more constraints on
-- the @r@ type. We could do an interpolation search if we assume more about the
-- @ro@ parameter ('SlotNo'), but that would be more complicated.
ledgerDbPast ::
     forall l r ro. (Ord ro, Eq r)
  => (r -> ro)
  -> WithOrigin r
  -> LedgerDB l r
  -> Maybe l
ledgerDbPast :: (r -> ro) -> WithOrigin r -> LedgerDB l r -> Maybe l
ledgerDbPast r -> ro
refOrder WithOrigin r
tip LedgerDB l r
db
    | WithOrigin r
tip WithOrigin r -> WithOrigin r -> Bool
forall a. Eq a => a -> a -> Bool
== LedgerDB l r -> WithOrigin r
forall l r. LedgerDB l r -> WithOrigin r
ledgerDbTip LedgerDB l r
db
    = l -> Maybe l
forall a. a -> Maybe a
Just (LedgerDB l r -> l
forall l r. LedgerDB l r -> l
ledgerDbCurrent LedgerDB l r
db)
    | WithOrigin r
tip WithOrigin r -> WithOrigin r -> Bool
forall a. Eq a => a -> a -> Bool
== ChainSummary l r -> WithOrigin r
forall l r. ChainSummary l r -> WithOrigin r
csTip (LedgerDB l r -> ChainSummary l r
forall l r. LedgerDB l r -> ChainSummary l r
ledgerDbAnchor LedgerDB l r
db)
    = l -> Maybe l
forall a. a -> Maybe a
Just (ChainSummary l r -> l
forall l r. ChainSummary l r -> l
csLedger (LedgerDB l r -> ChainSummary l r
forall l r. LedgerDB l r -> ChainSummary l r
ledgerDbAnchor LedgerDB l r
db))
    | NotOrigin r
tip' <- WithOrigin r
tip
    = Checkpoint l r -> l
forall l r. Checkpoint l r -> l
cpState (Checkpoint l r -> l) -> Maybe (Checkpoint l r) -> Maybe l
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r -> Seq (Checkpoint l r) -> Maybe (Checkpoint l r)
binarySearch r
tip' (StrictSeq (Checkpoint l r) -> Seq (Checkpoint l r)
forall a. StrictSeq a -> Seq a
Seq.getSeq (LedgerDB l r -> StrictSeq (Checkpoint l r)
forall l r. LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbCheckpoints LedgerDB l r
db))
    | Bool
otherwise
    = Maybe l
forall a. Maybe a
Nothing
  where
    binarySearch :: r -> LazySeq.Seq (Checkpoint l r) -> Maybe (Checkpoint l r)
    binarySearch :: r -> Seq (Checkpoint l r) -> Maybe (Checkpoint l r)
binarySearch r
_   Seq (Checkpoint l r)
LazySeq.Empty = Maybe (Checkpoint l r)
forall a. Maybe a
Nothing
    binarySearch r
ref Seq (Checkpoint l r)
checkpoints   = case Int
-> Seq (Checkpoint l r)
-> (Seq (Checkpoint l r), Seq (Checkpoint l r))
forall a. Int -> Seq a -> (Seq a, Seq a)
LazySeq.splitAt Int
middle Seq (Checkpoint l r)
checkpoints of
        (Seq (Checkpoint l r)
before, Seq (Checkpoint l r)
LazySeq.Empty)        -> r -> Seq (Checkpoint l r) -> Maybe (Checkpoint l r)
binarySearch r
ref Seq (Checkpoint l r)
before
        (Seq (Checkpoint l r)
before, Checkpoint l r
cp LazySeq.:<| Seq (Checkpoint l r)
after) ->
          case (ro -> ro -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ro -> ro -> Ordering) -> (r -> ro) -> r -> r -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` r -> ro
refOrder) r
ref (Checkpoint l r -> r
forall l r. Checkpoint l r -> r
cpBlock Checkpoint l r
cp) of
            Ordering
LT -> r -> Seq (Checkpoint l r) -> Maybe (Checkpoint l r)
binarySearch r
ref Seq (Checkpoint l r)
before
            Ordering
GT -> r -> Seq (Checkpoint l r) -> Maybe (Checkpoint l r)
binarySearch r
ref Seq (Checkpoint l r)
after
            Ordering
EQ
              | Checkpoint l r -> Bool
isMatch Checkpoint l r
cp -> Checkpoint l r -> Maybe (Checkpoint l r)
forall a. a -> Maybe a
Just Checkpoint l r
cp
              | Bool
otherwise  ->
                -- Oh EBBs, why do you make everything so much harder? An EBB
                -- has the same slot as the regular block after it. We look left
                -- and right from @cp@ for checkpoints with the same @ro@
                -- ('SlotNo' in practice) and do a linear search among those.
                -- When it's indeed a slot populated by both a regular block and
                -- EBB, we'll look at /one/ other checkpoint. In all other
                -- cases, we'll look at /none/. Note that we have to look in
                -- both directions because we don't know whether @cp@ is the EBB
                -- or the regular block in the same slot.
                (Checkpoint l r -> Bool)
-> Seq (Checkpoint l r) -> Maybe (Checkpoint l r)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Checkpoint l r -> Bool
isMatch ((Checkpoint l r -> Bool)
-> Seq (Checkpoint l r) -> Seq (Checkpoint l r)
forall a. (a -> Bool) -> Seq a -> Seq a
LazySeq.takeWhileR Checkpoint l r -> Bool
sameOrder Seq (Checkpoint l r)
before) Maybe (Checkpoint l r)
-> Maybe (Checkpoint l r) -> Maybe (Checkpoint l r)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                (Checkpoint l r -> Bool)
-> Seq (Checkpoint l r) -> Maybe (Checkpoint l r)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Checkpoint l r -> Bool
isMatch ((Checkpoint l r -> Bool)
-> Seq (Checkpoint l r) -> Seq (Checkpoint l r)
forall a. (a -> Bool) -> Seq a -> Seq a
LazySeq.takeWhileL Checkpoint l r -> Bool
sameOrder Seq (Checkpoint l r)
after)
      where
        middle :: Int
        middle :: Int
middle = Seq (Checkpoint l r) -> Int
forall a. Seq a -> Int
LazySeq.length Seq (Checkpoint l r)
checkpoints Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2

        isMatch :: Checkpoint l r -> Bool
        isMatch :: Checkpoint l r -> Bool
isMatch Checkpoint l r
cp = Checkpoint l r -> r
forall l r. Checkpoint l r -> r
cpBlock Checkpoint l r
cp r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
ref

        sameOrder :: Checkpoint l r -> Bool
        sameOrder :: Checkpoint l r -> Bool
sameOrder Checkpoint l r
cp = r -> ro
refOrder (Checkpoint l r -> r
forall l r. Checkpoint l r -> r
cpBlock Checkpoint l r
cp) ro -> ro -> Bool
forall a. Eq a => a -> a -> Bool
== r -> ro
refOrder r
ref

-- | Get a past ledger state
--
-- \( O(n) \)
--
-- Straightforward implementation of 'ledgerDbPast' using a linear search.
--
-- Can be used in tests to compare against 'ledgerDbPast'.
ledgerDbPastSpec ::
     forall l r. Eq r
  => WithOrigin r
  -> LedgerDB l r
  -> Maybe l
ledgerDbPastSpec :: WithOrigin r -> LedgerDB l r -> Maybe l
ledgerDbPastSpec WithOrigin r
tip LedgerDB l r
db
    | WithOrigin r
tip WithOrigin r -> WithOrigin r -> Bool
forall a. Eq a => a -> a -> Bool
== LedgerDB l r -> WithOrigin r
forall l r. LedgerDB l r -> WithOrigin r
ledgerDbTip LedgerDB l r
db
    = l -> Maybe l
forall a. a -> Maybe a
Just (LedgerDB l r -> l
forall l r. LedgerDB l r -> l
ledgerDbCurrent LedgerDB l r
db)
    | WithOrigin r
tip WithOrigin r -> WithOrigin r -> Bool
forall a. Eq a => a -> a -> Bool
== ChainSummary l r -> WithOrigin r
forall l r. ChainSummary l r -> WithOrigin r
csTip (LedgerDB l r -> ChainSummary l r
forall l r. LedgerDB l r -> ChainSummary l r
ledgerDbAnchor LedgerDB l r
db)
    = l -> Maybe l
forall a. a -> Maybe a
Just (ChainSummary l r -> l
forall l r. ChainSummary l r -> l
csLedger (LedgerDB l r -> ChainSummary l r
forall l r. LedgerDB l r -> ChainSummary l r
ledgerDbAnchor LedgerDB l r
db))
    | NotOrigin r
tip' <- WithOrigin r
tip
    = Checkpoint l r -> l
forall l r. Checkpoint l r -> l
cpState (Checkpoint l r -> l) -> Maybe (Checkpoint l r) -> Maybe l
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Checkpoint l r -> Bool)
-> StrictSeq (Checkpoint l r) -> Maybe (Checkpoint l r)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
tip') (r -> Bool) -> (Checkpoint l r -> r) -> Checkpoint l r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Checkpoint l r -> r
forall l r. Checkpoint l r -> r
cpBlock) (LedgerDB l r -> StrictSeq (Checkpoint l r)
forall l r. LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbCheckpoints LedgerDB l r
db)
    | Bool
otherwise
    = Maybe l
forall a. Maybe a
Nothing

-- | Apply the given function to all past ledgers in the 'LedgerDB', including
-- the one stored at the anchor.
--
-- \( O(n) \)
ledgerDbPastLedgers :: (l -> a) -> LedgerDB l r -> (a, StrictSeq a)
ledgerDbPastLedgers :: (l -> a) -> LedgerDB l r -> (a, StrictSeq a)
ledgerDbPastLedgers l -> a
f LedgerDB l r
db =
    ( l -> a
f (l -> a) -> (LedgerDB l r -> l) -> LedgerDB l r -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainSummary l r -> l
forall l r. ChainSummary l r -> l
csLedger (ChainSummary l r -> l)
-> (LedgerDB l r -> ChainSummary l r) -> LedgerDB l r -> l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB l r -> ChainSummary l r
forall l r. LedgerDB l r -> ChainSummary l r
ledgerDbAnchor (LedgerDB l r -> a) -> LedgerDB l r -> a
forall a b. (a -> b) -> a -> b
$ LedgerDB l r
db
    , (Checkpoint l r -> a) -> StrictSeq (Checkpoint l r) -> StrictSeq a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (l -> a
f (l -> a) -> (Checkpoint l r -> l) -> Checkpoint l r -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Checkpoint l r -> l
forall l r. Checkpoint l r -> l
cpState) (StrictSeq (Checkpoint l r) -> StrictSeq a)
-> (LedgerDB l r -> StrictSeq (Checkpoint l r))
-> LedgerDB l r
-> StrictSeq a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB l r -> StrictSeq (Checkpoint l r)
forall l r. LedgerDB l r -> StrictSeq (Checkpoint l r)
ledgerDbCheckpoints (LedgerDB l r -> StrictSeq a) -> LedgerDB l r -> StrictSeq a
forall a b. (a -> b) -> a -> b
$ LedgerDB l r
db
    )

{-------------------------------------------------------------------------------
  Updates
-------------------------------------------------------------------------------}

-- | Exceeded maximum rollback supported by the current ledger DB state
--
-- Under normal circumstances this will not arise. It can really only happen
-- in the presence of data corruption (or when switching to a shorter fork,
-- but that is disallowed by all currently known Ouroboros protocols).
--
-- Records both the supported and the requested rollback.
data ExceededRollback = ExceededRollback {
      ExceededRollback -> Word64
rollbackMaximum   :: Word64
    , ExceededRollback -> Word64
rollbackRequested :: Word64
    }

ledgerDbPush :: forall m c l r b. (ApplyBlock l b, Monad m, c)
             => LedgerCfg l
             -> Ap m l r b c -> LedgerDB l r -> m (LedgerDB l r)
ledgerDbPush :: LedgerCfg l -> Ap m l r b c -> LedgerDB l r -> m (LedgerDB l r)
ledgerDbPush LedgerCfg l
cfg Ap m l r b c
ap LedgerDB l r
db =
    (\l
current' -> l -> r -> LedgerDB l r -> LedgerDB l r
forall l r. l -> r -> LedgerDB l r -> LedgerDB l r
pushLedgerState l
current' (Ap m l r b c -> r
forall (m :: * -> *) l r b (c :: Constraint). Ap m l r b c -> r
apRef Ap m l r b c
ap) LedgerDB l r
db) (l -> LedgerDB l r) -> m l -> m (LedgerDB l r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      LedgerCfg l -> Ap m l r b c -> LedgerDB l r -> m l
forall (m :: * -> *) (c :: Constraint) l r b.
(ApplyBlock l b, Monad m, c) =>
LedgerCfg l -> Ap m l r b c -> LedgerDB l r -> m l
applyBlock LedgerCfg l
cfg Ap m l r b c
ap LedgerDB l r
db

-- | Push a bunch of blocks (oldest first)
ledgerDbPushMany :: (ApplyBlock l b, Monad m, c)
                 => LedgerCfg l
                 -> [Ap m l r b c] -> LedgerDB l r -> m (LedgerDB l r)
ledgerDbPushMany :: LedgerCfg l -> [Ap m l r b c] -> LedgerDB l r -> m (LedgerDB l r)
ledgerDbPushMany = (Ap m l r b c -> LedgerDB l r -> m (LedgerDB l r))
-> [Ap m l r b c] -> LedgerDB l r -> m (LedgerDB l r)
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM ((Ap m l r b c -> LedgerDB l r -> m (LedgerDB l r))
 -> [Ap m l r b c] -> LedgerDB l r -> m (LedgerDB l r))
-> (LedgerCfg l
    -> Ap m l r b c -> LedgerDB l r -> m (LedgerDB l r))
-> LedgerCfg l
-> [Ap m l r b c]
-> LedgerDB l r
-> m (LedgerDB l r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerCfg l -> Ap m l r b c -> LedgerDB l r -> m (LedgerDB l r)
forall (m :: * -> *) (c :: Constraint) l r b.
(ApplyBlock l b, Monad m, c) =>
LedgerCfg l -> Ap m l r b c -> LedgerDB l r -> m (LedgerDB l r)
ledgerDbPush

-- | Switch to a fork
ledgerDbSwitch :: (ApplyBlock l b, Monad m, c)
               => LedgerCfg l
               -> Word64          -- ^ How many blocks to roll back
               -> [Ap m l r b c]  -- ^ New blocks to apply
               -> LedgerDB l r
               -> m (Either ExceededRollback (LedgerDB l r))
ledgerDbSwitch :: LedgerCfg l
-> Word64
-> [Ap m l r b c]
-> LedgerDB l r
-> m (Either ExceededRollback (LedgerDB l r))
ledgerDbSwitch LedgerCfg l
cfg Word64
numRollbacks [Ap m l r b c]
newBlocks LedgerDB l r
db =
    case Word64 -> LedgerDB l r -> Maybe (LedgerDB l r)
forall l r. Word64 -> LedgerDB l r -> Maybe (LedgerDB l r)
rollback Word64
numRollbacks LedgerDB l r
db of
      Maybe (LedgerDB l r)
Nothing ->
        Either ExceededRollback (LedgerDB l r)
-> m (Either ExceededRollback (LedgerDB l r))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ExceededRollback (LedgerDB l r)
 -> m (Either ExceededRollback (LedgerDB l r)))
-> Either ExceededRollback (LedgerDB l r)
-> m (Either ExceededRollback (LedgerDB l r))
forall a b. (a -> b) -> a -> b
$ ExceededRollback -> Either ExceededRollback (LedgerDB l r)
forall a b. a -> Either a b
Left (ExceededRollback -> Either ExceededRollback (LedgerDB l r))
-> ExceededRollback -> Either ExceededRollback (LedgerDB l r)
forall a b. (a -> b) -> a -> b
$ ExceededRollback :: Word64 -> Word64 -> ExceededRollback
ExceededRollback {
            rollbackMaximum :: Word64
rollbackMaximum   = LedgerDB l r -> Word64
forall l r. LedgerDB l r -> Word64
ledgerDbMaxRollback LedgerDB l r
db
          , rollbackRequested :: Word64
rollbackRequested = Word64
numRollbacks
          }
      Just LedgerDB l r
db' ->
        LedgerDB l r -> Either ExceededRollback (LedgerDB l r)
forall a b. b -> Either a b
Right (LedgerDB l r -> Either ExceededRollback (LedgerDB l r))
-> m (LedgerDB l r) -> m (Either ExceededRollback (LedgerDB l r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerCfg l -> [Ap m l r b c] -> LedgerDB l r -> m (LedgerDB l r)
forall l b (m :: * -> *) (c :: Constraint) r.
(ApplyBlock l b, Monad m, c) =>
LedgerCfg l -> [Ap m l r b c] -> LedgerDB l r -> m (LedgerDB l r)
ledgerDbPushMany LedgerCfg l
cfg [Ap m l r b c]
newBlocks LedgerDB l r
db'

{-------------------------------------------------------------------------------
  The LedgerDB itself behaves like a ledger
-------------------------------------------------------------------------------}

type instance LedgerCfg (LedgerDB l r) = LedgerCfg l

type instance HeaderHash (LedgerDB l r) = HeaderHash l

instance IsLedger l => GetTip (LedgerDB l r) where
  getTip :: LedgerDB l r -> Point (LedgerDB l r)
getTip = Point l -> Point (LedgerDB l r)
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point l -> Point (LedgerDB l r))
-> (LedgerDB l r -> Point l)
-> LedgerDB l r
-> Point (LedgerDB l r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l -> Point l
forall l. GetTip l => l -> Point l
getTip (l -> Point l) -> (LedgerDB l r -> l) -> LedgerDB l r -> Point l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB l r -> l
forall l r. LedgerDB l r -> l
ledgerDbCurrent

instance IsLedger l => GetTip (Ticked (LedgerDB l r)) where
  getTip :: Ticked (LedgerDB l r) -> Point (Ticked (LedgerDB l r))
getTip = Point (LedgerDB l r) -> Point (Ticked (LedgerDB l r))
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (LedgerDB l r) -> Point (Ticked (LedgerDB l r)))
-> (Ticked (LedgerDB l r) -> Point (LedgerDB l r))
-> Ticked (LedgerDB l r)
-> Point (Ticked (LedgerDB l r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB l r -> Point (LedgerDB l r)
forall l. GetTip l => l -> Point l
getTip (LedgerDB l r -> Point (LedgerDB l r))
-> (Ticked (LedgerDB l r) -> LedgerDB l r)
-> Ticked (LedgerDB l r)
-> Point (LedgerDB l r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerDB l r) -> LedgerDB l r
forall l r. Ticked (LedgerDB l r) -> LedgerDB l r
tickedLedgerDbOrig

instance ( IsLedger l
           -- Required superclass constraints of 'IsLedger'
         , Show     r
         , Eq       r
         , NoThunks r
         ) => IsLedger (LedgerDB l r) where
  type LedgerErr (LedgerDB l r) = LedgerErr l

  applyChainTick :: LedgerCfg (LedgerDB l r)
-> SlotNo -> LedgerDB l r -> Ticked (LedgerDB l r)
applyChainTick LedgerCfg (LedgerDB l r)
cfg SlotNo
slot LedgerDB l r
db = TickedLedgerDB :: forall l r. Ticked l -> LedgerDB l r -> Ticked (LedgerDB l r)
TickedLedgerDB {
        tickedLedgerDbTicked :: Ticked l
tickedLedgerDbTicked = LedgerCfg l -> SlotNo -> l -> Ticked l
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick LedgerCfg l
LedgerCfg (LedgerDB l r)
cfg SlotNo
slot (LedgerDB l r -> l
forall l r. LedgerDB l r -> l
ledgerDbCurrent LedgerDB l r
db)
      , tickedLedgerDbOrig :: LedgerDB l r
tickedLedgerDbOrig   = LedgerDB l r
db
      }

instance ApplyBlock l blk => ApplyBlock (LedgerDB l (RealPoint blk)) blk where
  applyLedgerBlock :: LedgerCfg (LedgerDB l (RealPoint blk))
-> blk
-> Ticked (LedgerDB l (RealPoint blk))
-> Except
     (LedgerErr (LedgerDB l (RealPoint blk)))
     (LedgerDB l (RealPoint blk))
applyLedgerBlock LedgerCfg (LedgerDB l (RealPoint blk))
cfg blk
blk TickedLedgerDB{..} =
      l -> LedgerDB l (RealPoint blk)
push (l -> LedgerDB l (RealPoint blk))
-> ExceptT (LedgerErr l) Identity l
-> ExceptT (LedgerErr l) Identity (LedgerDB l (RealPoint blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerCfg l -> blk -> Ticked l -> ExceptT (LedgerErr l) Identity l
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l -> blk -> Ticked l -> Except (LedgerErr l) l
applyLedgerBlock
                 LedgerCfg l
LedgerCfg (LedgerDB l (RealPoint blk))
cfg
                 blk
blk
                 Ticked l
tickedLedgerDbTicked
   where
     push :: l -> LedgerDB l (RealPoint blk)
     push :: l -> LedgerDB l (RealPoint blk)
push l
l = l
-> RealPoint blk
-> LedgerDB l (RealPoint blk)
-> LedgerDB l (RealPoint blk)
forall l r. l -> r -> LedgerDB l r -> LedgerDB l r
pushLedgerState l
l (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
blk) LedgerDB l (RealPoint blk)
tickedLedgerDbOrig

  reapplyLedgerBlock :: LedgerCfg (LedgerDB l (RealPoint blk))
-> blk
-> Ticked (LedgerDB l (RealPoint blk))
-> LedgerDB l (RealPoint blk)
reapplyLedgerBlock LedgerCfg (LedgerDB l (RealPoint blk))
cfg blk
blk TickedLedgerDB{..} =
      l -> LedgerDB l (RealPoint blk)
push (l -> LedgerDB l (RealPoint blk))
-> l -> LedgerDB l (RealPoint blk)
forall a b. (a -> b) -> a -> b
$ LedgerCfg l -> blk -> Ticked l -> l
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l -> blk -> Ticked l -> l
reapplyLedgerBlock
               LedgerCfg l
LedgerCfg (LedgerDB l (RealPoint blk))
cfg
               blk
blk
               Ticked l
tickedLedgerDbTicked
   where
     push :: l -> LedgerDB l (RealPoint blk)
     push :: l -> LedgerDB l (RealPoint blk)
push l
l = l
-> RealPoint blk
-> LedgerDB l (RealPoint blk)
-> LedgerDB l (RealPoint blk)
forall l r. l -> r -> LedgerDB l r -> LedgerDB l r
pushLedgerState l
l (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
blk) LedgerDB l (RealPoint blk)
tickedLedgerDbOrig

{-------------------------------------------------------------------------------
  Suppor for testing
-------------------------------------------------------------------------------}

pureBlock :: b -> Ap m l b b ()
pureBlock :: b -> Ap m l b b (() :: Constraint)
pureBlock b
b = b -> b -> Ap m l b b (() :: Constraint)
forall r b (m :: * -> *) l. r -> b -> Ap m l r b (() :: Constraint)
ReapplyVal b
b b
b

triviallyResolve :: forall b a. Proxy b
                 -> Reader (ResolveBlock Identity b b) a -> a
triviallyResolve :: Proxy b -> Reader (ResolveBlock Identity b b) a -> a
triviallyResolve Proxy b
_ = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a)
-> (Reader (ResolveBlock Identity b b) a -> Identity a)
-> Reader (ResolveBlock Identity b b) a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolveBlock Identity b b
-> Reader (ResolveBlock Identity b b) a -> Identity a
forall (m :: * -> *) r b a.
ResolveBlock m r b -> ReaderT (ResolveBlock m r b) m a -> m a
defaultResolveBlocks ResolveBlock Identity b b
forall (m :: * -> *) a. Monad m => a -> m a
return

ledgerDbPush' :: ApplyBlock l b
              => LedgerCfg l -> b -> LedgerDB l b -> LedgerDB l b
ledgerDbPush' :: LedgerCfg l -> b -> LedgerDB l b -> LedgerDB l b
ledgerDbPush' LedgerCfg l
cfg b
b = Identity (LedgerDB l b) -> LedgerDB l b
forall a. Identity a -> a
runIdentity (Identity (LedgerDB l b) -> LedgerDB l b)
-> (LedgerDB l b -> Identity (LedgerDB l b))
-> LedgerDB l b
-> LedgerDB l b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerCfg l
-> Ap Identity l b b (() :: Constraint)
-> LedgerDB l b
-> Identity (LedgerDB l b)
forall (m :: * -> *) (c :: Constraint) l r b.
(ApplyBlock l b, Monad m, c) =>
LedgerCfg l -> Ap m l r b c -> LedgerDB l r -> m (LedgerDB l r)
ledgerDbPush LedgerCfg l
cfg (b -> Ap Identity l b b (() :: Constraint)
forall b (m :: * -> *) l. b -> Ap m l b b (() :: Constraint)
pureBlock b
b)

ledgerDbPushMany' :: ApplyBlock l b
                  => LedgerCfg l -> [b] -> LedgerDB l b -> LedgerDB l b
ledgerDbPushMany' :: LedgerCfg l -> [b] -> LedgerDB l b -> LedgerDB l b
ledgerDbPushMany' LedgerCfg l
cfg [b]
bs = Identity (LedgerDB l b) -> LedgerDB l b
forall a. Identity a -> a
runIdentity (Identity (LedgerDB l b) -> LedgerDB l b)
-> (LedgerDB l b -> Identity (LedgerDB l b))
-> LedgerDB l b
-> LedgerDB l b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerCfg l
-> [Ap Identity l b b (() :: Constraint)]
-> LedgerDB l b
-> Identity (LedgerDB l b)
forall l b (m :: * -> *) (c :: Constraint) r.
(ApplyBlock l b, Monad m, c) =>
LedgerCfg l -> [Ap m l r b c] -> LedgerDB l r -> m (LedgerDB l r)
ledgerDbPushMany LedgerCfg l
cfg ((b -> Ap Identity l b b (() :: Constraint))
-> [b] -> [Ap Identity l b b (() :: Constraint)]
forall a b. (a -> b) -> [a] -> [b]
map b -> Ap Identity l b b (() :: Constraint)
forall b (m :: * -> *) l. b -> Ap m l b b (() :: Constraint)
pureBlock [b]
bs)

ledgerDbSwitch' :: forall l b. ApplyBlock l b
                => LedgerCfg l
                -> Word64 -> [b] -> LedgerDB l b -> Maybe (LedgerDB l b)
ledgerDbSwitch' :: LedgerCfg l
-> Word64 -> [b] -> LedgerDB l b -> Maybe (LedgerDB l b)
ledgerDbSwitch' LedgerCfg l
cfg Word64
n [b]
bs LedgerDB l b
db =
    case Proxy b
-> Reader
     (ResolveBlock Identity b b)
     (Either ExceededRollback (LedgerDB l b))
-> Either ExceededRollback (LedgerDB l b)
forall b a. Proxy b -> Reader (ResolveBlock Identity b b) a -> a
triviallyResolve (Proxy b
forall k (t :: k). Proxy t
Proxy @b) (Reader
   (ResolveBlock Identity b b)
   (Either ExceededRollback (LedgerDB l b))
 -> Either ExceededRollback (LedgerDB l b))
-> Reader
     (ResolveBlock Identity b b)
     (Either ExceededRollback (LedgerDB l b))
-> Either ExceededRollback (LedgerDB l b)
forall a b. (a -> b) -> a -> b
$
           LedgerCfg l
-> Word64
-> [Ap
      (ReaderT (ResolveBlock Identity b b) Identity)
      l
      b
      b
      (() :: Constraint)]
-> LedgerDB l b
-> Reader
     (ResolveBlock Identity b b)
     (Either ExceededRollback (LedgerDB l b))
forall l b (m :: * -> *) (c :: Constraint) r.
(ApplyBlock l b, Monad m, c) =>
LedgerCfg l
-> Word64
-> [Ap m l r b c]
-> LedgerDB l r
-> m (Either ExceededRollback (LedgerDB l r))
ledgerDbSwitch LedgerCfg l
cfg Word64
n ((b
 -> Ap
      (ReaderT (ResolveBlock Identity b b) Identity)
      l
      b
      b
      (() :: Constraint))
-> [b]
-> [Ap
      (ReaderT (ResolveBlock Identity b b) Identity)
      l
      b
      b
      (() :: Constraint)]
forall a b. (a -> b) -> [a] -> [b]
map b
-> Ap
     (ReaderT (ResolveBlock Identity b b) Identity)
     l
     b
     b
     (() :: Constraint)
forall b (m :: * -> *) l. b -> Ap m l b b (() :: Constraint)
pureBlock [b]
bs) LedgerDB l b
db of
      Left  ExceededRollback{} -> Maybe (LedgerDB l b)
forall a. Maybe a
Nothing
      Right LedgerDB l b
db'                -> LedgerDB l b -> Maybe (LedgerDB l b)
forall a. a -> Maybe a
Just LedgerDB l b
db'

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

instance (Serialise l, Serialise r) => Serialise (ChainSummary l r) where
  encode :: ChainSummary l r -> Encoding
encode = (l -> Encoding) -> (r -> Encoding) -> ChainSummary l r -> Encoding
forall l r.
(l -> Encoding) -> (r -> Encoding) -> ChainSummary l r -> Encoding
encodeChainSummary l -> Encoding
forall a. Serialise a => a -> Encoding
encode r -> Encoding
forall a. Serialise a => a -> Encoding
encode
  decode :: Decoder s (ChainSummary l r)
decode = (forall s. Decoder s l)
-> (forall s. Decoder s r)
-> forall s. Decoder s (ChainSummary l r)
forall l r.
(forall s. Decoder s l)
-> (forall s. Decoder s r)
-> forall s. Decoder s (ChainSummary l r)
decodeChainSummary forall s. Decoder s l
forall a s. Serialise a => Decoder s a
decode forall s. Decoder s r
forall a s. Serialise a => Decoder s a
decode

encodeChainSummary :: (l -> Encoding)
                   -> (r -> Encoding)
                   -> ChainSummary l r -> Encoding
encodeChainSummary :: (l -> Encoding) -> (r -> Encoding) -> ChainSummary l r -> Encoding
encodeChainSummary l -> Encoding
encodeLedger r -> Encoding
encodeRef ChainSummary{l
Word64
WithOrigin r
csLedger :: l
csLength :: Word64
csTip :: WithOrigin r
csLedger :: forall l r. ChainSummary l r -> l
csLength :: forall l r. ChainSummary l r -> Word64
csTip :: forall l r. ChainSummary l r -> WithOrigin r
..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
Enc.encodeListLen Word
3
    , (r -> Encoding) -> WithOrigin r -> Encoding
forall a. (a -> Encoding) -> WithOrigin a -> Encoding
encodeWithOrigin r -> Encoding
encodeRef WithOrigin r
csTip
    , Word64 -> Encoding
Enc.encodeWord64 Word64
csLength
    , l -> Encoding
encodeLedger l
csLedger
    ]

decodeChainSummary :: (forall s. Decoder s l)
                   -> (forall s. Decoder s r)
                   -> forall s. Decoder s (ChainSummary l r)
decodeChainSummary :: (forall s. Decoder s l)
-> (forall s. Decoder s r)
-> forall s. Decoder s (ChainSummary l r)
decodeChainSummary forall s. Decoder s l
decodeLedger forall s. Decoder s r
decodeRef = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
Dec.decodeListLenOf Int
3
    WithOrigin r
csTip    <- Decoder s r -> Decoder s (WithOrigin r)
forall s a. Decoder s a -> Decoder s (WithOrigin a)
decodeWithOrigin Decoder s r
forall s. Decoder s r
decodeRef
    Word64
csLength <- Decoder s Word64
forall s. Decoder s Word64
Dec.decodeWord64
    l
csLedger <- Decoder s l
forall s. Decoder s l
decodeLedger
    ChainSummary l r -> Decoder s (ChainSummary l r)
forall (m :: * -> *) a. Monad m => a -> m a
return ChainSummary :: forall l r. WithOrigin r -> Word64 -> l -> ChainSummary l r
ChainSummary{l
Word64
WithOrigin r
csLedger :: l
csLength :: Word64
csTip :: WithOrigin r
csLedger :: l
csLength :: Word64
csTip :: WithOrigin r
..}