Skip to content

Commit 9af6866

Browse files
carbolymercarbolymer
authored
Merge pull request #663 from IntersectMBO/mgalazyn/feature/refactor-txmintvalue
Refactor `TxMintValue`
2 parents 0c45959 + 0f51874 commit 9af6866

File tree

9 files changed

+181
-162
lines changed

9 files changed

+181
-162
lines changed

‎cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

Lines changed: 35 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -662,11 +662,18 @@ genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era)
662662
genTxMintValue =
663663
inEonForEra
664664
(pure TxMintNone)
665-
$ \supported ->
665+
$ \w -> do
666+
policies <- Gen.list (Range.constant 1 3) genPolicyId
667+
assets <- forM policies $ \policy ->
668+
(,) policy <$>
669+
Gen.list
670+
(Range.constant 1 3)
671+
((,,) <$> genAssetName
672+
<*> genPositiveQuantity
673+
<*> fmap (fmap pure) genScriptWitnessForMint (maryEraOnwardsToShelleyBasedEra w))
666674
Gen.choice
667675
[ pure TxMintNone
668-
-- TODO write a generator for the last parameter of 'TxMintValue' constructor
669-
, TxMintValue supported <$> genValueForMinting <*> return (pure mempty)
676+
, pure $ TxMintValue w (fromList assets)
670677
]
671678

672679
genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era)
@@ -1196,13 +1203,13 @@ genScriptWitnessForStake sbe = do
11961203
SimpleScript simpleScript -> do
11971204
simpleScriptOrReferenceInput <- Gen.choice
11981205
[ pure $ SScript simpleScript
1199-
, SReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash
1206+
, SReferenceScript <$> genTxIn
12001207
]
12011208
pure $ Api.SimpleScriptWitness scriptLangInEra simpleScriptOrReferenceInput
12021209
PlutusScript plutusScriptVersion' plutusScript -> do
12031210
plutusScriptOrReferenceInput <- Gen.choice
12041211
[ pure $ PScript plutusScript
1205-
, PReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash
1212+
, PReferenceScript <$> genTxIn
12061213
]
12071214
scriptRedeemer <- genHashableScriptData
12081215
PlutusScriptWitness
@@ -1213,6 +1220,27 @@ genScriptWitnessForStake sbe = do
12131220
scriptRedeemer
12141221
<$> genExecutionUnits
12151222

1216-
1217-
1223+
genScriptWitnessForMint :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxMint era)
1224+
genScriptWitnessForMint sbe = do
1225+
ScriptInEra scriptLangInEra script' <- genScriptInEra sbe
1226+
case script' of
1227+
SimpleScript simpleScript -> do
1228+
simpleScriptOrReferenceInput <- Gen.choice
1229+
[ pure $ SScript simpleScript
1230+
, SReferenceScript <$> genTxIn
1231+
]
1232+
pure $ Api.SimpleScriptWitness scriptLangInEra simpleScriptOrReferenceInput
1233+
PlutusScript plutusScriptVersion' plutusScript -> do
1234+
plutusScriptOrReferenceInput <- Gen.choice
1235+
[ pure $ PScript plutusScript
1236+
, PReferenceScript <$> genTxIn
1237+
]
1238+
scriptRedeemer <- genHashableScriptData
1239+
PlutusScriptWitness
1240+
scriptLangInEra
1241+
plutusScriptVersion'
1242+
plutusScriptOrReferenceInput
1243+
NoScriptDatumForMint
1244+
scriptRedeemer
1245+
<$> genExecutionUnits
12181246

‎cardano-api/internal/Cardano/Api/Fees.hs

Lines changed: 14 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@
88
{-# LANGUAGE RankNTypes #-}
99
{-# LANGUAGE ScopedTypeVariables #-}
1010
{-# LANGUAGE StandaloneDeriving #-}
11+
{-# LANGUAGE TupleSections #-}
1112

1213
-- | Fee calculation
1314
module Cardano.Api.Fees
@@ -1320,10 +1321,8 @@ calculateChangeValue
13201321
:: ShelleyBasedEra era -> Value -> TxBodyContent build era -> Value
13211322
calculateChangeValue sbe incoming txbodycontent =
13221323
let outgoing = calculateCreatedUTOValue sbe txbodycontent
1323-
minted = case txMintValue txbodycontent of
1324-
TxMintNone -> mempty
1325-
TxMintValue _ v _ -> v
1326-
in mconcat [incoming, minted, negateValue outgoing]
1324+
mintedValue = txMintValueToValue $ txMintValue txbodycontent
1325+
in mconcat [incoming, mintedValue, negateValue outgoing]
13271326

13281327
-- | This is used in the balance calculation in the event where
13291328
-- the user does not supply the UTxO(s) they intend to spend
@@ -1593,33 +1592,20 @@ substituteExecutionUnits
15931592
:: TxMintValue BuildTx era
15941593
-> Either (TxBodyErrorAutoBalance era) (TxMintValue BuildTx era)
15951594
mapScriptWitnessesMinting TxMintNone = Right TxMintNone
1596-
mapScriptWitnessesMinting
1597-
( TxMintValue
1598-
supported
1599-
value
1600-
(BuildTxWith witnesses)
1601-
) =
1602-
-- TxMintValue supported value $ BuildTxWith $ fromList
1603-
let mappedScriptWitnesses
1604-
:: [(PolicyId, Either (TxBodyErrorAutoBalance era) (ScriptWitness WitCtxMint era))]
1605-
mappedScriptWitnesses =
1606-
[ (policyid, witness')
1607-
| -- The minting policies are indexed in policy id order in the value
1608-
let ValueNestedRep bundle = valueToNestedRep value
1609-
, (ix, ValueNestedBundle policyid _) <- zip [0 ..] bundle
1610-
, witness <- maybeToList (Map.lookup policyid witnesses)
1611-
, let witness' = substituteExecUnits (ScriptWitnessIndexMint ix) witness
1612-
]
1613-
in do
1614-
final <- traverseScriptWitnesses mappedScriptWitnesses
1615-
Right . TxMintValue supported value . BuildTxWith $
1616-
fromList final
1595+
mapScriptWitnessesMinting txMintValue'@(TxMintValue w _) = do
1596+
let mappedScriptWitnesses =
1597+
[ (policyId, pure . (assetName',quantity,) <$> substitutedWitness)
1598+
| (ix, policyId, assetName', quantity, BuildTxWith witness) <- txMintValueToIndexed txMintValue'
1599+
, let substitutedWitness = BuildTxWith <$> substituteExecUnits ix witness
1600+
]
1601+
final <- Map.fromListWith (<>) <$> traverseScriptWitnesses mappedScriptWitnesses
1602+
pure $ TxMintValue w final
16171603

16181604
traverseScriptWitnesses
1619-
:: [(a, Either (TxBodyErrorAutoBalance era) (ScriptWitness ctx era))]
1620-
-> Either (TxBodyErrorAutoBalance era) [(a, ScriptWitness ctx era)]
1605+
:: [(a, Either (TxBodyErrorAutoBalance era) b)]
1606+
-> Either (TxBodyErrorAutoBalance era) [(a, b)]
16211607
traverseScriptWitnesses =
1622-
traverse (\(item, eScriptWitness) -> eScriptWitness >>= (\sWit -> Right (item, sWit)))
1608+
traverse (\(item, eRes) -> eRes >>= (\res -> Right (item, res)))
16231609

16241610
calculateMinimumUTxO
16251611
:: ShelleyBasedEra era

‎cardano-api/internal/Cardano/Api/Script.hs

Lines changed: 59 additions & 67 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE FlexibleInstances #-}
55
{-# LANGUAGE GADTs #-}
66
{-# LANGUAGE InstanceSigs #-}
7+
{-# LANGUAGE LambdaCase #-}
78
{-# LANGUAGE MultiParamTypeClasses #-}
89
{-# LANGUAGE NamedFieldPuns #-}
910
{-# LANGUAGE PatternSynonyms #-}
@@ -47,25 +48,27 @@ module Cardano.Api.Script
4748
-- * Reference scripts
4849
, ReferenceScript (..)
4950
, refScriptToShelleyScript
50-
, getScriptWitnessReferenceInput
5151

5252
-- * Use of a script in an era as a witness
5353
, WitCtxTxIn
5454
, WitCtxMint
5555
, WitCtxStake
5656
, WitCtx (..)
5757
, ScriptWitness (..)
58+
, getScriptWitnessReferenceInput
59+
, getScriptWitnessScript
60+
, getScriptWitnessReferenceInputOrScript
5861
, Witness (..)
5962
, KeyWitnessInCtx (..)
6063
, ScriptWitnessInCtx (..)
6164
, IsScriptWitnessInCtx (..)
6265
, ScriptDatum (..)
6366
, ScriptRedeemer
64-
, scriptWitnessScript
6567

6668
-- ** Languages supported in each era
6769
, ScriptLanguageInEra (..)
6870
, scriptLanguageSupportedInEra
71+
, sbeToSimpleScriptLanguageInEra
6972
, languageOfScriptLanguageInEra
7073
, eraOfScriptLanguageInEra
7174

@@ -228,7 +231,8 @@ instance HasTypeProxy PlutusScriptV3 where
228231
--
229232
data ScriptLanguage lang where
230233
SimpleScriptLanguage :: ScriptLanguage SimpleScript'
231-
PlutusScriptLanguage :: PlutusScriptVersion lang -> ScriptLanguage lang
234+
PlutusScriptLanguage
235+
:: IsPlutusScriptLanguage lang => PlutusScriptVersion lang -> ScriptLanguage lang
232236

233237
deriving instance (Eq (ScriptLanguage lang))
234238

@@ -285,7 +289,8 @@ instance Bounded AnyScriptLanguage where
285289

286290
data AnyPlutusScriptVersion where
287291
AnyPlutusScriptVersion
288-
:: PlutusScriptVersion lang
292+
:: IsPlutusScriptLanguage lang
293+
=> PlutusScriptVersion lang
289294
-> AnyPlutusScriptVersion
290295

291296
deriving instance (Show AnyPlutusScriptVersion)
@@ -407,7 +412,8 @@ data Script lang where
407412
:: !SimpleScript
408413
-> Script SimpleScript'
409414
PlutusScript
410-
:: !(PlutusScriptVersion lang)
415+
:: IsPlutusScriptLanguage lang
416+
=> !(PlutusScriptVersion lang)
411417
-> !(PlutusScript lang)
412418
-> Script lang
413419

@@ -576,18 +582,8 @@ scriptLanguageSupportedInEra
576582
-> Maybe (ScriptLanguageInEra lang era)
577583
scriptLanguageSupportedInEra era lang =
578584
case (era, lang) of
579-
(ShelleyBasedEraShelley, SimpleScriptLanguage) ->
580-
Just SimpleScriptInShelley
581-
(ShelleyBasedEraAllegra, SimpleScriptLanguage) ->
582-
Just SimpleScriptInAllegra
583-
(ShelleyBasedEraMary, SimpleScriptLanguage) ->
584-
Just SimpleScriptInMary
585-
(ShelleyBasedEraAlonzo, SimpleScriptLanguage) ->
586-
Just SimpleScriptInAlonzo
587-
(ShelleyBasedEraBabbage, SimpleScriptLanguage) ->
588-
Just SimpleScriptInBabbage
589-
(ShelleyBasedEraConway, SimpleScriptLanguage) ->
590-
Just SimpleScriptInConway
585+
(sbe, SimpleScriptLanguage) ->
586+
Just $ sbeToSimpleScriptLanguageInEra sbe
591587
(ShelleyBasedEraAlonzo, PlutusScriptLanguage PlutusScriptV1) ->
592588
Just PlutusScriptV1InAlonzo
593589
(ShelleyBasedEraBabbage, PlutusScriptLanguage PlutusScriptV1) ->
@@ -620,23 +616,33 @@ languageOfScriptLanguageInEra langInEra =
620616
PlutusScriptV2InConway -> PlutusScriptLanguage PlutusScriptV2
621617
PlutusScriptV3InConway -> PlutusScriptLanguage PlutusScriptV3
622618

619+
sbeToSimpleScriptLanguageInEra
620+
:: ShelleyBasedEra era
621+
-> ScriptLanguageInEra SimpleScript' era
622+
sbeToSimpleScriptLanguageInEra = \case
623+
ShelleyBasedEraShelley -> SimpleScriptInShelley
624+
ShelleyBasedEraAllegra -> SimpleScriptInAllegra
625+
ShelleyBasedEraMary -> SimpleScriptInMary
626+
ShelleyBasedEraAlonzo -> SimpleScriptInAlonzo
627+
ShelleyBasedEraBabbage -> SimpleScriptInBabbage
628+
ShelleyBasedEraConway -> SimpleScriptInConway
629+
623630
eraOfScriptLanguageInEra
624631
:: ScriptLanguageInEra lang era
625632
-> ShelleyBasedEra era
626-
eraOfScriptLanguageInEra langInEra =
627-
case langInEra of
628-
SimpleScriptInShelley -> ShelleyBasedEraShelley
629-
SimpleScriptInAllegra -> ShelleyBasedEraAllegra
630-
SimpleScriptInMary -> ShelleyBasedEraMary
631-
SimpleScriptInAlonzo -> ShelleyBasedEraAlonzo
632-
SimpleScriptInBabbage -> ShelleyBasedEraBabbage
633-
SimpleScriptInConway -> ShelleyBasedEraConway
634-
PlutusScriptV1InAlonzo -> ShelleyBasedEraAlonzo
635-
PlutusScriptV1InBabbage -> ShelleyBasedEraBabbage
636-
PlutusScriptV1InConway -> ShelleyBasedEraConway
637-
PlutusScriptV2InBabbage -> ShelleyBasedEraBabbage
638-
PlutusScriptV2InConway -> ShelleyBasedEraConway
639-
PlutusScriptV3InConway -> ShelleyBasedEraConway
633+
eraOfScriptLanguageInEra = \case
634+
SimpleScriptInShelley -> ShelleyBasedEraShelley
635+
SimpleScriptInAllegra -> ShelleyBasedEraAllegra
636+
SimpleScriptInMary -> ShelleyBasedEraMary
637+
SimpleScriptInAlonzo -> ShelleyBasedEraAlonzo
638+
SimpleScriptInBabbage -> ShelleyBasedEraBabbage
639+
SimpleScriptInConway -> ShelleyBasedEraConway
640+
PlutusScriptV1InAlonzo -> ShelleyBasedEraAlonzo
641+
PlutusScriptV1InBabbage -> ShelleyBasedEraBabbage
642+
PlutusScriptV1InConway -> ShelleyBasedEraConway
643+
PlutusScriptV2InBabbage -> ShelleyBasedEraBabbage
644+
PlutusScriptV2InConway -> ShelleyBasedEraConway
645+
PlutusScriptV3InConway -> ShelleyBasedEraConway
640646

641647
-- | Given a target era and a script in some language, check if the language is
642648
-- supported in that era, and if so return a 'ScriptInEra'.
@@ -682,27 +688,14 @@ data WitCtx witctx where
682688
-- or to mint tokens. This datatype encapsulates this concept.
683689
data PlutusScriptOrReferenceInput lang
684690
= PScript (PlutusScript lang)
685-
| -- | Needed to construct the redeemer pointer map
686-
-- in the case of minting reference scripts where we don't
687-
-- have direct access to the script
688-
PReferenceScript
689-
TxIn
690-
(Maybe ScriptHash)
691+
| PReferenceScript TxIn
691692
deriving (Eq, Show)
692693

693694
data SimpleScriptOrReferenceInput lang
694695
= SScript SimpleScript
695-
| SReferenceScript TxIn (Maybe ScriptHash)
696+
| SReferenceScript TxIn
696697
deriving (Eq, Show)
697698

698-
getScriptWitnessReferenceInput :: ScriptWitness witctx era -> Maybe TxIn
699-
getScriptWitnessReferenceInput (SimpleScriptWitness _ (SReferenceScript txIn _)) =
700-
Just txIn
701-
getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PReferenceScript txIn _) _ _ _) =
702-
Just txIn
703-
getScriptWitnessReferenceInput (SimpleScriptWitness _ (SScript _)) = Nothing
704-
getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PScript _) _ _ _) = Nothing
705-
706699
-- | A /use/ of a script within a transaction body to witness that something is
707700
-- being used in an authorised manner. That can be
708701
--
@@ -721,7 +714,8 @@ data ScriptWitness witctx era where
721714
-> SimpleScriptOrReferenceInput SimpleScript'
722715
-> ScriptWitness witctx era
723716
PlutusScriptWitness
724-
:: ScriptLanguageInEra lang era
717+
:: IsPlutusScriptLanguage lang
718+
=> ScriptLanguageInEra lang era
725719
-> PlutusScriptVersion lang
726720
-> PlutusScriptOrReferenceInput lang
727721
-> ScriptDatum witctx
@@ -782,28 +776,26 @@ deriving instance Eq (ScriptDatum witctx)
782776

783777
deriving instance Show (ScriptDatum witctx)
784778

785-
-- We cannot always extract a script from a script witness due to reference scripts.
779+
getScriptWitnessReferenceInput :: ScriptWitness witctx era -> Maybe TxIn
780+
getScriptWitnessReferenceInput = either (const Nothing) Just . getScriptWitnessReferenceInputOrScript
781+
782+
getScriptWitnessScript :: ScriptWitness witctx era -> Maybe (ScriptInEra era)
783+
getScriptWitnessScript = either Just (const Nothing) . getScriptWitnessReferenceInputOrScript
784+
785+
-- | We cannot always extract a script from a script witness due to reference scripts.
786786
-- Reference scripts exist in the UTxO, so without access to the UTxO we cannot
787787
-- retrieve the script.
788-
scriptWitnessScript :: ScriptWitness witctx era -> Maybe (ScriptInEra era)
789-
scriptWitnessScript (SimpleScriptWitness SimpleScriptInShelley (SScript script)) =
790-
Just $ ScriptInEra SimpleScriptInShelley (SimpleScript script)
791-
scriptWitnessScript (SimpleScriptWitness SimpleScriptInAllegra (SScript script)) =
792-
Just $ ScriptInEra SimpleScriptInAllegra (SimpleScript script)
793-
scriptWitnessScript (SimpleScriptWitness SimpleScriptInMary (SScript script)) =
794-
Just $ ScriptInEra SimpleScriptInMary (SimpleScript script)
795-
scriptWitnessScript (SimpleScriptWitness SimpleScriptInAlonzo (SScript script)) =
796-
Just $ ScriptInEra SimpleScriptInAlonzo (SimpleScript script)
797-
scriptWitnessScript (SimpleScriptWitness SimpleScriptInBabbage (SScript script)) =
798-
Just $ ScriptInEra SimpleScriptInBabbage (SimpleScript script)
799-
scriptWitnessScript (SimpleScriptWitness SimpleScriptInConway (SScript script)) =
800-
Just $ ScriptInEra SimpleScriptInConway (SimpleScript script)
801-
scriptWitnessScript (PlutusScriptWitness langInEra version (PScript script) _ _ _) =
802-
Just $ ScriptInEra langInEra (PlutusScript version script)
803-
scriptWitnessScript (SimpleScriptWitness _ (SReferenceScript _ _)) =
804-
Nothing
805-
scriptWitnessScript (PlutusScriptWitness _ _ (PReferenceScript _ _) _ _ _) =
806-
Nothing
788+
-- So in the cases for script reference, the result contains @Right TxIn@.
789+
getScriptWitnessReferenceInputOrScript :: ScriptWitness witctx era -> Either (ScriptInEra era) TxIn
790+
getScriptWitnessReferenceInputOrScript = \case
791+
SimpleScriptWitness (s :: (ScriptLanguageInEra SimpleScript' era)) (SScript script) ->
792+
Left $ ScriptInEra s (SimpleScript script)
793+
PlutusScriptWitness langInEra version (PScript script) _ _ _ ->
794+
Left $ ScriptInEra langInEra (PlutusScript version script)
795+
SimpleScriptWitness _ (SReferenceScript txIn) ->
796+
Right txIn
797+
PlutusScriptWitness _ _ (PReferenceScript txIn) _ _ _ ->
798+
Right txIn
807799

808800
-- ----------------------------------------------------------------------------
809801
-- The kind of witness to use, key (signature) or script

0 commit comments

Comments
 (0)