module Cooked.MockChain.MockChainSt where

import Cardano.Api qualified as Cardano
import Cardano.Api.Shelley qualified as Cardano
import Cardano.Ledger.Shelley.API qualified as Shelley
import Cardano.Ledger.Shelley.LedgerState qualified as Shelley
import Cardano.Node.Emulator.Internal.Node qualified as Emulator
import Control.Monad
import Control.Monad.Except
import Cooked.Conversion.ToScriptHash
import Cooked.Conversion.ToVersionedScript
import Cooked.InitialDistribution
import Cooked.MockChain.BlockChain
import Cooked.MockChain.GenerateTx
import Cooked.MockChain.GenerateTx.Output
import Cooked.MockChain.MinAda
import Cooked.MockChain.UtxoState
import Cooked.Output
import Cooked.Skeleton
import Data.Bifunctor (bimap)
import Data.Default
import Data.List (foldl')
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (mapMaybe)
import Ledger.Index qualified as Ledger
import Ledger.Orphans ()
import Ledger.Slot qualified as Ledger
import Ledger.Tx qualified as Ledger
import Ledger.Tx.CardanoAPI qualified as Ledger
import Optics.Core (view)
import Plutus.Script.Utils.Scripts qualified as Script
import PlutusLedgerApi.V3 qualified as Api

-- | Slightly more concrete version of 'UtxoState', used to actually run the
-- simulation.
data MockChainSt = MockChainSt
  { MockChainSt -> Params
mcstParams :: Emulator.Params,
    MockChainSt -> UtxoIndex
mcstIndex :: Ledger.UtxoIndex,
    -- map from datum hash to (datum, count), where count is the number of UTxOs
    -- that currently have the datum. This map is used to display the contents
    -- of the state to the user, and to recover datums for transaction
    -- generation.
    MockChainSt -> Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: Map Api.DatumHash (TxSkelOutDatum, Integer),
    MockChainSt -> Map ValidatorHash (Versioned Validator)
mcstValidators :: Map Script.ValidatorHash (Script.Versioned Script.Validator),
    MockChainSt -> Slot
mcstCurrentSlot :: Ledger.Slot
  }
  deriving (Int -> MockChainSt -> ShowS
[MockChainSt] -> ShowS
MockChainSt -> String
(Int -> MockChainSt -> ShowS)
-> (MockChainSt -> String)
-> ([MockChainSt] -> ShowS)
-> Show MockChainSt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MockChainSt -> ShowS
showsPrec :: Int -> MockChainSt -> ShowS
$cshow :: MockChainSt -> String
show :: MockChainSt -> String
$cshowList :: [MockChainSt] -> ShowS
showList :: [MockChainSt] -> ShowS
Show, MockChainSt -> MockChainSt -> Bool
(MockChainSt -> MockChainSt -> Bool)
-> (MockChainSt -> MockChainSt -> Bool) -> Eq MockChainSt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MockChainSt -> MockChainSt -> Bool
== :: MockChainSt -> MockChainSt -> Bool
$c/= :: MockChainSt -> MockChainSt -> Bool
/= :: MockChainSt -> MockChainSt -> Bool
Eq)

instance Default MockChainSt where
  def :: MockChainSt
def = Params
-> UtxoIndex
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map ValidatorHash (Versioned Validator)
-> Slot
-> MockChainSt
MockChainSt Params
forall a. Default a => a
def (Blockchain -> UtxoIndex
Ledger.initialise [[]]) Map DatumHash (TxSkelOutDatum, Integer)
forall k a. Map k a
Map.empty Map ValidatorHash (Versioned Validator)
forall k a. Map k a
Map.empty Slot
0

-- | Converts a builtin UtxoIndex into our own usable map between utxos and
-- associated outputs.
getIndex :: Ledger.UtxoIndex -> Map Api.TxOutRef Api.TxOut
getIndex :: UtxoIndex -> Map TxOutRef TxOut
getIndex =
  [(TxOutRef, TxOut)] -> Map TxOutRef TxOut
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    ([(TxOutRef, TxOut)] -> Map TxOutRef TxOut)
-> (UtxoIndex -> [(TxOutRef, TxOut)])
-> UtxoIndex
-> Map TxOutRef TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, TxOut CtxUTxO ConwayEra) -> (TxOutRef, TxOut))
-> [(TxIn, TxOut CtxUTxO ConwayEra)] -> [(TxOutRef, TxOut)]
forall a b. (a -> b) -> [a] -> [b]
map ((TxIn -> TxOutRef)
-> (TxOut CtxUTxO ConwayEra -> TxOut)
-> (TxIn, TxOut CtxUTxO ConwayEra)
-> (TxOutRef, TxOut)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap TxIn -> TxOutRef
Ledger.fromCardanoTxIn (TxOut CtxTx ConwayEra -> TxOut
forall era. TxOut CtxTx era -> TxOut
Ledger.fromCardanoTxOutToPV2TxInfoTxOut (TxOut CtxTx ConwayEra -> TxOut)
-> (TxOut CtxUTxO ConwayEra -> TxOut CtxTx ConwayEra)
-> TxOut CtxUTxO ConwayEra
-> TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO ConwayEra -> TxOut CtxTx ConwayEra
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
toCtxTxTxOut))
    ([(TxIn, TxOut CtxUTxO ConwayEra)] -> [(TxOutRef, TxOut)])
-> (UtxoIndex -> [(TxIn, TxOut CtxUTxO ConwayEra)])
-> UtxoIndex
-> [(TxOutRef, TxOut)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn (TxOut CtxUTxO ConwayEra)
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall k a. Map k a -> [(k, a)]
Map.toList
    (Map TxIn (TxOut CtxUTxO ConwayEra)
 -> [(TxIn, TxOut CtxUTxO ConwayEra)])
-> (UtxoIndex -> Map TxIn (TxOut CtxUTxO ConwayEra))
-> UtxoIndex
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoIndex -> Map TxIn (TxOut CtxUTxO ConwayEra)
forall era. UTxO era -> Map TxIn (TxOut CtxUTxO era)
Cardano.unUTxO
  where
    -- We need to convert a UTxO context TxOut to a Transaction context Tx out.
    -- It's complicated because the datum type is indexed by the context.
    toCtxTxTxOut :: Cardano.TxOut Cardano.CtxUTxO era -> Cardano.TxOut Cardano.CtxTx era
    toCtxTxTxOut :: forall era. TxOut CtxUTxO era -> TxOut CtxTx era
toCtxTxTxOut (Cardano.TxOut AddressInEra era
addr TxOutValue era
val TxOutDatum CtxUTxO era
d ReferenceScript era
refS) =
      let dat :: TxOutDatum CtxTx era
dat = case TxOutDatum CtxUTxO era
d of
            TxOutDatum CtxUTxO era
Cardano.TxOutDatumNone -> TxOutDatum CtxTx era
forall ctx era. TxOutDatum ctx era
Cardano.TxOutDatumNone
            Cardano.TxOutDatumHash AlonzoEraOnwards era
s Hash ScriptData
h -> AlonzoEraOnwards era -> Hash ScriptData -> TxOutDatum CtxTx era
forall era ctx.
AlonzoEraOnwards era -> Hash ScriptData -> TxOutDatum ctx era
Cardano.TxOutDatumHash AlonzoEraOnwards era
s Hash ScriptData
h
            Cardano.TxOutDatumInline BabbageEraOnwards era
s HashableScriptData
sd -> BabbageEraOnwards era -> HashableScriptData -> TxOutDatum CtxTx era
forall era ctx.
BabbageEraOnwards era -> HashableScriptData -> TxOutDatum ctx era
Cardano.TxOutDatumInline BabbageEraOnwards era
s HashableScriptData
sd
       in AddressInEra era
-> TxOutValue era
-> TxOutDatum CtxTx era
-> ReferenceScript era
-> TxOut CtxTx era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
Cardano.TxOut AddressInEra era
addr TxOutValue era
val TxOutDatum CtxTx era
dat ReferenceScript era
refS

mcstToUtxoState :: MockChainSt -> UtxoState
mcstToUtxoState :: MockChainSt -> UtxoState
mcstToUtxoState MockChainSt {UtxoIndex
mcstIndex :: MockChainSt -> UtxoIndex
mcstIndex :: UtxoIndex
mcstIndex, Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: MockChainSt -> Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums} =
  Map Address UtxoPayloadSet -> UtxoState
UtxoState
    (Map Address UtxoPayloadSet -> UtxoState)
-> (UtxoIndex -> Map Address UtxoPayloadSet)
-> UtxoIndex
-> UtxoState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Address, UtxoPayloadSet)
 -> Map Address UtxoPayloadSet -> Map Address UtxoPayloadSet)
-> Map Address UtxoPayloadSet
-> [(Address, UtxoPayloadSet)]
-> Map Address UtxoPayloadSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Address
address, UtxoPayloadSet
utxoValueSet) Map Address UtxoPayloadSet
acc -> (UtxoPayloadSet -> UtxoPayloadSet -> UtxoPayloadSet)
-> Address
-> UtxoPayloadSet
-> Map Address UtxoPayloadSet
-> Map Address UtxoPayloadSet
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith UtxoPayloadSet -> UtxoPayloadSet -> UtxoPayloadSet
forall a. Semigroup a => a -> a -> a
(<>) Address
address UtxoPayloadSet
utxoValueSet Map Address UtxoPayloadSet
acc) Map Address UtxoPayloadSet
forall k a. Map k a
Map.empty
    ([(Address, UtxoPayloadSet)] -> Map Address UtxoPayloadSet)
-> (UtxoIndex -> [(Address, UtxoPayloadSet)])
-> UtxoIndex
-> Map Address UtxoPayloadSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, TxOut CtxUTxO ConwayEra)
 -> Maybe (Address, UtxoPayloadSet))
-> [(TxIn, TxOut CtxUTxO ConwayEra)] -> [(Address, UtxoPayloadSet)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
      ( (TxOutRef, TxOut) -> Maybe (Address, UtxoPayloadSet)
extractPayload
          ((TxOutRef, TxOut) -> Maybe (Address, UtxoPayloadSet))
-> ((TxIn, TxOut CtxUTxO ConwayEra) -> (TxOutRef, TxOut))
-> (TxIn, TxOut CtxUTxO ConwayEra)
-> Maybe (Address, UtxoPayloadSet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn -> TxOutRef)
-> (TxOut CtxUTxO ConwayEra -> TxOut)
-> (TxIn, TxOut CtxUTxO ConwayEra)
-> (TxOutRef, TxOut)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
            TxIn -> TxOutRef
Ledger.fromCardanoTxIn
            TxOut CtxUTxO ConwayEra -> TxOut
forall era. TxOut CtxUTxO era -> TxOut
Ledger.fromCardanoTxOutToPV2TxInfoTxOut'
      )
    ([(TxIn, TxOut CtxUTxO ConwayEra)] -> [(Address, UtxoPayloadSet)])
-> (UtxoIndex -> [(TxIn, TxOut CtxUTxO ConwayEra)])
-> UtxoIndex
-> [(Address, UtxoPayloadSet)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn (TxOut CtxUTxO ConwayEra)
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall k a. Map k a -> [(k, a)]
Map.toList
    (Map TxIn (TxOut CtxUTxO ConwayEra)
 -> [(TxIn, TxOut CtxUTxO ConwayEra)])
-> (UtxoIndex -> Map TxIn (TxOut CtxUTxO ConwayEra))
-> UtxoIndex
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoIndex -> Map TxIn (TxOut CtxUTxO ConwayEra)
forall era. UTxO era -> Map TxIn (TxOut CtxUTxO era)
Cardano.unUTxO
    (UtxoIndex -> UtxoState) -> UtxoIndex -> UtxoState
forall a b. (a -> b) -> a -> b
$ UtxoIndex
mcstIndex
  where
    extractPayload :: (Api.TxOutRef, Api.TxOut) -> Maybe (Api.Address, UtxoPayloadSet)
    extractPayload :: (TxOutRef, TxOut) -> Maybe (Address, UtxoPayloadSet)
extractPayload (TxOutRef
txOutRef, out :: TxOut
out@Api.TxOut {Address
txOutAddress :: Address
txOutAddress :: TxOut -> Address
Api.txOutAddress, Value
txOutValue :: Value
txOutValue :: TxOut -> Value
Api.txOutValue, OutputDatum
txOutDatum :: OutputDatum
txOutDatum :: TxOut -> OutputDatum
Api.txOutDatum}) =
      do
        let mRefScript :: Maybe ScriptHash
mRefScript = TxOut -> Maybe ScriptHash
forall o.
(IsAbstractOutput o, ToScriptHash (ReferenceScriptType o)) =>
o -> Maybe ScriptHash
outputReferenceScriptHash TxOut
out
        TxSkelOutDatum
txSkelOutDatum <-
          case OutputDatum
txOutDatum of
            OutputDatum
Api.NoOutputDatum -> TxSkelOutDatum -> Maybe TxSkelOutDatum
forall a. a -> Maybe a
Just TxSkelOutDatum
TxSkelOutNoDatum
            Api.OutputDatum Datum
datum -> (TxSkelOutDatum, Integer) -> TxSkelOutDatum
forall a b. (a, b) -> a
fst ((TxSkelOutDatum, Integer) -> TxSkelOutDatum)
-> Maybe (TxSkelOutDatum, Integer) -> Maybe TxSkelOutDatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatumHash
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Maybe (TxSkelOutDatum, Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Datum -> DatumHash
Script.datumHash Datum
datum) Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums
            Api.OutputDatumHash DatumHash
hash -> (TxSkelOutDatum, Integer) -> TxSkelOutDatum
forall a b. (a, b) -> a
fst ((TxSkelOutDatum, Integer) -> TxSkelOutDatum)
-> Maybe (TxSkelOutDatum, Integer) -> Maybe TxSkelOutDatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatumHash
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Maybe (TxSkelOutDatum, Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup DatumHash
hash Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums
        (Address, UtxoPayloadSet) -> Maybe (Address, UtxoPayloadSet)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return
          ( Address
txOutAddress,
            [UtxoPayload] -> UtxoPayloadSet
UtxoPayloadSet [TxOutRef
-> Value -> TxSkelOutDatum -> Maybe ScriptHash -> UtxoPayload
UtxoPayload TxOutRef
txOutRef Value
txOutValue TxSkelOutDatum
txSkelOutDatum Maybe ScriptHash
mRefScript]
          )

-- | Generating a skeleton context from a mockchain state. This is dedicated to
-- allowing the pretty printer to resolve skeleton parts.
mcstToSkelContext :: MockChainSt -> SkelContext
mcstToSkelContext :: MockChainSt -> SkelContext
mcstToSkelContext MockChainSt {Map DatumHash (TxSkelOutDatum, Integer)
Map ValidatorHash (Versioned Validator)
UtxoIndex
Params
Slot
mcstParams :: MockChainSt -> Params
mcstIndex :: MockChainSt -> UtxoIndex
mcstDatums :: MockChainSt -> Map DatumHash (TxSkelOutDatum, Integer)
mcstValidators :: MockChainSt -> Map ValidatorHash (Versioned Validator)
mcstCurrentSlot :: MockChainSt -> Slot
mcstParams :: Params
mcstIndex :: UtxoIndex
mcstDatums :: Map DatumHash (TxSkelOutDatum, Integer)
mcstValidators :: Map ValidatorHash (Versioned Validator)
mcstCurrentSlot :: Slot
..} =
  Map TxOutRef TxOut -> Map DatumHash TxSkelOutDatum -> SkelContext
SkelContext
    (UtxoIndex -> Map TxOutRef TxOut
getIndex UtxoIndex
mcstIndex)
    (((TxSkelOutDatum, Integer) -> TxSkelOutDatum)
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map DatumHash TxSkelOutDatum
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (TxSkelOutDatum, Integer) -> TxSkelOutDatum
forall a b. (a, b) -> a
fst Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums)

-- | Generating an emulated state for the emulator from a mockchain state and
-- some parameters, based on a standard initial state
mcstToEmulatedLedgerState :: MockChainSt -> Emulator.EmulatedLedgerState
mcstToEmulatedLedgerState :: MockChainSt -> EmulatedLedgerState
mcstToEmulatedLedgerState MockChainSt {Map DatumHash (TxSkelOutDatum, Integer)
Map ValidatorHash (Versioned Validator)
UtxoIndex
Params
Slot
mcstParams :: MockChainSt -> Params
mcstIndex :: MockChainSt -> UtxoIndex
mcstDatums :: MockChainSt -> Map DatumHash (TxSkelOutDatum, Integer)
mcstValidators :: MockChainSt -> Map ValidatorHash (Versioned Validator)
mcstCurrentSlot :: MockChainSt -> Slot
mcstParams :: Params
mcstIndex :: UtxoIndex
mcstDatums :: Map DatumHash (TxSkelOutDatum, Integer)
mcstValidators :: Map ValidatorHash (Versioned Validator)
mcstCurrentSlot :: Slot
..} =
  let els :: EmulatedLedgerState
els@(Emulator.EmulatedLedgerState MempoolEnv EmulatorEra
le LedgerState EmulatorEra
mps) = Params -> EmulatedLedgerState
Emulator.initialState Params
mcstParams
   in EmulatedLedgerState
els
        { Emulator._ledgerEnv = le {Shelley.ledgerSlotNo = fromIntegral mcstCurrentSlot},
          Emulator._memPoolState =
            mps
              { Shelley.lsUTxOState =
                  Shelley.smartUTxOState
                    (Emulator.emulatorPParams mcstParams)
                    (Ledger.fromPlutusIndex mcstIndex)
                    (Emulator.Coin 0)
                    (Emulator.Coin 0)
                    def
                    (Emulator.Coin 0)
              }
        }

addDatums :: [(Api.DatumHash, TxSkelOutDatum)] -> MockChainSt -> MockChainSt
addDatums :: [(DatumHash, TxSkelOutDatum)] -> MockChainSt -> MockChainSt
addDatums [(DatumHash, TxSkelOutDatum)]
toAdd st :: MockChainSt
st@(MockChainSt {Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: MockChainSt -> Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums}) =
  MockChainSt
st
    { mcstDatums =
        foldl
          ( \Map DatumHash (TxSkelOutDatum, Integer)
datumMap (DatumHash
dHash, TxSkelOutDatum
dat) ->
              ((TxSkelOutDatum, Integer)
 -> (TxSkelOutDatum, Integer) -> (TxSkelOutDatum, Integer))
-> DatumHash
-> (TxSkelOutDatum, Integer)
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map DatumHash (TxSkelOutDatum, Integer)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\(TxSkelOutDatum
d, Integer
n) (TxSkelOutDatum
_, Integer
n') -> (TxSkelOutDatum
d, Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n')) DatumHash
dHash (TxSkelOutDatum
dat, Integer
1) Map DatumHash (TxSkelOutDatum, Integer)
datumMap
          )
          mcstDatums
          toAdd
    }

removeDatums :: [Api.DatumHash] -> MockChainSt -> MockChainSt
removeDatums :: [DatumHash] -> MockChainSt -> MockChainSt
removeDatums [DatumHash]
toRemove st :: MockChainSt
st@(MockChainSt {Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: MockChainSt -> Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums :: Map DatumHash (TxSkelOutDatum, Integer)
mcstDatums}) =
  MockChainSt
st
    { mcstDatums =
        foldl
          (flip (Map.update (\(TxSkelOutDatum
dat, Integer
n) -> (TxSkelOutDatum
dat,) (Integer -> (TxSkelOutDatum, Integer))
-> Maybe Integer -> Maybe (TxSkelOutDatum, Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Maybe Integer
minusMaybe Integer
n)))
          mcstDatums
          toRemove
    }
  where
    -- This is unsafe as this assumes n >= 1
    minusMaybe :: Integer -> Maybe Integer
    minusMaybe :: Integer -> Maybe Integer
minusMaybe Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 = Maybe Integer
forall a. Maybe a
Nothing
    minusMaybe Integer
n = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1

addValidators :: Map Script.ValidatorHash (Script.Versioned Script.Validator) -> MockChainSt -> MockChainSt
addValidators :: Map ValidatorHash (Versioned Validator)
-> MockChainSt -> MockChainSt
addValidators Map ValidatorHash (Versioned Validator)
valMap st :: MockChainSt
st@(MockChainSt {Map ValidatorHash (Versioned Validator)
mcstValidators :: MockChainSt -> Map ValidatorHash (Versioned Validator)
mcstValidators :: Map ValidatorHash (Versioned Validator)
mcstValidators}) = MockChainSt
st {mcstValidators = Map.union valMap mcstValidators}

-- * Initial `MockChainSt` from an initial distribution

mockChainSt0From :: (MonadBlockChainBalancing m) => InitialDistribution -> m MockChainSt
mockChainSt0From :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
InitialDistribution -> m MockChainSt
mockChainSt0From InitialDistribution
i0 = (\UtxoIndex
x -> Params
-> UtxoIndex
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map ValidatorHash (Versioned Validator)
-> Slot
-> MockChainSt
MockChainSt Params
forall a. Default a => a
def UtxoIndex
x (InitialDistribution -> Map DatumHash (TxSkelOutDatum, Integer)
datumMap0From InitialDistribution
i0) (InitialDistribution -> Map ValidatorHash (Versioned Validator)
referenceScriptMap0From InitialDistribution
i0 Map ValidatorHash (Versioned Validator)
-> Map ValidatorHash (Versioned Validator)
-> Map ValidatorHash (Versioned Validator)
forall a. Semigroup a => a -> a -> a
<> InitialDistribution -> Map ValidatorHash (Versioned Validator)
scriptMap0From InitialDistribution
i0) Slot
0) (UtxoIndex -> MockChainSt) -> m UtxoIndex -> m MockChainSt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InitialDistribution -> m UtxoIndex
forall (m :: * -> *).
MonadBlockChainBalancing m =>
InitialDistribution -> m UtxoIndex
utxoIndex0From InitialDistribution
i0

-- | Reference scripts from initial distributions should be accounted for in the
-- `MockChainSt` which is done using this function.
referenceScriptMap0From :: InitialDistribution -> Map Script.ValidatorHash (Script.Versioned Script.Validator)
referenceScriptMap0From :: InitialDistribution -> Map ValidatorHash (Versioned Validator)
referenceScriptMap0From =
  -- This builds a map of entries from the reference scripts contained in the
  -- initial distribution
  [(ValidatorHash, Versioned Validator)]
-> Map ValidatorHash (Versioned Validator)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ValidatorHash, Versioned Validator)]
 -> Map ValidatorHash (Versioned Validator))
-> (InitialDistribution -> [(ValidatorHash, Versioned Validator)])
-> InitialDistribution
-> Map ValidatorHash (Versioned Validator)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSkelOut -> Maybe (ValidatorHash, Versioned Validator))
-> [TxSkelOut] -> [(ValidatorHash, Versioned Validator)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxSkelOut -> Maybe (ValidatorHash, Versioned Validator)
unitMaybeFrom ([TxSkelOut] -> [(ValidatorHash, Versioned Validator)])
-> (InitialDistribution -> [TxSkelOut])
-> InitialDistribution
-> [(ValidatorHash, Versioned Validator)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitialDistribution -> [TxSkelOut]
unInitialDistribution
  where
    -- This takes a single output and returns a possible map entry when it
    -- contains a reference script
    unitMaybeFrom :: TxSkelOut -> Maybe (Script.ValidatorHash, Script.Versioned Script.Validator)
    unitMaybeFrom :: TxSkelOut -> Maybe (ValidatorHash, Versioned Validator)
unitMaybeFrom (Pays o
output) = do
      ReferenceScriptType o
refScript <- Optic' A_Lens NoIx o (Maybe (ReferenceScriptType o))
-> o -> Maybe (ReferenceScriptType o)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx o (Maybe (ReferenceScriptType o))
forall o.
IsAbstractOutput o =>
Lens' o (Maybe (ReferenceScriptType o))
outputReferenceScriptL o
output
      let vScript :: Versioned Script
vScript@(Script.Versioned Script
script Language
version) = ReferenceScriptType o -> Versioned Script
forall a. ToVersionedScript a => a -> Versioned Script
toVersionedScript ReferenceScriptType o
refScript
      (ValidatorHash, Versioned Validator)
-> Maybe (ValidatorHash, Versioned Validator)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuiltinByteString -> ValidatorHash
Script.ValidatorHash (BuiltinByteString -> ValidatorHash)
-> BuiltinByteString -> ValidatorHash
forall a b. (a -> b) -> a -> b
$ ScriptHash -> BuiltinByteString
Api.getScriptHash (ScriptHash -> BuiltinByteString)
-> ScriptHash -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ Versioned Script -> ScriptHash
forall a. ToScriptHash a => a -> ScriptHash
toScriptHash Versioned Script
vScript, Validator -> Language -> Versioned Validator
forall script. script -> Language -> Versioned script
Script.Versioned (Script -> Validator
Script.Validator Script
script) Language
version)

-- | Scripts from initial distributions should be accounted for in the
-- `MockChainSt` which is done using this function.
scriptMap0From :: InitialDistribution -> Map Script.ValidatorHash (Script.Versioned Script.Validator)
scriptMap0From :: InitialDistribution -> Map ValidatorHash (Versioned Validator)
scriptMap0From =
  -- This builds a map of entries from the scripts contained in the initial
  -- distribution
  [(ValidatorHash, Versioned Validator)]
-> Map ValidatorHash (Versioned Validator)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ValidatorHash, Versioned Validator)]
 -> Map ValidatorHash (Versioned Validator))
-> (InitialDistribution -> [(ValidatorHash, Versioned Validator)])
-> InitialDistribution
-> Map ValidatorHash (Versioned Validator)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSkelOut -> Maybe (ValidatorHash, Versioned Validator))
-> [TxSkelOut] -> [(ValidatorHash, Versioned Validator)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxSkelOut -> Maybe (ValidatorHash, Versioned Validator)
unitMaybeFrom ([TxSkelOut] -> [(ValidatorHash, Versioned Validator)])
-> (InitialDistribution -> [TxSkelOut])
-> InitialDistribution
-> [(ValidatorHash, Versioned Validator)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitialDistribution -> [TxSkelOut]
unInitialDistribution
  where
    -- This takes a single output and returns a possible map entry when it
    -- contains a script
    unitMaybeFrom :: TxSkelOut -> Maybe (Script.ValidatorHash, Script.Versioned Script.Validator)
    unitMaybeFrom :: TxSkelOut -> Maybe (ValidatorHash, Versioned Validator)
unitMaybeFrom TxSkelOut
txSkelOut = do
      Versioned Validator
val <- TxSkelOut -> Maybe (Versioned Validator)
txSkelOutValidator TxSkelOut
txSkelOut
      (ValidatorHash, Versioned Validator)
-> Maybe (ValidatorHash, Versioned Validator)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuiltinByteString -> ValidatorHash
Script.ValidatorHash (BuiltinByteString -> ValidatorHash)
-> BuiltinByteString -> ValidatorHash
forall a b. (a -> b) -> a -> b
$ ScriptHash -> BuiltinByteString
Api.getScriptHash (ScriptHash -> BuiltinByteString)
-> ScriptHash -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ Versioned Validator -> ScriptHash
forall a. ToScriptHash a => a -> ScriptHash
toScriptHash Versioned Validator
val, Versioned Validator
val)

-- | Datums from initial distributions should be accounted for in the
-- `MockChainSt` which is done using this function.
datumMap0From :: InitialDistribution -> Map Api.DatumHash (TxSkelOutDatum, Integer)
datumMap0From :: InitialDistribution -> Map DatumHash (TxSkelOutDatum, Integer)
datumMap0From (InitialDistribution [TxSkelOut]
initDist) =
  -- This concatenates singleton maps from inputs and accounts for the number of
  -- occurrences of similar datums
  (Map DatumHash (TxSkelOutDatum, Integer)
 -> TxSkelOut -> Map DatumHash (TxSkelOutDatum, Integer))
-> Map DatumHash (TxSkelOutDatum, Integer)
-> [TxSkelOut]
-> Map DatumHash (TxSkelOutDatum, Integer)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map DatumHash (TxSkelOutDatum, Integer)
m -> ((TxSkelOutDatum, Integer)
 -> (TxSkelOutDatum, Integer) -> (TxSkelOutDatum, Integer))
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map DatumHash (TxSkelOutDatum, Integer)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\(TxSkelOutDatum
d, Integer
n1) (TxSkelOutDatum
_, Integer
n2) -> (TxSkelOutDatum
d, Integer
n1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n2)) Map DatumHash (TxSkelOutDatum, Integer)
m (Map DatumHash (TxSkelOutDatum, Integer)
 -> Map DatumHash (TxSkelOutDatum, Integer))
-> (TxSkelOut -> Map DatumHash (TxSkelOutDatum, Integer))
-> TxSkelOut
-> Map DatumHash (TxSkelOutDatum, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkelOut -> Map DatumHash (TxSkelOutDatum, Integer)
unitMapFrom) Map DatumHash (TxSkelOutDatum, Integer)
forall k a. Map k a
Map.empty [TxSkelOut]
initDist
  where
    -- This takes a single output and creates an empty map if it contains no
    -- datum, or a singleton map if it contains one
    unitMapFrom :: TxSkelOut -> Map Api.DatumHash (TxSkelOutDatum, Integer)
    unitMapFrom :: TxSkelOut -> Map DatumHash (TxSkelOutDatum, Integer)
unitMapFrom TxSkelOut
txSkelOut =
      let datum :: TxSkelOutDatum
datum = Optic' A_Lens NoIx TxSkelOut TxSkelOutDatum
-> TxSkelOut -> TxSkelOutDatum
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx TxSkelOut TxSkelOutDatum
txSkelOutDatumL TxSkelOut
txSkelOut
       in Map DatumHash (TxSkelOutDatum, Integer)
-> (Datum -> Map DatumHash (TxSkelOutDatum, Integer))
-> Maybe Datum
-> Map DatumHash (TxSkelOutDatum, Integer)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map DatumHash (TxSkelOutDatum, Integer)
forall k a. Map k a
Map.empty ((DatumHash
 -> (TxSkelOutDatum, Integer)
 -> Map DatumHash (TxSkelOutDatum, Integer))
-> (TxSkelOutDatum, Integer)
-> DatumHash
-> Map DatumHash (TxSkelOutDatum, Integer)
forall a b c. (a -> b -> c) -> b -> a -> c
flip DatumHash
-> (TxSkelOutDatum, Integer)
-> Map DatumHash (TxSkelOutDatum, Integer)
forall k a. k -> a -> Map k a
Map.singleton (TxSkelOutDatum
datum, Integer
1) (DatumHash -> Map DatumHash (TxSkelOutDatum, Integer))
-> (Datum -> DatumHash)
-> Datum
-> Map DatumHash (TxSkelOutDatum, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Datum -> DatumHash
Script.datumHash) (Maybe Datum -> Map DatumHash (TxSkelOutDatum, Integer))
-> Maybe Datum -> Map DatumHash (TxSkelOutDatum, Integer)
forall a b. (a -> b) -> a -> b
$ TxSkelOutDatum -> Maybe Datum
txSkelOutUntypedDatum TxSkelOutDatum
datum

-- | This creates the initial UtxoIndex from an initial distribution by
-- submitting an initial transaction with the appropriate content:
--
-- - inputs consist of a single dummy pseudo input
--
-- - outputs are translated from the `TxSkelOut` list in the initial
--   distribution
--
-- Two things to note:
--
-- - We don't know what "Magic" means for the network ID (TODO)
--
-- - The genesis key hash has been taken from
--   https://github.com/input-output-hk/cardano-node/blob/543b267d75d3d448e1940f9ec04b42bd01bbb16b/cardano-api/test/Test/Cardano/Api/Genesis.hs#L60
utxoIndex0From :: (MonadBlockChainBalancing m) => InitialDistribution -> m Ledger.UtxoIndex
utxoIndex0From :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
InitialDistribution -> m UtxoIndex
utxoIndex0From (InitialDistribution [TxSkelOut]
initDist) = do
  NetworkId
networkId <- Params -> NetworkId
Emulator.pNetworkId (Params -> NetworkId) -> m Params -> m NetworkId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  let genesisKeyHash :: Hash GenesisUTxOKey
genesisKeyHash = KeyHash 'Payment StandardCrypto -> Hash GenesisUTxOKey
Cardano.GenesisUTxOKeyHash (KeyHash 'Payment StandardCrypto -> Hash GenesisUTxOKey)
-> KeyHash 'Payment StandardCrypto -> Hash GenesisUTxOKey
forall a b. (a -> b) -> a -> b
$ Hash (ADDRHASH StandardCrypto) (VerKeyDSIGN (DSIGN StandardCrypto))
-> KeyHash 'Payment StandardCrypto
forall (discriminator :: KeyRole) c.
Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
-> KeyHash discriminator c
Shelley.KeyHash Hash (ADDRHASH StandardCrypto) (VerKeyDSIGN (DSIGN StandardCrypto))
Hash Blake2b_224 (VerKeyDSIGN Ed25519DSIGN)
"23d51e91ae5adc7ae801e9de4cd54175fb7464ec2680b25686bbb194"
      inputs :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))]
inputs = [(NetworkId -> Hash GenesisUTxOKey -> TxIn
Cardano.genesisUTxOPseudoTxIn NetworkId
networkId Hash GenesisUTxOKey
genesisKeyHash, Witness WitCtxTxIn ConwayEra
-> BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra)
forall a. a -> BuildTxWith BuildTx a
Cardano.BuildTxWith (Witness WitCtxTxIn ConwayEra
 -> BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))
-> Witness WitCtxTxIn ConwayEra
-> BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn ConwayEra
forall witctx era. KeyWitnessInCtx witctx -> Witness witctx era
Cardano.KeyWitness KeyWitnessInCtx WitCtxTxIn
Cardano.KeyWitnessForSpending)]
  [TxOut CtxTx ConwayEra]
outputs <- (TxSkelOut -> m (TxOut CtxTx ConwayEra))
-> [TxSkelOut] -> m [TxOut CtxTx ConwayEra]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TxSkelOut -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m TxSkelOut
toTxSkelOutWithMinAda (TxSkelOut -> m TxSkelOut)
-> (TxSkelOut -> m (TxOut CtxTx ConwayEra))
-> TxSkelOut
-> m (TxOut CtxTx ConwayEra)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> TxSkelOut -> m (TxOut CtxTx ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m (TxOut CtxTx ConwayEra)
toCardanoTxOut) [TxSkelOut]
initDist
  Blockchain -> UtxoIndex
Ledger.initialise (Blockchain -> UtxoIndex)
-> (TxBody ConwayEra -> Blockchain)
-> TxBody ConwayEra
-> UtxoIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([OnChainTx] -> Blockchain -> Blockchain
forall a. a -> [a] -> [a]
: []) ([OnChainTx] -> Blockchain)
-> (TxBody ConwayEra -> [OnChainTx])
-> TxBody ConwayEra
-> Blockchain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OnChainTx -> [OnChainTx] -> [OnChainTx]
forall a. a -> [a] -> [a]
: []) (OnChainTx -> [OnChainTx])
-> (TxBody ConwayEra -> OnChainTx)
-> TxBody ConwayEra
-> [OnChainTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoTx -> OnChainTx
Emulator.unsafeMakeValid (CardanoTx -> OnChainTx)
-> (TxBody ConwayEra -> CardanoTx) -> TxBody ConwayEra -> OnChainTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx ConwayEra -> CardanoTx
Ledger.CardanoEmulatorEraTx (Tx ConwayEra -> CardanoTx)
-> (TxBody ConwayEra -> Tx ConwayEra)
-> TxBody ConwayEra
-> CardanoTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Wallet] -> TxBody ConwayEra -> Tx ConwayEra
txSignersAndBodyToCardanoTx []
    (TxBody ConwayEra -> UtxoIndex)
-> m (TxBody ConwayEra) -> m UtxoIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TxBodyError -> m (TxBody ConwayEra))
-> (TxBody ConwayEra -> m (TxBody ConwayEra))
-> Either TxBodyError (TxBody ConwayEra)
-> m (TxBody ConwayEra)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (MockChainError -> m (TxBody ConwayEra)
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MockChainError -> m (TxBody ConwayEra))
-> (TxBodyError -> MockChainError)
-> TxBodyError
-> m (TxBody ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenerateTxError -> MockChainError
MCEGenerationError (GenerateTxError -> MockChainError)
-> (TxBodyError -> GenerateTxError)
-> TxBodyError
-> MockChainError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TxBodyError -> GenerateTxError
TxBodyError String
"generateTx :")
      TxBody ConwayEra -> m (TxBody ConwayEra)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
      ( ShelleyBasedEra ConwayEra
-> TxBodyContent BuildTx ConwayEra
-> Either TxBodyError (TxBody ConwayEra)
forall era.
ShelleyBasedEra era
-> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
Cardano.createAndValidateTransactionBody
          ShelleyBasedEra ConwayEra
Cardano.ShelleyBasedEraConway
          (TxBodyContent BuildTx ConwayEra
Ledger.emptyTxBodyContent {Cardano.txOuts = outputs, Cardano.txIns = inputs})
      )

utxoIndex0 :: (MonadBlockChainBalancing m) => m Ledger.UtxoIndex
utxoIndex0 :: forall (m :: * -> *). MonadBlockChainBalancing m => m UtxoIndex
utxoIndex0 = InitialDistribution -> m UtxoIndex
forall (m :: * -> *).
MonadBlockChainBalancing m =>
InitialDistribution -> m UtxoIndex
utxoIndex0From InitialDistribution
forall a. Default a => a
def