Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Refactor TxMintValue #663

Merged
merged 4 commits into from
Nov 20, 2024
Merged

Refactor TxMintValue #663

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
cfd2778
Propagate IsPlutusLanguage constraint
Jimbo4350 Nov 11, 2024
a374fb6
Refactor `TxMintValue` to better represent minting state
carbolymer Oct 25, 2024
e58eb3f
Add getScriptWitnessScript, getScriptWitnessReferenceInput, getScript…
carbolymer Nov 8, 2024
0f51874
Add sbeToSimpleScriptLanguageInEra
carbolymer Nov 19, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
42 changes: 35 additions & 7 deletions cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -662,11 +662,18 @@ genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era)
genTxMintValue =
inEonForEra
(pure TxMintNone)
$ \supported ->
$ \w -> do
policies <- Gen.list (Range.constant 1 3) genPolicyId
assets <- forM policies $ \policy ->
(,) policy <$>
Gen.list
(Range.constant 1 3)
((,,) <$> genAssetName
<*> genPositiveQuantity
<*> fmap (fmap pure) genScriptWitnessForMint (maryEraOnwardsToShelleyBasedEra w))
Gen.choice
[ pure TxMintNone
-- TODO write a generator for the last parameter of 'TxMintValue' constructor
, TxMintValue supported <$> genValueForMinting <*> return (pure mempty)
, pure $ TxMintValue w (fromList assets)
]

genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era)
Expand Down Expand Up @@ -1196,13 +1203,13 @@ genScriptWitnessForStake sbe = do
SimpleScript simpleScript -> do
simpleScriptOrReferenceInput <- Gen.choice
[ pure $ SScript simpleScript
, SReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash
, SReferenceScript <$> genTxIn
]
pure $ Api.SimpleScriptWitness scriptLangInEra simpleScriptOrReferenceInput
PlutusScript plutusScriptVersion' plutusScript -> do
plutusScriptOrReferenceInput <- Gen.choice
[ pure $ PScript plutusScript
, PReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash
, PReferenceScript <$> genTxIn
]
scriptRedeemer <- genHashableScriptData
PlutusScriptWitness
Expand All @@ -1213,6 +1220,27 @@ genScriptWitnessForStake sbe = do
scriptRedeemer
<$> genExecutionUnits



genScriptWitnessForMint :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxMint era)
genScriptWitnessForMint sbe = do
ScriptInEra scriptLangInEra script' <- genScriptInEra sbe
case script' of
SimpleScript simpleScript -> do
simpleScriptOrReferenceInput <- Gen.choice
[ pure $ SScript simpleScript
, SReferenceScript <$> genTxIn
]
pure $ Api.SimpleScriptWitness scriptLangInEra simpleScriptOrReferenceInput
PlutusScript plutusScriptVersion' plutusScript -> do
plutusScriptOrReferenceInput <- Gen.choice
[ pure $ PScript plutusScript
, PReferenceScript <$> genTxIn
]
scriptRedeemer <- genHashableScriptData
PlutusScriptWitness
scriptLangInEra
plutusScriptVersion'
plutusScriptOrReferenceInput
NoScriptDatumForMint
scriptRedeemer
<$> genExecutionUnits

42 changes: 14 additions & 28 deletions cardano-api/internal/Cardano/Api/Fees.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}

-- | Fee calculation
module Cardano.Api.Fees
Expand Down Expand Up @@ -1320,10 +1321,8 @@ calculateChangeValue
:: ShelleyBasedEra era -> Value -> TxBodyContent build era -> Value
calculateChangeValue sbe incoming txbodycontent =
let outgoing = calculateCreatedUTOValue sbe txbodycontent
minted = case txMintValue txbodycontent of
TxMintNone -> mempty
TxMintValue _ v _ -> v
in mconcat [incoming, minted, negateValue outgoing]
mintedValue = txMintValueToValue $ txMintValue txbodycontent
in mconcat [incoming, mintedValue, negateValue outgoing]

-- | This is used in the balance calculation in the event where
-- the user does not supply the UTxO(s) they intend to spend
Expand Down Expand Up @@ -1593,33 +1592,20 @@ substituteExecutionUnits
:: TxMintValue BuildTx era
-> Either (TxBodyErrorAutoBalance era) (TxMintValue BuildTx era)
mapScriptWitnessesMinting TxMintNone = Right TxMintNone
mapScriptWitnessesMinting
( TxMintValue
supported
value
(BuildTxWith witnesses)
) =
-- TxMintValue supported value $ BuildTxWith $ fromList
let mappedScriptWitnesses
:: [(PolicyId, Either (TxBodyErrorAutoBalance era) (ScriptWitness WitCtxMint era))]
mappedScriptWitnesses =
[ (policyid, witness')
| -- The minting policies are indexed in policy id order in the value
let ValueNestedRep bundle = valueToNestedRep value
, (ix, ValueNestedBundle policyid _) <- zip [0 ..] bundle
, witness <- maybeToList (Map.lookup policyid witnesses)
, let witness' = substituteExecUnits (ScriptWitnessIndexMint ix) witness
]
in do
final <- traverseScriptWitnesses mappedScriptWitnesses
Right . TxMintValue supported value . BuildTxWith $
fromList final
mapScriptWitnessesMinting txMintValue'@(TxMintValue w _) = do
let mappedScriptWitnesses =
[ (policyId, pure . (assetName',quantity,) <$> substitutedWitness)
| (ix, policyId, assetName', quantity, BuildTxWith witness) <- txMintValueToIndexed txMintValue'
, let substitutedWitness = BuildTxWith <$> substituteExecUnits ix witness
]
final <- Map.fromListWith (<>) <$> traverseScriptWitnesses mappedScriptWitnesses
pure $ TxMintValue w final

traverseScriptWitnesses
:: [(a, Either (TxBodyErrorAutoBalance era) (ScriptWitness ctx era))]
-> Either (TxBodyErrorAutoBalance era) [(a, ScriptWitness ctx era)]
:: [(a, Either (TxBodyErrorAutoBalance era) b)]
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This may be "neater" Haskell but making this more generic doesn't really help the reader IMO. Also it's only instantiated to ScriptWitness ctx era.

Copy link
Contributor Author

@carbolymer carbolymer Nov 12, 2024 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It's not only instantiated to ScriptWitness ctx era - in line 1629 it is used against

        [ (Value, Either (TxBodyErrorAutoBalance era)
          ( AssetName
          , Quantity
          , BuildTxWith build (ScriptWitness WitCtxMint era)
          )
        ]

So the previous function type won't work.

-> Either (TxBodyErrorAutoBalance era) [(a, b)]
traverseScriptWitnesses =
traverse (\(item, eScriptWitness) -> eScriptWitness >>= (\sWit -> Right (item, sWit)))
traverse (\(item, eRes) -> eRes >>= (\res -> Right (item, res)))

calculateMinimumUTxO
:: ShelleyBasedEra era
Expand Down
126 changes: 59 additions & 67 deletions cardano-api/internal/Cardano/Api/Script.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
Expand Down Expand Up @@ -47,25 +48,27 @@ module Cardano.Api.Script
-- * Reference scripts
, ReferenceScript (..)
, refScriptToShelleyScript
, getScriptWitnessReferenceInput

-- * Use of a script in an era as a witness
, WitCtxTxIn
, WitCtxMint
, WitCtxStake
, WitCtx (..)
, ScriptWitness (..)
, getScriptWitnessReferenceInput
, getScriptWitnessScript
, getScriptWitnessReferenceInputOrScript
, Witness (..)
, KeyWitnessInCtx (..)
, ScriptWitnessInCtx (..)
, IsScriptWitnessInCtx (..)
, ScriptDatum (..)
, ScriptRedeemer
, scriptWitnessScript

-- ** Languages supported in each era
, ScriptLanguageInEra (..)
, scriptLanguageSupportedInEra
, sbeToSimpleScriptLanguageInEra
, languageOfScriptLanguageInEra
, eraOfScriptLanguageInEra

Expand Down Expand Up @@ -228,7 +231,8 @@ instance HasTypeProxy PlutusScriptV3 where
--
data ScriptLanguage lang where
SimpleScriptLanguage :: ScriptLanguage SimpleScript'
PlutusScriptLanguage :: PlutusScriptVersion lang -> ScriptLanguage lang
PlutusScriptLanguage
:: IsPlutusScriptLanguage lang => PlutusScriptVersion lang -> ScriptLanguage lang

deriving instance (Eq (ScriptLanguage lang))

Expand Down Expand Up @@ -285,7 +289,8 @@ instance Bounded AnyScriptLanguage where

data AnyPlutusScriptVersion where
AnyPlutusScriptVersion
:: PlutusScriptVersion lang
:: IsPlutusScriptLanguage lang
=> PlutusScriptVersion lang
-> AnyPlutusScriptVersion

deriving instance (Show AnyPlutusScriptVersion)
Expand Down Expand Up @@ -407,7 +412,8 @@ data Script lang where
:: !SimpleScript
-> Script SimpleScript'
PlutusScript
:: !(PlutusScriptVersion lang)
:: IsPlutusScriptLanguage lang
=> !(PlutusScriptVersion lang)
-> !(PlutusScript lang)
-> Script lang

Expand Down Expand Up @@ -576,18 +582,8 @@ scriptLanguageSupportedInEra
-> Maybe (ScriptLanguageInEra lang era)
scriptLanguageSupportedInEra era lang =
case (era, lang) of
(ShelleyBasedEraShelley, SimpleScriptLanguage) ->
Just SimpleScriptInShelley
(ShelleyBasedEraAllegra, SimpleScriptLanguage) ->
Just SimpleScriptInAllegra
(ShelleyBasedEraMary, SimpleScriptLanguage) ->
Just SimpleScriptInMary
(ShelleyBasedEraAlonzo, SimpleScriptLanguage) ->
Just SimpleScriptInAlonzo
(ShelleyBasedEraBabbage, SimpleScriptLanguage) ->
Just SimpleScriptInBabbage
(ShelleyBasedEraConway, SimpleScriptLanguage) ->
Just SimpleScriptInConway
(sbe, SimpleScriptLanguage) ->
Just $ sbeToSimpleScriptLanguageInEra sbe
(ShelleyBasedEraAlonzo, PlutusScriptLanguage PlutusScriptV1) ->
Just PlutusScriptV1InAlonzo
(ShelleyBasedEraBabbage, PlutusScriptLanguage PlutusScriptV1) ->
Expand Down Expand Up @@ -620,23 +616,33 @@ languageOfScriptLanguageInEra langInEra =
PlutusScriptV2InConway -> PlutusScriptLanguage PlutusScriptV2
PlutusScriptV3InConway -> PlutusScriptLanguage PlutusScriptV3

sbeToSimpleScriptLanguageInEra
:: ShelleyBasedEra era
-> ScriptLanguageInEra SimpleScript' era
sbeToSimpleScriptLanguageInEra = \case
ShelleyBasedEraShelley -> SimpleScriptInShelley
ShelleyBasedEraAllegra -> SimpleScriptInAllegra
ShelleyBasedEraMary -> SimpleScriptInMary
ShelleyBasedEraAlonzo -> SimpleScriptInAlonzo
ShelleyBasedEraBabbage -> SimpleScriptInBabbage
ShelleyBasedEraConway -> SimpleScriptInConway

eraOfScriptLanguageInEra
:: ScriptLanguageInEra lang era
-> ShelleyBasedEra era
eraOfScriptLanguageInEra langInEra =
case langInEra of
SimpleScriptInShelley -> ShelleyBasedEraShelley
SimpleScriptInAllegra -> ShelleyBasedEraAllegra
SimpleScriptInMary -> ShelleyBasedEraMary
SimpleScriptInAlonzo -> ShelleyBasedEraAlonzo
SimpleScriptInBabbage -> ShelleyBasedEraBabbage
SimpleScriptInConway -> ShelleyBasedEraConway
PlutusScriptV1InAlonzo -> ShelleyBasedEraAlonzo
PlutusScriptV1InBabbage -> ShelleyBasedEraBabbage
PlutusScriptV1InConway -> ShelleyBasedEraConway
PlutusScriptV2InBabbage -> ShelleyBasedEraBabbage
PlutusScriptV2InConway -> ShelleyBasedEraConway
PlutusScriptV3InConway -> ShelleyBasedEraConway
eraOfScriptLanguageInEra = \case
SimpleScriptInShelley -> ShelleyBasedEraShelley
SimpleScriptInAllegra -> ShelleyBasedEraAllegra
SimpleScriptInMary -> ShelleyBasedEraMary
SimpleScriptInAlonzo -> ShelleyBasedEraAlonzo
SimpleScriptInBabbage -> ShelleyBasedEraBabbage
SimpleScriptInConway -> ShelleyBasedEraConway
PlutusScriptV1InAlonzo -> ShelleyBasedEraAlonzo
PlutusScriptV1InBabbage -> ShelleyBasedEraBabbage
PlutusScriptV1InConway -> ShelleyBasedEraConway
PlutusScriptV2InBabbage -> ShelleyBasedEraBabbage
PlutusScriptV2InConway -> ShelleyBasedEraConway
PlutusScriptV3InConway -> ShelleyBasedEraConway

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

data SimpleScriptOrReferenceInput lang
= SScript SimpleScript
| SReferenceScript TxIn (Maybe ScriptHash)
| SReferenceScript TxIn
deriving (Eq, Show)

getScriptWitnessReferenceInput :: ScriptWitness witctx era -> Maybe TxIn
getScriptWitnessReferenceInput (SimpleScriptWitness _ (SReferenceScript txIn _)) =
Just txIn
getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PReferenceScript txIn _) _ _ _) =
Just txIn
getScriptWitnessReferenceInput (SimpleScriptWitness _ (SScript _)) = Nothing
getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PScript _) _ _ _) = Nothing

-- | A /use/ of a script within a transaction body to witness that something is
-- being used in an authorised manner. That can be
--
Expand All @@ -721,7 +714,8 @@ data ScriptWitness witctx era where
-> SimpleScriptOrReferenceInput SimpleScript'
-> ScriptWitness witctx era
PlutusScriptWitness
:: ScriptLanguageInEra lang era
:: IsPlutusScriptLanguage lang
=> ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScriptOrReferenceInput lang
-> ScriptDatum witctx
Expand Down Expand Up @@ -782,28 +776,26 @@ deriving instance Eq (ScriptDatum witctx)

deriving instance Show (ScriptDatum witctx)

-- We cannot always extract a script from a script witness due to reference scripts.
getScriptWitnessReferenceInput :: ScriptWitness witctx era -> Maybe TxIn
getScriptWitnessReferenceInput = either (const Nothing) Just . getScriptWitnessReferenceInputOrScript

getScriptWitnessScript :: ScriptWitness witctx era -> Maybe (ScriptInEra era)
getScriptWitnessScript = either Just (const Nothing) . getScriptWitnessReferenceInputOrScript

-- | We cannot always extract a script from a script witness due to reference scripts.
-- Reference scripts exist in the UTxO, so without access to the UTxO we cannot
-- retrieve the script.
scriptWitnessScript :: ScriptWitness witctx era -> Maybe (ScriptInEra era)
scriptWitnessScript (SimpleScriptWitness SimpleScriptInShelley (SScript script)) =
Just $ ScriptInEra SimpleScriptInShelley (SimpleScript script)
scriptWitnessScript (SimpleScriptWitness SimpleScriptInAllegra (SScript script)) =
Just $ ScriptInEra SimpleScriptInAllegra (SimpleScript script)
scriptWitnessScript (SimpleScriptWitness SimpleScriptInMary (SScript script)) =
Just $ ScriptInEra SimpleScriptInMary (SimpleScript script)
scriptWitnessScript (SimpleScriptWitness SimpleScriptInAlonzo (SScript script)) =
Just $ ScriptInEra SimpleScriptInAlonzo (SimpleScript script)
scriptWitnessScript (SimpleScriptWitness SimpleScriptInBabbage (SScript script)) =
Just $ ScriptInEra SimpleScriptInBabbage (SimpleScript script)
scriptWitnessScript (SimpleScriptWitness SimpleScriptInConway (SScript script)) =
Just $ ScriptInEra SimpleScriptInConway (SimpleScript script)
scriptWitnessScript (PlutusScriptWitness langInEra version (PScript script) _ _ _) =
Just $ ScriptInEra langInEra (PlutusScript version script)
scriptWitnessScript (SimpleScriptWitness _ (SReferenceScript _ _)) =
Nothing
scriptWitnessScript (PlutusScriptWitness _ _ (PReferenceScript _ _) _ _ _) =
Nothing
-- So in the cases for script reference, the result contains @Right TxIn@.
getScriptWitnessReferenceInputOrScript :: ScriptWitness witctx era -> Either (ScriptInEra era) TxIn
getScriptWitnessReferenceInputOrScript = \case
SimpleScriptWitness (s :: (ScriptLanguageInEra SimpleScript' era)) (SScript script) ->
Left $ ScriptInEra s (SimpleScript script)
PlutusScriptWitness langInEra version (PScript script) _ _ _ ->
Left $ ScriptInEra langInEra (PlutusScript version script)
SimpleScriptWitness _ (SReferenceScript txIn) ->
Right txIn
PlutusScriptWitness _ _ (PReferenceScript txIn) _ _ _ ->
Right txIn

-- ----------------------------------------------------------------------------
-- The kind of witness to use, key (signature) or script
Expand Down
Loading
Loading