{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeFamilies          #-}

{-# OPTIONS_GHC -Wno-orphans #-}

-- | Instances requires for consensus/ledger integration
module Ouroboros.Consensus.Byron.Ledger.Ledger (
    ByronTransition (..)
    -- * Ledger integration
  , byronEraParams
  , byronEraParamsNeverHardForks
  , initByronLedgerState
    -- * Serialisation
  , decodeByronAnnTip
  , decodeByronLedgerState
  , decodeByronQuery
  , decodeByronResult
  , encodeByronAnnTip
  , encodeByronExtLedgerState
  , encodeByronHeaderState
  , encodeByronLedgerState
  , encodeByronQuery
  , encodeByronResult
    -- * Type family instances
  , BlockQuery (..)
  , LedgerState (..)
  , Ticked (..)
    -- * Auxiliary
  , validationErrorImpossible
  ) where

import           Codec.CBOR.Decoding (Decoder)
import qualified Codec.CBOR.Decoding as CBOR
import           Codec.CBOR.Encoding (Encoding)
import qualified Codec.CBOR.Encoding as CBOR
import           Codec.Serialise (decode, encode)
import           Control.Monad.Except
import           Data.ByteString (ByteString)
import           Data.Kind (Type)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)

import           Cardano.Binary (encodeListLen, enforceSize, fromCBOR, toCBOR)

import qualified Cardano.Chain.Block as CC
import qualified Cardano.Chain.Byron.API as CC
import qualified Cardano.Chain.Genesis as Gen
import qualified Cardano.Chain.UTxO as CC
import qualified Cardano.Chain.Update as Update
import qualified Cardano.Chain.Update.Validation.Endorsement as UPE
import qualified Cardano.Chain.Update.Validation.Interface as UPI
import qualified Cardano.Chain.ValidationMode as CC

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Forecast
import           Ouroboros.Consensus.HardFork.Abstract
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.CommonProtocolParams
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Query
import           Ouroboros.Consensus.Ledger.SupportsPeerSelection
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Protocol.PBFT
import           Ouroboros.Consensus.Util (ShowProxy (..), (..:))

import           Ouroboros.Consensus.Byron.Ledger.Block
import           Ouroboros.Consensus.Byron.Ledger.Conversions
import           Ouroboros.Consensus.Byron.Ledger.HeaderValidation ()
import           Ouroboros.Consensus.Byron.Ledger.PBFT
import           Ouroboros.Consensus.Byron.Ledger.Serialisation

{-------------------------------------------------------------------------------
  LedgerState
-------------------------------------------------------------------------------}

data instance LedgerState ByronBlock = ByronLedgerState {
      LedgerState ByronBlock -> WithOrigin BlockNo
byronLedgerTipBlockNo :: !(WithOrigin BlockNo)
    , LedgerState ByronBlock -> ChainValidationState
byronLedgerState      :: !CC.ChainValidationState
    , LedgerState ByronBlock -> ByronTransition
byronLedgerTransition :: !ByronTransition
    }
  deriving (LedgerState ByronBlock -> LedgerState ByronBlock -> Bool
(LedgerState ByronBlock -> LedgerState ByronBlock -> Bool)
-> (LedgerState ByronBlock -> LedgerState ByronBlock -> Bool)
-> Eq (LedgerState ByronBlock)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LedgerState ByronBlock -> LedgerState ByronBlock -> Bool
$c/= :: LedgerState ByronBlock -> LedgerState ByronBlock -> Bool
== :: LedgerState ByronBlock -> LedgerState ByronBlock -> Bool
$c== :: LedgerState ByronBlock -> LedgerState ByronBlock -> Bool
Eq, Int -> LedgerState ByronBlock -> ShowS
[LedgerState ByronBlock] -> ShowS
LedgerState ByronBlock -> String
(Int -> LedgerState ByronBlock -> ShowS)
-> (LedgerState ByronBlock -> String)
-> ([LedgerState ByronBlock] -> ShowS)
-> Show (LedgerState ByronBlock)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LedgerState ByronBlock] -> ShowS
$cshowList :: [LedgerState ByronBlock] -> ShowS
show :: LedgerState ByronBlock -> String
$cshow :: LedgerState ByronBlock -> String
showsPrec :: Int -> LedgerState ByronBlock -> ShowS
$cshowsPrec :: Int -> LedgerState ByronBlock -> ShowS
Show, (forall x.
 LedgerState ByronBlock -> Rep (LedgerState ByronBlock) x)
-> (forall x.
    Rep (LedgerState ByronBlock) x -> LedgerState ByronBlock)
-> Generic (LedgerState ByronBlock)
forall x. Rep (LedgerState ByronBlock) x -> LedgerState ByronBlock
forall x. LedgerState ByronBlock -> Rep (LedgerState ByronBlock) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep (LedgerState ByronBlock) x -> LedgerState ByronBlock
$cfrom :: forall x. LedgerState ByronBlock -> Rep (LedgerState ByronBlock) x
Generic, Context -> LedgerState ByronBlock -> IO (Maybe ThunkInfo)
Proxy (LedgerState ByronBlock) -> String
(Context -> LedgerState ByronBlock -> IO (Maybe ThunkInfo))
-> (Context -> LedgerState ByronBlock -> IO (Maybe ThunkInfo))
-> (Proxy (LedgerState ByronBlock) -> String)
-> NoThunks (LedgerState ByronBlock)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (LedgerState ByronBlock) -> String
$cshowTypeOf :: Proxy (LedgerState ByronBlock) -> String
wNoThunks :: Context -> LedgerState ByronBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LedgerState ByronBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> LedgerState ByronBlock -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> LedgerState ByronBlock -> IO (Maybe ThunkInfo)
NoThunks)

-- | Information required to determine the transition from Byron to Shelley
data ByronTransition =
    -- | Per candidate proposal, the 'BlockNo' in which it became a candidate
    --
    -- The HFC needs to know when a candidate proposal becomes stable. We cannot
    -- reliably do this using 'SlotNo': doing so would mean that if we were to
    -- switch to a denser fork, something that was previously deemed stable is
    -- suddenly not deemed stable anymore (although in actuality it still is).
    -- We therefore must do this based on 'BlockNo' instead, but unfortunately
    -- the Byron ledger does not record this information. Therefore, we record
    -- it here instead.
    --
    -- Invariant: the domain of this map should equal the set of candidate
    -- proposals.
    ByronTransitionInfo !(Map Update.ProtocolVersion BlockNo)
  deriving (ByronTransition -> ByronTransition -> Bool
(ByronTransition -> ByronTransition -> Bool)
-> (ByronTransition -> ByronTransition -> Bool)
-> Eq ByronTransition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ByronTransition -> ByronTransition -> Bool
$c/= :: ByronTransition -> ByronTransition -> Bool
== :: ByronTransition -> ByronTransition -> Bool
$c== :: ByronTransition -> ByronTransition -> Bool
Eq, Int -> ByronTransition -> ShowS
[ByronTransition] -> ShowS
ByronTransition -> String
(Int -> ByronTransition -> ShowS)
-> (ByronTransition -> String)
-> ([ByronTransition] -> ShowS)
-> Show ByronTransition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ByronTransition] -> ShowS
$cshowList :: [ByronTransition] -> ShowS
show :: ByronTransition -> String
$cshow :: ByronTransition -> String
showsPrec :: Int -> ByronTransition -> ShowS
$cshowsPrec :: Int -> ByronTransition -> ShowS
Show, (forall x. ByronTransition -> Rep ByronTransition x)
-> (forall x. Rep ByronTransition x -> ByronTransition)
-> Generic ByronTransition
forall x. Rep ByronTransition x -> ByronTransition
forall x. ByronTransition -> Rep ByronTransition x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ByronTransition x -> ByronTransition
$cfrom :: forall x. ByronTransition -> Rep ByronTransition x
Generic, Context -> ByronTransition -> IO (Maybe ThunkInfo)
Proxy ByronTransition -> String
(Context -> ByronTransition -> IO (Maybe ThunkInfo))
-> (Context -> ByronTransition -> IO (Maybe ThunkInfo))
-> (Proxy ByronTransition -> String)
-> NoThunks ByronTransition
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy ByronTransition -> String
$cshowTypeOf :: Proxy ByronTransition -> String
wNoThunks :: Context -> ByronTransition -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ByronTransition -> IO (Maybe ThunkInfo)
noThunks :: Context -> ByronTransition -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> ByronTransition -> IO (Maybe ThunkInfo)
NoThunks)

instance UpdateLedger ByronBlock

type instance LedgerCfg (LedgerState ByronBlock) = Gen.Config

initByronLedgerState :: Gen.Config
                     -> Maybe CC.UTxO -- ^ Optionally override UTxO
                     -> LedgerState ByronBlock
initByronLedgerState :: Config -> Maybe UTxO -> LedgerState ByronBlock
initByronLedgerState Config
genesis Maybe UTxO
mUtxo = ByronLedgerState :: WithOrigin BlockNo
-> ChainValidationState
-> ByronTransition
-> LedgerState ByronBlock
ByronLedgerState {
      byronLedgerState :: ChainValidationState
byronLedgerState      = Maybe UTxO -> ChainValidationState -> ChainValidationState
override Maybe UTxO
mUtxo ChainValidationState
initState
    , byronLedgerTipBlockNo :: WithOrigin BlockNo
byronLedgerTipBlockNo = WithOrigin BlockNo
forall t. WithOrigin t
Origin
    , byronLedgerTransition :: ByronTransition
byronLedgerTransition = Map ProtocolVersion BlockNo -> ByronTransition
ByronTransitionInfo Map ProtocolVersion BlockNo
forall k a. Map k a
Map.empty
    }
  where
    initState :: CC.ChainValidationState
    initState :: ChainValidationState
initState = case Except Error ChainValidationState
-> Either Error ChainValidationState
forall e a. Except e a -> Either e a
runExcept (Except Error ChainValidationState
 -> Either Error ChainValidationState)
-> Except Error ChainValidationState
-> Either Error ChainValidationState
forall a b. (a -> b) -> a -> b
$ Config -> Except Error ChainValidationState
forall (m :: * -> *).
MonadError Error m =>
Config -> m ChainValidationState
CC.initialChainValidationState Config
genesis of
      Right ChainValidationState
st -> ChainValidationState
st
      Left Error
e   -> String -> ChainValidationState
forall a. HasCallStack => String -> a
error (String -> ChainValidationState) -> String -> ChainValidationState
forall a b. (a -> b) -> a -> b
$
        String
"could not create initial ChainValidationState: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Error -> String
forall a. Show a => a -> String
show Error
e

    override :: Maybe CC.UTxO
             -> CC.ChainValidationState -> CC.ChainValidationState
    override :: Maybe UTxO -> ChainValidationState -> ChainValidationState
override Maybe UTxO
Nothing     ChainValidationState
st = ChainValidationState
st
    override (Just UTxO
utxo) ChainValidationState
st = ChainValidationState
st { $sel:cvsUtxo:ChainValidationState :: UTxO
CC.cvsUtxo = UTxO
utxo }

{-------------------------------------------------------------------------------
  GetTip
-------------------------------------------------------------------------------}

instance GetTip (LedgerState ByronBlock) where
  getTip :: LedgerState ByronBlock -> Point (LedgerState ByronBlock)
getTip = Point ByronBlock -> Point (LedgerState ByronBlock)
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point ByronBlock -> Point (LedgerState ByronBlock))
-> (LedgerState ByronBlock -> Point ByronBlock)
-> LedgerState ByronBlock
-> Point (LedgerState ByronBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainValidationState -> Point ByronBlock
getByronTip (ChainValidationState -> Point ByronBlock)
-> (LedgerState ByronBlock -> ChainValidationState)
-> LedgerState ByronBlock
-> Point ByronBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState ByronBlock -> ChainValidationState
byronLedgerState

instance GetTip (Ticked (LedgerState ByronBlock)) where
  getTip :: Ticked (LedgerState ByronBlock)
-> Point (Ticked (LedgerState ByronBlock))
getTip = Point ByronBlock -> Point (Ticked (LedgerState ByronBlock))
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point ByronBlock -> Point (Ticked (LedgerState ByronBlock)))
-> (Ticked (LedgerState ByronBlock) -> Point ByronBlock)
-> Ticked (LedgerState ByronBlock)
-> Point (Ticked (LedgerState ByronBlock))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainValidationState -> Point ByronBlock
getByronTip (ChainValidationState -> Point ByronBlock)
-> (Ticked (LedgerState ByronBlock) -> ChainValidationState)
-> Ticked (LedgerState ByronBlock)
-> Point ByronBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState ByronBlock) -> ChainValidationState
tickedByronLedgerState

getByronTip :: CC.ChainValidationState -> Point ByronBlock
getByronTip :: ChainValidationState -> Point ByronBlock
getByronTip ChainValidationState
state =
    case ChainValidationState -> Either GenesisHash HeaderHash
CC.cvsPreviousHash ChainValidationState
state of
      -- In this case there are no blocks in the ledger state. The genesis
      -- block does not occupy a slot, so its point is Origin.
      Left GenesisHash
_genHash -> Point ByronBlock
forall block. Point block
GenesisPoint
      Right HeaderHash
hdrHash -> SlotNo -> HeaderHash ByronBlock -> Point ByronBlock
forall block. SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
slot (HeaderHash -> ByronHash
ByronHash HeaderHash
hdrHash)
        where
          slot :: SlotNo
slot = SlotNumber -> SlotNo
fromByronSlotNo (ChainValidationState -> SlotNumber
CC.cvsLastSlot ChainValidationState
state)

{-------------------------------------------------------------------------------
  Ticked ledger state
-------------------------------------------------------------------------------}

-- | The ticked Byron ledger state
data instance Ticked (LedgerState ByronBlock) = TickedByronLedgerState {
      Ticked (LedgerState ByronBlock) -> ChainValidationState
tickedByronLedgerState        :: !CC.ChainValidationState
    , Ticked (LedgerState ByronBlock) -> ByronTransition
untickedByronLedgerTransition :: !ByronTransition
    }
  deriving ((forall x.
 Ticked (LedgerState ByronBlock)
 -> Rep (Ticked (LedgerState ByronBlock)) x)
-> (forall x.
    Rep (Ticked (LedgerState ByronBlock)) x
    -> Ticked (LedgerState ByronBlock))
-> Generic (Ticked (LedgerState ByronBlock))
forall x.
Rep (Ticked (LedgerState ByronBlock)) x
-> Ticked (LedgerState ByronBlock)
forall x.
Ticked (LedgerState ByronBlock)
-> Rep (Ticked (LedgerState ByronBlock)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep (Ticked (LedgerState ByronBlock)) x
-> Ticked (LedgerState ByronBlock)
$cfrom :: forall x.
Ticked (LedgerState ByronBlock)
-> Rep (Ticked (LedgerState ByronBlock)) x
Generic, Context -> Ticked (LedgerState ByronBlock) -> IO (Maybe ThunkInfo)
Proxy (Ticked (LedgerState ByronBlock)) -> String
(Context
 -> Ticked (LedgerState ByronBlock) -> IO (Maybe ThunkInfo))
-> (Context
    -> Ticked (LedgerState ByronBlock) -> IO (Maybe ThunkInfo))
-> (Proxy (Ticked (LedgerState ByronBlock)) -> String)
-> NoThunks (Ticked (LedgerState ByronBlock))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (Ticked (LedgerState ByronBlock)) -> String
$cshowTypeOf :: Proxy (Ticked (LedgerState ByronBlock)) -> String
wNoThunks :: Context -> Ticked (LedgerState ByronBlock) -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Ticked (LedgerState ByronBlock) -> IO (Maybe ThunkInfo)
noThunks :: Context -> Ticked (LedgerState ByronBlock) -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> Ticked (LedgerState ByronBlock) -> IO (Maybe ThunkInfo)
NoThunks)

instance IsLedger (LedgerState ByronBlock) where
  type LedgerErr (LedgerState ByronBlock) = CC.ChainValidationError

  type AuxLedgerEvent (LedgerState ByronBlock) =
    VoidLedgerEvent (LedgerState ByronBlock)

  applyChainTickLedgerResult :: LedgerCfg (LedgerState ByronBlock)
-> SlotNo
-> LedgerState ByronBlock
-> LedgerResult
     (LedgerState ByronBlock) (Ticked (LedgerState ByronBlock))
applyChainTickLedgerResult LedgerCfg (LedgerState ByronBlock)
cfg SlotNo
slotNo ByronLedgerState{..} = Ticked (LedgerState ByronBlock)
-> LedgerResult
     (LedgerState ByronBlock) (Ticked (LedgerState ByronBlock))
forall a l. a -> LedgerResult l a
pureLedgerResult (Ticked (LedgerState ByronBlock)
 -> LedgerResult
      (LedgerState ByronBlock) (Ticked (LedgerState ByronBlock)))
-> Ticked (LedgerState ByronBlock)
-> LedgerResult
     (LedgerState ByronBlock) (Ticked (LedgerState ByronBlock))
forall a b. (a -> b) -> a -> b
$
      TickedByronLedgerState :: ChainValidationState
-> ByronTransition -> Ticked (LedgerState ByronBlock)
TickedByronLedgerState {
          tickedByronLedgerState :: ChainValidationState
tickedByronLedgerState =
            Config
-> SlotNumber -> ChainValidationState -> ChainValidationState
CC.applyChainTick Config
LedgerCfg (LedgerState ByronBlock)
cfg (SlotNo -> SlotNumber
toByronSlotNo SlotNo
slotNo) ChainValidationState
byronLedgerState
        , untickedByronLedgerTransition :: ByronTransition
untickedByronLedgerTransition =
            ByronTransition
byronLedgerTransition
        }

{-------------------------------------------------------------------------------
  Supporting the various consensus interfaces
-------------------------------------------------------------------------------}

instance ApplyBlock (LedgerState ByronBlock) ByronBlock where
  applyBlockLedgerResult :: LedgerCfg (LedgerState ByronBlock)
-> ByronBlock
-> Ticked (LedgerState ByronBlock)
-> Except
     (LedgerErr (LedgerState ByronBlock))
     (LedgerResult (LedgerState ByronBlock) (LedgerState ByronBlock))
applyBlockLedgerResult = (LedgerState ByronBlock
 -> LedgerResult (LedgerState ByronBlock) (LedgerState ByronBlock))
-> ExceptT ChainValidationError Identity (LedgerState ByronBlock)
-> ExceptT
     ChainValidationError
     Identity
     (LedgerResult (LedgerState ByronBlock) (LedgerState ByronBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LedgerState ByronBlock
-> LedgerResult (LedgerState ByronBlock) (LedgerState ByronBlock)
forall a l. a -> LedgerResult l a
pureLedgerResult (ExceptT ChainValidationError Identity (LedgerState ByronBlock)
 -> ExceptT
      ChainValidationError
      Identity
      (LedgerResult (LedgerState ByronBlock) (LedgerState ByronBlock)))
-> (Config
    -> ByronBlock
    -> Ticked (LedgerState ByronBlock)
    -> ExceptT ChainValidationError Identity (LedgerState ByronBlock))
-> Config
-> ByronBlock
-> Ticked (LedgerState ByronBlock)
-> ExceptT
     ChainValidationError
     Identity
     (LedgerResult (LedgerState ByronBlock) (LedgerState ByronBlock))
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: ValidationMode
-> LedgerCfg (LedgerState ByronBlock)
-> ByronBlock
-> Ticked (LedgerState ByronBlock)
-> Except
     (LedgerErr (LedgerState ByronBlock)) (LedgerState ByronBlock)
applyByronBlock ValidationMode
validationMode
    where
      validationMode :: ValidationMode
validationMode = BlockValidationMode -> ValidationMode
CC.fromBlockValidationMode BlockValidationMode
CC.BlockValidation

  reapplyBlockLedgerResult :: LedgerCfg (LedgerState ByronBlock)
-> ByronBlock
-> Ticked (LedgerState ByronBlock)
-> LedgerResult (LedgerState ByronBlock) (LedgerState ByronBlock)
reapplyBlockLedgerResult =
          (LedgerState ByronBlock
-> LedgerResult (LedgerState ByronBlock) (LedgerState ByronBlock)
forall a l. a -> LedgerResult l a
pureLedgerResult (LedgerState ByronBlock
 -> LedgerResult (LedgerState ByronBlock) (LedgerState ByronBlock))
-> (ExceptT ChainValidationError Identity (LedgerState ByronBlock)
    -> LedgerState ByronBlock)
-> ExceptT ChainValidationError Identity (LedgerState ByronBlock)
-> LedgerResult (LedgerState ByronBlock) (LedgerState ByronBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT ChainValidationError Identity (LedgerState ByronBlock)
-> LedgerState ByronBlock
forall err a. Except err a -> a
validationErrorImpossible)
      (ExceptT ChainValidationError Identity (LedgerState ByronBlock)
 -> LedgerResult (LedgerState ByronBlock) (LedgerState ByronBlock))
-> (Config
    -> ByronBlock
    -> Ticked (LedgerState ByronBlock)
    -> ExceptT ChainValidationError Identity (LedgerState ByronBlock))
-> Config
-> ByronBlock
-> Ticked (LedgerState ByronBlock)
-> LedgerResult (LedgerState ByronBlock) (LedgerState ByronBlock)
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: ValidationMode
-> LedgerCfg (LedgerState ByronBlock)
-> ByronBlock
-> Ticked (LedgerState ByronBlock)
-> Except
     (LedgerErr (LedgerState ByronBlock)) (LedgerState ByronBlock)
applyByronBlock ValidationMode
validationMode
    where
      validationMode :: ValidationMode
validationMode = BlockValidationMode -> ValidationMode
CC.fromBlockValidationMode BlockValidationMode
CC.NoBlockValidation

data instance BlockQuery ByronBlock :: Type -> Type where
  GetUpdateInterfaceState :: BlockQuery ByronBlock UPI.State

instance QueryLedger ByronBlock where
  answerBlockQuery :: ExtLedgerCfg ByronBlock
-> BlockQuery ByronBlock result
-> ExtLedgerState ByronBlock
-> result
answerBlockQuery ExtLedgerCfg ByronBlock
_cfg BlockQuery ByronBlock result
GetUpdateInterfaceState (ExtLedgerState LedgerState ByronBlock
ledgerState HeaderState ByronBlock
_) =
    ChainValidationState -> State
CC.cvsUpdateState (LedgerState ByronBlock -> ChainValidationState
byronLedgerState LedgerState ByronBlock
ledgerState)

instance SameDepIndex (BlockQuery ByronBlock) where
  sameDepIndex :: BlockQuery ByronBlock a
-> BlockQuery ByronBlock b -> Maybe (a :~: b)
sameDepIndex BlockQuery ByronBlock a
GetUpdateInterfaceState BlockQuery ByronBlock b
GetUpdateInterfaceState = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl

deriving instance Eq (BlockQuery ByronBlock result)
deriving instance Show (BlockQuery ByronBlock result)

instance ShowQuery (BlockQuery ByronBlock) where
  showResult :: BlockQuery ByronBlock result -> result -> String
showResult BlockQuery ByronBlock result
GetUpdateInterfaceState = result -> String
forall a. Show a => a -> String
show

instance ShowProxy (BlockQuery ByronBlock) where

instance LedgerSupportsPeerSelection ByronBlock where
  getPeers :: LedgerState ByronBlock -> [(PoolStake, NonEmpty StakePoolRelay)]
getPeers = [(PoolStake, NonEmpty StakePoolRelay)]
-> LedgerState ByronBlock -> [(PoolStake, NonEmpty StakePoolRelay)]
forall a b. a -> b -> a
const []

instance CommonProtocolParams ByronBlock where
  maxHeaderSize :: LedgerState ByronBlock -> Word32
maxHeaderSize = Natural -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Word32)
-> (LedgerState ByronBlock -> Natural)
-> LedgerState ByronBlock
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolParameters -> Natural
Update.ppMaxHeaderSize (ProtocolParameters -> Natural)
-> (LedgerState ByronBlock -> ProtocolParameters)
-> LedgerState ByronBlock
-> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState ByronBlock -> ProtocolParameters
getProtocolParameters
  maxTxSize :: LedgerState ByronBlock -> Word32
maxTxSize     = Natural -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Word32)
-> (LedgerState ByronBlock -> Natural)
-> LedgerState ByronBlock
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolParameters -> Natural
Update.ppMaxTxSize     (ProtocolParameters -> Natural)
-> (LedgerState ByronBlock -> ProtocolParameters)
-> LedgerState ByronBlock
-> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState ByronBlock -> ProtocolParameters
getProtocolParameters

-- | Return the protocol parameters adopted by the given ledger.
getProtocolParameters :: LedgerState ByronBlock -> Update.ProtocolParameters
getProtocolParameters :: LedgerState ByronBlock -> ProtocolParameters
getProtocolParameters =
      State -> ProtocolParameters
CC.adoptedProtocolParameters
    (State -> ProtocolParameters)
-> (LedgerState ByronBlock -> State)
-> LedgerState ByronBlock
-> ProtocolParameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainValidationState -> State
CC.cvsUpdateState
    (ChainValidationState -> State)
-> (LedgerState ByronBlock -> ChainValidationState)
-> LedgerState ByronBlock
-> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState ByronBlock -> ChainValidationState
byronLedgerState

instance LedgerSupportsProtocol ByronBlock where
  protocolLedgerView :: LedgerCfg (LedgerState ByronBlock)
-> Ticked (LedgerState ByronBlock)
-> Ticked (LedgerView (BlockProtocol ByronBlock))
protocolLedgerView LedgerCfg (LedgerState ByronBlock)
_cfg =
        Map -> Ticked (PBftLedgerView PBftByronCrypto)
toTickedPBftLedgerView
      (Map -> Ticked (PBftLedgerView PBftByronCrypto))
-> (Ticked (LedgerState ByronBlock) -> Map)
-> Ticked (LedgerState ByronBlock)
-> Ticked (PBftLedgerView PBftByronCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainValidationState -> Map
CC.getDelegationMap
      (ChainValidationState -> Map)
-> (Ticked (LedgerState ByronBlock) -> ChainValidationState)
-> Ticked (LedgerState ByronBlock)
-> Map
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState ByronBlock) -> ChainValidationState
tickedByronLedgerState

  -- Create a forecast of the delegation state
  --
  -- We can return forecasts for slots in the @[NOW .. NOW+2k)@ window, where
  -- @NOW@ is the slot number of the last block applied to the ledger.
  --
  -- These forecasts will be used to validate future headers, i.e., to check
  -- whether they have been created by the right delegates.
  --
  -- We cannot look more than @2k@ slots ahead, because there might be
  -- delegation state changes present in the blocks between the last block
  -- applied to the ledger and the header to validate that can kick in after
  -- @2k@ slots.
  --
  -- To create a forecast, take the delegation state from the given ledger
  -- state, and apply the updates that should be applied by the given slot.
  ledgerViewForecastAt :: LedgerCfg (LedgerState ByronBlock)
-> LedgerState ByronBlock
-> Forecast (LedgerView (BlockProtocol ByronBlock))
ledgerViewForecastAt LedgerCfg (LedgerState ByronBlock)
cfg (ByronLedgerState _tipBlkNo st _) = WithOrigin SlotNo
-> (SlotNo
    -> Except
         OutsideForecastRange (Ticked (PBftLedgerView PBftByronCrypto)))
-> Forecast (PBftLedgerView PBftByronCrypto)
forall a.
WithOrigin SlotNo
-> (SlotNo -> Except OutsideForecastRange (Ticked a)) -> Forecast a
Forecast WithOrigin SlotNo
at ((SlotNo
  -> Except
       OutsideForecastRange (Ticked (PBftLedgerView PBftByronCrypto)))
 -> Forecast (PBftLedgerView PBftByronCrypto))
-> (SlotNo
    -> Except
         OutsideForecastRange (Ticked (PBftLedgerView PBftByronCrypto)))
-> Forecast (PBftLedgerView PBftByronCrypto)
forall a b. (a -> b) -> a -> b
$ \SlotNo
for ->
      Map -> Ticked (PBftLedgerView PBftByronCrypto)
toTickedPBftLedgerView (Map -> Ticked (PBftLedgerView PBftByronCrypto))
-> ExceptT OutsideForecastRange Identity Map
-> Except
     OutsideForecastRange (Ticked (PBftLedgerView PBftByronCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if
        | SlotNo
for SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
lastSlot ->
          Map -> ExceptT OutsideForecastRange Identity Map
forall (m :: * -> *) a. Monad m => a -> m a
return (Map -> ExceptT OutsideForecastRange Identity Map)
-> Map -> ExceptT OutsideForecastRange Identity Map
forall a b. (a -> b) -> a -> b
$ ChainValidationState -> Map
CC.getDelegationMap ChainValidationState
st
        | SlotNo
for SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
maxFor ->
          Map -> ExceptT OutsideForecastRange Identity Map
forall (m :: * -> *) a. Monad m => a -> m a
return (Map -> ExceptT OutsideForecastRange Identity Map)
-> Map -> ExceptT OutsideForecastRange Identity Map
forall a b. (a -> b) -> a -> b
$ SlotNumber -> ChainValidationState -> Map
CC.previewDelegationMap (SlotNo -> SlotNumber
toByronSlotNo SlotNo
for) ChainValidationState
st
        | Bool
otherwise ->
          OutsideForecastRange -> ExceptT OutsideForecastRange Identity Map
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (OutsideForecastRange -> ExceptT OutsideForecastRange Identity Map)
-> OutsideForecastRange
-> ExceptT OutsideForecastRange Identity Map
forall a b. (a -> b) -> a -> b
$ OutsideForecastRange :: WithOrigin SlotNo -> SlotNo -> SlotNo -> OutsideForecastRange
OutsideForecastRange {
              outsideForecastAt :: WithOrigin SlotNo
outsideForecastAt     = WithOrigin SlotNo
at
            , outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor = SlotNo
maxFor
            , outsideForecastFor :: SlotNo
outsideForecastFor    = SlotNo
for
            }
    where
      SecurityParam Word64
k = Config -> SecurityParam
genesisSecurityParam Config
LedgerCfg (LedgerState ByronBlock)
cfg
      lastSlot :: SlotNo
lastSlot        = SlotNumber -> SlotNo
fromByronSlotNo (SlotNumber -> SlotNo) -> SlotNumber -> SlotNo
forall a b. (a -> b) -> a -> b
$ ChainValidationState -> SlotNumber
CC.cvsLastSlot ChainValidationState
st
      at :: WithOrigin SlotNo
at              = SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
lastSlot

      -- The upper bound is exclusive
      maxFor :: SlotNo
      maxFor :: SlotNo
maxFor = case WithOrigin SlotNo
at of
          WithOrigin SlotNo
Origin      -> Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
k
          NotOrigin SlotNo
s -> Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
s Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
k)

-- | To be used for a Byron-to-X (where X is typically Shelley) chain.
byronEraParams :: Gen.Config -> HardFork.EraParams
byronEraParams :: Config -> EraParams
byronEraParams Config
genesis = EraParams :: EpochSize -> SlotLength -> SafeZone -> EraParams
HardFork.EraParams {
      eraEpochSize :: EpochSize
eraEpochSize  = EpochSlots -> EpochSize
fromByronEpochSlots (EpochSlots -> EpochSize) -> EpochSlots -> EpochSize
forall a b. (a -> b) -> a -> b
$ Config -> EpochSlots
Gen.configEpochSlots Config
genesis
    , eraSlotLength :: SlotLength
eraSlotLength = Natural -> SlotLength
fromByronSlotLength (Natural -> SlotLength) -> Natural -> SlotLength
forall a b. (a -> b) -> a -> b
$ Config -> Natural
genesisSlotLength Config
genesis
    , eraSafeZone :: SafeZone
eraSafeZone   = Word64 -> SafeZone
HardFork.StandardSafeZone (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
k)
    }
  where
    SecurityParam Word64
k = Config -> SecurityParam
genesisSecurityParam Config
genesis

-- | Separate variant of 'byronEraParams' to be used for a Byron-only chain.
byronEraParamsNeverHardForks :: Gen.Config -> HardFork.EraParams
byronEraParamsNeverHardForks :: Config -> EraParams
byronEraParamsNeverHardForks Config
genesis = EraParams :: EpochSize -> SlotLength -> SafeZone -> EraParams
HardFork.EraParams {
      eraEpochSize :: EpochSize
eraEpochSize  = EpochSlots -> EpochSize
fromByronEpochSlots (EpochSlots -> EpochSize) -> EpochSlots -> EpochSize
forall a b. (a -> b) -> a -> b
$ Config -> EpochSlots
Gen.configEpochSlots Config
genesis
    , eraSlotLength :: SlotLength
eraSlotLength = Natural -> SlotLength
fromByronSlotLength (Natural -> SlotLength) -> Natural -> SlotLength
forall a b. (a -> b) -> a -> b
$ Config -> Natural
genesisSlotLength Config
genesis
    , eraSafeZone :: SafeZone
eraSafeZone   = SafeZone
HardFork.UnsafeIndefiniteSafeZone
    }

instance HasHardForkHistory ByronBlock where
  type HardForkIndices ByronBlock = '[ByronBlock]
  hardForkSummary :: LedgerCfg (LedgerState ByronBlock)
-> LedgerState ByronBlock -> Summary (HardForkIndices ByronBlock)
hardForkSummary = (LedgerCfg (LedgerState ByronBlock) -> EraParams)
-> LedgerCfg (LedgerState ByronBlock)
-> LedgerState ByronBlock
-> Summary '[ByronBlock]
forall blk.
(LedgerConfig blk -> EraParams)
-> LedgerConfig blk -> LedgerState blk -> Summary '[blk]
neverForksHardForkSummary Config -> EraParams
LedgerCfg (LedgerState ByronBlock) -> EraParams
byronEraParamsNeverHardForks

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

-- | Mark computation as validation error free
--
-- Given a 'BlockValidationMode' of 'NoBlockValidation', a call to
-- 'applyByronBlock' shouldn't fail since the ledger layer won't be performing
-- any block validation checks. However, because 'applyByronBlock' can fail in
-- the event it is given a 'BlockValidationMode' of 'BlockValidation', it still
-- /looks/ like it can fail (since its type doesn't change based on the
-- 'ValidationMode') and we must still treat it as such.
validationErrorImpossible :: forall err a. Except err a -> a
validationErrorImpossible :: Except err a -> a
validationErrorImpossible = Either err a -> a
cantBeError (Either err a -> a)
-> (Except err a -> Either err a) -> Except err a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except err a -> Either err a
forall e a. Except e a -> Either e a
runExcept
  where
    cantBeError :: Either err a -> a
    cantBeError :: Either err a -> a
cantBeError (Left  err
_) = String -> a
forall a. HasCallStack => String -> a
error String
"validationErrorImpossible: unexpected error"
    cantBeError (Right a
a) = a
a

{-------------------------------------------------------------------------------
  Applying a block

  Most of the work here is done by the ledger layer. We just need to pass
  the right arguments, and maintain the snapshots.
-------------------------------------------------------------------------------}

applyByronBlock :: CC.ValidationMode
                -> LedgerConfig ByronBlock
                -> ByronBlock
                -> TickedLedgerState ByronBlock
                -> Except (LedgerError ByronBlock) (LedgerState ByronBlock)
applyByronBlock :: ValidationMode
-> LedgerCfg (LedgerState ByronBlock)
-> ByronBlock
-> Ticked (LedgerState ByronBlock)
-> Except
     (LedgerErr (LedgerState ByronBlock)) (LedgerState ByronBlock)
applyByronBlock ValidationMode
validationMode
                LedgerCfg (LedgerState ByronBlock)
cfg
                blk :: ByronBlock
blk@(ByronBlock ABlockOrBoundary ByteString
raw SlotNo
_ (ByronHash HeaderHash
blkHash))
                Ticked (LedgerState ByronBlock)
ls =
    case ABlockOrBoundary ByteString
raw of
      CC.ABOBBlock    ABlock ByteString
raw' -> ValidationMode
-> Config
-> ABlock ByteString
-> HeaderHash
-> BlockNo
-> Ticked (LedgerState ByronBlock)
-> Except
     (LedgerErr (LedgerState ByronBlock)) (LedgerState ByronBlock)
applyABlock ValidationMode
validationMode Config
LedgerCfg (LedgerState ByronBlock)
cfg ABlock ByteString
raw' HeaderHash
blkHash BlockNo
blkNo Ticked (LedgerState ByronBlock)
ls
      CC.ABOBBoundary ABoundaryBlock ByteString
raw' -> Config
-> ABoundaryBlock ByteString
-> BlockNo
-> Ticked (LedgerState ByronBlock)
-> Except
     (LedgerErr (LedgerState ByronBlock)) (LedgerState ByronBlock)
applyABoundaryBlock        Config
LedgerCfg (LedgerState ByronBlock)
cfg ABoundaryBlock ByteString
raw'         BlockNo
blkNo Ticked (LedgerState ByronBlock)
ls
  where
    blkNo :: BlockNo
    blkNo :: BlockNo
blkNo = ByronBlock -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo ByronBlock
blk

applyABlock :: CC.ValidationMode
            -> Gen.Config
            -> CC.ABlock ByteString
            -> CC.HeaderHash
            -> BlockNo
            -> Ticked (LedgerState (ByronBlock))
            -> Except (LedgerError ByronBlock) (LedgerState ByronBlock)
applyABlock :: ValidationMode
-> Config
-> ABlock ByteString
-> HeaderHash
-> BlockNo
-> Ticked (LedgerState ByronBlock)
-> Except
     (LedgerErr (LedgerState ByronBlock)) (LedgerState ByronBlock)
applyABlock ValidationMode
validationMode Config
cfg ABlock ByteString
blk HeaderHash
blkHash BlockNo
blkNo TickedByronLedgerState{..} = do
    ChainValidationState
st' <- Config
-> ValidationMode
-> ABlock ByteString
-> HeaderHash
-> ChainValidationState
-> ExceptT ChainValidationError Identity ChainValidationState
forall (m :: * -> *).
MonadError ChainValidationError m =>
Config
-> ValidationMode
-> ABlock ByteString
-> HeaderHash
-> ChainValidationState
-> m ChainValidationState
CC.validateBlock Config
cfg ValidationMode
validationMode ABlock ByteString
blk HeaderHash
blkHash ChainValidationState
tickedByronLedgerState

    let updState :: UPI.State
        updState :: State
updState = ChainValidationState -> State
CC.cvsUpdateState ChainValidationState
st'

        -- Transition info as it would look like if all entries were new
        ifNew :: Map Update.ProtocolVersion BlockNo
        ifNew :: Map ProtocolVersion BlockNo
ifNew = [(ProtocolVersion, BlockNo)] -> Map ProtocolVersion BlockNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ProtocolVersion, BlockNo)] -> Map ProtocolVersion BlockNo)
-> [(ProtocolVersion, BlockNo)] -> Map ProtocolVersion BlockNo
forall a b. (a -> b) -> a -> b
$ (CandidateProtocolUpdate -> (ProtocolVersion, BlockNo))
-> [CandidateProtocolUpdate] -> [(ProtocolVersion, BlockNo)]
forall a b. (a -> b) -> [a] -> [b]
map CandidateProtocolUpdate -> (ProtocolVersion, BlockNo)
aux (State -> [CandidateProtocolUpdate]
UPI.candidateProtocolUpdates State
updState)
          where
            aux :: UPE.CandidateProtocolUpdate
                -> (Update.ProtocolVersion, BlockNo)
            aux :: CandidateProtocolUpdate -> (ProtocolVersion, BlockNo)
aux CandidateProtocolUpdate
candidate = (CandidateProtocolUpdate -> ProtocolVersion
UPE.cpuProtocolVersion CandidateProtocolUpdate
candidate, BlockNo
blkNo)

        transition' :: ByronTransition
        transition' :: ByronTransition
transition' =
            case ByronTransition
untickedByronLedgerTransition of
              ByronTransitionInfo Map ProtocolVersion BlockNo
oldEntries -> Map ProtocolVersion BlockNo -> ByronTransition
ByronTransitionInfo (Map ProtocolVersion BlockNo -> ByronTransition)
-> Map ProtocolVersion BlockNo -> ByronTransition
forall a b. (a -> b) -> a -> b
$
                -- Candidates that have /just/ become candidates
                let newEntries :: Map Update.ProtocolVersion BlockNo
                    newEntries :: Map ProtocolVersion BlockNo
newEntries = Map ProtocolVersion BlockNo
ifNew Map ProtocolVersion BlockNo
-> Map ProtocolVersion BlockNo -> Map ProtocolVersion BlockNo
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map ProtocolVersion BlockNo
oldEntries

                -- Remove any entries that aren't candidates anymore
                in (Map ProtocolVersion BlockNo
oldEntries Map ProtocolVersion BlockNo
-> Map ProtocolVersion BlockNo -> Map ProtocolVersion BlockNo
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.intersection` Map ProtocolVersion BlockNo
ifNew) Map ProtocolVersion BlockNo
-> Map ProtocolVersion BlockNo -> Map ProtocolVersion BlockNo
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map ProtocolVersion BlockNo
newEntries

    LedgerState ByronBlock
-> ExceptT ChainValidationError Identity (LedgerState ByronBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return ByronLedgerState :: WithOrigin BlockNo
-> ChainValidationState
-> ByronTransition
-> LedgerState ByronBlock
ByronLedgerState {
          byronLedgerTipBlockNo :: WithOrigin BlockNo
byronLedgerTipBlockNo = BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
NotOrigin BlockNo
blkNo
        , byronLedgerState :: ChainValidationState
byronLedgerState      = ChainValidationState
st'
        , byronLedgerTransition :: ByronTransition
byronLedgerTransition = ByronTransition
transition'
        }

-- | Apply boundary block
--
-- Since boundary blocks don't modify the delegation state, they also don't
-- modify the delegation history.
applyABoundaryBlock :: Gen.Config
                    -> CC.ABoundaryBlock ByteString
                    -> BlockNo
                    -> Ticked (LedgerState ByronBlock)
                    -> Except (LedgerError ByronBlock) (LedgerState ByronBlock)
applyABoundaryBlock :: Config
-> ABoundaryBlock ByteString
-> BlockNo
-> Ticked (LedgerState ByronBlock)
-> Except
     (LedgerErr (LedgerState ByronBlock)) (LedgerState ByronBlock)
applyABoundaryBlock Config
cfg ABoundaryBlock ByteString
blk BlockNo
blkNo TickedByronLedgerState{..} = do
    ChainValidationState
st' <- Config
-> ABoundaryBlock ByteString
-> ChainValidationState
-> ExceptT ChainValidationError Identity ChainValidationState
forall (m :: * -> *).
MonadError ChainValidationError m =>
Config
-> ABoundaryBlock ByteString
-> ChainValidationState
-> m ChainValidationState
CC.validateBoundary Config
cfg ABoundaryBlock ByteString
blk ChainValidationState
tickedByronLedgerState
    LedgerState ByronBlock
-> ExceptT ChainValidationError Identity (LedgerState ByronBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return ByronLedgerState :: WithOrigin BlockNo
-> ChainValidationState
-> ByronTransition
-> LedgerState ByronBlock
ByronLedgerState {
        byronLedgerTipBlockNo :: WithOrigin BlockNo
byronLedgerTipBlockNo = BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
NotOrigin BlockNo
blkNo
      , byronLedgerState :: ChainValidationState
byronLedgerState      = ChainValidationState
st'
      , byronLedgerTransition :: ByronTransition
byronLedgerTransition = ByronTransition
untickedByronLedgerTransition
      }

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

encodeByronAnnTip :: AnnTip ByronBlock -> Encoding
encodeByronAnnTip :: AnnTip ByronBlock -> Encoding
encodeByronAnnTip = (HeaderHash ByronBlock -> Encoding)
-> AnnTip ByronBlock -> Encoding
forall blk.
(TipInfo blk ~ TipInfoIsEBB blk) =>
(HeaderHash blk -> Encoding) -> AnnTip blk -> Encoding
encodeAnnTipIsEBB HeaderHash ByronBlock -> Encoding
encodeByronHeaderHash

decodeByronAnnTip :: Decoder s (AnnTip ByronBlock)
decodeByronAnnTip :: Decoder s (AnnTip ByronBlock)
decodeByronAnnTip = (forall s. Decoder s (HeaderHash ByronBlock))
-> forall s. Decoder s (AnnTip ByronBlock)
forall blk.
(TipInfo blk ~ TipInfoIsEBB blk) =>
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (AnnTip blk)
decodeAnnTipIsEBB forall s. Decoder s (HeaderHash ByronBlock)
decodeByronHeaderHash

encodeByronExtLedgerState :: ExtLedgerState ByronBlock -> Encoding
encodeByronExtLedgerState :: ExtLedgerState ByronBlock -> Encoding
encodeByronExtLedgerState = (LedgerState ByronBlock -> Encoding)
-> (ChainDepState (BlockProtocol ByronBlock) -> Encoding)
-> (AnnTip ByronBlock -> Encoding)
-> ExtLedgerState ByronBlock
-> Encoding
forall blk.
(LedgerState blk -> Encoding)
-> (ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding)
-> ExtLedgerState blk
-> Encoding
encodeExtLedgerState
    LedgerState ByronBlock -> Encoding
encodeByronLedgerState
    ChainDepState (BlockProtocol ByronBlock) -> Encoding
encodeByronChainDepState
    AnnTip ByronBlock -> Encoding
encodeByronAnnTip

encodeByronHeaderState :: HeaderState ByronBlock -> Encoding
encodeByronHeaderState :: HeaderState ByronBlock -> Encoding
encodeByronHeaderState = (ChainDepState (BlockProtocol ByronBlock) -> Encoding)
-> (AnnTip ByronBlock -> Encoding)
-> HeaderState ByronBlock
-> Encoding
forall blk.
(ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding) -> HeaderState blk -> Encoding
encodeHeaderState
    ChainDepState (BlockProtocol ByronBlock) -> Encoding
encodeByronChainDepState
    AnnTip ByronBlock -> Encoding
encodeByronAnnTip

-- | Encode transition info
--
-- We encode the absence of any info separately. This gives us a bit more
-- wiggle room to change our mind about what we store in snapshots, as they
-- typically don't contain any transition info.
--
-- Implementation note: we should have encoded the absence of data with the
-- inclusion of a list length. We didn't, so the decoder is a bit awkward :/
--
-- TODO: If we break compatibility anyway, we might decide to clean this up.
encodeByronTransition :: ByronTransition -> Encoding
encodeByronTransition :: ByronTransition -> Encoding
encodeByronTransition (ByronTransitionInfo Map ProtocolVersion BlockNo
bNos)
  | Map ProtocolVersion BlockNo -> Bool
forall k a. Map k a -> Bool
Map.null Map ProtocolVersion BlockNo
bNos = Word8 -> Encoding
CBOR.encodeWord8 Word8
0
  | Bool
otherwise     =
         Word -> Encoding
CBOR.encodeListLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Map ProtocolVersion BlockNo -> Int
forall k a. Map k a -> Int
Map.size Map ProtocolVersion BlockNo
bNos))
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat (((ProtocolVersion, BlockNo) -> Encoding)
-> [(ProtocolVersion, BlockNo)] -> [Encoding]
forall a b. (a -> b) -> [a] -> [b]
map (ProtocolVersion, BlockNo) -> Encoding
aux (Map ProtocolVersion BlockNo -> [(ProtocolVersion, BlockNo)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map ProtocolVersion BlockNo
bNos))
  where
    aux :: (Update.ProtocolVersion, BlockNo) -> Encoding
    aux :: (ProtocolVersion, BlockNo) -> Encoding
aux (Update.ProtocolVersion { Word16
pvMajor :: ProtocolVersion -> Word16
pvMajor :: Word16
pvMajor, Word16
pvMinor :: ProtocolVersion -> Word16
pvMinor :: Word16
pvMinor, Word8
pvAlt :: ProtocolVersion -> Word8
pvAlt :: Word8
pvAlt }, BlockNo
bno) = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
          Word -> Encoding
CBOR.encodeListLen Word
4
        , Word16 -> Encoding
forall a. Serialise a => a -> Encoding
encode Word16
pvMajor
        , Word16 -> Encoding
forall a. Serialise a => a -> Encoding
encode Word16
pvMinor
        , Word8 -> Encoding
forall a. Serialise a => a -> Encoding
encode Word8
pvAlt
        , BlockNo -> Encoding
forall a. Serialise a => a -> Encoding
encode BlockNo
bno
        ]

-- | Decode Byron transition info
--
-- See comments for 'encodeByronTransition'.
decodeByronTransition :: Decoder s ByronTransition
decodeByronTransition :: Decoder s ByronTransition
decodeByronTransition = do
    TokenType
ttype <- Decoder s TokenType
forall s. Decoder s TokenType
CBOR.peekTokenType
    (Map ProtocolVersion BlockNo -> ByronTransition)
-> Decoder s (Map ProtocolVersion BlockNo)
-> Decoder s ByronTransition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map ProtocolVersion BlockNo -> ByronTransition
ByronTransitionInfo (Decoder s (Map ProtocolVersion BlockNo)
 -> Decoder s ByronTransition)
-> Decoder s (Map ProtocolVersion BlockNo)
-> Decoder s ByronTransition
forall a b. (a -> b) -> a -> b
$ case TokenType
ttype of
      TokenType
CBOR.TypeUInt -> do
        Word8
tag <- Decoder s Word8
forall s. Decoder s Word8
CBOR.decodeWord8
        case Word8
tag of
          Word8
0          -> Map ProtocolVersion BlockNo
-> Decoder s (Map ProtocolVersion BlockNo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map ProtocolVersion BlockNo
 -> Decoder s (Map ProtocolVersion BlockNo))
-> Map ProtocolVersion BlockNo
-> Decoder s (Map ProtocolVersion BlockNo)
forall a b. (a -> b) -> a -> b
$ Map ProtocolVersion BlockNo
forall k a. Map k a
Map.empty
          Word8
_otherwise -> String -> Decoder s (Map ProtocolVersion BlockNo)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decodeByronTransition: unexpected tag"
      TokenType
CBOR.TypeListLen -> do
        Int
size <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
        [(ProtocolVersion, BlockNo)] -> Map ProtocolVersion BlockNo
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList ([(ProtocolVersion, BlockNo)] -> Map ProtocolVersion BlockNo)
-> Decoder s [(ProtocolVersion, BlockNo)]
-> Decoder s (Map ProtocolVersion BlockNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Decoder s (ProtocolVersion, BlockNo)
-> Decoder s [(ProtocolVersion, BlockNo)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
size Decoder s (ProtocolVersion, BlockNo)
forall s. Decoder s (ProtocolVersion, BlockNo)
aux
      TokenType
_otherwise ->
        String -> Decoder s (Map ProtocolVersion BlockNo)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decodeByronTransition: unexpected token type"
  where
    aux :: Decoder s (Update.ProtocolVersion, BlockNo)
    aux :: Decoder s (ProtocolVersion, BlockNo)
aux = do
        Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"decodeByronTransition.aux" Int
4
        Word16
pvMajor <- Decoder s Word16
forall a s. Serialise a => Decoder s a
decode
        Word16
pvMinor <- Decoder s Word16
forall a s. Serialise a => Decoder s a
decode
        Word8
pvAlt   <- Decoder s Word8
forall a s. Serialise a => Decoder s a
decode
        BlockNo
bno     <- Decoder s BlockNo
forall a s. Serialise a => Decoder s a
decode
        (ProtocolVersion, BlockNo) -> Decoder s (ProtocolVersion, BlockNo)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProtocolVersion :: Word16 -> Word16 -> Word8 -> ProtocolVersion
Update.ProtocolVersion { Word16
pvMajor :: Word16
pvMajor :: Word16
pvMajor, Word16
pvMinor :: Word16
pvMinor :: Word16
pvMinor, Word8
pvAlt :: Word8
pvAlt :: Word8
pvAlt }, BlockNo
bno)

encodeByronLedgerState :: LedgerState ByronBlock -> Encoding
encodeByronLedgerState :: LedgerState ByronBlock -> Encoding
encodeByronLedgerState ByronLedgerState{..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
3
    , WithOrigin BlockNo -> Encoding
forall a. Serialise a => a -> Encoding
encode WithOrigin BlockNo
byronLedgerTipBlockNo
    , ChainValidationState -> Encoding
forall a. Serialise a => a -> Encoding
encode ChainValidationState
byronLedgerState
    , ByronTransition -> Encoding
encodeByronTransition ByronTransition
byronLedgerTransition
    ]

decodeByronLedgerState :: Decoder s (LedgerState ByronBlock)
decodeByronLedgerState :: Decoder s (LedgerState ByronBlock)
decodeByronLedgerState = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"ByronLedgerState" Int
3
    WithOrigin BlockNo
-> ChainValidationState
-> ByronTransition
-> LedgerState ByronBlock
ByronLedgerState
      (WithOrigin BlockNo
 -> ChainValidationState
 -> ByronTransition
 -> LedgerState ByronBlock)
-> Decoder s (WithOrigin BlockNo)
-> Decoder
     s
     (ChainValidationState -> ByronTransition -> LedgerState ByronBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (WithOrigin BlockNo)
forall a s. Serialise a => Decoder s a
decode
      Decoder
  s
  (ChainValidationState -> ByronTransition -> LedgerState ByronBlock)
-> Decoder s ChainValidationState
-> Decoder s (ByronTransition -> LedgerState ByronBlock)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s ChainValidationState
forall a s. Serialise a => Decoder s a
decode
      Decoder s (ByronTransition -> LedgerState ByronBlock)
-> Decoder s ByronTransition -> Decoder s (LedgerState ByronBlock)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s ByronTransition
forall s. Decoder s ByronTransition
decodeByronTransition

encodeByronQuery :: BlockQuery ByronBlock result -> Encoding
encodeByronQuery :: BlockQuery ByronBlock result -> Encoding
encodeByronQuery BlockQuery ByronBlock result
query = case BlockQuery ByronBlock result
query of
    BlockQuery ByronBlock result
GetUpdateInterfaceState -> Word8 -> Encoding
CBOR.encodeWord8 Word8
0

decodeByronQuery :: Decoder s (SomeSecond BlockQuery ByronBlock)
decodeByronQuery :: Decoder s (SomeSecond BlockQuery ByronBlock)
decodeByronQuery = do
    Word8
tag <- Decoder s Word8
forall s. Decoder s Word8
CBOR.decodeWord8
    case Word8
tag of
      Word8
0 -> SomeSecond BlockQuery ByronBlock
-> Decoder s (SomeSecond BlockQuery ByronBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeSecond BlockQuery ByronBlock
 -> Decoder s (SomeSecond BlockQuery ByronBlock))
-> SomeSecond BlockQuery ByronBlock
-> Decoder s (SomeSecond BlockQuery ByronBlock)
forall a b. (a -> b) -> a -> b
$ BlockQuery ByronBlock State -> SomeSecond BlockQuery ByronBlock
forall (f :: * -> * -> *) a b. f a b -> SomeSecond f a
SomeSecond BlockQuery ByronBlock State
GetUpdateInterfaceState
      Word8
_ -> String -> Decoder s (SomeSecond BlockQuery ByronBlock)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (SomeSecond BlockQuery ByronBlock))
-> String -> Decoder s (SomeSecond BlockQuery ByronBlock)
forall a b. (a -> b) -> a -> b
$ String
"decodeByronQuery: invalid tag " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
tag

encodeByronResult :: BlockQuery ByronBlock result -> result -> Encoding
encodeByronResult :: BlockQuery ByronBlock result -> result -> Encoding
encodeByronResult BlockQuery ByronBlock result
query = case BlockQuery ByronBlock result
query of
    BlockQuery ByronBlock result
GetUpdateInterfaceState -> result -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR

decodeByronResult :: BlockQuery ByronBlock result
                  -> forall s. Decoder s result
decodeByronResult :: BlockQuery ByronBlock result -> forall s. Decoder s result
decodeByronResult BlockQuery ByronBlock result
query = case BlockQuery ByronBlock result
query of
    BlockQuery ByronBlock result
GetUpdateInterfaceState -> Decoder s result
forall a s. FromCBOR a => Decoder s a
fromCBOR