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.Arrow
import Cooked.Conversion.ToScriptHash
import Cooked.Conversion.ToVersionedScript
import Cooked.InitialDistribution
import Cooked.MockChain.GenerateTx (GenerateTxError (..), generateTxOut)
import Cooked.MockChain.UtxoState
import Cooked.Output
import Cooked.Skeleton
import Data.Bifunctor (bimap)
import Data.Default
import Data.Either.Combinators (mapLeft)
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 = MockChainSt
mockChainSt0

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

-- * Canonical initial values

utxoState0 :: UtxoState
utxoState0 :: UtxoState
utxoState0 = MockChainSt -> UtxoState
mcstToUtxoState MockChainSt
mockChainSt0

mockChainSt0 :: MockChainSt
mockChainSt0 :: MockChainSt
mockChainSt0 = Params
-> UtxoIndex
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map ValidatorHash (Versioned Validator)
-> Slot
-> MockChainSt
MockChainSt Params
forall a. Default a => a
def UtxoIndex
utxoIndex0 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

-- * Initial `MockChainSt` from an initial distribution

mockChainSt0From :: InitialDistribution -> MockChainSt
mockChainSt0From :: InitialDistribution -> MockChainSt
mockChainSt0From InitialDistribution
i0 = Params
-> UtxoIndex
-> Map DatumHash (TxSkelOutDatum, Integer)
-> Map ValidatorHash (Versioned Validator)
-> Slot
-> MockChainSt
MockChainSt Params
forall a. Default a => a
def (InitialDistribution -> UtxoIndex
utxoIndex0From InitialDistribution
i0) (InitialDistribution -> Map DatumHash (TxSkelOutDatum, Integer)
datumMap0From InitialDistribution
i0) (InitialDistribution -> Map ValidatorHash (Versioned Validator)
referenceScriptMap0From InitialDistribution
i0) Slot
0

-- | 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 (InitialDistribution [TxSkelOut]
initDist) =
  -- 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))
-> [(ValidatorHash, Versioned Validator)]
-> Map ValidatorHash (Versioned Validator)
forall a b. (a -> b) -> a -> b
$ (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]
initDist
  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
          Api.ScriptHash BuiltinByteString
scriptHash = Versioned Script -> ScriptHash
forall a. ToScriptHash a => a -> ScriptHash
toScriptHash Versioned Script
vScript
      (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
scriptHash, Validator -> Language -> Versioned Validator
forall script. script -> Language -> Versioned script
Script.Versioned (Script -> Validator
Script.Validator Script
script) Language
version)

-- | 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
--
-- - all non-ada assets in outputs are considered minted
--
-- - 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 :: InitialDistribution -> Ledger.UtxoIndex
utxoIndex0From :: InitialDistribution -> UtxoIndex
utxoIndex0From (InitialDistribution [TxSkelOut]
initDist) = case Either GenerateTxError (TxBody ConwayEra)
mkBody of
  Left GenerateTxError
err -> String -> UtxoIndex
forall a. HasCallStack => String -> a
error (String -> UtxoIndex) -> String -> UtxoIndex
forall a b. (a -> b) -> a -> b
$ GenerateTxError -> String
forall a. Show a => a -> String
show GenerateTxError
err
  -- TODO: There may be better ways to generate this initial state, see
  -- createGenesisTransaction for instance
  Right TxBody ConwayEra
body -> Blockchain -> UtxoIndex
Ledger.initialise [[CardanoTx -> OnChainTx
Emulator.unsafeMakeValid (CardanoTx -> OnChainTx) -> CardanoTx -> OnChainTx
forall a b. (a -> b) -> a -> b
$ Tx ConwayEra -> CardanoTx
Ledger.CardanoEmulatorEraTx (Tx ConwayEra -> CardanoTx) -> Tx ConwayEra -> CardanoTx
forall a b. (a -> b) -> a -> b
$ TxBody ConwayEra -> [KeyWitness ConwayEra] -> Tx ConwayEra
forall era. TxBody era -> [KeyWitness era] -> Tx era
Cardano.Tx TxBody ConwayEra
body []]]
  where
    mkBody :: Either GenerateTxError (Cardano.TxBody Cardano.ConwayEra)
    mkBody :: Either GenerateTxError (TxBody ConwayEra)
mkBody = do
      Value
value <- (ToCardanoError -> GenerateTxError)
-> Either ToCardanoError Value -> Either GenerateTxError Value
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft (String -> ToCardanoError -> GenerateTxError
ToCardanoError String
"Value error") (Either ToCardanoError Value -> Either GenerateTxError Value)
-> Either ToCardanoError Value -> Either GenerateTxError Value
forall a b. (a -> b) -> a -> b
$ Value -> Either ToCardanoError Value
Ledger.toCardanoValue ((Value -> TxSkelOut -> Value) -> Value -> [TxSkelOut] -> Value
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Value
v -> (Value
v Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<>) (Value -> Value) -> (TxSkelOut -> Value) -> TxSkelOut -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' A_Lens NoIx TxSkelOut Value -> TxSkelOut -> Value
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx TxSkelOut Value
txSkelOutValueL) Value
forall a. Monoid a => a
mempty [TxSkelOut]
initDist)
      let mintValue :: TxMintValue BuildTx ConwayEra
mintValue = (Value
 -> BuildTxWith
      BuildTx (Map PolicyId (ScriptWitness WitCtxMint ConwayEra))
 -> TxMintValue BuildTx ConwayEra)
-> BuildTxWith
     BuildTx (Map PolicyId (ScriptWitness WitCtxMint ConwayEra))
-> Value
-> TxMintValue BuildTx ConwayEra
forall a b c. (a -> b -> c) -> b -> a -> c
flip (MaryEraOnwards ConwayEra
-> Value
-> BuildTxWith
     BuildTx (Map PolicyId (ScriptWitness WitCtxMint ConwayEra))
-> TxMintValue BuildTx ConwayEra
forall era build.
MaryEraOnwards era
-> Value
-> BuildTxWith build (Map PolicyId (ScriptWitness WitCtxMint era))
-> TxMintValue build era
Cardano.TxMintValue MaryEraOnwards ConwayEra
Cardano.MaryEraOnwardsConway) (Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
-> BuildTxWith
     BuildTx (Map PolicyId (ScriptWitness WitCtxMint ConwayEra))
forall a. a -> BuildTxWith BuildTx a
Cardano.BuildTxWith Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
forall a. Monoid a => a
mempty) (Value -> TxMintValue BuildTx ConwayEra)
-> (Value -> Value) -> Value -> TxMintValue BuildTx ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AssetId -> Bool) -> Value -> Value
Cardano.filterValue (AssetId -> AssetId -> Bool
forall a. Eq a => a -> a -> Bool
/= AssetId
Cardano.AdaAssetId) (Value -> TxMintValue BuildTx ConwayEra)
-> Value -> TxMintValue BuildTx ConwayEra
forall a b. (a -> b) -> a -> b
$ Value
value
          theNetworkId :: NetworkId
theNetworkId = NetworkMagic -> NetworkId
Cardano.Testnet (NetworkMagic -> NetworkId) -> NetworkMagic -> NetworkId
forall a b. (a -> b) -> a -> b
$ Word32 -> NetworkMagic
Cardano.NetworkMagic Word32
42
          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 era))]
inputs = [(NetworkId -> Hash GenesisUTxOKey -> TxIn
Cardano.genesisUTxOPseudoTxIn NetworkId
theNetworkId Hash GenesisUTxOKey
genesisKeyHash, Witness WitCtxTxIn era
-> BuildTxWith BuildTx (Witness WitCtxTxIn era)
forall a. a -> BuildTxWith BuildTx a
Cardano.BuildTxWith (Witness WitCtxTxIn era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn era))
-> Witness WitCtxTxIn era
-> BuildTxWith BuildTx (Witness WitCtxTxIn era)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn era
forall witctx era. KeyWitnessInCtx witctx -> Witness witctx era
Cardano.KeyWitness KeyWitnessInCtx WitCtxTxIn
Cardano.KeyWitnessForSpending)]
      [TxOut CtxTx ConwayEra]
outputs <- (TxSkelOut -> Either GenerateTxError (TxOut CtxTx ConwayEra))
-> [TxSkelOut] -> Either GenerateTxError [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 (NetworkId
-> TxSkelOut -> Either GenerateTxError (TxOut CtxTx ConwayEra)
generateTxOut NetworkId
theNetworkId) [TxSkelOut]
initDist
      (TxBodyError -> GenerateTxError)
-> Either TxBodyError (TxBody ConwayEra)
-> Either GenerateTxError (TxBody ConwayEra)
forall a c b. (a -> c) -> Either a b -> Either c b
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (String -> TxBodyError -> GenerateTxError
TxBodyError String
"Body error") (Either TxBodyError (TxBody ConwayEra)
 -> Either GenerateTxError (TxBody ConwayEra))
-> Either TxBodyError (TxBody ConwayEra)
-> Either GenerateTxError (TxBody ConwayEra)
forall a b. (a -> b) -> a -> b
$
        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
 -> Either TxBodyError (TxBody ConwayEra))
-> TxBodyContent BuildTx ConwayEra
-> Either TxBodyError (TxBody ConwayEra)
forall a b. (a -> b) -> a -> b
$
          TxBodyContent BuildTx ConwayEra
Ledger.emptyTxBodyContent {Cardano.txMintValue = mintValue, Cardano.txOuts = outputs, Cardano.txIns = inputs}

utxoIndex0 :: Ledger.UtxoIndex
utxoIndex0 :: UtxoIndex
utxoIndex0 = InitialDistribution -> UtxoIndex
utxoIndex0From InitialDistribution
forall a. Default a => a
def