{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Cardano.Chain.Byron.API.Mempool
  ( ApplyMempoolPayloadErr (..),
    applyMempoolPayload,
    mempoolPayloadRecoverBytes,
    mempoolPayloadReencode,
  )
where

import Cardano.Binary
import qualified Cardano.Chain.Block as CC
import Cardano.Chain.Byron.API.Common
import qualified Cardano.Chain.Delegation as Delegation
import qualified Cardano.Chain.Delegation.Validation.Interface as D.Iface
import qualified Cardano.Chain.Delegation.Validation.Scheduling as D.Sched
import qualified Cardano.Chain.Genesis as Gen
import qualified Cardano.Chain.MempoolPayload as CC
import qualified Cardano.Chain.Slotting as CC
import qualified Cardano.Chain.UTxO as Utxo
import qualified Cardano.Chain.Update as Update
import qualified Cardano.Chain.Update.Validation.Interface as U.Iface
import qualified Cardano.Chain.ValidationMode as CC
import Cardano.Crypto.ProtocolMagic
import Cardano.Prelude
import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Write as CBOR
import qualified Data.Set as Set

{-------------------------------------------------------------------------------
  Apply any kind of transactions
-------------------------------------------------------------------------------}

-- | Errors that arise from applying an arbitrary mempool payload
--
-- Although @cardano-legder@ defines 'MempoolPayload', it does not define a
-- corresponding error type. We could 'ChainValidationError', but it's too
-- large, which is problematic because we actually sent encoded versions of
-- these errors across the wire.
data ApplyMempoolPayloadErr
  = MempoolTxErr Utxo.UTxOValidationError
  | MempoolDlgErr D.Sched.Error
  | MempoolUpdateProposalErr U.Iface.Error
  | MempoolUpdateVoteErr U.Iface.Error
  deriving (ApplyMempoolPayloadErr -> ApplyMempoolPayloadErr -> Bool
(ApplyMempoolPayloadErr -> ApplyMempoolPayloadErr -> Bool)
-> (ApplyMempoolPayloadErr -> ApplyMempoolPayloadErr -> Bool)
-> Eq ApplyMempoolPayloadErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApplyMempoolPayloadErr -> ApplyMempoolPayloadErr -> Bool
$c/= :: ApplyMempoolPayloadErr -> ApplyMempoolPayloadErr -> Bool
== :: ApplyMempoolPayloadErr -> ApplyMempoolPayloadErr -> Bool
$c== :: ApplyMempoolPayloadErr -> ApplyMempoolPayloadErr -> Bool
Eq, Int -> ApplyMempoolPayloadErr -> ShowS
[ApplyMempoolPayloadErr] -> ShowS
ApplyMempoolPayloadErr -> String
(Int -> ApplyMempoolPayloadErr -> ShowS)
-> (ApplyMempoolPayloadErr -> String)
-> ([ApplyMempoolPayloadErr] -> ShowS)
-> Show ApplyMempoolPayloadErr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApplyMempoolPayloadErr] -> ShowS
$cshowList :: [ApplyMempoolPayloadErr] -> ShowS
show :: ApplyMempoolPayloadErr -> String
$cshow :: ApplyMempoolPayloadErr -> String
showsPrec :: Int -> ApplyMempoolPayloadErr -> ShowS
$cshowsPrec :: Int -> ApplyMempoolPayloadErr -> ShowS
Show)

instance ToCBOR ApplyMempoolPayloadErr where
  toCBOR :: ApplyMempoolPayloadErr -> Encoding
toCBOR (MempoolTxErr UTxOValidationError
err) =
    Word -> Encoding
CBOR.encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
0 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UTxOValidationError -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR UTxOValidationError
err
  toCBOR (MempoolDlgErr Error
err) =
    Word -> Encoding
CBOR.encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
1 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Error -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Error
err
  toCBOR (MempoolUpdateProposalErr Error
err) =
    Word -> Encoding
CBOR.encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
2 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Error -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Error
err
  toCBOR (MempoolUpdateVoteErr Error
err) =
    Word -> Encoding
CBOR.encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
3 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Error -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Error
err

instance FromCBOR ApplyMempoolPayloadErr where
  fromCBOR :: Decoder s ApplyMempoolPayloadErr
fromCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"ApplyMempoolPayloadErr" Int
2
    Decoder s Word8
forall s. Decoder s Word8
CBOR.decodeWord8 Decoder s Word8
-> (Word8 -> Decoder s ApplyMempoolPayloadErr)
-> Decoder s ApplyMempoolPayloadErr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Word8
0 -> UTxOValidationError -> ApplyMempoolPayloadErr
MempoolTxErr (UTxOValidationError -> ApplyMempoolPayloadErr)
-> Decoder s UTxOValidationError
-> Decoder s ApplyMempoolPayloadErr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s UTxOValidationError
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
1 -> Error -> ApplyMempoolPayloadErr
MempoolDlgErr (Error -> ApplyMempoolPayloadErr)
-> Decoder s Error -> Decoder s ApplyMempoolPayloadErr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Error
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
2 -> Error -> ApplyMempoolPayloadErr
MempoolUpdateProposalErr (Error -> ApplyMempoolPayloadErr)
-> Decoder s Error -> Decoder s ApplyMempoolPayloadErr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Error
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
3 -> Error -> ApplyMempoolPayloadErr
MempoolUpdateVoteErr (Error -> ApplyMempoolPayloadErr)
-> Decoder s Error -> Decoder s ApplyMempoolPayloadErr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Error
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
tag -> DecoderError -> Decoder s ApplyMempoolPayloadErr
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s ApplyMempoolPayloadErr)
-> DecoderError -> Decoder s ApplyMempoolPayloadErr
forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"ApplyMempoolPayloadErr" Word8
tag

applyMempoolPayload ::
  MonadError ApplyMempoolPayloadErr m =>
  CC.ValidationMode ->
  Gen.Config ->
  CC.SlotNumber ->
  CC.AMempoolPayload ByteString ->
  CC.ChainValidationState ->
  m CC.ChainValidationState
applyMempoolPayload :: ValidationMode
-> Config
-> SlotNumber
-> AMempoolPayload ByteString
-> ChainValidationState
-> m ChainValidationState
applyMempoolPayload ValidationMode
validationMode Config
cfg SlotNumber
currentSlot AMempoolPayload ByteString
payload =
  case AMempoolPayload ByteString
payload of
    CC.MempoolTx ATxAux ByteString
tx ->
      (Either UTxOValidationError ChainValidationState
-> (UTxOValidationError -> ApplyMempoolPayloadErr)
-> m ChainValidationState
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` UTxOValidationError -> ApplyMempoolPayloadErr
MempoolTxErr)
        (Either UTxOValidationError ChainValidationState
 -> m ChainValidationState)
-> (ChainValidationState
    -> Either UTxOValidationError ChainValidationState)
-> ChainValidationState
-> m ChainValidationState
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ValidationMode
-> Config
-> [ATxAux ByteString]
-> ChainValidationState
-> Either UTxOValidationError ChainValidationState
forall (m :: * -> *).
MonadError UTxOValidationError m =>
ValidationMode
-> Config
-> [ATxAux ByteString]
-> ChainValidationState
-> m ChainValidationState
applyTxAux ValidationMode
validationMode Config
cfg [ATxAux ByteString
tx]
    CC.MempoolDlg ACertificate ByteString
cert ->
      (Either Error ChainValidationState
-> (Error -> ApplyMempoolPayloadErr) -> m ChainValidationState
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Error -> ApplyMempoolPayloadErr
MempoolDlgErr)
        (Either Error ChainValidationState -> m ChainValidationState)
-> (ChainValidationState -> Either Error ChainValidationState)
-> ChainValidationState
-> m ChainValidationState
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config
-> SlotNumber
-> [ACertificate ByteString]
-> ChainValidationState
-> Either Error ChainValidationState
forall (m :: * -> *).
MonadError Error m =>
Config
-> SlotNumber
-> [ACertificate ByteString]
-> ChainValidationState
-> m ChainValidationState
applyCertificate Config
cfg SlotNumber
currentSlot [ACertificate ByteString
cert]
    CC.MempoolUpdateProposal AProposal ByteString
proposal ->
      (Either Error ChainValidationState
-> (Error -> ApplyMempoolPayloadErr) -> m ChainValidationState
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Error -> ApplyMempoolPayloadErr
MempoolUpdateProposalErr)
        (Either Error ChainValidationState -> m ChainValidationState)
-> (ChainValidationState -> Either Error ChainValidationState)
-> ChainValidationState
-> m ChainValidationState
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config
-> SlotNumber
-> AProposal ByteString
-> ChainValidationState
-> Either Error ChainValidationState
forall (m :: * -> *).
MonadError Error m =>
Config
-> SlotNumber
-> AProposal ByteString
-> ChainValidationState
-> m ChainValidationState
applyUpdateProposal Config
cfg SlotNumber
currentSlot AProposal ByteString
proposal
    CC.MempoolUpdateVote AVote ByteString
vote ->
      (Either Error ChainValidationState
-> (Error -> ApplyMempoolPayloadErr) -> m ChainValidationState
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Error -> ApplyMempoolPayloadErr
MempoolUpdateVoteErr)
        (Either Error ChainValidationState -> m ChainValidationState)
-> (ChainValidationState -> Either Error ChainValidationState)
-> ChainValidationState
-> m ChainValidationState
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config
-> SlotNumber
-> AVote ByteString
-> ChainValidationState
-> Either Error ChainValidationState
forall (m :: * -> *).
MonadError Error m =>
Config
-> SlotNumber
-> AVote ByteString
-> ChainValidationState
-> m ChainValidationState
applyUpdateVote Config
cfg SlotNumber
currentSlot AVote ByteString
vote

-- | The encoding of the mempool payload (without a 'AMempoolPayload' envelope)
mempoolPayloadRecoverBytes :: CC.AMempoolPayload ByteString -> ByteString
mempoolPayloadRecoverBytes :: AMempoolPayload ByteString -> ByteString
mempoolPayloadRecoverBytes = AMempoolPayload ByteString -> ByteString
go
  where
    go :: CC.AMempoolPayload ByteString -> ByteString
    go :: AMempoolPayload ByteString -> ByteString
go (CC.MempoolTx ATxAux ByteString
payload) = ATxAux ByteString -> ByteString
forall t. Decoded t => t -> ByteString
recoverBytes ATxAux ByteString
payload
    go (CC.MempoolDlg ACertificate ByteString
payload) = ACertificate ByteString -> ByteString
forall t. Decoded t => t -> ByteString
recoverBytes ACertificate ByteString
payload
    go (CC.MempoolUpdateProposal AProposal ByteString
payload) = AProposal ByteString -> ByteString
forall t. Decoded t => t -> ByteString
recoverBytes AProposal ByteString
payload
    go (CC.MempoolUpdateVote AVote ByteString
payload) = AVote ByteString -> ByteString
forall t. Decoded t => t -> ByteString
recoverBytes AVote ByteString
payload

-- | Re-encode the mempool payload (without any envelope)
mempoolPayloadReencode :: CC.AMempoolPayload a -> ByteString
mempoolPayloadReencode :: AMempoolPayload a -> ByteString
mempoolPayloadReencode = AMempoolPayload a -> ByteString
forall a. AMempoolPayload a -> ByteString
go
  where
    go :: forall a. CC.AMempoolPayload a -> ByteString
    go :: AMempoolPayload a -> ByteString
go (CC.MempoolTx ATxAux a
payload) = ATxAux a -> ByteString
forall (f :: * -> *) a.
(Functor f, ToCBOR (f ())) =>
f a -> ByteString
reencode ATxAux a
payload
    go (CC.MempoolDlg ACertificate a
payload) = ACertificate a -> ByteString
forall (f :: * -> *) a.
(Functor f, ToCBOR (f ())) =>
f a -> ByteString
reencode ACertificate a
payload
    go (CC.MempoolUpdateProposal AProposal a
payload) = AProposal a -> ByteString
forall (f :: * -> *) a.
(Functor f, ToCBOR (f ())) =>
f a -> ByteString
reencode AProposal a
payload
    go (CC.MempoolUpdateVote AVote a
payload) = AVote a -> ByteString
forall (f :: * -> *) a.
(Functor f, ToCBOR (f ())) =>
f a -> ByteString
reencode AVote a
payload

    reencode :: (Functor f, ToCBOR (f ())) => f a -> ByteString
    reencode :: f a -> ByteString
reencode = Encoding -> ByteString
CBOR.toStrictByteString (Encoding -> ByteString) -> (f a -> Encoding) -> f a -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f () -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (f () -> Encoding) -> (f a -> f ()) -> f a -> Encoding
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f a -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void

{-------------------------------------------------------------------------------
  Applying transactions
-------------------------------------------------------------------------------}

mkUtxoEnvironment ::
  Gen.Config ->
  CC.ChainValidationState ->
  Utxo.Environment
mkUtxoEnvironment :: Config -> ChainValidationState -> Environment
mkUtxoEnvironment Config
cfg ChainValidationState
cvs =
  Environment :: AProtocolMagic ByteString
-> ProtocolParameters -> UTxOConfiguration -> Environment
Utxo.Environment
    { protocolMagic :: AProtocolMagic ByteString
Utxo.protocolMagic = AProtocolMagic ByteString
protocolMagic,
      protocolParameters :: ProtocolParameters
Utxo.protocolParameters = State -> ProtocolParameters
U.Iface.adoptedProtocolParameters State
updateState,
      utxoConfiguration :: UTxOConfiguration
Utxo.utxoConfiguration = Config -> UTxOConfiguration
Gen.configUTxOConfiguration Config
cfg
    }
  where
    protocolMagic :: AProtocolMagic ByteString
protocolMagic = ProtocolMagic -> AProtocolMagic ByteString
reAnnotateMagic (Config -> ProtocolMagic
Gen.configProtocolMagic Config
cfg)
    updateState :: State
updateState = ChainValidationState -> State
CC.cvsUpdateState ChainValidationState
cvs

mkDelegationEnvironment ::
  Gen.Config ->
  CC.SlotNumber ->
  D.Iface.Environment
mkDelegationEnvironment :: Config -> SlotNumber -> Environment
mkDelegationEnvironment Config
cfg SlotNumber
currentSlot =
  Environment :: Annotated ProtocolMagicId ByteString
-> Set KeyHash
-> BlockCount
-> EpochNumber
-> SlotNumber
-> Environment
D.Iface.Environment
    { protocolMagic :: Annotated ProtocolMagicId ByteString
D.Iface.protocolMagic = AProtocolMagic ByteString -> Annotated ProtocolMagicId ByteString
forall a. AProtocolMagic a -> Annotated ProtocolMagicId a
getAProtocolMagicId AProtocolMagic ByteString
protocolMagic,
      allowedDelegators :: Set KeyHash
D.Iface.allowedDelegators = Config -> Set KeyHash
allowedDelegators Config
cfg,
      k :: BlockCount
D.Iface.k = BlockCount
k,
      -- The @currentSlot@/@currentEpoch@ for checking a delegation certificate
      -- must be that of the block in which the delegation certificate is/will
      -- be included.
      currentEpoch :: EpochNumber
D.Iface.currentEpoch = EpochNumber
currentEpoch,
      currentSlot :: SlotNumber
D.Iface.currentSlot = SlotNumber
currentSlot
    }
  where
    k :: BlockCount
k = Config -> BlockCount
Gen.configK Config
cfg
    protocolMagic :: AProtocolMagic ByteString
protocolMagic = ProtocolMagic -> AProtocolMagic ByteString
reAnnotateMagic (Config -> ProtocolMagic
Gen.configProtocolMagic Config
cfg)
    currentEpoch :: EpochNumber
currentEpoch = EpochSlots -> SlotNumber -> EpochNumber
CC.slotNumberEpoch (Config -> EpochSlots
Gen.configEpochSlots Config
cfg) SlotNumber
currentSlot

mkUpdateEnvironment ::
  Gen.Config ->
  CC.SlotNumber ->
  Delegation.Map ->
  U.Iface.Environment
mkUpdateEnvironment :: Config -> SlotNumber -> Map -> Environment
mkUpdateEnvironment Config
cfg SlotNumber
currentSlot Map
delegationMap =
  Environment :: Annotated ProtocolMagicId ByteString
-> BlockCount -> SlotNumber -> Word8 -> Map -> Environment
U.Iface.Environment
    { protocolMagic :: Annotated ProtocolMagicId ByteString
U.Iface.protocolMagic = AProtocolMagic ByteString -> Annotated ProtocolMagicId ByteString
forall a. AProtocolMagic a -> Annotated ProtocolMagicId a
getAProtocolMagicId AProtocolMagic ByteString
protocolMagic,
      k :: BlockCount
U.Iface.k = BlockCount
k,
      currentSlot :: SlotNumber
U.Iface.currentSlot = SlotNumber
currentSlot,
      numGenKeys :: Word8
U.Iface.numGenKeys = Word8
numGenKeys,
      delegationMap :: Map
U.Iface.delegationMap = Map
delegationMap
    }
  where
    k :: BlockCount
k = Config -> BlockCount
Gen.configK Config
cfg
    protocolMagic :: AProtocolMagic ByteString
protocolMagic = ProtocolMagic -> AProtocolMagic ByteString
reAnnotateMagic (Config -> ProtocolMagic
Gen.configProtocolMagic Config
cfg)
    numGenKeys :: Word8
numGenKeys = Int -> Word8
toNumGenKeys (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Set KeyHash -> Int
forall a. Set a -> Int
Set.size (Config -> Set KeyHash
allowedDelegators Config
cfg)

    toNumGenKeys :: Int -> Word8
    toNumGenKeys :: Int -> Word8
toNumGenKeys Int
n
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
forall a. Bounded a => a
maxBound :: Word8) =
          Text -> Word8
forall a. HasCallStack => Text -> a
panic (Text -> Word8) -> Text -> Word8
forall a b. (a -> b) -> a -> b
$
            Text
"toNumGenKeys: Too many genesis keys"
      | Bool
otherwise = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n

applyTxAux ::
  MonadError Utxo.UTxOValidationError m =>
  CC.ValidationMode ->
  Gen.Config ->
  [Utxo.ATxAux ByteString] ->
  CC.ChainValidationState ->
  m CC.ChainValidationState
applyTxAux :: ValidationMode
-> Config
-> [ATxAux ByteString]
-> ChainValidationState
-> m ChainValidationState
applyTxAux ValidationMode
validationMode Config
cfg [ATxAux ByteString]
txs ChainValidationState
cvs =
  (ReaderT ValidationMode m ChainValidationState
 -> ValidationMode -> m ChainValidationState)
-> ValidationMode
-> ReaderT ValidationMode m ChainValidationState
-> m ChainValidationState
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ValidationMode m ChainValidationState
-> ValidationMode -> m ChainValidationState
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ValidationMode
validationMode (ReaderT ValidationMode m ChainValidationState
 -> m ChainValidationState)
-> ReaderT ValidationMode m ChainValidationState
-> m ChainValidationState
forall a b. (a -> b) -> a -> b
$
    (UTxO -> ChainValidationState -> ChainValidationState
`setUTxO` ChainValidationState
cvs)
      (UTxO -> ChainValidationState)
-> ReaderT ValidationMode m UTxO
-> ReaderT ValidationMode m ChainValidationState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Environment
-> UTxO -> [ATxAux ByteString] -> ReaderT ValidationMode m UTxO
forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> [ATxAux ByteString] -> m UTxO
Utxo.updateUTxO Environment
utxoEnv UTxO
utxo [ATxAux ByteString]
txs
  where
    utxoEnv :: Environment
utxoEnv = Config -> ChainValidationState -> Environment
mkUtxoEnvironment Config
cfg ChainValidationState
cvs
    utxo :: UTxO
utxo = ChainValidationState -> UTxO
CC.cvsUtxo ChainValidationState
cvs

applyCertificate ::
  MonadError D.Sched.Error m =>
  Gen.Config ->
  CC.SlotNumber ->
  [Delegation.ACertificate ByteString] ->
  CC.ChainValidationState ->
  m CC.ChainValidationState
applyCertificate :: Config
-> SlotNumber
-> [ACertificate ByteString]
-> ChainValidationState
-> m ChainValidationState
applyCertificate Config
cfg SlotNumber
currentSlot [ACertificate ByteString]
certs ChainValidationState
cvs =
  (State -> ChainValidationState -> ChainValidationState
`setDelegationState` ChainValidationState
cvs)
    (State -> ChainValidationState)
-> m State -> m ChainValidationState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Environment -> State -> [ACertificate ByteString] -> m State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> [ACertificate ByteString] -> m State
D.Iface.updateDelegation Environment
dlgEnv State
dlgState [ACertificate ByteString]
certs
  where
    dlgEnv :: Environment
dlgEnv = Config -> SlotNumber -> Environment
mkDelegationEnvironment Config
cfg SlotNumber
currentSlot
    dlgState :: State
dlgState = ChainValidationState -> State
CC.cvsDelegationState ChainValidationState
cvs

applyUpdateProposal ::
  MonadError U.Iface.Error m =>
  Gen.Config ->
  CC.SlotNumber ->
  Update.AProposal ByteString ->
  CC.ChainValidationState ->
  m CC.ChainValidationState
applyUpdateProposal :: Config
-> SlotNumber
-> AProposal ByteString
-> ChainValidationState
-> m ChainValidationState
applyUpdateProposal Config
cfg SlotNumber
currentSlot AProposal ByteString
proposal ChainValidationState
cvs =
  (State -> ChainValidationState -> ChainValidationState
`setUpdateState` ChainValidationState
cvs)
    (State -> ChainValidationState)
-> m State -> m ChainValidationState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Environment -> State -> AProposal ByteString -> m State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> AProposal ByteString -> m State
U.Iface.registerProposal Environment
updateEnv State
updateState AProposal ByteString
proposal
  where
    updateEnv :: Environment
updateEnv = Config -> SlotNumber -> Map -> Environment
mkUpdateEnvironment Config
cfg SlotNumber
currentSlot (ChainValidationState -> Map
getDelegationMap ChainValidationState
cvs)
    updateState :: State
updateState = ChainValidationState -> State
CC.cvsUpdateState ChainValidationState
cvs

applyUpdateVote ::
  MonadError U.Iface.Error m =>
  Gen.Config ->
  CC.SlotNumber ->
  Update.AVote ByteString ->
  CC.ChainValidationState ->
  m CC.ChainValidationState
applyUpdateVote :: Config
-> SlotNumber
-> AVote ByteString
-> ChainValidationState
-> m ChainValidationState
applyUpdateVote Config
cfg SlotNumber
currentSlot AVote ByteString
vote ChainValidationState
cvs =
  (State -> ChainValidationState -> ChainValidationState
`setUpdateState` ChainValidationState
cvs)
    (State -> ChainValidationState)
-> m State -> m ChainValidationState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Environment -> State -> AVote ByteString -> m State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> AVote ByteString -> m State
U.Iface.registerVote Environment
updateEnv State
updateState AVote ByteString
vote
  where
    updateEnv :: Environment
updateEnv = Config -> SlotNumber -> Map -> Environment
mkUpdateEnvironment Config
cfg SlotNumber
currentSlot (ChainValidationState -> Map
getDelegationMap ChainValidationState
cvs)
    updateState :: State
updateState = ChainValidationState -> State
CC.cvsUpdateState ChainValidationState
cvs

{-------------------------------------------------------------------------------
  Update parts of the chain state
-------------------------------------------------------------------------------}

setUTxO ::
  Utxo.UTxO ->
  CC.ChainValidationState ->
  CC.ChainValidationState
setUTxO :: UTxO -> ChainValidationState -> ChainValidationState
setUTxO UTxO
newUTxO ChainValidationState
cvs = ChainValidationState
cvs {$sel:cvsUtxo:ChainValidationState :: UTxO
CC.cvsUtxo = UTxO
newUTxO}

setDelegationState ::
  D.Iface.State ->
  CC.ChainValidationState ->
  CC.ChainValidationState
setDelegationState :: State -> ChainValidationState -> ChainValidationState
setDelegationState State
newDlg ChainValidationState
cvs = ChainValidationState
cvs {$sel:cvsDelegationState:ChainValidationState :: State
CC.cvsDelegationState = State
newDlg}

setUpdateState ::
  U.Iface.State ->
  CC.ChainValidationState ->
  CC.ChainValidationState
setUpdateState :: State -> ChainValidationState -> ChainValidationState
setUpdateState State
newUpdate ChainValidationState
cvs = ChainValidationState
cvs {$sel:cvsUpdateState:ChainValidationState :: State
CC.cvsUpdateState = State
newUpdate}