{-# 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.Chain where

import Cardano.Api qualified as C
import Cardano.Node.Emulator.Params (Params (..))
import Cardano.Node.Emulator.Validation qualified as Validation
import Control.Lens hiding (index)
import Control.Monad.Freer
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.Either (fromRight)
import Data.Foldable (traverse_)
import Data.List ((\\))
import Data.Map qualified as Map
import Data.Maybe (mapMaybe)
import Data.Monoid (Ap (Ap))
import Data.Text (Text)
import Data.Traversable (for)
import GHC.Generics (Generic)
import Ledger (Block, Blockchain, CardanoTx (..), OnChainTx (..), Slot (..), TxId, TxIn (txInRef),
               getCardanoTxCollateralInputs, getCardanoTxFee, getCardanoTxId, getCardanoTxTotalCollateral,
               getCardanoTxValidityRange, txOutValue, unOnChain)
import Ledger.Index qualified as Index
import Ledger.Interval qualified as Interval
import Ledger.Tx.CardanoAPI (fromPlutusIndex)
import Ledger.Value.CardanoAPI (lovelaceToValue)
import Plutus.V1.Ledger.Scripts qualified as Scripts
import Prettyprinter

-- | Events produced by the blockchain emulator.
data ChainEvent =
    TxnValidate TxId CardanoTx [Text]
    -- ^ A transaction has been validated and added to the blockchain.
    | TxnValidationFail Index.ValidationPhase TxId CardanoTx Index.ValidationError C.Value [Text]
    -- ^ A transaction failed to validate. The @Value@ indicates the amount of collateral stored in the transaction.
    | 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
        TxnValidate TxId
i CardanoTx
_ [Text]
logs             -> Doc ann
"TxnValidate" 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 TxId
i Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Text] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Text]
logs
        TxnValidationFail ValidationPhase
p TxId
i CardanoTx
_ ValidationError
e Value
_ [Text]
logs -> Doc ann
"TxnValidationFail" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ValidationPhase -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ValidationPhase
p 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 TxId
i Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ValidationError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ValidationError
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Text] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Text]
logs
        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

-- | 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)

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

makeLenses ''ChainState

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
    TxnValidationFail{} -> ChainEvent -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logWarn ChainEvent
e
    TxnValidate{}       -> 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 ((ChainState -> ChainState) -> Eff effs ())
-> (ChainState -> ChainState) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ ((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 -> TxPool -> TxPool
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
        ([(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)]
processed, ValidationCtx UtxoIndex
idx' Params
_) =
            (State
   ValidationCtx
   [(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)]
 -> ValidationCtx
 -> ([(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)],
     ValidationCtx))
-> ValidationCtx
-> State
     ValidationCtx
     [(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)]
-> ([(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)],
    ValidationCtx)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State
  ValidationCtx
  [(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)]
-> ValidationCtx
-> ([(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)],
    ValidationCtx)
forall s a. State s a -> s -> (a, s)
S.runState (UtxoIndex -> Params -> ValidationCtx
ValidationCtx UtxoIndex
idx Params
params) (State
   ValidationCtx
   [(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)]
 -> ([(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)],
     ValidationCtx))
-> State
     ValidationCtx
     [(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)]
-> ([(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)],
    ValidationCtx)
forall a b. (a -> b) -> a -> b
$ TxPool
-> (CardanoTx
    -> StateT
         ValidationCtx
         Identity
         (CardanoTx, Either ValidationErrorInPhase ValidationSuccess))
-> State
     ValidationCtx
     [(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for TxPool
txns ((CardanoTx
  -> StateT
       ValidationCtx
       Identity
       (CardanoTx, Either ValidationErrorInPhase ValidationSuccess))
 -> State
      ValidationCtx
      [(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)])
-> (CardanoTx
    -> StateT
         ValidationCtx
         Identity
         (CardanoTx, Either ValidationErrorInPhase ValidationSuccess))
-> State
     ValidationCtx
     [(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)]
forall a b. (a -> b) -> a -> b
$ \CardanoTx
tx -> do
                Either ValidationErrorInPhase ValidationSuccess
result <- Slot
-> CardanoTx
-> StateT
     ValidationCtx
     Identity
     (Either ValidationErrorInPhase ValidationSuccess)
forall (m :: * -> *).
MonadState ValidationCtx m =>
Slot
-> CardanoTx -> m (Either ValidationErrorInPhase ValidationSuccess)
validateEm Slot
slot CardanoTx
tx
                (CardanoTx, Either ValidationErrorInPhase ValidationSuccess)
-> StateT
     ValidationCtx
     Identity
     (CardanoTx, Either ValidationErrorInPhase ValidationSuccess)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CardanoTx
tx, Either ValidationErrorInPhase ValidationSuccess
result)

        -- The new block contains all transaction that were validated
        -- successfully
        block :: Block
block = ((CardanoTx, Either ValidationErrorInPhase ValidationSuccess)
 -> Maybe OnChainTx)
-> [(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)]
-> Block
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (CardanoTx, Either ValidationErrorInPhase ValidationSuccess)
-> Maybe OnChainTx
forall b b.
(CardanoTx, Either (ValidationPhase, b) b) -> Maybe OnChainTx
toOnChain [(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)]
processed
          where
            toOnChain :: (CardanoTx, Either (ValidationPhase, b) b) -> Maybe OnChainTx
toOnChain (CardanoTx
_ , Left (ValidationPhase
Index.Phase1, b
_)) = Maybe OnChainTx
forall a. Maybe a
Nothing
            toOnChain (CardanoTx
tx, Left (ValidationPhase
Index.Phase2, b
_)) = OnChainTx -> Maybe OnChainTx
forall a. a -> Maybe a
Just (CardanoTx -> OnChainTx
Invalid CardanoTx
tx)
            toOnChain (CardanoTx
tx, Right b
_               ) = OnChainTx -> Maybe OnChainTx
forall a. a -> Maybe a
Just (CardanoTx -> OnChainTx
Valid CardanoTx
tx)

        -- 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   = ((CardanoTx
 -> Either ValidationErrorInPhase ValidationSuccess -> ChainEvent)
-> (CardanoTx, Either ValidationErrorInPhase ValidationSuccess)
-> ChainEvent
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (UtxoIndex
-> CardanoTx
-> Either ValidationErrorInPhase ValidationSuccess
-> ChainEvent
mkValidationEvent UtxoIndex
idx) ((CardanoTx, Either ValidationErrorInPhase ValidationSuccess)
 -> ChainEvent)
-> [(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)]
-> [ChainEvent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CardanoTx, Either ValidationErrorInPhase ValidationSuccess)]
processed) [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'

getCollateral :: Index.UtxoIndex -> CardanoTx -> C.Value
getCollateral :: UtxoIndex -> CardanoTx -> Value
getCollateral UtxoIndex
idx CardanoTx
tx = case CardanoTx -> Maybe Lovelace
getCardanoTxTotalCollateral CardanoTx
tx of
    Just Lovelace
v -> Lovelace -> Value
lovelaceToValue Lovelace
v
    Maybe Lovelace
Nothing -> Value -> Either ValidationError Value -> Value
forall b a. b -> Either a b -> b
fromRight (Lovelace -> Value
lovelaceToValue (Lovelace -> Value) -> Lovelace -> Value
forall a b. (a -> b) -> a -> b
$ CardanoTx -> Lovelace
getCardanoTxFee CardanoTx
tx) (Either ValidationError Value -> Value)
-> Either ValidationError Value -> Value
forall a b. (a -> b) -> a -> b
$
        (Unwrapped (Ap (Either ValidationError) Value)
 -> Ap (Either ValidationError) Value)
-> ((TxIn -> Ap (Either ValidationError) Value)
    -> [TxIn] -> Ap (Either ValidationError) Value)
-> (TxIn -> Unwrapped (Ap (Either ValidationError) Value))
-> [TxIn]
-> Either ValidationError Value
forall (f :: * -> *) (g :: * -> *) s t.
(Functor f, Functor g, Rewrapping s t) =>
(Unwrapped s -> s)
-> (f t -> g s) -> f (Unwrapped t) -> g (Unwrapped s)
alaf Unwrapped (Ap (Either ValidationError) Value)
-> Ap (Either ValidationError) Value
forall k (f :: k -> *) (a :: k). f a -> Ap f a
Ap (TxIn -> Ap (Either ValidationError) Value)
-> [TxIn] -> Ap (Either ValidationError) Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((TxOut -> Value)
-> Either ValidationError TxOut -> Either ValidationError Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut -> Value
txOutValue (Either ValidationError TxOut -> Either ValidationError Value)
-> (TxIn -> Either ValidationError TxOut)
-> TxIn
-> Either ValidationError Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef -> UtxoIndex -> Either ValidationError TxOut
forall (m :: * -> *).
MonadError ValidationError m =>
TxOutRef -> UtxoIndex -> m TxOut
`Index.lookup` UtxoIndex
idx) (TxOutRef -> Either ValidationError TxOut)
-> (TxIn -> TxOutRef) -> TxIn -> Either ValidationError TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> TxOutRef
txInRef) (CardanoTx -> [TxIn]
getCardanoTxCollateralInputs CardanoTx
tx)

-- | 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


mkValidationEvent :: Index.UtxoIndex -> CardanoTx -> Either Index.ValidationErrorInPhase Index.ValidationSuccess -> ChainEvent
mkValidationEvent :: UtxoIndex
-> CardanoTx
-> Either ValidationErrorInPhase ValidationSuccess
-> ChainEvent
mkValidationEvent UtxoIndex
idx CardanoTx
t Either ValidationErrorInPhase ValidationSuccess
result =
    case Either ValidationErrorInPhase ValidationSuccess
result of
        Right ValidationSuccess
r      -> TxId -> CardanoTx -> [Text] -> ChainEvent
TxnValidate (CardanoTx -> TxId
getCardanoTxId CardanoTx
t) CardanoTx
t [Text]
logs
            where logs :: [Text]
logs = ((RdmrPtr, ([Text], ExUnits)) -> [Text])
-> [(RdmrPtr, ([Text], ExUnits))] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Text], ExUnits) -> [Text]
forall a b. (a, b) -> a
fst (([Text], ExUnits) -> [Text])
-> ((RdmrPtr, ([Text], ExUnits)) -> ([Text], ExUnits))
-> (RdmrPtr, ([Text], ExUnits))
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RdmrPtr, ([Text], ExUnits)) -> ([Text], ExUnits)
forall a b. (a, b) -> b
snd) ([(RdmrPtr, ([Text], ExUnits))] -> [Text])
-> [(RdmrPtr, ([Text], ExUnits))] -> [Text]
forall a b. (a -> b) -> a -> b
$ ValidationSuccess -> [(RdmrPtr, ([Text], ExUnits))]
forall k a. Map k a -> [(k, a)]
Map.toList ValidationSuccess
r
        Left (ValidationPhase
phase, ValidationError
err) -> ValidationPhase
-> TxId
-> CardanoTx
-> ValidationError
-> Value
-> [Text]
-> ChainEvent
TxnValidationFail ValidationPhase
phase (CardanoTx -> TxId
getCardanoTxId CardanoTx
t) CardanoTx
t ValidationError
err (UtxoIndex -> CardanoTx -> Value
getCollateral UtxoIndex
idx CardanoTx
t) [Text]
logs
            where
                logs :: [Text]
logs = case ValidationError
err of
                    Index.ScriptFailure (Scripts.EvaluationError [Text]
msgs String
_) -> [Text]
msgs
                    ValidationError
_                                                    -> []

-- | Validate a transaction in the current emulator state.
validateEm
    :: S.MonadState ValidationCtx m
    => Slot
    -> CardanoTx
    -> m (Either Index.ValidationErrorInPhase Index.ValidationSuccess)
validateEm :: Slot
-> CardanoTx -> m (Either ValidationErrorInPhase ValidationSuccess)
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
        cUtxoIndex :: UTxO (BabbageEra StandardCrypto)
cUtxoIndex = (Either ValidationErrorInPhase ToCardanoError
 -> UTxO (BabbageEra StandardCrypto))
-> (UTxO (BabbageEra StandardCrypto)
    -> UTxO (BabbageEra StandardCrypto))
-> Either
     (Either ValidationErrorInPhase ToCardanoError)
     (UTxO (BabbageEra StandardCrypto))
-> UTxO (BabbageEra StandardCrypto)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> UTxO (BabbageEra StandardCrypto)
forall a. HasCallStack => String -> a
error (String -> UTxO (BabbageEra StandardCrypto))
-> (Either ValidationErrorInPhase ToCardanoError -> String)
-> Either ValidationErrorInPhase ToCardanoError
-> UTxO (BabbageEra StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ValidationErrorInPhase ToCardanoError -> String
forall a. Show a => a -> String
show) UTxO (BabbageEra StandardCrypto)
-> UTxO (BabbageEra StandardCrypto)
forall a. a -> a
id (Either
   (Either ValidationErrorInPhase ToCardanoError)
   (UTxO (BabbageEra StandardCrypto))
 -> UTxO (BabbageEra StandardCrypto))
-> Either
     (Either ValidationErrorInPhase ToCardanoError)
     (UTxO (BabbageEra StandardCrypto))
-> UTxO (BabbageEra StandardCrypto)
forall a b. (a -> b) -> a -> b
$ UtxoIndex
-> Either
     (Either ValidationErrorInPhase ToCardanoError)
     (UTxO (BabbageEra StandardCrypto))
fromPlutusIndex UtxoIndex
idx
        e :: Either ValidationErrorInPhase ValidationSuccess
e = Params
-> Slot
-> UTxO (BabbageEra StandardCrypto)
-> CardanoTx
-> Either ValidationErrorInPhase ValidationSuccess
Validation.validateCardanoTx Params
params Slot
h UTxO (BabbageEra StandardCrypto)
cUtxoIndex CardanoTx
txn
        idx' :: UtxoIndex
idx' = case Either ValidationErrorInPhase ValidationSuccess
e of
            Left (ValidationPhase
Index.Phase1, ValidationError
_) -> UtxoIndex
idx
            Left (ValidationPhase
Index.Phase2, ValidationError
_) -> CardanoTx -> UtxoIndex -> UtxoIndex
Index.insertCollateral CardanoTx
txn UtxoIndex
idx
            Right ValidationSuccess
_                -> 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' }
    Either ValidationErrorInPhase ValidationSuccess
-> m (Either ValidationErrorInPhase ValidationSuccess)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ValidationErrorInPhase ValidationSuccess
e

-- | 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 -> TxPool -> TxPool
addTxToPool :: CardanoTx -> TxPool -> TxPool
addTxToPool = (:)

makePrisms ''ChainEvent