Skip to content

Commit

Permalink
wip
Browse files Browse the repository at this point in the history
  • Loading branch information
carbolymer committed Oct 31, 2024
1 parent 4619ac0 commit ef2b00c
Show file tree
Hide file tree
Showing 4 changed files with 66 additions and 57 deletions.
7 changes: 4 additions & 3 deletions cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs
Original file line number Diff line number Diff line change
Expand Up @@ -649,11 +649,12 @@ genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era)
genTxMintValue =
inEonForEra
(pure TxMintNone)
$ \supported ->
$ \w -> do
values <- Gen.list (Range.constant 1 10) (genValueForMinting w)
Gen.choice
[ pure TxMintNone
-- TODO write a generator for the last parameter of 'TxMintValue' constructor
, TxMintValue supported <$> genValueForMinting supported <*> return (pure mempty)
-- TODO write a generator for ScriptWitness and use it here
, pure $ TxMintValue w ((, undefined) <$> values) -- FIXME
]

genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era)
Expand Down
43 changes: 22 additions & 21 deletions cardano-api/internal/Cardano/Api/Fees.hs
Original file line number Diff line number Diff line change
Expand Up @@ -1353,10 +1353,10 @@ calculateChangeValue
:: ShelleyBasedEra era -> Value -> TxBodyContent build era -> Value
calculateChangeValue sbe incoming txbodycontent =
let outgoing = calculateCreatedUTOValue sbe txbodycontent
minted = case txMintValue txbodycontent of
mintedValues = case txMintValue txbodycontent of
TxMintNone -> mempty
TxMintValue _ v _ -> v
in mconcat [incoming, minted, negateValue outgoing]
TxMintValue _ vs -> fst <$> vs
in mconcat $ [incoming] <> mintedValues <> [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 @@ -1629,24 +1629,25 @@ substituteExecutionUnits
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
valueWitnesses
) = undefined

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

traverseScriptWitnesses
:: [(a, Either (TxBodyErrorAutoBalance era) (ScriptWitness ctx era))]
Expand Down
63 changes: 34 additions & 29 deletions cardano-api/internal/Cardano/Api/Tx/Body.hs
Original file line number Diff line number Diff line change
Expand Up @@ -1249,10 +1249,7 @@ data TxMintValue build era where
TxMintNone :: TxMintValue build era
TxMintValue
:: MaryEraOnwards era
-> Value
-> BuildTxWith
build
(Map PolicyId (ScriptWitness WitCtxMint era))
-> [(Value, BuildTxWith build (ScriptWitness WitCtxMint era))]
-> TxMintValue build era

deriving instance Eq (TxMintValue build era)
Expand Down Expand Up @@ -1829,7 +1826,7 @@ validateMintValue :: TxMintValue build era -> Either TxBodyError ()
validateMintValue txMintValue =
case txMintValue of
TxMintNone -> return ()
TxMintValue _ v _ -> guard (selectLovelace v == 0) ?! TxBodyMintAdaError
TxMintValue _ vs -> forM_ vs $ \(v, _) -> guard (selectLovelace v == 0) ?! TxBodyMintAdaError

inputIndexDoesNotExceedMax :: [(TxIn, a)] -> Either TxBodyError ()
inputIndexDoesNotExceedMax txIns =
Expand Down Expand Up @@ -2287,20 +2284,26 @@ fromLedgerTxMintValue
:: ShelleyBasedEra era
-> Ledger.TxBody (ShelleyLedgerEra era)
-> TxMintValue ViewTx era
fromLedgerTxMintValue sbe body =
case sbe of
ShelleyBasedEraShelley -> TxMintNone
ShelleyBasedEraAllegra -> TxMintNone
ShelleyBasedEraMary -> toMintValue body MaryEraOnwardsMary
ShelleyBasedEraAlonzo -> toMintValue body MaryEraOnwardsAlonzo
ShelleyBasedEraBabbage -> toMintValue body MaryEraOnwardsBabbage
ShelleyBasedEraConway -> toMintValue body MaryEraOnwardsConway
where
toMintValue txBody maInEra
| L.isZero mint = TxMintNone
| otherwise = TxMintValue maInEra (fromMaryValue mint) ViewTx
where
mint = MaryValue (Ledger.Coin 0) (txBody ^. L.mintTxBodyL)
fromLedgerTxMintValue sbe body = forEraInEon (toCardanoEra sbe) TxMintNone $ \w -> maryEraOnwardsConstraints w $ do
let mint = MaryValue (Ledger.Coin 0) (body ^. L.mintTxBodyL)
if L.isZero mint
then TxMintNone
else TxMintValue w [(fromMaryValue mint, ViewTx)]

-- TxMintValue w undefined
-- case sbe of
-- ShelleyBasedEraShelley -> TxMintNone
-- ShelleyBasedEraAllegra -> TxMintNone
-- ShelleyBasedEraMary -> toMintValue body MaryEraOnwardsMary
-- ShelleyBasedEraAlonzo -> toMintValue body MaryEraOnwardsAlonzo
-- ShelleyBasedEraBabbage -> toMintValue body MaryEraOnwardsBabbage
-- ShelleyBasedEraConway -> toMintValue body MaryEraOnwardsConway
-- where
-- toMintValue txBody maInEra
-- | L.isZero mint = TxMintNone
-- | otherwise = TxMintValue maInEra (fromMaryValue mint) ViewTx
-- where
-- mint = MaryValue (Ledger.Coin 0) (txBody ^. L.mintTxBodyL)

makeByronTransactionBody
:: ()
Expand Down Expand Up @@ -2417,9 +2420,10 @@ convMintValue :: TxMintValue build era -> MultiAsset StandardCrypto
convMintValue txMintValue =
case txMintValue of
TxMintNone -> mempty
TxMintValue _ v _ ->
case toMaryValue v of
MaryValue _ ma -> ma
TxMintValue _ vs ->
mconcat $ flip map vs $ \(v, _) ->
case toMaryValue v of
MaryValue _ ma -> ma

convExtraKeyWitnesses
:: TxExtraKeyWitnesses era -> Set (Shelley.KeyHash Shelley.Witness StandardCrypto)
Expand Down Expand Up @@ -3330,13 +3334,14 @@ collectTxBodyScriptWitnesses
:: TxMintValue BuildTx era
-> [(ScriptWitnessIndex, AnyScriptWitness era)]
scriptWitnessesMinting TxMintNone = []
scriptWitnessesMinting (TxMintValue _ value (BuildTxWith witnesses)) =
[ (ScriptWitnessIndexMint ix, AnyScriptWitness 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)
]
scriptWitnessesMinting (TxMintValue _ _vw) = undefined
-- FIXME
-- [ (ScriptWitnessIndexMint ix, AnyScriptWitness 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)
-- ]

scriptWitnessesVoting
:: TxVotingProcedures BuildTx era
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -83,8 +83,9 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr
let txMint =
TxMintValue
meo
[(AssetId policyId' "eeee", 1)]
(BuildTxWith [(policyId', plutusWitness)])
undefined
-- [(AssetId policyId' "eeee", 1)]
-- (BuildTxWith [(policyId', plutusWitness)])

-- tx body content without an asset in TxOut
let content =
Expand Down Expand Up @@ -167,8 +168,9 @@ prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $
let txMint =
TxMintValue
meo
[(AssetId policyId' "eeee", 1)]
(BuildTxWith [(policyId', plutusWitness)])
undefined
-- [(AssetId policyId' "eeee", 1)]
-- (BuildTxWith [(policyId', plutusWitness)])

let content =
defaultTxBodyContent sbe
Expand Down

0 comments on commit ef2b00c

Please sign in to comment.