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

Jump to bottom

Parameterize Value parser on role of the Value being parsed: transaction output or minting policy #666

Merged
merged 2 commits into from
Nov 6, 2024
Merged

Parameterize Value parser on role of the Value being parsed: transaction output or minting policy #666

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
dae49f1
Parameterize Value parser on role of the Value being parsed
smelc Oct 29, 2024
273e276
ValueParser: expose new functions that avoid using the role
smelc Nov 5, 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
40 changes: 27 additions & 13 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
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
Expand Down Expand Up @@ -98,6 +99,7 @@ module Test.Gen.Cardano.Api.Typed
, genPositiveLovelace
, genValue
, genValueDefault
, genValueForRole
, genVerificationKey
, genVerificationKeyHash
, genUpdateProposal
Expand Down Expand Up @@ -160,7 +162,7 @@ import Data.Maybe
import Data.Ratio (Ratio, (%))
import Data.String
import Data.Word (Word16, Word32, Word64)
import GHC.Exts (IsList(..))
import GHC.Exts (IsList (..))
import GHC.Stack
import Numeric.Natural (Natural)

Expand Down Expand Up @@ -375,25 +377,37 @@ genUnsignedQuantity = genQuantity (Range.constant 0 2)
genPositiveQuantity :: Gen Quantity
genPositiveQuantity = genQuantity (Range.constant 1 2)

genValue
:: MaryEraOnwards era -> Gen AssetId -> Gen Quantity -> Gen (L.Value (ShelleyLedgerEra era))
genValue w genAId genQuant =
toLedgerValue w . valueFromList
<$> Gen.list
genValue :: Gen AssetId -> Gen Quantity -> Gen Value
genValue genAId genQuant =
valueFromList <$> Gen.list
(Range.constant 0 10)
((,) <$> genAId <*> genQuant)

genLedgerValue
:: MaryEraOnwards era -> Gen AssetId -> Gen Quantity -> Gen (L.Value (ShelleyLedgerEra era))
genLedgerValue w genAId genQuant =
toLedgerValue w <$> genValue genAId genQuant

-- | Generate a 'Value' with any asset ID and a positive or negative quantity.
genValueDefault :: MaryEraOnwards era -> Gen (L.Value (ShelleyLedgerEra era))
genValueDefault w = genValue w genAssetId genSignedNonZeroQuantity
genValueDefault w = genLedgerValue w genAssetId genSignedNonZeroQuantity

genValueForRole :: MaryEraOnwards era -> ValueRole -> Gen Value
genValueForRole w =
\case
RoleMint ->
genValueForMinting
RoleUTxO ->
fromLedgerValue sbe <$> genValueForTxOut sbe
where
sbe = maryEraOnwardsToShelleyBasedEra w

-- | Generate a 'Value' suitable for minting, i.e. non-ADA asset ID and a
-- positive or negative quantity.
genValueForMinting :: MaryEraOnwards era -> Gen Value
genValueForMinting w =
fromLedgerValue sbe <$> genValue w genAssetIdNoAda genSignedNonZeroQuantity
genValueForMinting :: Gen Value
genValueForMinting =
genValue genAssetIdNoAda genSignedNonZeroQuantity
where
sbe = maryEraOnwardsToShelleyBasedEra w
genAssetIdNoAda :: Gen AssetId
genAssetIdNoAda = AssetId <$> genPolicyId <*> genAssetName

Expand All @@ -409,7 +423,7 @@ genValueForTxOut sbe = do
caseShelleyToAllegraOrMaryEraOnwards
(const (pure ada))
( \w -> do
v <- Gen.list (Range.constant 0 5) $ genValue w genAssetId genPositiveQuantity
v <- Gen.list (Range.constant 0 5) $ genLedgerValue w genAssetId genPositiveQuantity
pure $ ada <> mconcat v
)
sbe
Expand Down Expand Up @@ -653,7 +667,7 @@ genTxMintValue =
Gen.choice
[ pure TxMintNone
-- TODO write a generator for the last parameter of 'TxMintValue' constructor
, TxMintValue supported <$> genValueForMinting supported <*> return (pure mempty)
, TxMintValue supported <$> genValueForMinting <*> return (pure mempty)
]

genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era)
Expand Down
5 changes: 5 additions & 0 deletions cardano-api/internal/Cardano/Api/Value.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -22,6 +22,7 @@ module Cardano.Api.Value
, valueFromList
, valueToList
, filterValue
, allPositive
, negateValue
, negateLedgerValue
, calcMinimumDeposit
Expand Down Expand Up @@ -239,6 +240,10 @@ valueFromList = fromList
valueToList :: Value -> [(AssetId, Quantity)]
valueToList = toList

-- | Check if the 'Value' consists of /only/ positive quantities.
allPositive :: Value -> Bool
allPositive (Value m) = all (>= 0) (Map.elems m)

-- | This lets you write @a - b@ as @a <> negateValue b@.
negateValue :: Value -> Value
negateValue (Value m) = Value (Map.map negate m)
Expand Down
49 changes: 45 additions & 4 deletions cardano-api/internal/Cardano/Api/ValueParser.hs
View file
Open in desktop
Copy link
Contributor

@carbolymer carbolymer Nov 4, 2024 •
edited
Loading

Choose a reason for hiding this comment

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

In line 67, there's a case match:

ValueExprMultiAsset polId aName quant -> [(AssetId polId aName, quant)]

could you provide a parser

Parser (PolicyId, AssetName, Quantity)

?

(It could be also Parser [(PolicyId, AssetName, Quantity)] - whatever is more convenient here).

That would be very useful for parsing values for minting.

This can be done in a follow up PR.

Copy link
Contributor

Choose a reason for hiding this comment

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

If you don't plan to work on it, I can implement that after you finish your work.

Copy link
Contributor Author

Choose a reason for hiding this comment

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

@carbolymer> I want to have @Jimbo4350's feedback before amending this PR.

Copy link
Contributor

@Jimbo4350 Jimbo4350 Nov 4, 2024 •
edited
Loading

Choose a reason for hiding this comment

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

I was thinking of a change like this: master...jordan/delete-me-value-parser-test

ghci> parse parseMintingMultiAssetValue "" "-5 51936f3c98a04b6609aa9b5c832ba1182cf43a58e534fcc05db09d69.4D696C6C6172436F696E"
Right (valueFromList [(AssetId "51936f3c98a04b6609aa9b5c832ba1182cf43a58e534fcc05db09d69" "MillarCoin",-5)])
ghci> parse  parseTxOutMultiAssetValue "" "-5 51936f3c98a04b6609aa9b5c832ba1182cf43a58e534fcc05db09d69.4D696C6C6172436F696E"
Left (line 1, column 1):
unexpected "-"
expecting multi-asset value expression

We could customize the error message if need be.

Copy link
Contributor Author

Choose a reason for hiding this comment

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

@Jimbo4350> the problem with the approach consisting of restricting the operators is that it forbids sums whose total is positive, but that contain negative operands (as tested in this test: https://github.com/IntersectMBO/cardano-cli/blob/43137957a2e943bf9873718f1c99591e8b54afd0/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Transaction/Build.hs#L93).

I checked with Modus Create's smart contracts auditing team and they reported that they see such uses.

So I kept my approach but added the new functions parseTxOutMultiAssetValue and parseMintingMultiAssetValue that you had shown.

Copy link
Contributor

@carbolymer carbolymer Nov 5, 2024 •
edited
Loading

Choose a reason for hiding this comment

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

@Jimbo4350

parseMintingMultiAssetValue :: Parser Value

My main problem with the parser is it's return type. Value is too broad for minting - you shouldn't be able to keep ADA there.

Copy link
Contributor

@carbolymer carbolymer Nov 5, 2024 •
edited
Loading

Choose a reason for hiding this comment

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

Regarding negative values in minting, I think we still need them for burning tokens. https://developers.cardano.org/docs/native-tokens/minting/#burning-token

Original file line number Diff line number Diff line change
Expand Up @@ -2,8 +2,12 @@

module Cardano.Api.ValueParser
( parseValue
, parseTxOutMultiAssetValue
, parseMintingMultiAssetValue
, parseUTxOValue
, assetName
, policyId
smelc marked this conversation as resolved.
Show resolved Hide resolved
, ValueRole (..)
)
where

Expand All @@ -13,6 +17,7 @@ import Cardano.Api.Utils (failEitherWith)
import Cardano.Api.Value

import Control.Applicative (many, some, (<|>))
import Control.Monad (unless, when)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Char as Char
import Data.Functor (void, ($>))
Expand All @@ -26,9 +31,45 @@ import Text.Parsec.Expr (Assoc (..), Operator (..), buildExpressionPar
import Text.Parsec.String (Parser)
import Text.ParserCombinators.Parsec.Combinator (many1)

-- | Parse a 'Value' from its string representation.
parseValue :: Parser Value
parseValue = evalValueExpr <$> parseValueExpr
-- | The role for which a 'Value' is being parsed.
data ValueRole
= -- | The value is used as a UTxO or transaction output.
RoleUTxO
| -- | The value is used as a minting policy.
RoleMint
deriving (Eq, Show, Enum, Bounded)

-- | Parse a 'Value' from its string representation. The @role@ argument for which purpose
-- the value is being parsed. This is used to enforce additional constraints on the value.
-- Why do we parse a general value and check for additional constraints you may ask?
carbolymer marked this conversation as resolved.
Show resolved Hide resolved
-- Because we can't rule out the negation operator
-- for transaction outputs: some users have negative values in additions, with the addition's total
-- summing up to a positive value. So forbidding negations altogether is too restrictive.
parseValue :: ValueRole -> Parser Value
parseValue role = do
valueExpr <- parseValueExpr
let value = evalValueExpr valueExpr
case role of
RoleUTxO -> do
unless (allPositive value) $
fail $
"Value must be positive in UTxO (or transaction output): " <> show value
return value
RoleMint -> do
let (Coin lovelace) = selectLovelace value
when (lovelace /= 0) $
fail $
"Lovelace must be zero in minting value: " <> show value
return value

parseTxOutMultiAssetValue :: Parser Value
parseTxOutMultiAssetValue = parseValue RoleUTxO

parseMintingMultiAssetValue :: Parser Value
parseMintingMultiAssetValue = parseValue RoleMint

parseUTxOValue :: Parser Value
parseUTxOValue = parseValue RoleUTxO

-- | Evaluate a 'ValueExpr' and construct a 'Value'.
evalValueExpr :: ValueExpr -> Value
Expand Down Expand Up @@ -170,6 +211,6 @@ assetId =
assetIdNoAssetName :: PolicyId -> Parser AssetId
assetIdNoAssetName polId = pure (AssetId polId "")

-- | Quantity (word64) parser.
-- | Quantity (word64) parser. Only accepts positive quantities.
quantity :: Parser Quantity
quantity = fmap Quantity word64
1 change: 1 addition & 0 deletions cardano-api/src/Cardano/Api.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -232,6 +232,7 @@ module Cardano.Api
, AssetName (..)
, AssetId (..)
, Value
, ValueRole (..)
, parseValue
, policyId
, selectAsset
Expand Down
16 changes: 9 additions & 7 deletions cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Value.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -14,35 +14,37 @@ import qualified Data.Text as Text
import GHC.Exts (IsList (..))
import qualified Text.Parsec as Parsec (parse)

import Test.Gen.Cardano.Api.Typed (genAssetName, genValueDefault, genValueNestedRep)
import Test.Gen.Cardano.Api.Typed (genAssetName, genValueDefault, genValueForRole,
genValueNestedRep)

import Hedgehog (Property, forAll, property, tripping, (===))
import qualified Hedgehog.Extras as H
import qualified Hedgehog.Extras.Test.Golden as H
import qualified Hedgehog.Gen as Gen

{- HLINT ignore "Use let" -}

hprop_roundtrip_Value_parse_render :: Property
hprop_roundtrip_Value_parse_render =
property $ do
ledgerValue <- forAll $ genValueDefault MaryEraOnwardsConway
let value = fromLedgerValue ShelleyBasedEraConway ledgerValue
valueRole <- forAll Gen.enumBounded
value <- forAll $ genValueForRole MaryEraOnwardsConway valueRole
H.noteShow_ value
tripping
value
renderValue
(Parsec.parse parseValue "" . Text.unpack)
(Parsec.parse (parseValue valueRole) "" . Text.unpack)

hprop_roundtrip_Value_parse_renderPretty :: Property
hprop_roundtrip_Value_parse_renderPretty =
property $ do
ledgerValue <- forAll $ genValueDefault MaryEraOnwardsConway
let value = fromLedgerValue ShelleyBasedEraConway ledgerValue
valueRole <- forAll Gen.enumBounded
value <- forAll $ genValueForRole MaryEraOnwardsConway valueRole
H.noteShow_ value
tripping
value
renderValuePretty
(Parsec.parse parseValue "" . Text.unpack)
(Parsec.parse (parseValue valueRole) "" . Text.unpack)

hprop_goldenValue_1_lovelace :: Property
hprop_goldenValue_1_lovelace =
Expand Down
Loading