{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Hydra.Chain.Direct.Contract.Mutation where
import Hydra.Cardano.Api
import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Alonzo.Scripts qualified as Ledger
import Cardano.Ledger.Alonzo.TxWits qualified as Ledger
import Cardano.Ledger.Api (AllegraEraTxBody (vldtTxBodyL), AlonzoPlutusPurpose (..), AsIndex (..), inputsTxBodyL, mintTxBodyL, outputsTxBodyL, reqSignerHashesTxBodyL)
import Cardano.Ledger.Core qualified as Ledger
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Mary.Value qualified as Ledger
import Cardano.Ledger.Plutus.Data qualified as Ledger
import Control.Exception (assert)
import Control.Lens (set, view, (.~), (^.))
import Data.Map qualified as Map
import Data.Sequence.Strict qualified as StrictSeq
import Data.Set qualified as Set
import Hydra.Cardano.Api.Pretty (renderTxWithUTxO)
import Hydra.Chain.Direct.Fixture (testPolicyId)
import Hydra.Chain.Direct.Fixture qualified as Fixture
import Hydra.Chain.Direct.Tx (findFirst, onChainIdToAssetName, verificationKeyToOnChainId)
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Data.ContestationPeriod
import Hydra.Data.Party qualified as Data (Party)
import Hydra.Ledger.Cardano (genKeyPair, genOutput)
import Hydra.Ledger.Cardano.Evaluate (evaluateTx)
import Hydra.Plutus.Orphans ()
import Hydra.Prelude hiding (label)
import PlutusLedgerApi.V2 (CurrencySymbol, POSIXTime, toData)
import PlutusLedgerApi.V2 qualified as Plutus
import System.Directory.Internal.Prelude qualified as Prelude
import Test.Hydra.Prelude
import Test.QuickCheck (
Property,
checkCoverage,
counterexample,
forAll,
property,
suchThat,
)
import Test.QuickCheck.Instances ()
propMutation :: (Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property
propMutation :: (Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property
propMutation (Tx
tx, UTxO
utxo) (Tx, UTxO) -> Gen SomeMutation
genMutation =
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll @_ @Property ((Tx, UTxO) -> Gen SomeMutation
genMutation (Tx
tx, UTxO
utxo)) ((SomeMutation -> Property) -> Property)
-> (SomeMutation -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \SomeMutation{lbl
label :: lbl
$sel:label:SomeMutation :: ()
label, Mutation
mutation :: Mutation
$sel:mutation:SomeMutation :: SomeMutation -> Mutation
mutation, Maybe Text
expectedError :: Maybe Text
$sel:expectedError:SomeMutation :: SomeMutation -> Maybe Text
expectedError} ->
(Tx
tx, UTxO
utxo)
(Tx, UTxO) -> ((Tx, UTxO) -> (Tx, UTxO)) -> (Tx, UTxO)
forall a b. a -> (a -> b) -> b
& Mutation -> (Tx, UTxO) -> (Tx, UTxO)
applyMutation Mutation
mutation
(Tx, UTxO) -> ((Tx, UTxO) -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Maybe Text -> (Tx, UTxO) -> Property
propTransactionFailsPhase2 Maybe Text
expectedError
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& [lbl] -> Property -> Property
forall a prop.
(Show a, Enum a, Bounded a, Typeable a, Testable prop) =>
[a] -> prop -> Property
genericCoverTable [lbl
label]
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage
propTransactionFailsPhase2 :: Maybe Text -> (Tx, UTxO) -> Property
propTransactionFailsPhase2 :: Maybe Text -> (Tx, UTxO) -> Property
propTransactionFailsPhase2 Maybe Text
mExpectedError (Tx
tx, UTxO
lookupUTxO) =
case Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
tx UTxO
lookupUTxO of
Left EvaluationError
err ->
Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Mutated transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Phase-1 validation failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationError -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationError
err)
Right EvaluationReport
redeemerReport ->
let errors :: [ScriptExecutionError]
errors = [Either ScriptExecutionError ExecutionUnits]
-> [ScriptExecutionError]
forall a b. [Either a b] -> [a]
lefts ([Either ScriptExecutionError ExecutionUnits]
-> [ScriptExecutionError])
-> [Either ScriptExecutionError ExecutionUnits]
-> [ScriptExecutionError]
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall k a. Map k a -> [a]
Map.elems EvaluationReport
redeemerReport
in case Maybe Text
mExpectedError of
Maybe Text
Nothing ->
Bool -> Bool
not ([ScriptExecutionError] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ScriptExecutionError]
errors)
Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Mutated transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Redeemer report: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationReport -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationReport
redeemerReport)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Phase-2 validation should have failed"
Just Text
expectedError ->
(ScriptExecutionError -> Bool) -> [ScriptExecutionError] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> ScriptExecutionError -> Bool
matchesErrorMessage Text
expectedError) [ScriptExecutionError]
errors
Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Mutated transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Redeemer report: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationReport -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationReport
redeemerReport)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Phase-2 validation should have failed with error message: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
expectedError)
where
matchesErrorMessage :: Text -> ScriptExecutionError -> Bool
matchesErrorMessage Text
errMsg = \case
ScriptErrorEvaluationFailed EvaluationError
_ [Text]
errList -> Text
errMsg Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Text]
errList
ScriptExecutionError
_otherScriptExecutionError -> Bool
False
propTransactionEvaluates :: (Tx, UTxO) -> Property
propTransactionEvaluates :: (Tx, UTxO) -> Property
propTransactionEvaluates (Tx
tx, UTxO
lookupUTxO) =
case Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
tx UTxO
lookupUTxO of
Left EvaluationError
err ->
Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Phase-1 validation failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationError -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationError
err)
Right EvaluationReport
redeemerReport ->
(Either ScriptExecutionError ExecutionUnits -> Bool)
-> [Either ScriptExecutionError ExecutionUnits] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isRight (EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall k a. Map k a -> [a]
Map.elems EvaluationReport
redeemerReport)
Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Redeemer report: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationReport -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationReport
redeemerReport)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Phase-2 validation failed"
propTransactionFailsEvaluation :: (Tx, UTxO) -> Property
propTransactionFailsEvaluation :: (Tx, UTxO) -> Property
propTransactionFailsEvaluation (Tx
tx, UTxO
lookupUTxO) =
case Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
tx UTxO
lookupUTxO of
Left EvaluationError
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
Right EvaluationReport
redeemerReport ->
(Either ScriptExecutionError ExecutionUnits -> Bool)
-> EvaluationReport -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isLeft EvaluationReport
redeemerReport
Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Redeemer report: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationReport -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationReport
redeemerReport)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Phase-2 validation should have failed"
data SomeMutation = forall lbl.
(Typeable lbl, Enum lbl, Bounded lbl, Show lbl) =>
SomeMutation
{ SomeMutation -> Maybe Text
expectedError :: Maybe Text
, ()
label :: lbl
, SomeMutation -> Mutation
mutation :: Mutation
}
deriving stock instance Show SomeMutation
data Mutation
=
ChangeHeadRedeemer Head.Input
|
ChangeInputHeadDatum Head.State
|
PrependOutput (TxOut CtxTx)
|
AppendOutput (TxOut CtxTx)
|
RemoveOutput Word
|
RemoveInput TxIn
|
AddInput TxIn (TxOut CtxUTxO) (Maybe HashableScriptData)
|
AddScript PlutusScript
|
ChangeInput TxIn (TxOut CtxUTxO) (Maybe HashableScriptData)
|
ChangeOutput Word (TxOut CtxTx)
|
ChangeMintedValue Value
|
ChangeRequiredSigners [Hash PaymentKey]
|
ChangeValidityInterval (TxValidityLowerBound, TxValidityUpperBound)
| ChangeValidityLowerBound TxValidityLowerBound
| ChangeValidityUpperBound TxValidityUpperBound
|
ChangeMintingPolicy PlutusScript
|
Changes [Mutation]
deriving stock (Int -> Mutation -> String -> String
[Mutation] -> String -> String
Mutation -> String
(Int -> Mutation -> String -> String)
-> (Mutation -> String)
-> ([Mutation] -> String -> String)
-> Show Mutation
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Mutation -> String -> String
showsPrec :: Int -> Mutation -> String -> String
$cshow :: Mutation -> String
show :: Mutation -> String
$cshowList :: [Mutation] -> String -> String
showList :: [Mutation] -> String -> String
Show, (forall x. Mutation -> Rep Mutation x)
-> (forall x. Rep Mutation x -> Mutation) -> Generic Mutation
forall x. Rep Mutation x -> Mutation
forall x. Mutation -> Rep Mutation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Mutation -> Rep Mutation x
from :: forall x. Mutation -> Rep Mutation x
$cto :: forall x. Rep Mutation x -> Mutation
to :: forall x. Rep Mutation x -> Mutation
Generic)
applyMutation :: Mutation -> (Tx, UTxO) -> (Tx, UTxO)
applyMutation :: Mutation -> (Tx, UTxO) -> (Tx, UTxO)
applyMutation Mutation
mutation (tx :: Tx
tx@(Tx TxBody
body [KeyWitness]
wits), UTxO
utxo) = case Mutation
mutation of
ChangeHeadRedeemer Input
newRedeemer ->
(TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits, UTxO
utxo)
where
body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
redeemers' Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
redeemers' :: TxBodyScriptData
redeemers' = (PlutusPurpose AsIndex LedgerEra
-> (Data LedgerEra, ExUnits) -> (Data LedgerEra, ExUnits))
-> TxBodyScriptData -> TxBodyScriptData
alterRedeemers AlonzoPlutusPurpose AsIndex StandardBabbage
-> (Data StandardBabbage, ExUnits)
-> (Data StandardBabbage, ExUnits)
PlutusPurpose AsIndex LedgerEra
-> (Data LedgerEra, ExUnits) -> (Data LedgerEra, ExUnits)
newHeadRedeemer TxBodyScriptData
scriptData
newHeadRedeemer :: AlonzoPlutusPurpose AsIndex StandardBabbage
-> (Data StandardBabbage, ExUnits)
-> (Data StandardBabbage, ExUnits)
newHeadRedeemer AlonzoPlutusPurpose AsIndex StandardBabbage
ix (Data StandardBabbage
dat, ExUnits
units)
| TxOut CtxUTxO -> Bool
isHeadOutput (AlonzoPlutusPurpose AsIndex StandardBabbage -> TxOut CtxUTxO
forall w. AlonzoPlutusPurpose AsIndex w -> TxOut CtxUTxO
resolveInput AlonzoPlutusPurpose AsIndex StandardBabbage
ix) = (Data -> Data StandardBabbage
forall era. Era era => Data -> Data era
Ledger.Data (Input -> Data
forall a. ToData a => a -> Data
toData Input
newRedeemer), ExUnits
units)
| Bool
otherwise = (Data StandardBabbage
dat, ExUnits
units)
resolveInput :: Ledger.AlonzoPlutusPurpose AsIndex w -> TxOut CtxUTxO
resolveInput :: forall w. AlonzoPlutusPurpose AsIndex w -> TxOut CtxUTxO
resolveInput AlonzoPlutusPurpose AsIndex w
ix =
let k :: Word32
k = case AlonzoPlutusPurpose AsIndex w
ix of
AlonzoSpending AsIndex Word32 (TxIn (EraCrypto w))
i -> AsIndex Word32 (TxIn (EraCrypto w)) -> Word32
forall ix it. AsIndex ix it -> ix
unAsIndex AsIndex Word32 (TxIn (EraCrypto w))
i
AlonzoCertifying AsIndex Word32 (TxCert w)
i -> AsIndex Word32 (TxCert w) -> Word32
forall ix it. AsIndex ix it -> ix
unAsIndex AsIndex Word32 (TxCert w)
i
AlonzoRewarding AsIndex Word32 (RewardAcnt (EraCrypto w))
i -> AsIndex Word32 (RewardAcnt (EraCrypto w)) -> Word32
forall ix it. AsIndex ix it -> ix
unAsIndex AsIndex Word32 (RewardAcnt (EraCrypto w))
i
AlonzoMinting AsIndex Word32 (PolicyID (EraCrypto w))
i -> AsIndex Word32 (PolicyID (EraCrypto w)) -> Word32
forall ix it. AsIndex ix it -> ix
unAsIndex AsIndex Word32 (PolicyID (EraCrypto w))
i
txIn :: TxIn StandardCrypto
txIn = Int -> Set (TxIn StandardCrypto) -> TxIn StandardCrypto
forall a. Int -> Set a -> a
Set.elemAt (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
k) Set (TxIn StandardCrypto)
Set (TxIn (EraCrypto StandardBabbage))
ledgerInputs
in case TxIn -> UTxO -> Maybe (TxOut CtxUTxO)
forall out. TxIn -> UTxO' out -> Maybe out
UTxO.resolve (TxIn StandardCrypto -> TxIn
fromLedgerTxIn TxIn StandardCrypto
txIn) UTxO
utxo of
Maybe (TxOut CtxUTxO)
Nothing -> Text -> TxOut CtxUTxO
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> TxOut CtxUTxO) -> Text -> TxOut CtxUTxO
forall a b. (a -> b) -> a -> b
$ Text
"txIn not resolvable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxIn StandardCrypto -> Text
forall b a. (Show a, IsString b) => a -> b
show TxIn StandardCrypto
txIn
Just TxOut CtxUTxO
o -> TxOut CtxUTxO
o
ledgerInputs :: Set (TxIn (EraCrypto StandardBabbage))
ledgerInputs = Getting
(Set (TxIn (EraCrypto StandardBabbage)))
(TxBody StandardBabbage)
(Set (TxIn (EraCrypto StandardBabbage)))
-> BabbageTxBody StandardBabbage
-> Set (TxIn (EraCrypto StandardBabbage))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(Set (TxIn (EraCrypto StandardBabbage)))
(TxBody StandardBabbage)
(Set (TxIn (EraCrypto StandardBabbage)))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
(TxBody StandardBabbage) (Set (TxIn (EraCrypto StandardBabbage)))
inputsTxBodyL TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody
ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
ChangeInputHeadDatum State
d' ->
( Tx
tx
, TxOut CtxUTxO -> TxOut CtxUTxO
replaceHeadDatum (TxOut CtxUTxO -> TxOut CtxUTxO) -> UTxO -> UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO
utxo
)
where
replaceHeadDatum :: TxOut CtxUTxO -> TxOut CtxUTxO
replaceHeadDatum o :: TxOut CtxUTxO
o@(TxOut AddressInEra
addr Value
value TxOutDatum CtxUTxO
_ ReferenceScript
refScript)
| TxOut CtxUTxO -> Bool
isHeadOutput TxOut CtxUTxO
o =
AddressInEra
-> Value -> TxOutDatum CtxUTxO -> ReferenceScript -> TxOut CtxUTxO
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
addr Value
value (State -> TxOutDatum CtxUTxO
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline State
d') ReferenceScript
refScript
| Bool
otherwise = TxOut CtxUTxO
o
PrependOutput TxOut CtxTx
txOut ->
( ([TxOut CtxTx] -> [TxOut CtxTx]) -> Tx -> Tx
alterTxOuts (TxOut CtxTx
txOut :) Tx
tx
, UTxO
utxo
)
AppendOutput TxOut CtxTx
txOut ->
( ([TxOut CtxTx] -> [TxOut CtxTx]) -> Tx -> Tx
alterTxOuts ([TxOut CtxTx] -> [TxOut CtxTx] -> [TxOut CtxTx]
forall a. Semigroup a => a -> a -> a
<> [TxOut CtxTx
txOut]) Tx
tx
, UTxO
utxo
)
RemoveOutput Word
ix ->
( ([TxOut CtxTx] -> [TxOut CtxTx]) -> Tx -> Tx
alterTxOuts (Word -> [TxOut CtxTx] -> [TxOut CtxTx]
forall {b} {b}. Integral b => b -> [b] -> [b]
removeAt Word
ix) Tx
tx
, UTxO
utxo
)
where
removeAt :: b -> [b] -> [b]
removeAt b
i [b]
es =
if b -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
es
then Text -> [b]
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"trying to removeAt beyond end of list"
else
((b, b) -> b) -> [(b, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, b) -> b
forall a b. (a, b) -> b
snd ([(b, b)] -> [b]) -> [(b, b)] -> [b]
forall a b. (a -> b) -> a -> b
$
((b, b) -> Bool) -> [(b, b)] -> [(b, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
/= b
i) (b -> Bool) -> ((b, b) -> b) -> (b, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, b) -> b
forall a b. (a, b) -> a
fst) ([(b, b)] -> [(b, b)]) -> [(b, b)] -> [(b, b)]
forall a b. (a -> b) -> a -> b
$
[b] -> [b] -> [(b, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [b
0 ..] [b]
es
RemoveInput TxIn
txIn ->
( ([(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)])
-> Tx -> Tx
alterTxIns (((TxIn, Maybe HashableScriptData) -> Bool)
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TxIn
i, Maybe HashableScriptData
_) -> TxIn
i TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
/= TxIn
txIn)) Tx
tx
, UTxO
utxo
)
AddInput TxIn
i TxOut CtxUTxO
o Maybe HashableScriptData
newRedeemer ->
( ([(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)])
-> Tx -> Tx
alterTxIns [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
addRedeemer Tx
tx
, Map TxIn (TxOut CtxUTxO) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO (Map TxIn (TxOut CtxUTxO) -> UTxO)
-> Map TxIn (TxOut CtxUTxO) -> UTxO
forall a b. (a -> b) -> a -> b
$ TxIn
-> TxOut CtxUTxO
-> Map TxIn (TxOut CtxUTxO)
-> Map TxIn (TxOut CtxUTxO)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
i TxOut CtxUTxO
o (UTxO -> Map TxIn (TxOut CtxUTxO)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap UTxO
utxo)
)
where
addRedeemer :: [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
addRedeemer =
((TxIn, Maybe HashableScriptData)
-> (TxIn, Maybe HashableScriptData))
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall a b. (a -> b) -> [a] -> [b]
map (((TxIn, Maybe HashableScriptData)
-> (TxIn, Maybe HashableScriptData))
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)])
-> ((TxIn, Maybe HashableScriptData)
-> (TxIn, Maybe HashableScriptData))
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall a b. (a -> b) -> a -> b
$ \(TxIn
txIn', Maybe HashableScriptData
mRedeemer) ->
if TxIn
txIn' TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxIn
i then (TxIn
i, Maybe HashableScriptData
newRedeemer) else (TxIn
txIn', Maybe HashableScriptData
mRedeemer)
AddScript PlutusScript
script ->
(TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits, UTxO
utxo)
where
ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
[AlonzoScript StandardBabbage]
scripts' TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
scripts' :: [AlonzoScript StandardBabbage]
scripts' = [Script LedgerEra]
[AlonzoScript StandardBabbage]
scripts [AlonzoScript StandardBabbage]
-> [AlonzoScript StandardBabbage] -> [AlonzoScript StandardBabbage]
forall a. Semigroup a => a -> a -> a
<> [PlutusScript -> AlonzoScript LedgerEra
forall lang era.
ToAlonzoScript lang era =>
PlutusScript lang -> AlonzoScript (ShelleyLedgerEra era)
toLedgerScript PlutusScript
script]
ChangeInput TxIn
txIn TxOut CtxUTxO
txOut Maybe HashableScriptData
newRedeemer ->
Bool -> (Tx, UTxO) -> (Tx, UTxO)
forall a. HasCallStack => Bool -> a -> a
assert
Bool
redeemerGivenIfScriptTxOut
( ([(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)])
-> Tx -> Tx
alterTxIns [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
replaceRedeemer Tx
tx
, Map TxIn (TxOut CtxUTxO) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO (Map TxIn (TxOut CtxUTxO) -> UTxO)
-> Map TxIn (TxOut CtxUTxO) -> UTxO
forall a b. (a -> b) -> a -> b
$ TxIn
-> TxOut CtxUTxO
-> Map TxIn (TxOut CtxUTxO)
-> Map TxIn (TxOut CtxUTxO)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
txIn TxOut CtxUTxO
txOut (UTxO -> Map TxIn (TxOut CtxUTxO)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap UTxO
utxo)
)
where
redeemerGivenIfScriptTxOut :: Bool
redeemerGivenIfScriptTxOut =
Bool -> Bool
not Bool
isScriptOutput Bool -> Bool -> Bool
|| Maybe HashableScriptData -> Bool
forall a. Maybe a -> Bool
isJust Maybe HashableScriptData
newRedeemer
isScriptOutput :: Bool
isScriptOutput = case TxOut CtxUTxO -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut CtxUTxO
txOut of
ByronAddressInEra ByronAddress{} -> Bool
False
ShelleyAddressInEra (ShelleyAddress Network
_ PaymentCredential StandardCrypto
cred StakeReference StandardCrypto
_) ->
case PaymentCredential StandardCrypto
cred of
KeyHashObj{} -> Bool
False
ScriptHashObj{} -> Bool
True
replaceRedeemer :: [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
replaceRedeemer =
((TxIn, Maybe HashableScriptData)
-> (TxIn, Maybe HashableScriptData))
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall a b. (a -> b) -> [a] -> [b]
map (((TxIn, Maybe HashableScriptData)
-> (TxIn, Maybe HashableScriptData))
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)])
-> ((TxIn, Maybe HashableScriptData)
-> (TxIn, Maybe HashableScriptData))
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall a b. (a -> b) -> a -> b
$ \(TxIn
txIn', Maybe HashableScriptData
mRedeemer) ->
if TxIn
txIn' TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxIn
txIn then (TxIn
txIn, Maybe HashableScriptData
newRedeemer) else (TxIn
txIn', Maybe HashableScriptData
mRedeemer)
ChangeOutput Word
ix TxOut CtxTx
txOut ->
( ([TxOut CtxTx] -> [TxOut CtxTx]) -> Tx -> Tx
alterTxOuts [TxOut CtxTx] -> [TxOut CtxTx]
replaceAtIndex Tx
tx
, UTxO
utxo
)
where
replaceAtIndex :: [TxOut CtxTx] -> [TxOut CtxTx]
replaceAtIndex [TxOut CtxTx]
outs =
((Word, TxOut CtxTx) -> [TxOut CtxTx] -> [TxOut CtxTx])
-> [TxOut CtxTx] -> [(Word, TxOut CtxTx)] -> [TxOut CtxTx]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
( \(Word
i, TxOut CtxTx
out) [TxOut CtxTx]
list ->
if Word
i Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
ix then TxOut CtxTx
txOut TxOut CtxTx -> [TxOut CtxTx] -> [TxOut CtxTx]
forall a. a -> [a] -> [a]
: [TxOut CtxTx]
list else TxOut CtxTx
out TxOut CtxTx -> [TxOut CtxTx] -> [TxOut CtxTx]
forall a. a -> [a] -> [a]
: [TxOut CtxTx]
list
)
[]
([Word] -> [TxOut CtxTx] -> [(Word, TxOut CtxTx)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0 ..] [TxOut CtxTx]
outs)
ChangeMintedValue Value
v' ->
(TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits, UTxO
utxo)
where
ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
valueToMultiAsset :: MaryValue c -> MultiAsset c
valueToMultiAsset (Ledger.MaryValue Coin
_ MultiAsset c
multiAsset) = MultiAsset c
multiAsset
ledgerBody' :: BabbageTxBody StandardBabbage
ledgerBody' =
TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody
BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& ASetter
(BabbageTxBody StandardBabbage)
(BabbageTxBody StandardBabbage)
(MultiAsset (EraCrypto StandardBabbage))
(MultiAsset StandardCrypto)
-> MultiAsset StandardCrypto
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
(BabbageTxBody StandardBabbage)
(BabbageTxBody StandardBabbage)
(MultiAsset (EraCrypto StandardBabbage))
(MultiAsset StandardCrypto)
(MultiAsset (EraCrypto StandardBabbage)
-> Identity (MultiAsset (EraCrypto StandardBabbage)))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
MaryEraTxBody era =>
Lens' (TxBody era) (MultiAsset (EraCrypto era))
Lens'
(TxBody StandardBabbage) (MultiAsset (EraCrypto StandardBabbage))
mintTxBodyL (MaryValue StandardCrypto -> MultiAsset StandardCrypto
forall {c}. MaryValue c -> MultiAsset c
valueToMultiAsset (MaryValue StandardCrypto -> MultiAsset StandardCrypto)
-> MaryValue StandardCrypto -> MultiAsset StandardCrypto
forall a b. (a -> b) -> a -> b
$ Value -> MaryValue StandardCrypto
toLedgerValue Value
v')
body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody' [Script LedgerEra]
scripts TxBodyScriptData
scriptData' Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
scriptData' :: TxBodyScriptData
scriptData' =
if Value
v' Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
forall a. Monoid a => a
mempty
then TxBodyScriptData
scriptData
else case TxBodyScriptData
scriptData of
TxBodyScriptData
TxBodyNoScriptData -> TxBodyScriptData
TxBodyNoScriptData
TxBodyScriptData TxDats LedgerEra
dats (Ledger.Redeemers Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
redeemers) ->
let newRedeemers :: Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
newRedeemers =
(AlonzoPlutusPurpose AsIndex StandardBabbage
-> (Data StandardBabbage, ExUnits) -> Bool)
-> Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
-> Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
( \AlonzoPlutusPurpose AsIndex StandardBabbage
x (Data StandardBabbage, ExUnits)
_ -> case AlonzoPlutusPurpose AsIndex StandardBabbage
x of
Ledger.AlonzoMinting AsIndex Word32 (PolicyID (EraCrypto StandardBabbage))
_ -> Bool
False
AlonzoPlutusPurpose AsIndex StandardBabbage
_ -> Bool
True
)
Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
redeemers
in TxDats LedgerEra -> Redeemers LedgerEra -> TxBodyScriptData
TxBodyScriptData TxDats LedgerEra
dats (Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIndex era) (Data era, ExUnits)
-> Redeemers era
Ledger.Redeemers Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
newRedeemers)
ChangeRequiredSigners [Hash PaymentKey]
newSigners ->
(TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits, UTxO
utxo)
where
ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody' [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
ledgerBody' :: BabbageTxBody StandardBabbage
ledgerBody' =
TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody
BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& ASetter
(BabbageTxBody StandardBabbage)
(BabbageTxBody StandardBabbage)
(Set (KeyHash 'Witness (EraCrypto StandardBabbage)))
(Set (KeyHash 'Witness StandardCrypto))
-> Set (KeyHash 'Witness StandardCrypto)
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
(BabbageTxBody StandardBabbage)
(BabbageTxBody StandardBabbage)
(Set (KeyHash 'Witness (EraCrypto StandardBabbage)))
(Set (KeyHash 'Witness StandardCrypto))
(Set (KeyHash 'Witness (EraCrypto StandardBabbage))
-> Identity (Set (KeyHash 'Witness (EraCrypto StandardBabbage))))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (KeyHash 'Witness (EraCrypto era)))
Lens'
(TxBody StandardBabbage)
(Set (KeyHash 'Witness (EraCrypto StandardBabbage)))
reqSignerHashesTxBodyL ([KeyHash 'Witness StandardCrypto]
-> Set (KeyHash 'Witness StandardCrypto)
forall a. Ord a => [a] -> Set a
Set.fromList (Hash PaymentKey -> KeyHash 'Witness StandardCrypto
toLedgerKeyHash (Hash PaymentKey -> KeyHash 'Witness StandardCrypto)
-> [Hash PaymentKey] -> [KeyHash 'Witness StandardCrypto]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Hash PaymentKey]
newSigners))
ChangeValidityInterval (TxValidityLowerBound
lowerBound, TxValidityUpperBound
upperBound) ->
Maybe TxValidityLowerBound
-> Maybe TxValidityUpperBound -> (Tx, UTxO)
changeValidityInterval (TxValidityLowerBound -> Maybe TxValidityLowerBound
forall a. a -> Maybe a
Just TxValidityLowerBound
lowerBound) (TxValidityUpperBound -> Maybe TxValidityUpperBound
forall a. a -> Maybe a
Just TxValidityUpperBound
upperBound)
ChangeValidityLowerBound TxValidityLowerBound
bound ->
Maybe TxValidityLowerBound
-> Maybe TxValidityUpperBound -> (Tx, UTxO)
changeValidityInterval (TxValidityLowerBound -> Maybe TxValidityLowerBound
forall a. a -> Maybe a
Just TxValidityLowerBound
bound) Maybe TxValidityUpperBound
forall a. Maybe a
Nothing
ChangeValidityUpperBound TxValidityUpperBound
bound ->
Maybe TxValidityLowerBound
-> Maybe TxValidityUpperBound -> (Tx, UTxO)
changeValidityInterval Maybe TxValidityLowerBound
forall a. Maybe a
Nothing (TxValidityUpperBound -> Maybe TxValidityUpperBound
forall a. a -> Maybe a
Just TxValidityUpperBound
bound)
ChangeMintingPolicy PlutusScript
pScript ->
( TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits
, UTxO
utxo
)
where
mutatedPid :: PolicyId
mutatedPid = Script PlutusScriptV2 -> PolicyId
forall lang. Script lang -> PolicyId
scriptPolicyId (Script PlutusScriptV2 -> PolicyId)
-> Script PlutusScriptV2 -> PolicyId
forall a b. (a -> b) -> a -> b
$ PlutusScript -> Script PlutusScriptV2
PlutusScript PlutusScript
pScript
body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody' [Script LedgerEra]
[AlonzoScript StandardBabbage]
scripts' TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
valueToMultiAsset :: MaryValue c -> MultiAsset c
valueToMultiAsset (Ledger.MaryValue Coin
_ MultiAsset c
multiAsset) = MultiAsset c
multiAsset
ledgerBody' :: BabbageTxBody StandardBabbage
ledgerBody' =
TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody
BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& ASetter
(BabbageTxBody StandardBabbage)
(BabbageTxBody StandardBabbage)
(MultiAsset (EraCrypto StandardBabbage))
(MultiAsset StandardCrypto)
-> MultiAsset StandardCrypto
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
set
ASetter
(BabbageTxBody StandardBabbage)
(BabbageTxBody StandardBabbage)
(MultiAsset (EraCrypto StandardBabbage))
(MultiAsset StandardCrypto)
(MultiAsset (EraCrypto StandardBabbage)
-> Identity (MultiAsset (EraCrypto StandardBabbage)))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
MaryEraTxBody era =>
Lens' (TxBody era) (MultiAsset (EraCrypto era))
Lens'
(TxBody StandardBabbage) (MultiAsset (EraCrypto StandardBabbage))
mintTxBodyL
( MaryValue StandardCrypto -> MultiAsset StandardCrypto
forall {c}. MaryValue c -> MultiAsset c
valueToMultiAsset (MaryValue StandardCrypto -> MultiAsset StandardCrypto)
-> (Value -> MaryValue StandardCrypto)
-> Value
-> MultiAsset StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> MaryValue StandardCrypto
toLedgerValue (Value -> MultiAsset StandardCrypto)
-> Value -> MultiAsset StandardCrypto
forall a b. (a -> b) -> a -> b
$
PolicyId -> PolicyId -> Value -> Value
replacePolicyInValue PolicyId
selectedPid PolicyId
mutatedPid Value
mint
)
selectedPid :: PolicyId
selectedPid =
PolicyId -> Maybe PolicyId -> PolicyId
forall a. a -> Maybe a -> a
fromMaybe (Text -> PolicyId
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"cannot mutate non minting transaction")
(Maybe PolicyId -> PolicyId)
-> ([(AssetId, Quantity)] -> Maybe PolicyId)
-> [(AssetId, Quantity)]
-> PolicyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AssetId, Quantity) -> Maybe PolicyId)
-> [(AssetId, Quantity)] -> Maybe PolicyId
forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
findFirst
( \case
(AssetId PolicyId
pid AssetName
_, Quantity
_) -> PolicyId -> Maybe PolicyId
forall a. a -> Maybe a
Just PolicyId
pid
(AssetId
AdaAssetId, Quantity
_) -> Maybe PolicyId
forall a. Maybe a
Nothing
)
([(AssetId, Quantity)] -> PolicyId)
-> [(AssetId, Quantity)] -> PolicyId
forall a b. (a -> b) -> a -> b
$ Value -> [(AssetId, Quantity)]
valueToList Value
mint
mint :: Value
mint = MultiAsset StandardCrypto -> Value
fromLedgerMultiAsset (MultiAsset StandardCrypto -> Value)
-> MultiAsset StandardCrypto -> Value
forall a b. (a -> b) -> a -> b
$ Getting
(MultiAsset StandardCrypto)
(TxBody StandardBabbage)
(MultiAsset StandardCrypto)
-> BabbageTxBody StandardBabbage -> MultiAsset StandardCrypto
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(MultiAsset StandardCrypto)
(TxBody StandardBabbage)
(MultiAsset StandardCrypto)
(MultiAsset (EraCrypto StandardBabbage)
-> Const
(MultiAsset StandardCrypto)
(MultiAsset (EraCrypto StandardBabbage)))
-> TxBody StandardBabbage
-> Const (MultiAsset StandardCrypto) (TxBody StandardBabbage)
forall era.
MaryEraTxBody era =>
Lens' (TxBody era) (MultiAsset (EraCrypto era))
Lens'
(TxBody StandardBabbage) (MultiAsset (EraCrypto StandardBabbage))
mintTxBodyL TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody
scripts' :: [AlonzoScript StandardBabbage]
scripts' =
(AlonzoScript StandardBabbage -> AlonzoScript StandardBabbage)
-> [AlonzoScript StandardBabbage] -> [AlonzoScript StandardBabbage]
forall a b. (a -> b) -> [a] -> [b]
map
( \AlonzoScript StandardBabbage
s ->
if ScriptHash StandardCrypto -> PolicyID StandardCrypto
forall c. ScriptHash c -> PolicyID c
Ledger.PolicyID (forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
Ledger.hashScript @LedgerEra Script LedgerEra
AlonzoScript StandardBabbage
s) PolicyID StandardCrypto -> PolicyID StandardCrypto -> Bool
forall a. Eq a => a -> a -> Bool
== PolicyId -> PolicyID StandardCrypto
toLedgerPolicyID PolicyId
selectedPid
then PlutusScript -> AlonzoScript LedgerEra
forall lang era.
ToAlonzoScript lang era =>
PlutusScript lang -> AlonzoScript (ShelleyLedgerEra era)
toLedgerScript PlutusScript
pScript
else AlonzoScript StandardBabbage
s
)
[Script LedgerEra]
[AlonzoScript StandardBabbage]
scripts
ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
Changes [Mutation]
mutations ->
(Mutation -> (Tx, UTxO) -> (Tx, UTxO))
-> (Tx, UTxO) -> [Mutation] -> (Tx, UTxO)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Mutation -> (Tx, UTxO) -> (Tx, UTxO)
applyMutation (Tx
tx, UTxO
utxo) [Mutation]
mutations
where
changeValidityInterval :: Maybe TxValidityLowerBound
-> Maybe TxValidityUpperBound -> (Tx, UTxO)
changeValidityInterval Maybe TxValidityLowerBound
lowerBound' Maybe TxValidityUpperBound
upperBound' =
(TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits, UTxO
utxo)
where
ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody' [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
ledgerBody' :: BabbageTxBody StandardBabbage
ledgerBody' =
TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody
BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& (ValidityInterval -> Identity ValidityInterval)
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
(ValidityInterval -> Identity ValidityInterval)
-> BabbageTxBody StandardBabbage
-> Identity (BabbageTxBody StandardBabbage)
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody StandardBabbage) ValidityInterval
vldtTxBodyL
((ValidityInterval -> Identity ValidityInterval)
-> BabbageTxBody StandardBabbage
-> Identity (BabbageTxBody StandardBabbage))
-> ValidityInterval
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (TxValidityLowerBound, TxValidityUpperBound) -> ValidityInterval
forall era.
(TxValidityLowerBound era, TxValidityUpperBound era)
-> ValidityInterval
toLedgerValidityInterval
( TxValidityLowerBound
-> Maybe TxValidityLowerBound -> TxValidityLowerBound
forall a. a -> Maybe a -> a
fromMaybe TxValidityLowerBound
lowerBound Maybe TxValidityLowerBound
lowerBound'
, TxValidityUpperBound
-> Maybe TxValidityUpperBound -> TxValidityUpperBound
forall a. a -> Maybe a -> a
fromMaybe TxValidityUpperBound
upperBound Maybe TxValidityUpperBound
upperBound'
)
(TxValidityLowerBound
lowerBound, TxValidityUpperBound
upperBound) = ValidityInterval -> (TxValidityLowerBound, TxValidityUpperBound)
fromLedgerValidityInterval ValidityInterval
ledgerValidityInterval
ledgerValidityInterval :: ValidityInterval
ledgerValidityInterval = TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody BabbageTxBody StandardBabbage
-> Getting
ValidityInterval (BabbageTxBody StandardBabbage) ValidityInterval
-> ValidityInterval
forall s a. s -> Getting a s a -> a
^. (ValidityInterval -> Const ValidityInterval ValidityInterval)
-> TxBody StandardBabbage
-> Const ValidityInterval (TxBody StandardBabbage)
Getting
ValidityInterval (BabbageTxBody StandardBabbage) ValidityInterval
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody StandardBabbage) ValidityInterval
vldtTxBodyL
deriving stock instance Eq Head.Input
instance Arbitrary Head.Input where
arbitrary :: Gen Input
arbitrary = Gen Input
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
instance Arbitrary Head.State where
arbitrary :: Gen State
arbitrary = Gen State
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
isHeadOutput :: TxOut CtxUTxO -> Bool
isHeadOutput :: TxOut CtxUTxO -> Bool
isHeadOutput TxOut{txOutAddress :: forall ctx. TxOut ctx -> AddressInEra
txOutAddress = AddressInEra
addr} = AddressInEra
addr AddressInEra -> AddressInEra -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra
headAddress
where
headAddress :: AddressInEra
headAddress = forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
Fixture.testNetworkId PlutusScript
forall {lang}. PlutusScript lang
headScript
headScript :: PlutusScript lang
headScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Head.validatorScript
addDatum :: TxOutDatum CtxTx -> TxBodyScriptData -> TxBodyScriptData
addDatum :: TxOutDatum CtxTx -> TxBodyScriptData -> TxBodyScriptData
addDatum TxOutDatum CtxTx
datum TxBodyScriptData
scriptData =
case TxOutDatum CtxTx
datum of
TxOutDatum CtxTx
TxOutDatumNone -> Text -> TxBodyScriptData
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected datum none"
TxOutDatumHash Hash ScriptData
_ha -> Text -> TxBodyScriptData
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"hash only, expected full datum"
TxOutDatumInline HashableScriptData
_sd -> Text -> TxBodyScriptData
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"not useful for inline datums"
TxOutDatumInTx HashableScriptData
sd ->
case TxBodyScriptData
scriptData of
TxBodyScriptData
TxBodyNoScriptData -> Text -> TxBodyScriptData
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"TxBodyNoScriptData unexpected"
TxBodyScriptData (Ledger.TxDats Map (DataHash (EraCrypto StandardBabbage)) (Data StandardBabbage)
dats) Redeemers LedgerEra
redeemers ->
let dat :: Data StandardBabbage
dat = HashableScriptData -> Data StandardBabbage
forall era. Era era => HashableScriptData -> Data era
toLedgerData HashableScriptData
sd
newDats :: TxDats StandardBabbage
newDats = Map (DataHash (EraCrypto StandardBabbage)) (Data StandardBabbage)
-> TxDats StandardBabbage
forall era.
Era era =>
Map (DataHash (EraCrypto era)) (Data era) -> TxDats era
Ledger.TxDats (Map (DataHash (EraCrypto StandardBabbage)) (Data StandardBabbage)
-> TxDats StandardBabbage)
-> Map
(DataHash (EraCrypto StandardBabbage)) (Data StandardBabbage)
-> TxDats StandardBabbage
forall a b. (a -> b) -> a -> b
$ DataHash StandardCrypto
-> Data StandardBabbage
-> Map (DataHash StandardCrypto) (Data StandardBabbage)
-> Map (DataHash StandardCrypto) (Data StandardBabbage)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Data StandardBabbage -> DataHash (EraCrypto StandardBabbage)
forall era. Era era => Data era -> DataHash (EraCrypto era)
Ledger.hashData Data StandardBabbage
dat) Data StandardBabbage
dat Map (DataHash StandardCrypto) (Data StandardBabbage)
Map (DataHash (EraCrypto StandardBabbage)) (Data StandardBabbage)
dats
in TxDats LedgerEra -> Redeemers LedgerEra -> TxBodyScriptData
TxBodyScriptData TxDats LedgerEra
TxDats StandardBabbage
newDats Redeemers LedgerEra
redeemers
modifyInlineDatum :: (FromScriptData a, ToScriptData a) => (a -> a) -> TxOut CtxTx -> TxOut CtxTx
modifyInlineDatum :: forall a.
(FromScriptData a, ToScriptData a) =>
(a -> a) -> TxOut CtxTx -> TxOut CtxTx
modifyInlineDatum a -> a
fn TxOut CtxTx
txOut =
case TxOut CtxTx -> TxOutDatum CtxTx
forall ctx. TxOut ctx -> TxOutDatum ctx
txOutDatum TxOut CtxTx
txOut of
TxOutDatum CtxTx
TxOutDatumNone ->
Text -> TxOut CtxTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Unexpected empty head datum"
(TxOutDatumHash Hash ScriptData
_ha) ->
Text -> TxOut CtxTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Unexpected hash-only datum"
(TxOutDatumInTx HashableScriptData
_sd) ->
Text -> TxOut CtxTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Unexpected in-tx datum"
(TxOutDatumInline HashableScriptData
sd) ->
case HashableScriptData -> Maybe a
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
sd of
Just a
st ->
TxOut CtxTx
txOut{txOutDatum = mkTxOutDatumInline $ fn st}
Maybe a
Nothing ->
Text -> TxOut CtxTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Invalid data"
addParticipationTokens :: [VerificationKey PaymentKey] -> TxOut CtxUTxO -> TxOut CtxUTxO
addParticipationTokens :: [VerificationKey PaymentKey] -> TxOut CtxUTxO -> TxOut CtxUTxO
addParticipationTokens [VerificationKey PaymentKey]
vks TxOut CtxUTxO
txOut =
TxOut CtxUTxO
txOut{txOutValue = val'}
where
val' :: Value
val' =
TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
txOut
Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> [(AssetId, Quantity)] -> Value
valueFromList
[ (PolicyId -> AssetName -> AssetId
AssetId PolicyId
testPolicyId (OnChainId -> AssetName
onChainIdToAssetName OnChainId
oid), Quantity
1)
| OnChainId
oid <- [OnChainId]
participants
]
participants :: [OnChainId]
participants = VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId (VerificationKey PaymentKey -> OnChainId)
-> [VerificationKey PaymentKey] -> [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VerificationKey PaymentKey]
vks
ensureDatums :: [TxOut CtxTx] -> TxBodyScriptData -> TxBodyScriptData
ensureDatums :: [TxOut CtxTx] -> TxBodyScriptData -> TxBodyScriptData
ensureDatums [TxOut CtxTx]
outs TxBodyScriptData
scriptData =
(TxOut CtxTx -> TxBodyScriptData -> TxBodyScriptData)
-> TxBodyScriptData -> [TxOut CtxTx] -> TxBodyScriptData
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TxOut CtxTx -> TxBodyScriptData -> TxBodyScriptData
ensureDatum TxBodyScriptData
scriptData [TxOut CtxTx]
outs
where
ensureDatum :: TxOut CtxTx -> TxBodyScriptData -> TxBodyScriptData
ensureDatum TxOut CtxTx
txOut TxBodyScriptData
sd =
case TxOut CtxTx -> TxOutDatum CtxTx
forall ctx. TxOut ctx -> TxOutDatum ctx
txOutDatum TxOut CtxTx
txOut of
d :: TxOutDatum CtxTx
d@(TxOutDatumInTx HashableScriptData
_) -> TxOutDatum CtxTx -> TxBodyScriptData -> TxBodyScriptData
addDatum TxOutDatum CtxTx
d TxBodyScriptData
sd
TxOutDatum CtxTx
_ -> TxBodyScriptData
sd
alterRedeemers ::
( Ledger.PlutusPurpose Ledger.AsIndex LedgerEra ->
(Ledger.Data LedgerEra, Ledger.ExUnits) ->
(Ledger.Data LedgerEra, Ledger.ExUnits)
) ->
TxBodyScriptData ->
TxBodyScriptData
alterRedeemers :: (PlutusPurpose AsIndex LedgerEra
-> (Data LedgerEra, ExUnits) -> (Data LedgerEra, ExUnits))
-> TxBodyScriptData -> TxBodyScriptData
alterRedeemers PlutusPurpose AsIndex LedgerEra
-> (Data LedgerEra, ExUnits) -> (Data LedgerEra, ExUnits)
fn = \case
TxBodyScriptData
TxBodyNoScriptData -> Text -> TxBodyScriptData
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"TxBodyNoScriptData unexpected"
TxBodyScriptData TxDats LedgerEra
dats (Ledger.Redeemers Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
redeemers) ->
let newRedeemers :: Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
newRedeemers = (AlonzoPlutusPurpose AsIndex StandardBabbage
-> (Data StandardBabbage, ExUnits)
-> (Data StandardBabbage, ExUnits))
-> Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
-> Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey AlonzoPlutusPurpose AsIndex StandardBabbage
-> (Data StandardBabbage, ExUnits)
-> (Data StandardBabbage, ExUnits)
PlutusPurpose AsIndex LedgerEra
-> (Data LedgerEra, ExUnits) -> (Data LedgerEra, ExUnits)
fn Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
redeemers
in TxDats LedgerEra -> Redeemers LedgerEra -> TxBodyScriptData
TxBodyScriptData TxDats LedgerEra
dats (Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIndex era) (Data era, ExUnits)
-> Redeemers era
Ledger.Redeemers Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
newRedeemers)
alterTxIns ::
([(TxIn, Maybe HashableScriptData)] -> [(TxIn, Maybe HashableScriptData)]) ->
Tx ->
Tx
alterTxIns :: ([(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)])
-> Tx -> Tx
alterTxIns [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
fn Tx
tx =
TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits
where
body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody' [Script LedgerEra]
scripts TxBodyScriptData
scriptData' Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
ledgerBody' :: BabbageTxBody StandardBabbage
ledgerBody' = TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& ASetter
(BabbageTxBody StandardBabbage)
(BabbageTxBody StandardBabbage)
(Set (TxIn (EraCrypto StandardBabbage)))
(Set (TxIn StandardCrypto))
-> Set (TxIn StandardCrypto)
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
(BabbageTxBody StandardBabbage)
(BabbageTxBody StandardBabbage)
(Set (TxIn (EraCrypto StandardBabbage)))
(Set (TxIn StandardCrypto))
(Set (TxIn (EraCrypto StandardBabbage))
-> Identity (Set (TxIn (EraCrypto StandardBabbage))))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
(TxBody StandardBabbage) (Set (TxIn (EraCrypto StandardBabbage)))
inputsTxBodyL Set (TxIn StandardCrypto)
inputs'
inputs' :: Set (TxIn StandardCrypto)
inputs' = [TxIn StandardCrypto] -> Set (TxIn StandardCrypto)
forall a. Ord a => [a] -> Set a
Set.fromList ([TxIn StandardCrypto] -> Set (TxIn StandardCrypto))
-> [TxIn StandardCrypto] -> Set (TxIn StandardCrypto)
forall a b. (a -> b) -> a -> b
$ TxIn -> TxIn StandardCrypto
toLedgerTxIn (TxIn -> TxIn StandardCrypto)
-> ((TxIn, Maybe HashableScriptData) -> TxIn)
-> (TxIn, Maybe HashableScriptData)
-> TxIn StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, Maybe HashableScriptData) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, Maybe HashableScriptData) -> TxIn StandardCrypto)
-> [(TxIn, Maybe HashableScriptData)] -> [TxIn StandardCrypto]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxIn, Maybe HashableScriptData)]
newSortedInputs
scriptData' :: TxBodyScriptData
scriptData' = TxDats LedgerEra -> Redeemers LedgerEra -> TxBodyScriptData
TxBodyScriptData TxDats LedgerEra
TxDats StandardBabbage
dats Redeemers LedgerEra
Redeemers StandardBabbage
redeemers'
redeemers' :: Redeemers StandardBabbage
redeemers' = Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIndex era) (Data era, ExUnits)
-> Redeemers era
Ledger.Redeemers (Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage)
-> Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall a b. (a -> b) -> a -> b
$ Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
forall {era}.
Map
(AlonzoPlutusPurpose AsIndex era) (Data StandardBabbage, ExUnits)
rebuiltSpendingRedeemers Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
-> Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
-> Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
forall a. Semigroup a => a -> a -> a
<> Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
nonSpendingRedeemers
nonSpendingRedeemers :: Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
nonSpendingRedeemers =
(AlonzoPlutusPurpose AsIndex StandardBabbage
-> (Data StandardBabbage, ExUnits) -> Bool)
-> Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
-> Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
( \AlonzoPlutusPurpose AsIndex StandardBabbage
x (Data StandardBabbage, ExUnits)
_ -> case AlonzoPlutusPurpose AsIndex StandardBabbage
x of
Ledger.AlonzoSpending AsIndex Word32 (TxIn (EraCrypto StandardBabbage))
_ -> Bool
False
AlonzoPlutusPurpose AsIndex StandardBabbage
_ -> Bool
True
)
Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
redeemersMap
rebuiltSpendingRedeemers :: Map
(AlonzoPlutusPurpose AsIndex era) (Data StandardBabbage, ExUnits)
rebuiltSpendingRedeemers = [(AlonzoPlutusPurpose AsIndex era,
(Data StandardBabbage, ExUnits))]
-> Map
(AlonzoPlutusPurpose AsIndex era) (Data StandardBabbage, ExUnits)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(AlonzoPlutusPurpose AsIndex era,
(Data StandardBabbage, ExUnits))]
-> Map
(AlonzoPlutusPurpose AsIndex era) (Data StandardBabbage, ExUnits))
-> [(AlonzoPlutusPurpose AsIndex era,
(Data StandardBabbage, ExUnits))]
-> Map
(AlonzoPlutusPurpose AsIndex era) (Data StandardBabbage, ExUnits)
forall a b. (a -> b) -> a -> b
$
(((Word32, (TxIn, Maybe HashableScriptData))
-> Maybe
(AlonzoPlutusPurpose AsIndex era, (Data StandardBabbage, ExUnits)))
-> [(Word32, (TxIn, Maybe HashableScriptData))]
-> [(AlonzoPlutusPurpose AsIndex era,
(Data StandardBabbage, ExUnits))])
-> [(Word32, (TxIn, Maybe HashableScriptData))]
-> ((Word32, (TxIn, Maybe HashableScriptData))
-> Maybe
(AlonzoPlutusPurpose AsIndex era, (Data StandardBabbage, ExUnits)))
-> [(AlonzoPlutusPurpose AsIndex era,
(Data StandardBabbage, ExUnits))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Word32, (TxIn, Maybe HashableScriptData))
-> Maybe
(AlonzoPlutusPurpose AsIndex era, (Data StandardBabbage, ExUnits)))
-> [(Word32, (TxIn, Maybe HashableScriptData))]
-> [(AlonzoPlutusPurpose AsIndex era,
(Data StandardBabbage, ExUnits))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Word32]
-> [(TxIn, Maybe HashableScriptData)]
-> [(Word32, (TxIn, Maybe HashableScriptData))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0 ..] [(TxIn, Maybe HashableScriptData)]
newSortedInputs) (((Word32, (TxIn, Maybe HashableScriptData))
-> Maybe
(AlonzoPlutusPurpose AsIndex era, (Data StandardBabbage, ExUnits)))
-> [(AlonzoPlutusPurpose AsIndex era,
(Data StandardBabbage, ExUnits))])
-> ((Word32, (TxIn, Maybe HashableScriptData))
-> Maybe
(AlonzoPlutusPurpose AsIndex era, (Data StandardBabbage, ExUnits)))
-> [(AlonzoPlutusPurpose AsIndex era,
(Data StandardBabbage, ExUnits))]
forall a b. (a -> b) -> a -> b
$ \(Word32
i, (TxIn
_, Maybe HashableScriptData
mRedeemer)) ->
Maybe HashableScriptData
mRedeemer Maybe HashableScriptData
-> (HashableScriptData
-> (AlonzoPlutusPurpose AsIndex era,
(Data StandardBabbage, ExUnits)))
-> Maybe
(AlonzoPlutusPurpose AsIndex era, (Data StandardBabbage, ExUnits))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \HashableScriptData
d ->
(AsIndex Word32 (TxIn (EraCrypto era))
-> AlonzoPlutusPurpose AsIndex era
forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> AlonzoPlutusPurpose f era
Ledger.AlonzoSpending (Word32 -> AsIndex Word32 (TxIn (EraCrypto era))
forall ix it. ix -> AsIndex ix it
AsIndex Word32
i), (HashableScriptData -> Data StandardBabbage
forall era. Era era => HashableScriptData -> Data era
toLedgerData HashableScriptData
d, Nat -> Nat -> ExUnits
Ledger.ExUnits Nat
0 Nat
0))
newSortedInputs :: [(TxIn, Maybe HashableScriptData)]
newSortedInputs :: [(TxIn, Maybe HashableScriptData)]
newSortedInputs =
((TxIn, Maybe HashableScriptData) -> TxIn)
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (TxIn, Maybe HashableScriptData) -> TxIn
forall a b. (a, b) -> a
fst
([(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)])
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall a b. (a -> b) -> a -> b
$ [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
fn
([(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)])
-> (Set (TxIn StandardCrypto)
-> [(TxIn, Maybe HashableScriptData)])
-> Set (TxIn StandardCrypto)
-> [(TxIn, Maybe HashableScriptData)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxIn] -> [(TxIn, Maybe HashableScriptData)]
resolveRedeemers
([TxIn] -> [(TxIn, Maybe HashableScriptData)])
-> (Set (TxIn StandardCrypto) -> [TxIn])
-> Set (TxIn StandardCrypto)
-> [(TxIn, Maybe HashableScriptData)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn StandardCrypto -> TxIn) -> [TxIn StandardCrypto] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxIn StandardCrypto -> TxIn
fromLedgerTxIn
([TxIn StandardCrypto] -> [TxIn])
-> (Set (TxIn StandardCrypto) -> [TxIn StandardCrypto])
-> Set (TxIn StandardCrypto)
-> [TxIn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (TxIn StandardCrypto) -> [TxIn StandardCrypto]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
(Set (TxIn StandardCrypto) -> [(TxIn, Maybe HashableScriptData)])
-> Set (TxIn StandardCrypto) -> [(TxIn, Maybe HashableScriptData)]
forall a b. (a -> b) -> a -> b
$ Getting
(Set (TxIn StandardCrypto))
(TxBody StandardBabbage)
(Set (TxIn StandardCrypto))
-> BabbageTxBody StandardBabbage -> Set (TxIn StandardCrypto)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(Set (TxIn StandardCrypto))
(TxBody StandardBabbage)
(Set (TxIn StandardCrypto))
(Set (TxIn (EraCrypto StandardBabbage))
-> Const
(Set (TxIn StandardCrypto))
(Set (TxIn (EraCrypto StandardBabbage))))
-> TxBody StandardBabbage
-> Const (Set (TxIn StandardCrypto)) (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
(TxBody StandardBabbage) (Set (TxIn (EraCrypto StandardBabbage)))
inputsTxBodyL TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody
resolveRedeemers :: [TxIn] -> [(TxIn, Maybe HashableScriptData)]
resolveRedeemers :: [TxIn] -> [(TxIn, Maybe HashableScriptData)]
resolveRedeemers [TxIn]
txInputs =
[TxIn] -> [Word32] -> [(TxIn, Word32)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TxIn]
txInputs [Word32
0 ..] [(TxIn, Word32)]
-> ((TxIn, Word32) -> (TxIn, Maybe HashableScriptData))
-> [(TxIn, Maybe HashableScriptData)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(TxIn
txIn, Word32
i) ->
case AlonzoPlutusPurpose AsIndex StandardBabbage
-> Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
-> Maybe (Data StandardBabbage, ExUnits)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (AsIndex Word32 (TxIn (EraCrypto StandardBabbage))
-> AlonzoPlutusPurpose AsIndex StandardBabbage
forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> AlonzoPlutusPurpose f era
Ledger.AlonzoSpending (Word32 -> AsIndex Word32 (TxIn StandardCrypto)
forall ix it. ix -> AsIndex ix it
AsIndex Word32
i)) Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
redeemersMap of
Maybe (Data StandardBabbage, ExUnits)
Nothing -> (TxIn
txIn, Maybe HashableScriptData
forall a. Maybe a
Nothing)
Just (Data StandardBabbage
redeemerData, ExUnits
_exUnits) -> (TxIn
txIn, HashableScriptData -> Maybe HashableScriptData
forall a. a -> Maybe a
Just (HashableScriptData -> Maybe HashableScriptData)
-> HashableScriptData -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ Data StandardBabbage -> HashableScriptData
forall era. Data era -> HashableScriptData
fromLedgerData Data StandardBabbage
redeemerData)
(TxDats StandardBabbage
dats, Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
redeemersMap) = case TxBodyScriptData
scriptData of
TxBodyScriptData
TxBodyNoScriptData -> (TxDats StandardBabbage
forall a. Monoid a => a
mempty, Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
forall a. Monoid a => a
mempty)
TxBodyScriptData TxDats LedgerEra
d (Ledger.Redeemers Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
r) -> (TxDats LedgerEra
TxDats StandardBabbage
d, Map
(AlonzoPlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
Map
(PlutusPurpose AsIndex StandardBabbage)
(Data StandardBabbage, ExUnits)
r)
ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
Tx TxBody
body [KeyWitness]
wits = Tx
tx
alterTxOuts ::
([TxOut CtxTx] -> [TxOut CtxTx]) ->
Tx ->
Tx
alterTxOuts :: ([TxOut CtxTx] -> [TxOut CtxTx]) -> Tx -> Tx
alterTxOuts [TxOut CtxTx] -> [TxOut CtxTx]
fn Tx
tx =
TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits
where
body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody' [Script LedgerEra]
scripts TxBodyScriptData
scriptData' Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
ledgerBody' :: BabbageTxBody StandardBabbage
ledgerBody' = TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut StandardBabbage)
-> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
-> BabbageTxBody StandardBabbage
-> Identity (BabbageTxBody StandardBabbage)
(StrictSeq (TxOut StandardBabbage)
-> Identity (StrictSeq (TxOut StandardBabbage)))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody StandardBabbage) (StrictSeq (TxOut StandardBabbage))
outputsTxBodyL ((StrictSeq (TxOut StandardBabbage)
-> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
-> BabbageTxBody StandardBabbage
-> Identity (BabbageTxBody StandardBabbage))
-> StrictSeq (BabbageTxOut StandardBabbage)
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (BabbageTxOut StandardBabbage)
ledgerOutputs'
ledgerOutputs' :: StrictSeq (BabbageTxOut StandardBabbage)
ledgerOutputs' = [BabbageTxOut StandardBabbage]
-> StrictSeq (BabbageTxOut StandardBabbage)
forall a. [a] -> StrictSeq a
StrictSeq.fromList ([BabbageTxOut StandardBabbage]
-> StrictSeq (BabbageTxOut StandardBabbage))
-> ([TxOut CtxTx] -> [BabbageTxOut StandardBabbage])
-> [TxOut CtxTx]
-> StrictSeq (BabbageTxOut StandardBabbage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut CtxTx -> BabbageTxOut StandardBabbage)
-> [TxOut CtxTx] -> [BabbageTxOut StandardBabbage]
forall a b. (a -> b) -> [a] -> [b]
map (TxOut CtxUTxO -> BabbageTxOut StandardBabbage
TxOut CtxUTxO -> TxOut LedgerEra
toLedgerTxOut (TxOut CtxUTxO -> BabbageTxOut StandardBabbage)
-> (TxOut CtxTx -> TxOut CtxUTxO)
-> TxOut CtxTx
-> BabbageTxOut StandardBabbage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxTx -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut) ([TxOut CtxTx] -> StrictSeq (BabbageTxOut StandardBabbage))
-> [TxOut CtxTx] -> StrictSeq (BabbageTxOut StandardBabbage)
forall a b. (a -> b) -> a -> b
$ [TxOut CtxTx]
outputs'
outputs' :: [TxOut CtxTx]
outputs' = [TxOut CtxTx] -> [TxOut CtxTx]
fn ([TxOut CtxTx] -> [TxOut CtxTx])
-> (StrictSeq (BabbageTxOut StandardBabbage) -> [TxOut CtxTx])
-> StrictSeq (BabbageTxOut StandardBabbage)
-> [TxOut CtxTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BabbageTxOut StandardBabbage -> TxOut CtxTx)
-> [BabbageTxOut StandardBabbage] -> [TxOut CtxTx]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BabbageTxOut StandardBabbage -> TxOut CtxTx
TxOut LedgerEra -> TxOut CtxTx
forall ctx. TxOut LedgerEra -> TxOut ctx Era
fromLedgerTxOut ([BabbageTxOut StandardBabbage] -> [TxOut CtxTx])
-> (StrictSeq (BabbageTxOut StandardBabbage)
-> [BabbageTxOut StandardBabbage])
-> StrictSeq (BabbageTxOut StandardBabbage)
-> [TxOut CtxTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (BabbageTxOut StandardBabbage)
-> [BabbageTxOut StandardBabbage]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (BabbageTxOut StandardBabbage) -> [TxOut CtxTx])
-> StrictSeq (BabbageTxOut StandardBabbage) -> [TxOut CtxTx]
forall a b. (a -> b) -> a -> b
$ TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody BabbageTxBody StandardBabbage
-> Getting
(StrictSeq (BabbageTxOut StandardBabbage))
(BabbageTxBody StandardBabbage)
(StrictSeq (BabbageTxOut StandardBabbage))
-> StrictSeq (BabbageTxOut StandardBabbage)
forall s a. s -> Getting a s a -> a
^. Getting
(StrictSeq (BabbageTxOut StandardBabbage))
(BabbageTxBody StandardBabbage)
(StrictSeq (BabbageTxOut StandardBabbage))
(StrictSeq (TxOut StandardBabbage)
-> Const
(StrictSeq (BabbageTxOut StandardBabbage))
(StrictSeq (TxOut StandardBabbage)))
-> TxBody StandardBabbage
-> Const
(StrictSeq (BabbageTxOut StandardBabbage)) (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody StandardBabbage) (StrictSeq (TxOut StandardBabbage))
outputsTxBodyL
scriptData' :: TxBodyScriptData
scriptData' = [TxOut CtxTx] -> TxBodyScriptData -> TxBodyScriptData
ensureDatums [TxOut CtxTx]
outputs' TxBodyScriptData
scriptData
ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
Tx TxBody
body [KeyWitness]
wits = Tx
tx
anyPayToPubKeyTxOut :: Gen (TxOut ctx)
anyPayToPubKeyTxOut :: forall ctx. Gen (TxOut ctx)
anyPayToPubKeyTxOut = Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> ((VerificationKey PaymentKey, SigningKey PaymentKey)
-> Gen (TxOut ctx))
-> Gen (TxOut ctx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VerificationKey PaymentKey -> Gen (TxOut ctx)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutput (VerificationKey PaymentKey -> Gen (TxOut ctx))
-> ((VerificationKey PaymentKey, SigningKey PaymentKey)
-> VerificationKey PaymentKey)
-> (VerificationKey PaymentKey, SigningKey PaymentKey)
-> Gen (TxOut ctx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VerificationKey PaymentKey, SigningKey PaymentKey)
-> VerificationKey PaymentKey
forall a b. (a, b) -> a
fst
headTxIn :: UTxO -> TxIn
headTxIn :: UTxO -> TxIn
headTxIn = (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, TxOut CtxUTxO) -> TxIn)
-> (UTxO -> (TxIn, TxOut CtxUTxO)) -> UTxO -> TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, TxOut CtxUTxO)] -> (TxIn, TxOut CtxUTxO)
forall a. HasCallStack => [a] -> a
Prelude.head ([(TxIn, TxOut CtxUTxO)] -> (TxIn, TxOut CtxUTxO))
-> (UTxO -> [(TxIn, TxOut CtxUTxO)])
-> UTxO
-> (TxIn, TxOut CtxUTxO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, TxOut CtxUTxO) -> Bool)
-> [(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxOut CtxUTxO -> Bool
isHeadOutput (TxOut CtxUTxO -> Bool)
-> ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO)
-> (TxIn, TxOut CtxUTxO)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO
forall a b. (a, b) -> b
snd) ([(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)])
-> (UTxO -> [(TxIn, TxOut CtxUTxO)])
-> UTxO
-> [(TxIn, TxOut CtxUTxO)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs
changeMintedValueQuantityFrom :: Tx -> Integer -> Gen Mutation
changeMintedValueQuantityFrom :: Tx -> Integer -> Gen Mutation
changeMintedValueQuantityFrom Tx
tx Integer
exclude =
Value -> Mutation
ChangeMintedValue
(Value -> Mutation) -> Gen Value -> Gen Mutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case TxMintValue ViewTx
mintedValue of
TxMintValue ViewTx
TxMintValueNone ->
Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
forall a. Monoid a => a
mempty
TxMintValue Value
v BuildTxWith ViewTx (Map PolicyId (ScriptWitness WitCtxMint))
_ -> do
Quantity
someQuantity <- Integer -> Quantity
forall a. Num a => Integer -> a
fromInteger (Integer -> Quantity) -> Gen Integer -> Gen Quantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. Arbitrary a => Gen a
arbitrary Gen Integer -> (Integer -> Bool) -> Gen Integer
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
exclude) Gen Integer -> (Integer -> Bool) -> Gen Integer
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0)
Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Gen Value)
-> ([(AssetId, Quantity)] -> Value)
-> [(AssetId, Quantity)]
-> Gen Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AssetId, Quantity)] -> Value
valueFromList ([(AssetId, Quantity)] -> Gen Value)
-> [(AssetId, Quantity)] -> Gen Value
forall a b. (a -> b) -> a -> b
$ ((AssetId, Quantity) -> (AssetId, Quantity))
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a b. (a -> b) -> [a] -> [b]
map ((Quantity -> Quantity)
-> (AssetId, Quantity) -> (AssetId, Quantity)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Quantity -> Quantity)
-> (AssetId, Quantity) -> (AssetId, Quantity))
-> (Quantity -> Quantity)
-> (AssetId, Quantity)
-> (AssetId, Quantity)
forall a b. (a -> b) -> a -> b
$ Quantity -> Quantity -> Quantity
forall a b. a -> b -> a
const Quantity
someQuantity) ([(AssetId, Quantity)] -> [(AssetId, Quantity)])
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a b. (a -> b) -> a -> b
$ Value -> [(AssetId, Quantity)]
valueToList Value
v
where
mintedValue :: TxMintValue ViewTx
mintedValue = TxBodyContent ViewTx -> TxMintValue ViewTx
forall buidl. TxBodyContent buidl -> TxMintValue buidl
txMintValue (TxBodyContent ViewTx -> TxMintValue ViewTx)
-> TxBodyContent ViewTx -> TxMintValue ViewTx
forall a b. (a -> b) -> a -> b
$ TxBody -> TxBodyContent ViewTx
txBodyContent (TxBody -> TxBodyContent ViewTx) -> TxBody -> TxBodyContent ViewTx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
txBody Tx
tx
changeMintedTokens :: Tx -> Value -> Gen Mutation
changeMintedTokens :: Tx -> Value -> Gen Mutation
changeMintedTokens Tx
tx Value
mintValue =
Value -> Mutation
ChangeMintedValue
(Value -> Mutation) -> Gen Value -> Gen Mutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case TxMintValue ViewTx
mintedValue of
TxMintValue ViewTx
TxMintValueNone ->
Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
mintValue
TxMintValue Value
v BuildTxWith ViewTx (Map PolicyId (ScriptWitness WitCtxMint))
_ ->
Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Gen Value) -> Value -> Gen Value
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
mintValue
where
mintedValue :: TxMintValue ViewTx
mintedValue = TxBodyContent ViewTx -> TxMintValue ViewTx
forall buidl. TxBodyContent buidl -> TxMintValue buidl
txMintValue (TxBodyContent ViewTx -> TxMintValue ViewTx)
-> TxBodyContent ViewTx -> TxMintValue ViewTx
forall a b. (a -> b) -> a -> b
$ TxBody -> TxBodyContent ViewTx
txBodyContent (TxBody -> TxBodyContent ViewTx) -> TxBody -> TxBodyContent ViewTx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
txBody Tx
tx
addPTWithQuantity :: Tx -> Quantity -> Gen Mutation
addPTWithQuantity :: Tx -> Quantity -> Gen Mutation
addPTWithQuantity Tx
tx Quantity
quantity =
Value -> Mutation
ChangeMintedValue (Value -> Mutation) -> Gen Value -> Gen Mutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
case TxMintValue ViewTx
mintedValue of
TxMintValue Value
v BuildTxWith ViewTx (Map PolicyId (ScriptWitness WitCtxMint))
_ -> do
case [(AssetId, Quantity)] -> (AssetId, Quantity)
forall a. HasCallStack => [a] -> a
Prelude.head ([(AssetId, Quantity)] -> (AssetId, Quantity))
-> [(AssetId, Quantity)] -> (AssetId, Quantity)
forall a b. (a -> b) -> a -> b
$ Value -> [(AssetId, Quantity)]
valueToList Value
v of
(AssetId
AdaAssetId, Quantity
_) -> Text -> Gen Value
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected mint of Ada"
(AssetId PolicyId
pid AssetName
_an, Quantity
_) -> do
AssetName
pkh <- Gen AssetName
forall a. Arbitrary a => Gen a
arbitrary
Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Gen Value) -> Value -> Gen Value
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> [(AssetId, Quantity)] -> Value
valueFromList [(PolicyId -> AssetName -> AssetId
AssetId PolicyId
pid AssetName
pkh, Quantity
quantity)]
TxMintValue ViewTx
TxMintValueNone ->
Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
forall a. Monoid a => a
mempty
where
mintedValue :: TxMintValue ViewTx
mintedValue = TxBodyContent ViewTx -> TxMintValue ViewTx
forall buidl. TxBodyContent buidl -> TxMintValue buidl
txMintValue (TxBodyContent ViewTx -> TxMintValue ViewTx)
-> TxBodyContent ViewTx -> TxMintValue ViewTx
forall a b. (a -> b) -> a -> b
$ TxBody -> TxBodyContent ViewTx
txBodyContent (TxBody -> TxBodyContent ViewTx) -> TxBody -> TxBodyContent ViewTx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
txBody Tx
tx
replacePolicyIdWith :: PolicyId -> PolicyId -> TxOut a -> TxOut a
replacePolicyIdWith :: forall a. PolicyId -> PolicyId -> TxOut a -> TxOut a
replacePolicyIdWith PolicyId
original PolicyId
replacement =
(Value -> Value) -> TxOut a Era -> TxOut a Era
forall era ctx.
(IsMaryEraOnwards era, IsShelleyBasedEra era) =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (PolicyId -> PolicyId -> Value -> Value
replacePolicyInValue PolicyId
original PolicyId
replacement)
replacePolicyInValue :: PolicyId -> PolicyId -> Value -> Value
replacePolicyInValue :: PolicyId -> PolicyId -> Value -> Value
replacePolicyInValue PolicyId
original PolicyId
replacement =
[(AssetId, Quantity)] -> Value
valueFromList ([(AssetId, Quantity)] -> Value)
-> (Value -> [(AssetId, Quantity)]) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AssetId, Quantity) -> (AssetId, Quantity))
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a b. (a -> b) -> [a] -> [b]
map (AssetId, Quantity) -> (AssetId, Quantity)
replaceAssetId ([(AssetId, Quantity)] -> [(AssetId, Quantity)])
-> (Value -> [(AssetId, Quantity)])
-> Value
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
valueToList
where
replaceAssetId :: (AssetId, Quantity) -> (AssetId, Quantity)
replaceAssetId (AssetId
aid, Quantity
q) = case AssetId
aid of
AssetId PolicyId
pid AssetName
an
| PolicyId
pid PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== PolicyId
original -> (PolicyId -> AssetName -> AssetId
AssetId PolicyId
replacement AssetName
an, Quantity
q)
AssetId
_ -> (AssetId
aid, Quantity
q)
replaceSnapshotNumber :: Head.SnapshotNumber -> Head.State -> Head.State
replaceSnapshotNumber :: Integer -> State -> State
replaceSnapshotNumber Integer
snapshotNumber = \case
Head.Closed{[Party]
parties :: [Party]
$sel:parties:Initial :: State -> [Party]
parties, Signature
utxoHash :: Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash, POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline, CurrencySymbol
headId :: CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId, [PubKeyHash]
contesters :: [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod} ->
Head.Closed
{ $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
, $sel:snapshotNumber:Initial :: Integer
Head.snapshotNumber = Integer
snapshotNumber
, $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
, $sel:contestationDeadline:Initial :: POSIXTime
Head.contestationDeadline = POSIXTime
contestationDeadline
, $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
, $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
, $sel:contesters:Initial :: [PubKeyHash]
Head.contesters = [PubKeyHash]
contesters
}
State
otherState -> State
otherState
replaceParties :: [Data.Party] -> Head.State -> Head.State
replaceParties :: [Party] -> State -> State
replaceParties [Party]
parties = \case
Head.Initial{ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId, TxOutRef
seed :: TxOutRef
$sel:seed:Initial :: State -> TxOutRef
seed} ->
Head.Initial
{ $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
, $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
, $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
, $sel:seed:Initial :: TxOutRef
Head.seed = TxOutRef
seed
}
Head.Open{ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId} ->
Head.Open
{ $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
, $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
, $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
, $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
}
Head.Closed{Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId, [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters :: [PubKeyHash]
contesters, ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
Head.Closed
{ $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
, $sel:snapshotNumber:Initial :: Integer
Head.snapshotNumber = Integer
snapshotNumber
, $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
, $sel:contestationDeadline:Initial :: POSIXTime
Head.contestationDeadline = POSIXTime
contestationDeadline
, $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
, $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
, $sel:contesters:Initial :: [PubKeyHash]
Head.contesters = [PubKeyHash]
contesters
}
State
otherState -> State
otherState
replaceUtxoHash :: Head.Hash -> Head.State -> Head.State
replaceUtxoHash :: Signature -> State -> State
replaceUtxoHash Signature
utxoHash = \case
Head.Open{ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId} ->
Head.Open
{ $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
, $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
, $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
, $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
}
Head.Closed{[Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId, [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters :: [PubKeyHash]
contesters, ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
Head.Closed
{ $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
, $sel:snapshotNumber:Initial :: Integer
Head.snapshotNumber = Integer
snapshotNumber
, $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
, $sel:contestationDeadline:Initial :: POSIXTime
Head.contestationDeadline = POSIXTime
contestationDeadline
, $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
, $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
, $sel:contesters:Initial :: [PubKeyHash]
Head.contesters = [PubKeyHash]
contesters
}
State
otherState -> State
otherState
replaceContestationDeadline :: POSIXTime -> Head.State -> Head.State
replaceContestationDeadline :: POSIXTime -> State -> State
replaceContestationDeadline POSIXTime
contestationDeadline = \case
Head.Closed{Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId, [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters :: [PubKeyHash]
contesters, ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
Head.Closed
{ Integer
$sel:snapshotNumber:Initial :: Integer
snapshotNumber :: Integer
snapshotNumber
, Signature
$sel:utxoHash:Initial :: Signature
utxoHash :: Signature
utxoHash
, [Party]
$sel:parties:Initial :: [Party]
parties :: [Party]
parties
, POSIXTime
$sel:contestationDeadline:Initial :: POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline
, ContestationPeriod
$sel:contestationPeriod:Initial :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod
, CurrencySymbol
$sel:headId:Initial :: CurrencySymbol
headId :: CurrencySymbol
headId
, [PubKeyHash]
$sel:contesters:Initial :: [PubKeyHash]
contesters :: [PubKeyHash]
contesters
}
State
otherState -> State
otherState
replaceContestationPeriod :: ContestationPeriod -> Head.State -> Head.State
replaceContestationPeriod :: ContestationPeriod -> State -> State
replaceContestationPeriod ContestationPeriod
contestationPeriod = \case
Head.Closed{Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId, [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters :: [PubKeyHash]
contesters, POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline} ->
Head.Closed
{ Integer
$sel:snapshotNumber:Initial :: Integer
snapshotNumber :: Integer
snapshotNumber
, Signature
$sel:utxoHash:Initial :: Signature
utxoHash :: Signature
utxoHash
, [Party]
$sel:parties:Initial :: [Party]
parties :: [Party]
parties
, POSIXTime
$sel:contestationDeadline:Initial :: POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline
, ContestationPeriod
$sel:contestationPeriod:Initial :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod
, CurrencySymbol
$sel:headId:Initial :: CurrencySymbol
headId :: CurrencySymbol
headId
, [PubKeyHash]
$sel:contesters:Initial :: [PubKeyHash]
contesters :: [PubKeyHash]
contesters
}
State
otherState -> State
otherState
replaceHeadId :: CurrencySymbol -> Head.State -> Head.State
replaceHeadId :: CurrencySymbol -> State -> State
replaceHeadId CurrencySymbol
headId = \case
Head.Initial{ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, TxOutRef
$sel:seed:Initial :: State -> TxOutRef
seed :: TxOutRef
seed} ->
Head.Initial
{ $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
, $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
, $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
, $sel:seed:Initial :: TxOutRef
Head.seed = TxOutRef
seed
}
Head.Open{ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties} ->
Head.Open
{ $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
, $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
, $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
, $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
}
Head.Closed{Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters :: [PubKeyHash]
contesters, ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
Head.Closed
{ $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
, $sel:snapshotNumber:Initial :: Integer
Head.snapshotNumber = Integer
snapshotNumber
, $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
, $sel:contestationDeadline:Initial :: POSIXTime
Head.contestationDeadline = POSIXTime
contestationDeadline
, $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
, $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
, $sel:contesters:Initial :: [PubKeyHash]
Head.contesters = [PubKeyHash]
contesters
}
State
otherState -> State
otherState
replaceContesters :: [Plutus.PubKeyHash] -> Head.State -> Head.State
replaceContesters :: [PubKeyHash] -> State -> State
replaceContesters [PubKeyHash]
contesters = \case
Head.Closed{Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId, ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
Head.Closed
{ $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
, $sel:snapshotNumber:Initial :: Integer
Head.snapshotNumber = Integer
snapshotNumber
, $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
, $sel:contestationDeadline:Initial :: POSIXTime
Head.contestationDeadline = POSIXTime
contestationDeadline
, $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
, $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
, $sel:contesters:Initial :: [PubKeyHash]
Head.contesters = [PubKeyHash]
contesters
}
State
otherState -> State
otherState
removePTFromMintedValue :: TxOut CtxUTxO -> Tx -> Value
removePTFromMintedValue :: TxOut CtxUTxO -> Tx -> Value
removePTFromMintedValue TxOut CtxUTxO
output Tx
tx =
case TxBodyContent ViewTx -> TxMintValue ViewTx
forall buidl. TxBodyContent buidl -> TxMintValue buidl
txMintValue (TxBodyContent ViewTx -> TxMintValue ViewTx)
-> TxBodyContent ViewTx -> TxMintValue ViewTx
forall a b. (a -> b) -> a -> b
$ TxBody -> TxBodyContent ViewTx
txBodyContent (TxBody -> TxBodyContent ViewTx) -> TxBody -> TxBodyContent ViewTx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
txBody Tx
tx of
TxMintValue ViewTx
TxMintValueNone -> Text -> Value
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"expected minted value"
TxMintValue Value
v BuildTxWith ViewTx (Map PolicyId (ScriptWitness WitCtxMint))
_ -> [(AssetId, Quantity)] -> Value
valueFromList ([(AssetId, Quantity)] -> Value) -> [(AssetId, Quantity)] -> Value
forall a b. (a -> b) -> a -> b
$ ((AssetId, Quantity) -> Bool)
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((AssetId, Quantity) -> Bool) -> (AssetId, Quantity) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AssetId, Quantity) -> Bool
isPT) ([(AssetId, Quantity)] -> [(AssetId, Quantity)])
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a b. (a -> b) -> a -> b
$ Value -> [(AssetId, Quantity)]
valueToList Value
v
where
outValue :: Value
outValue = TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
output
assetNames :: [(PolicyId, AssetName)]
assetNames =
[ (PolicyId
policyId, AssetName
pkh) | (AssetId PolicyId
policyId AssetName
pkh, Quantity
_) <- Value -> [(AssetId, Quantity)]
valueToList Value
outValue, PolicyId
policyId PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== PolicyId
testPolicyId
]
(PolicyId
headId, AssetName
assetName) =
case [(PolicyId, AssetName)]
assetNames of
[(PolicyId, AssetName)
assetId] -> (PolicyId, AssetName)
assetId
[(PolicyId, AssetName)]
_ -> Text -> (PolicyId, AssetName)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"expected one assetId"
isPT :: (AssetId, Quantity) -> Bool
isPT = \case
(AssetId PolicyId
pid AssetName
asset, Quantity
_) ->
PolicyId
pid PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== PolicyId
headId Bool -> Bool -> Bool
&& AssetName
asset AssetName -> AssetName -> Bool
forall a. Eq a => a -> a -> Bool
== AssetName
assetName
(AssetId, Quantity)
_ -> Bool
False