Merge pull request #666 from IntersectMBO/smelc/split-value-parser

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

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)

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)

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

cardano-api/src/Cardano/Api.hs

@@ -232,6 +232,7 @@ module Cardano.Api
   , AssetName (..)
   , AssetId (..)
   , Value
+  , ValueRole (..)
   , parseValue
   , policyId
   , selectAsset

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 =