diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 9f484b23bc..0af3991dcc 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -98,6 +99,7 @@ module Test.Gen.Cardano.Api.Typed , genPositiveLovelace , genValue , genValueDefault + , genValueForRole , genVerificationKey , genVerificationKeyHash , genUpdateProposal @@ -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) @@ -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 @@ -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 @@ -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) diff --git a/cardano-api/internal/Cardano/Api/Value.hs b/cardano-api/internal/Cardano/Api/Value.hs index 819e7eb336..070b4aba8e 100644 --- a/cardano-api/internal/Cardano/Api/Value.hs +++ b/cardano-api/internal/Cardano/Api/Value.hs @@ -22,6 +22,7 @@ module Cardano.Api.Value , valueFromList , valueToList , filterValue + , allPositive , negateValue , negateLedgerValue , calcMinimumDeposit @@ -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) diff --git a/cardano-api/internal/Cardano/Api/ValueParser.hs b/cardano-api/internal/Cardano/Api/ValueParser.hs index ada6c83bf1..340c4d1d9d 100644 --- a/cardano-api/internal/Cardano/Api/ValueParser.hs +++ b/cardano-api/internal/Cardano/Api/ValueParser.hs @@ -2,8 +2,12 @@ module Cardano.Api.ValueParser ( parseValue + , parseTxOutMultiAssetValue + , parseMintingMultiAssetValue + , parseUTxOValue , assetName , policyId + , ValueRole (..) ) where @@ -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, ($>)) @@ -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? +-- 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 @@ -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 diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index a261b89519..be93e8ac9c 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -232,6 +232,7 @@ module Cardano.Api , AssetName (..) , AssetId (..) , Value + , ValueRole (..) , parseValue , policyId , selectAsset diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Value.hs b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Value.hs index 9430e858af..67302304ea 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Value.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Value.hs @@ -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 =