{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}

module Cardano.Node.Emulator.Internal.Node.Chain where

import Cardano.Node.Emulator.Internal.Node.Params (Params)
import Cardano.Node.Emulator.Internal.Node.Validation qualified as Validation
import Control.Lens (makeLenses, makePrisms, over, view, (%~), (&), (.~))
import Control.Monad.Freer (Eff, Member, Members, send, type (~>))
import Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logInfo, logWarn)
import Control.Monad.Freer.State (State, gets, modify)
import Control.Monad.State qualified as S
import Data.Aeson (FromJSON, ToJSON)
import Data.Foldable (traverse_)
import Data.List ((\\))
import Data.Maybe (mapMaybe)
import Data.Traversable (for)
import GHC.Generics (Generic)
import Ledger (Block, Blockchain, CardanoTx, OnChainTx, Slot (Slot), getCardanoTxId, getCardanoTxValidityRange,
               unOnChain)
import Ledger.Index qualified as Index
import Ledger.Interval qualified as Interval
import Prettyprinter (Pretty (pretty), vsep, (<+>))

-- | Events produced by the blockchain emulator.
data ChainEvent
    = TxnValidation !Index.ValidationResult
    -- ^ A transaction has been validated and added to the blockchain.
    | SlotAdd !Slot
    deriving stock (ChainEvent -> ChainEvent -> Bool
(ChainEvent -> ChainEvent -> Bool)
-> (ChainEvent -> ChainEvent -> Bool) -> Eq ChainEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainEvent -> ChainEvent -> Bool
$c/= :: ChainEvent -> ChainEvent -> Bool
== :: ChainEvent -> ChainEvent -> Bool
$c== :: ChainEvent -> ChainEvent -> Bool
Eq, Int -> ChainEvent -> ShowS
[ChainEvent] -> ShowS
ChainEvent -> String
(Int -> ChainEvent -> ShowS)
-> (ChainEvent -> String)
-> ([ChainEvent] -> ShowS)
-> Show ChainEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainEvent] -> ShowS
$cshowList :: [ChainEvent] -> ShowS
show :: ChainEvent -> String
$cshow :: ChainEvent -> String
showsPrec :: Int -> ChainEvent -> ShowS
$cshowsPrec :: Int -> ChainEvent -> ShowS
Show, (forall x. ChainEvent -> Rep ChainEvent x)
-> (forall x. Rep ChainEvent x -> ChainEvent) -> Generic ChainEvent
forall x. Rep ChainEvent x -> ChainEvent
forall x. ChainEvent -> Rep ChainEvent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ChainEvent x -> ChainEvent
$cfrom :: forall x. ChainEvent -> Rep ChainEvent x
Generic)
    deriving anyclass (Value -> Parser [ChainEvent]
Value -> Parser ChainEvent
(Value -> Parser ChainEvent)
-> (Value -> Parser [ChainEvent]) -> FromJSON ChainEvent
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ChainEvent]
$cparseJSONList :: Value -> Parser [ChainEvent]
parseJSON :: Value -> Parser ChainEvent
$cparseJSON :: Value -> Parser ChainEvent
FromJSON, [ChainEvent] -> Encoding
[ChainEvent] -> Value
ChainEvent -> Encoding
ChainEvent -> Value
(ChainEvent -> Value)
-> (ChainEvent -> Encoding)
-> ([ChainEvent] -> Value)
-> ([ChainEvent] -> Encoding)
-> ToJSON ChainEvent
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ChainEvent] -> Encoding
$ctoEncodingList :: [ChainEvent] -> Encoding
toJSONList :: [ChainEvent] -> Value
$ctoJSONList :: [ChainEvent] -> Value
toEncoding :: ChainEvent -> Encoding
$ctoEncoding :: ChainEvent -> Encoding
toJSON :: ChainEvent -> Value
$ctoJSON :: ChainEvent -> Value
ToJSON)

instance Pretty ChainEvent where
    pretty :: ChainEvent -> Doc ann
pretty = \case
        TxnValidation ValidationResult
res -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
"TxnValidation" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TxId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (CardanoTx -> TxId
getCardanoTxId (CardanoTx -> TxId) -> CardanoTx -> TxId
forall a b. (a -> b) -> a -> b
$ ValidationResult -> CardanoTx
Index.cardanoTxFromValidationResult ValidationResult
res), ValidationResult -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ValidationResult
res]
        SlotAdd Slot
sl        -> Doc ann
"SlotAdd" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Slot -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Slot
sl

chainEventOnChainTx :: ChainEvent -> Maybe OnChainTx
chainEventOnChainTx :: ChainEvent -> Maybe OnChainTx
chainEventOnChainTx (TxnValidation ValidationResult
result) = ValidationResult -> Maybe OnChainTx
Index.toOnChain ValidationResult
result
chainEventOnChainTx ChainEvent
_                      = Maybe OnChainTx
forall a. Maybe a
Nothing

-- | A pool of transactions which have yet to be validated.
type TxPool = [CardanoTx]

data ChainState = ChainState {
    ChainState -> Blockchain
_chainNewestFirst :: !Blockchain, -- ^ The current chain, with the newest transactions first in the list.
    ChainState -> TxPool
_txPool           :: !TxPool, -- ^ The pool of pending transactions.
    ChainState -> UtxoIndex
_index            :: !Index.UtxoIndex, -- ^ The UTxO index, used for validation.
    ChainState -> Slot
_chainCurrentSlot :: !Slot -- ^ The current slot number
} deriving (Int -> ChainState -> ShowS
[ChainState] -> ShowS
ChainState -> String
(Int -> ChainState -> ShowS)
-> (ChainState -> String)
-> ([ChainState] -> ShowS)
-> Show ChainState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainState] -> ShowS
$cshowList :: [ChainState] -> ShowS
show :: ChainState -> String
$cshow :: ChainState -> String
showsPrec :: Int -> ChainState -> ShowS
$cshowsPrec :: Int -> ChainState -> ShowS
Show, (forall x. ChainState -> Rep ChainState x)
-> (forall x. Rep ChainState x -> ChainState) -> Generic ChainState
forall x. Rep ChainState x -> ChainState
forall x. ChainState -> Rep ChainState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ChainState x -> ChainState
$cfrom :: forall x. ChainState -> Rep ChainState x
Generic)

makeLenses ''ChainState

emptyChainState :: ChainState
emptyChainState :: ChainState
emptyChainState = Blockchain -> TxPool -> UtxoIndex -> Slot -> ChainState
ChainState [] [] UtxoIndex
forall a. Monoid a => a
mempty Slot
0

fromBlockchain :: Blockchain -> ChainState
fromBlockchain :: Blockchain -> ChainState
fromBlockchain Blockchain
bc = ChainState
emptyChainState
    ChainState -> (ChainState -> ChainState) -> ChainState
forall a b. a -> (a -> b) -> b
& (Blockchain -> Identity Blockchain)
-> ChainState -> Identity ChainState
Lens' ChainState Blockchain
chainNewestFirst ((Blockchain -> Identity Blockchain)
 -> ChainState -> Identity ChainState)
-> Blockchain -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Blockchain
bc
    ChainState -> (ChainState -> ChainState) -> ChainState
forall a b. a -> (a -> b) -> b
& (UtxoIndex -> Identity UtxoIndex)
-> ChainState -> Identity ChainState
Lens' ChainState UtxoIndex
index ((UtxoIndex -> Identity UtxoIndex)
 -> ChainState -> Identity ChainState)
-> UtxoIndex -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Blockchain -> UtxoIndex
Index.initialise Blockchain
bc

data ChainControlEffect r where
    ProcessBlock :: ChainControlEffect Block
    ModifySlot :: (Slot -> Slot) -> ChainControlEffect Slot

data ChainEffect r where
    QueueTx :: CardanoTx -> ChainEffect ()
    GetCurrentSlot :: ChainEffect Slot
    GetParams :: ChainEffect Params

-- | Make a new block
processBlock :: Member ChainControlEffect effs => Eff effs Block
processBlock :: Eff effs Block
processBlock = ChainControlEffect Block -> Eff effs Block
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send ChainControlEffect Block
ProcessBlock

-- | Adjust the current slot number, returning the new slot.
modifySlot :: Member ChainControlEffect effs => (Slot -> Slot) -> Eff effs Slot
modifySlot :: (Slot -> Slot) -> Eff effs Slot
modifySlot = ChainControlEffect Slot -> Eff effs Slot
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (ChainControlEffect Slot -> Eff effs Slot)
-> ((Slot -> Slot) -> ChainControlEffect Slot)
-> (Slot -> Slot)
-> Eff effs Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Slot -> Slot) -> ChainControlEffect Slot
ModifySlot

queueTx :: Member ChainEffect effs => CardanoTx -> Eff effs ()
queueTx :: CardanoTx -> Eff effs ()
queueTx CardanoTx
tx = ChainEffect () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (CardanoTx -> ChainEffect ()
QueueTx CardanoTx
tx)

getParams :: Member ChainEffect effs => Eff effs Params
getParams :: Eff effs Params
getParams = ChainEffect Params -> Eff effs Params
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send ChainEffect Params
GetParams

getCurrentSlot :: Member ChainEffect effs => Eff effs Slot
getCurrentSlot :: Eff effs Slot
getCurrentSlot = ChainEffect Slot -> Eff effs Slot
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send ChainEffect Slot
GetCurrentSlot

type ChainEffs = '[State ChainState, LogMsg ChainEvent]

handleControlChain :: Members ChainEffs effs => Params -> ChainControlEffect ~> Eff effs
handleControlChain :: Params -> ChainControlEffect ~> Eff effs
handleControlChain Params
params = \case
    ChainControlEffect x
ProcessBlock -> do
        TxPool
pool  <- (ChainState -> TxPool) -> Eff effs TxPool
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets ((ChainState -> TxPool) -> Eff effs TxPool)
-> (ChainState -> TxPool) -> Eff effs TxPool
forall a b. (a -> b) -> a -> b
$ Getting TxPool ChainState TxPool -> ChainState -> TxPool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TxPool ChainState TxPool
Lens' ChainState TxPool
txPool
        Slot
slot  <- (ChainState -> Slot) -> Eff effs Slot
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets ((ChainState -> Slot) -> Eff effs Slot)
-> (ChainState -> Slot) -> Eff effs Slot
forall a b. (a -> b) -> a -> b
$ Getting Slot ChainState Slot -> ChainState -> Slot
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Slot ChainState Slot
Lens' ChainState Slot
chainCurrentSlot
        UtxoIndex
idx   <- (ChainState -> UtxoIndex) -> Eff effs UtxoIndex
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets ((ChainState -> UtxoIndex) -> Eff effs UtxoIndex)
-> (ChainState -> UtxoIndex) -> Eff effs UtxoIndex
forall a b. (a -> b) -> a -> b
$ Getting UtxoIndex ChainState UtxoIndex -> ChainState -> UtxoIndex
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UtxoIndex ChainState UtxoIndex
Lens' ChainState UtxoIndex
index

        let ValidatedBlock Block
block [ChainEvent]
events UtxoIndex
idx' =
                Params -> Slot -> UtxoIndex -> TxPool -> ValidatedBlock
validateBlock Params
params Slot
slot UtxoIndex
idx TxPool
pool

        (ChainState -> ChainState) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify ((ChainState -> ChainState) -> Eff effs ())
-> (ChainState -> ChainState) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ (TxPool -> Identity TxPool) -> ChainState -> Identity ChainState
Lens' ChainState TxPool
txPool ((TxPool -> Identity TxPool) -> ChainState -> Identity ChainState)
-> TxPool -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ []
        (ChainState -> ChainState) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify ((ChainState -> ChainState) -> Eff effs ())
-> (ChainState -> ChainState) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ (UtxoIndex -> Identity UtxoIndex)
-> ChainState -> Identity ChainState
Lens' ChainState UtxoIndex
index ((UtxoIndex -> Identity UtxoIndex)
 -> ChainState -> Identity ChainState)
-> UtxoIndex -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UtxoIndex
idx'
        (ChainState -> ChainState) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify ((ChainState -> ChainState) -> Eff effs ())
-> (ChainState -> ChainState) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ Block -> ChainState -> ChainState
addBlock Block
block

        (ChainEvent -> Eff effs ()) -> [ChainEvent] -> Eff effs ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ChainEvent -> Eff effs ()
forall (effs :: [* -> *]).
Member (LogMsg ChainEvent) effs =>
ChainEvent -> Eff effs ()
logEvent [ChainEvent]
events
        Block -> Eff effs Block
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
block

    ModifySlot Slot -> Slot
f -> (ChainState -> ChainState) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify @ChainState (ASetter ChainState ChainState Slot Slot
-> (Slot -> Slot) -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter ChainState ChainState Slot Slot
Lens' ChainState Slot
chainCurrentSlot Slot -> Slot
f) Eff effs () -> Eff effs x -> Eff effs x
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ChainState -> x) -> Eff effs x
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets (Getting Slot ChainState Slot -> ChainState -> Slot
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Slot ChainState Slot
Lens' ChainState Slot
chainCurrentSlot)

logEvent :: Member (LogMsg ChainEvent) effs => ChainEvent -> Eff effs ()
logEvent :: ChainEvent -> Eff effs ()
logEvent ChainEvent
e = case ChainEvent
e of
    SlotAdd{}                        -> ChainEvent -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug ChainEvent
e
    TxnValidation Index.FailPhase1{} -> ChainEvent -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logWarn ChainEvent
e
    TxnValidation Index.FailPhase2{} -> ChainEvent -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logWarn ChainEvent
e
    TxnValidation Index.Success{}    -> ChainEvent -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo ChainEvent
e

handleChain :: (Members ChainEffs effs) => Params -> ChainEffect ~> Eff effs
handleChain :: Params -> ChainEffect ~> Eff effs
handleChain Params
params = \case
    QueueTx CardanoTx
tx     -> (ChainState -> ChainState) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify (CardanoTx -> ChainState -> ChainState
addTxToPool CardanoTx
tx)
    ChainEffect x
GetCurrentSlot -> (ChainState -> Slot) -> Eff effs Slot
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets ChainState -> Slot
_chainCurrentSlot
    ChainEffect x
GetParams      -> Params -> Eff effs Params
forall (f :: * -> *) a. Applicative f => a -> f a
pure Params
params

-- | The result of validating a block.
data ValidatedBlock = ValidatedBlock
    { ValidatedBlock -> Block
vlbValid  :: !Block
    -- ^ The transactions that have been validated in this block.
    , ValidatedBlock -> [ChainEvent]
vlbEvents :: ![ChainEvent]
    -- ^ Transaction validation events for the transactions in this block.
    , ValidatedBlock -> UtxoIndex
vlbIndex  :: !Index.UtxoIndex
    -- ^ The updated UTxO index after processing the block
    }

data ValidationCtx = ValidationCtx { ValidationCtx -> UtxoIndex
vctxIndex :: !Index.UtxoIndex, ValidationCtx -> Params
vctxParams :: !Params }

-- | Validate a block given the current slot and UTxO index, returning the valid
--   transactions, success/failure events and the updated UTxO set.
validateBlock :: Params -> Slot -> Index.UtxoIndex -> TxPool -> ValidatedBlock
validateBlock :: Params -> Slot -> UtxoIndex -> TxPool -> ValidatedBlock
validateBlock Params
params slot :: Slot
slot@(Slot Integer
s) UtxoIndex
idx TxPool
txns =
    let
        -- Validate transactions, updating the UTXO index each time
        ([ValidationResult]
results, ValidationCtx UtxoIndex
idx' Params
_) =
            (State ValidationCtx [ValidationResult]
 -> ValidationCtx -> ([ValidationResult], ValidationCtx))
-> ValidationCtx
-> State ValidationCtx [ValidationResult]
-> ([ValidationResult], ValidationCtx)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State ValidationCtx [ValidationResult]
-> ValidationCtx -> ([ValidationResult], ValidationCtx)
forall s a. State s a -> s -> (a, s)
S.runState (UtxoIndex -> Params -> ValidationCtx
ValidationCtx UtxoIndex
idx Params
params) (State ValidationCtx [ValidationResult]
 -> ([ValidationResult], ValidationCtx))
-> State ValidationCtx [ValidationResult]
-> ([ValidationResult], ValidationCtx)
forall a b. (a -> b) -> a -> b
$ TxPool
-> (CardanoTx -> StateT ValidationCtx Identity ValidationResult)
-> State ValidationCtx [ValidationResult]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for TxPool
txns ((CardanoTx -> StateT ValidationCtx Identity ValidationResult)
 -> State ValidationCtx [ValidationResult])
-> (CardanoTx -> StateT ValidationCtx Identity ValidationResult)
-> State ValidationCtx [ValidationResult]
forall a b. (a -> b) -> a -> b
$ Slot -> CardanoTx -> StateT ValidationCtx Identity ValidationResult
forall (m :: * -> *).
MonadState ValidationCtx m =>
Slot -> CardanoTx -> m ValidationResult
validateEm Slot
slot

        -- The new block contains all transaction that were validated
        -- successfully
        block :: Block
block = (ValidationResult -> Maybe OnChainTx)
-> [ValidationResult] -> Block
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ValidationResult -> Maybe OnChainTx
Index.toOnChain [ValidationResult]
results

        -- Also return an `EmulatorEvent` for each transaction that was
        -- processed
        nextSlot :: Slot
nextSlot = Integer -> Slot
Slot (Integer
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
        events :: [ChainEvent]
events   = (ValidationResult -> ChainEvent
TxnValidation (ValidationResult -> ChainEvent)
-> [ValidationResult] -> [ChainEvent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ValidationResult]
results) [ChainEvent] -> [ChainEvent] -> [ChainEvent]
forall a. [a] -> [a] -> [a]
++ [Slot -> ChainEvent
SlotAdd Slot
nextSlot]
    in Block -> [ChainEvent] -> UtxoIndex -> ValidatedBlock
ValidatedBlock Block
block [ChainEvent]
events UtxoIndex
idx'

-- | Check whether the given transaction can be validated in the given slot.
canValidateNow :: Slot -> CardanoTx -> Bool
canValidateNow :: Slot -> CardanoTx -> Bool
canValidateNow Slot
slot = Slot -> Interval Slot -> Bool
forall a. Ord a => a -> Interval a -> Bool
Interval.member Slot
slot (Interval Slot -> Bool)
-> (CardanoTx -> Interval Slot) -> CardanoTx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoTx -> Interval Slot
getCardanoTxValidityRange

-- | Validate a transaction in the current emulator state.
validateEm
    :: S.MonadState ValidationCtx m
    => Slot
    -> CardanoTx
    -> m Index.ValidationResult
validateEm :: Slot -> CardanoTx -> m ValidationResult
validateEm Slot
h CardanoTx
txn = do
    ctx :: ValidationCtx
ctx@(ValidationCtx UtxoIndex
idx Params
params) <- m ValidationCtx
forall s (m :: * -> *). MonadState s m => m s
S.get
    let
        res :: ValidationResult
res = Params -> Slot -> UtxoIndex -> CardanoTx -> ValidationResult
Validation.validateCardanoTx Params
params Slot
h UtxoIndex
idx CardanoTx
txn
        idx' :: UtxoIndex
idx' = case ValidationResult
res of
            Index.FailPhase1{} -> UtxoIndex
idx
            Index.FailPhase2{} -> CardanoTx -> UtxoIndex -> UtxoIndex
Index.insertCollateral CardanoTx
txn UtxoIndex
idx
            Index.Success{}    -> CardanoTx -> UtxoIndex -> UtxoIndex
Index.insert CardanoTx
txn UtxoIndex
idx
    ()
_ <- ValidationCtx -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put ValidationCtx
ctx{ vctxIndex :: UtxoIndex
vctxIndex = UtxoIndex
idx' }
    ValidationResult -> m ValidationResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidationResult
res

-- | Adds a block to ChainState, without validation.
addBlock :: Block -> ChainState -> ChainState
addBlock :: Block -> ChainState -> ChainState
addBlock Block
blk ChainState
st =
  ChainState
st ChainState -> (ChainState -> ChainState) -> ChainState
forall a b. a -> (a -> b) -> b
& (Blockchain -> Identity Blockchain)
-> ChainState -> Identity ChainState
Lens' ChainState Blockchain
chainNewestFirst ((Blockchain -> Identity Blockchain)
 -> ChainState -> Identity ChainState)
-> (Blockchain -> Blockchain) -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Block
blk Block -> Blockchain -> Blockchain
forall a. a -> [a] -> [a]
:)
     -- The block update may contain txs that are not in this client's
     -- `txPool` which will get ignored
     ChainState -> (ChainState -> ChainState) -> ChainState
forall a b. a -> (a -> b) -> b
& (TxPool -> Identity TxPool) -> ChainState -> Identity ChainState
Lens' ChainState TxPool
txPool ((TxPool -> Identity TxPool) -> ChainState -> Identity ChainState)
-> (TxPool -> TxPool) -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (TxPool -> TxPool -> TxPool
forall a. Eq a => [a] -> [a] -> [a]
\\ (OnChainTx -> CardanoTx) -> Block -> TxPool
forall a b. (a -> b) -> [a] -> [b]
map OnChainTx -> CardanoTx
unOnChain Block
blk)

addTxToPool :: CardanoTx -> ChainState -> ChainState
addTxToPool :: CardanoTx -> ChainState -> ChainState
addTxToPool CardanoTx
tx = ((TxPool -> Identity TxPool) -> ChainState -> Identity ChainState)
-> (TxPool -> TxPool) -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (TxPool -> Identity TxPool) -> ChainState -> Identity ChainState
Lens' ChainState TxPool
txPool (CardanoTx
tx CardanoTx -> TxPool -> TxPool
forall a. a -> [a] -> [a]
:)

makePrisms ''ChainEvent