Initial lexer and parser for specifying Mary multi assets via the cli

cardano-cli/cardano-cli.cabal

@@ -59,6 +59,9 @@ library
                        Cardano.CLI.Shelley.Run.TextView
                        Cardano.CLI.Shelley.Run.Transaction
 
+                       Cardano.CLI.Mary.TxOutParser
+                       Cardano.CLI.Mary.ValueParser
+
                        Cardano.CLI.TopHandler
 
   other-modules:       Paths_cardano_cli
@@ -81,7 +84,6 @@ library
                      , cardano-crypto-wrapper
                      , cardano-ledger
                      , cardano-ledger-shelley-ma
-                     -- TODO: We shouldn't be forced to import "cardano-node". Fix this.
                      , cardano-node
                      , cardano-prelude
                      , cardano-slotting
@@ -106,6 +108,7 @@ library
                      , ouroboros-consensus-shelley
                      , ouroboros-network
                      , primitive
+                     , parsec
                      , process
                      , scientific
                      , shelley-spec-ledger
@@ -170,6 +173,8 @@ test-suite cardano-cli-test
                       , base16-bytestring
                       , cardano-api
                       , cardano-cli
+                      , cardano-crypto-class
+                      , cardano-ledger-shelley-ma
                       , cardano-node
                       , cardano-prelude
                       , containers
@@ -180,15 +185,21 @@ test-suite cardano-cli-test
                       , hedgehog-extras
                       , lifted-base
                       , optparse-applicative
+                      , ouroboros-consensus-shelley
+                      , parsec
                       , process
+                      , shelley-spec-ledger
+                      , shelley-spec-ledger-test
                       , temporary
                       , text
                       , time
                       , transformers-except
                       , unordered-containers
 
   other-modules:        Test.Cli.FilePermissions
+                        -- Test.Cli.Gen
                         Test.Cli.ITN
+                        -- Test.Cli.MultiAssetParsing
                         Test.Cli.Pioneers.Exercise1
                         Test.Cli.Pioneers.Exercise2
                         Test.Cli.Pioneers.Exercise3

cardano-cli/src/Cardano/CLI/Mary/TxOutParser.hs

@@ -0,0 +1,46 @@
+module Cardano.CLI.Mary.TxOutParser
+  ( parseTxOutAnyEra
+  ) where
+
+import           Prelude
+
+import           Data.Char (isAsciiLower, isAsciiUpper, isDigit)
+import           Data.Text (Text)
+import qualified Data.Text as Text
+
+import           Control.Applicative (some)
+import           Text.Parsec (satisfy, option, (<?>))
+import           Text.Parsec.Char (char, spaces)
+import           Text.Parsec.String (Parser)
+
+import           Cardano.API (AddressAny (..), AsType (..), deserialiseAddress)
+import           Cardano.CLI.Types (TxOutAnyEra (..))
+import           Cardano.CLI.Mary.ValueParser (parseValue)
+
+
+parseTxOutAnyEra :: Parser TxOutAnyEra
+parseTxOutAnyEra = do
+    addr <- parseAddressAny
+    spaces
+    -- Accept the old style of separating the address and value in a
+    -- transaction output:
+    option () (char '+' >> spaces)
+    TxOutAnyEra addr <$> parseValue
+
+parseAddressAny :: Parser AddressAny
+parseAddressAny = do
+  str <- plausibleAddressString <?> "address"
+  case deserialiseAddress AsAddressAny str of
+    Nothing -> fail "expecting valid address"
+    Just addr -> pure addr
+
+plausibleAddressString :: Parser Text
+plausibleAddressString =
+    Text.pack <$> some (satisfy isPlausibleAddressChar)
+  where
+    -- Covers both base58 and bech32 (with constrained prefixes)
+    isPlausibleAddressChar c =
+      isAsciiLower c
+        || isAsciiUpper c
+        || isDigit c
+        || c == '_'

cardano-cli/src/Cardano/CLI/Mary/ValueParser.hs

@@ -0,0 +1,166 @@
+module Cardano.CLI.Mary.ValueParser
+  ( parseValue
+  ) where
+
+import           Prelude
+
+import qualified Data.Char as Char
+import           Data.Functor (void, ($>))
+import           Data.List (foldl')
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import           Data.Word (Word64)
+
+import           Control.Applicative (some, (<|>))
+
+import           Text.Parsec as Parsec (notFollowedBy, try, (<?>))
+import           Text.Parsec.Char (alphaNum, char, digit, hexDigit, space, spaces, string)
+import           Text.Parsec.Expr (Assoc (..), Operator (..), buildExpressionParser)
+import           Text.Parsec.String (Parser)
+import           Text.ParserCombinators.Parsec.Combinator (many1)
+
+import           Cardano.Api.Typed
+
+-- | Parse a 'Value' from its string representation.
+parseValue :: Parser Value
+parseValue = evalValueExpr <$> parseValueExpr
+
+-- | Evaluate a 'ValueExpr' and construct a 'Value'.
+evalValueExpr :: ValueExpr -> Value
+evalValueExpr vExpr =
+  case vExpr of
+    ValueExprAdd x y -> evalValueExpr x <> evalValueExpr y
+    ValueExprNegate x -> negateValue (evalValueExpr x)
+    ValueExprLovelace quant -> valueFromList [(AdaAssetId, quant)]
+    ValueExprMultiAsset polId aName quant ->
+      valueFromList [(AssetId polId aName , quant)]
+
+
+------------------------------------------------------------------------------
+-- Expression parser
+------------------------------------------------------------------------------
+
+-- | Intermediate representation of a parsed multi-asset value.
+data ValueExpr
+  = ValueExprAdd !ValueExpr !ValueExpr
+  | ValueExprNegate !ValueExpr
+  | ValueExprLovelace !Quantity
+  | ValueExprMultiAsset !PolicyId !AssetName !Quantity
+  deriving (Eq, Ord, Show)
+
+parseValueExpr :: Parser ValueExpr
+parseValueExpr =
+    buildExpressionParser operatorTable valueExprTerm
+      <?> "multi-asset value expression"
+  where
+    operatorTable =
+      [ [Prefix negateOp]
+      , [Infix  plusOp AssocLeft]
+      ]
+
+-- | Parse either a 'ValueExprLovelace' or 'ValueExprMultiAsset'.
+valueExprTerm :: Parser ValueExpr
+valueExprTerm = do
+    q <- try quantity <?> "quantity (word64)"
+    aId <- try assetIdUnspecified <|> assetIdSpecified <?> "asset id"
+    _ <- spaces
+    pure $ case aId of
+      AdaAssetId -> ValueExprLovelace q
+      AssetId polId aName -> ValueExprMultiAsset polId aName q
+  where
+    -- Parse an asset ID which must be lead by one or more whitespace
+    -- characters and may be trailed by whitespace characters.
+    assetIdSpecified :: Parser AssetId
+    assetIdSpecified = some space *> assetId
+
+    -- Default for if an asset ID is not specified.
+    assetIdUnspecified :: Parser AssetId
+    assetIdUnspecified =
+      spaces
+        *> notFollowedBy alphaNum
+        $> AdaAssetId
+
+------------------------------------------------------------------------------
+-- Primitive parsers
+------------------------------------------------------------------------------
+
+plusOp :: Parser (ValueExpr -> ValueExpr -> ValueExpr)
+plusOp = (char '+' *> spaces) $> ValueExprAdd
+
+negateOp :: Parser (ValueExpr -> ValueExpr)
+negateOp = (char '-' *> spaces) $> ValueExprNegate
+
+-- | Period (\".\") parser.
+period :: Parser ()
+period = void $ char '.'
+
+-- | Word64 parser.
+word64 :: Parser Integer
+word64 = do
+  i <- decimal
+  if i > fromIntegral (maxBound :: Word64)
+    then
+      fail $
+        "expecting word64, but the number exceeds the max bound: " <> show i
+    else return i
+
+decimal :: Parser Integer
+decimal = do
+    digits <- many1 digit
+    return $! foldl' (\x d -> 10*x + toInteger (Char.digitToInt d)) 0 digits
+
+-- | Asset name parser.
+assetName :: Parser AssetName
+assetName =
+    toAssetName <$> some alphaNum
+  where
+    toAssetName = AssetName . Text.encodeUtf8 . Text.pack
+
+-- | Policy ID parser.
+policyId :: Parser PolicyId
+policyId = do
+  hexText <- many1 hexDigit
+  case textToPolicyId hexText of
+    Just p -> pure p
+    Nothing ->
+      fail $ "expecting a 56 hex-encoded policy ID, but found only "
+          ++ show (length hexText) ++ " hex digits"
+  where
+    textToPolicyId =
+        fmap PolicyId
+      . deserialiseFromRawBytesHex AsScriptHash
+      . Text.encodeUtf8
+      . Text.pack
+
+-- | Asset ID parser.
+assetId :: Parser AssetId
+assetId =
+    try adaAssetId
+      <|> nonAdaAssetId
+      <?> "asset ID"
+  where
+    -- Parse the ADA asset ID.
+    adaAssetId :: Parser AssetId
+    adaAssetId = string "lovelace" $> AdaAssetId
+
+    -- Parse a multi-asset ID.
+    nonAdaAssetId :: Parser AssetId
+    nonAdaAssetId = do
+      polId <- policyId
+      fullAssetId polId <|> assetIdNoAssetName polId
+
+    -- Parse a fully specified multi-asset ID with both a policy ID and asset
+    -- name.
+    fullAssetId :: PolicyId -> Parser AssetId
+    fullAssetId polId = do
+      _ <- period
+      aName <- assetName <?> "alphanumeric asset name"
+      pure (AssetId polId aName)
+
+    -- Parse a multi-asset ID that specifies a policy ID, but no asset name.
+    assetIdNoAssetName :: PolicyId -> Parser AssetId
+    assetIdNoAssetName polId = pure (AssetId polId "")
+
+-- | Quantity (word64) parser.
+quantity :: Parser Quantity
+quantity = fmap Quantity word64

cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs

@@ -16,10 +16,12 @@ module Cardano.CLI.Shelley.Parsers
 import           Cardano.Prelude hiding (All, Any, option)
 import           Prelude (String)
 
-import           Cardano.Api.Typed hiding (PoolId)
 import           Cardano.Api.Protocol (Protocol (..))
+import           Cardano.Api.Typed hiding (PoolId)
 
 import           Cardano.Chain.Slotting (EpochSlots (..))
+import           Cardano.CLI.Mary.TxOutParser (parseTxOutAnyEra)
+import           Cardano.CLI.Mary.ValueParser (parseValue)
 import           Cardano.CLI.Shelley.Commands
 import           Cardano.CLI.Shelley.Key (InputFormat (..), VerificationKeyOrFile (..),
                      VerificationKeyOrHashOrFile (..), VerificationKeyTextOrFile (..),
@@ -33,15 +35,20 @@ import           Network.Socket (PortNumber)
 import           Options.Applicative hiding (str)
 import           Ouroboros.Consensus.BlockchainTime (SystemStart (..))
 
-import qualified Data.Attoparsec.ByteString.Char8 as Atto
 import qualified Data.ByteString.Char8 as BSC
 import qualified Data.Char as Char
 import qualified Data.IP as IP
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
+
 import qualified Options.Applicative as Opt
+import qualified Data.Attoparsec.ByteString.Char8 as Atto
+import qualified Text.Parsec as Parsec
+import qualified Text.Parsec.String as Parsec
+import qualified Text.Parsec.Error  as Parsec
+
 import qualified Shelley.Spec.Ledger.BaseTypes as Shelley
 import qualified Shelley.Spec.Ledger.TxBody as Shelley
 
@@ -1551,35 +1558,24 @@ parseTxIx = toEnum <$> Atto.decimal
 
 pTxOut :: Parser TxOutAnyEra
 pTxOut =
-  Opt.option (readerFromAttoParser parseTxOut)
-    (  Opt.long "tx-out"
-    <> Opt.metavar "TX-OUT"
-    <> Opt.help "The transaction output as Address+Lovelace where Address is \
-                \the Bech32-encoded address followed by the amount in \
-                \Lovelace."
-    )
-  where
-    parseTxOut :: Atto.Parser TxOutAnyEra
-    parseTxOut =
-      TxOutAnyEra <$> parseAddressAny
-                  <*  Atto.char '+'
-                  <*> pAdaOnlyValue
-
-pAdaOnlyValue :: Atto.Parser Value
-pAdaOnlyValue = lovelaceToValue <$> parseLovelace
+    Opt.option (readerFromParsecParser parseTxOutAnyEra)
+      (  Opt.long "tx-out"
+      <> Opt.metavar "TX-OUT"
+      -- TODO: Update the help text to describe the new syntax as well.
+      <> Opt.help "The transaction output as Address+Lovelace where Address is \
+                  \the Bech32-encoded address followed by the amount in \
+                  \Lovelace."
+      )
 
 pMintMultiAsset :: Parser Value
 pMintMultiAsset =
   Opt.option
-    (Opt.eitherReader readValue)
+    (readerFromParsecParser parseValue)
       (  Opt.long "mint"
       <> Opt.metavar "VALUE"
       <> Opt.help "Mint multi-asset value(s) with the multi-asset cli syntax"
       )
 
-readValue :: String -> Either String Value
-readValue _maCliSyntax = Left "Need 2072 for MA cli syntax parser"
-
 pTxLowerBound :: Parser SlotNo
 pTxLowerBound =
   SlotNo <$>
@@ -2424,3 +2420,16 @@ readRational = toRational <$> readerFromAttoParser Atto.scientific
 readerFromAttoParser :: Atto.Parser a -> Opt.ReadM a
 readerFromAttoParser p =
     Opt.eitherReader (Atto.parseOnly (p <* Atto.endOfInput) . BSC.pack)
+
+readerFromParsecParser :: Parsec.Parser a -> Opt.ReadM a
+readerFromParsecParser p =
+    Opt.eitherReader (first formatError . Parsec.parse (p <* Parsec.eof) "")
+  where
+    --TODO: the default parsec error formatting is quite good, but we could
+    -- customise it somewhat:
+    formatError err =
+      Parsec.showErrorMessages "or" "unknown parse error"
+                               "expecting" "unexpected" "end of input"
+                               (Parsec.errorMessages err)
+
+

cardano-cli/src/Cardano/CLI/Types.hs

@@ -90,4 +90,3 @@ data SigningKeyOrScriptFile = ScriptFileForWitness FilePath
 --
 data TxOutAnyEra = TxOutAnyEra AddressAny Value
   deriving (Eq, Show)
-