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

cardano-cli/cardano-cli.cabal

@@ -59,6 +59,8 @@ library
                        Cardano.CLI.Shelley.Run.TextView
                        Cardano.CLI.Shelley.Run.Transaction
 
+                       Cardano.CLI.Mary.Parser
+
                        Cardano.CLI.TopHandler
 
   other-modules:       Paths_cardano_cli
@@ -80,7 +82,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
@@ -103,6 +104,7 @@ library
                      , ouroboros-consensus-cardano
                      , ouroboros-consensus-shelley
                      , ouroboros-network
+                     , parsec
                      , process
                      , scientific
                      , shelley-spec-ledger
@@ -166,6 +168,8 @@ test-suite cardano-cli-test
                       , base16-bytestring
                       , cardano-api
                       , cardano-cli
+                      , cardano-crypto-class
+                      , cardano-ledger-shelley-ma
                       , cardano-node
                       , cardano-prelude
                       , containers
@@ -176,15 +180,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/Parser.hs

@@ -0,0 +1,205 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Cardano.CLI.Mary.Parser
+  ( Token (..)
+  , Tokens
+  , TParser
+  , addition
+  , calculateValue
+  , lexToken
+  , lexTokens
+  , preValueAddition
+  , preValueLovelace
+  , preValueMultiAsset
+  , preValueParser
+  , preValtoValue
+  , stringToValue
+  , textToPolicyId
+  , valueTokenFullySpecified
+  , valueTokenPidAndAssetId
+  , valueTokenPidOnly
+  ) where
+
+import           Cardano.Prelude hiding (try)
+import           Prelude (String, read)
+
+
+import           Control.Monad (fail)
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import           Text.Parsec (ParseError, Parsec, SourcePos, anyChar, getPosition, manyTill, parse,
+                     token, try, (<?>))
+import           Text.Parsec.Char (alphaNum, digit, hexDigit, letter, space, spaces, string)
+import           Text.Parsec.String (Parser)
+import           Text.ParserCombinators.Parsec.Combinator (eof, many1, notFollowedBy, sepBy1)
+
+import           Cardano.Crypto.Hash (hashFromStringAsHex)
+import           Cardano.Ledger.Mary (MaryEra)
+import           Cardano.Ledger.Mary.Value (AssetID (..), PolicyID (..), Value (..))
+import           Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
+import           Shelley.Spec.Ledger.Scripts (ScriptHash (..))
+
+{- HLINT ignore "Reduce duplication" -}
+
+stringToValue :: String -> Either ParseError (Value (MaryEra StandardCrypto))
+stringToValue input = calculateValue <$> fullParse input
+ where
+  fullParse :: String -> Either ParseError [PreValue]
+  fullParse str = parse lexTokens "" str >>= parse preValueParser ""
+
+calculateValue :: [PreValue] -> Value (MaryEra StandardCrypto)
+calculateValue = mconcat . map preValtoValue
+
+textToPolicyId :: Text -> PolicyID (MaryEra StandardCrypto)
+textToPolicyId hashText =
+  case hashFromStringAsHex $ Text.unpack hashText of
+    Just h -> PolicyID $ ScriptHash h
+    Nothing -> panic $ "PolicyId: " <> hashText <> " is not a hash."
+
+preValtoValue :: PreValue -> Value (MaryEra StandardCrypto)
+preValtoValue Addition = Value 0 mempty
+preValtoValue (Lovelace w64) = Value (toInteger w64) mempty
+preValtoValue (MultiAsset pId aId minted) =
+  let pId' = textToPolicyId pId
+      aId' = AssetID $ Text.encodeUtf8 aId
+  in Value 0 $ Map.singleton pId' (Map.singleton aId' minted)
+
+-- Parser
+
+type TParser a = Parsec Tokens () a
+
+data PreValue = Lovelace Word64
+              | MultiAsset Text Text Integer
+              -- ^ PolicyId AssetId AmountMinted
+              | Addition
+              deriving Show
+
+preValueParser :: TParser [PreValue]
+preValueParser = many1 (preValueLovelace <|> preValueMultiAsset <|> preValueAddition)
+
+tokenToTParser :: (Token -> Maybe a) -> TParser a
+tokenToTParser f =
+  token
+    (show . snd)
+    fst
+    $ \(_,t) -> f t
+
+preValueLovelace :: TParser PreValue
+preValueLovelace =
+  tokenToTParser (\t -> case t of
+                         LOVELACE n -> Just $ Lovelace n
+                         _ -> Nothing
+                 )
+
+preValueMultiAsset :: TParser PreValue
+preValueMultiAsset =
+  tokenToTParser (\t -> case t of
+                          MA pId aId aM -> Just $ MultiAsset pId aId aM
+                          _ -> Nothing
+                 )
+
+preValueAddition :: TParser PreValue
+preValueAddition =
+  tokenToTParser (\t -> case t of
+                          ADDITION -> Just Addition
+                          _ -> Nothing
+                 )
+
+-- Lexer
+
+type Tokens = [(SourcePos, Token)]
+
+data Token = LOVELACE Word64
+           | MA Text Text Integer
+           -- ^ ScriptHash AssetId AmountMinted
+           | ADDITION
+           | PERIOD
+           deriving (Eq, Ord, Show)
+
+lexTokens :: Parser Tokens
+lexTokens = spaces *> sepBy1 ((,) <$> getPosition <*> lexToken) spaces
+
+lexToken :: Parser Token
+lexToken =
+      try (lovelaceToken <?> "Expecting \"Word64 lovelace\"")
+  <|> (addition <?> "Expecting \"+\"")
+  <|> (valueToken <?> "Expecting \"INT hexidecimal.STRING\"")
+  <|> incorrectSyntax
+
+-- Primitive Token Lexers
+
+incorrectSyntax :: Parser Token
+incorrectSyntax = do
+  _ <- spaces
+  incorrect <- many alphaNum
+  _ <- manyTill anyChar eof
+  fail $ "Incorrect syntax: " <> incorrect
+       <> "\nExpecting \"Word64 lovelace\",\"+\" or \"INT hexidecimal.STRING\""
+
+period :: Parser Token
+period = PERIOD <$ string "."
+
+word64 :: Parser Word64
+word64 = do i <- integer
+            if i > fromIntegral (maxBound :: Word64)
+            then fail "Word64 max bound"
+            else return $ fromInteger i
+
+integer :: Parser Integer
+integer = do d <- many1 digit
+             notFollowedBy alphaNum
+             return $ read d
+
+lovelaceToken :: Parser Token
+lovelaceToken = do
+  w64 <- word64 <?> "Word64"
+  _ <- spaces
+  _ <- string "lovelace"
+  _ <- spaces
+  return $ LOVELACE w64
+
+valueToken :: Parser Token
+valueToken =
+      try valueTokenFullySpecified
+  <|> try valueTokenPidAndAssetId
+  <|> valueTokenPidOnly
+  <* spaces
+
+valueTokenFullySpecified :: Parser Token
+valueTokenFullySpecified = do
+  i <- try integer <?> "INT"
+  let minted = fromInteger i
+  _ <- spaces
+  pId <- scriptHash
+  _ <- period
+  assetId <- try $ many (letter <|> digit)
+  _ <- spaces
+  return $ MA pId (Text.pack assetId) minted
+
+valueTokenPidAndAssetId :: Parser Token
+valueTokenPidAndAssetId = do
+  pId <- scriptHash
+  _ <- period
+  notFollowedBy space
+  assetId <- many (letter <|> digit)
+  _ <- spaces <|> eof
+  notFollowedBy integer
+  return $ MA pId (Text.pack assetId) 1
+
+valueTokenPidOnly :: Parser Token
+valueTokenPidOnly = do
+  i <- try integer <?> "INT"
+  let minted = fromInteger i
+  _ <- spaces
+  pId <- scriptHash
+  notFollowedBy period
+  _ <- spaces
+  return $ MA pId (Text.pack "") minted
+
+scriptHash :: Parser Text
+scriptHash = Text.pack <$> many1 hexDigit
+
+addition :: Parser Token
+addition = (ADDITION <$ string "+") <* spaces
+

cardano-cli/test/Test/Cli/Gen.hs

@@ -0,0 +1,120 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Test.Cli.Gen where
+
+import           Cardano.Prelude
+
+import qualified Data.Map.Strict as Map
+import qualified Data.Text.Encoding as Text
+
+import           Cardano.CLI.Helpers (textShow)
+import           Cardano.CLI.Mary.Parser (Token (..), textToPolicyId)
+import           Cardano.Crypto.Hash (hashToTextAsHex)
+import           Cardano.Ledger.Mary (MaryEra)
+import           Cardano.Ledger.Mary.Value (AssetID (..), Value (..))
+import           Cardano.Ledger.ShelleyMA.Timelocks (Timelock (RequireAllOf), hashTimelockScript)
+import qualified Data.Sequence.Strict as Strict
+import           Hedgehog (Gen)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import           Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
+import qualified Shelley.Spec.Ledger.Scripts as Shelley
+
+-- Lexing Token Generators
+
+genVariableSpace :: Gen Text
+genVariableSpace = Gen.text (Range.constant 1 10) $ return ' '
+
+genLovelaceToken :: Gen (Text, Token)
+genLovelaceToken = do
+  w64 <- Gen.word64 Range.constantBounded
+  space1 <- genVariableSpace
+  space2 <- genVariableSpace
+  return (textShow w64 <> space1 <> "lovelace" <> space2, LOVELACE w64)
+
+genValueTokenFullySpecified :: Gen (Text, Token)
+genValueTokenFullySpecified = do
+  sHash <- genScriptHashMaryText
+  assetId <- Gen.text (Range.constant 1 15) Gen.alphaNum
+  (mintedText, minted) <- genMintedText
+  variableSpace <- genVariableSpace
+  return ( mintedText <> variableSpace <> sHash <> "." <> assetId <> variableSpace
+         , MA sHash assetId minted
+         )
+
+genValueTokenPidAndAssetId :: Gen (Text, Token)
+genValueTokenPidAndAssetId = do
+  sHash <- genScriptHashMaryText
+  assetId <- Gen.text (Range.constant 1 15) Gen.alphaNum
+  return ( sHash <> "." <> assetId
+         , MA sHash assetId 1
+         )
+
+genValueTokenPidOnly :: Gen (Text, Token)
+genValueTokenPidOnly = do
+  sHash <- genScriptHashMaryText
+  (mintedText, minted) <- genMintedText
+  variableSpace <- genVariableSpace
+  return ( mintedText <> variableSpace <> sHash
+         , MA sHash "" minted
+         )
+
+genValueTokens :: Gen [(Text, Token)]
+genValueTokens = do
+ valsFulSpec <- Gen.list (Range.constant 1 10) genValueTokenFullySpecified
+ valsPidAssetId <- Gen.list (Range.constant 1 10) genValueTokenPidAndAssetId
+ valsPidOnly <- Gen.list (Range.constant 1 10) genValueTokenPidOnly
+ return  $ valsFulSpec ++ valsPidAssetId ++ valsPidOnly
+
+genAdditionToken :: Gen (Text, Token)
+genAdditionToken = do spaces1 <- genVariableSpace
+                      return ("+" <> spaces1, ADDITION)
+
+genTokens :: Gen (Text, [Token])
+genTokens = do lovelaces <- Gen.list (Range.constant 1 10) genLovelaceToken
+               vals <- genValueTokens
+               let total = lovelaces ++ vals
+               additionTk <- genAdditionToken
+               return . sequence $ intersperse additionTk total
+
+genMintedText :: Gen (Text, Integer)
+genMintedText = do
+  let mBound = fromIntegral (maxBound :: Word64)
+  minted <- Gen.integral_ (Range.constant 1 mBound)
+  return $ (textShow minted, minted)
+
+-- Parsing Token Generators
+
+genValues :: Gen (Text, Value (MaryEra StandardCrypto))
+genValues = do lovelaces <- Gen.list (Range.constant 1 10) genLovelaceValue
+               vals <- Gen.list (Range.constant 1 10) genMultiAssetValue
+               add <- genAdditionValue
+               let total = lovelaces ++ vals
+               return . mconcat  $ intersperse add total
+
+genLovelaceValue :: Gen (Text, Value (MaryEra StandardCrypto))
+genLovelaceValue = do (input, LOVELACE w64) <- genLovelaceToken
+                      return (input, Value (toInteger w64) mempty)
+
+genMultiAssetValue :: Gen (Text, Value (MaryEra StandardCrypto))
+genMultiAssetValue = do vTkns <- genValueTokens
+                        (input, MA scriptH assetId minted) <- Gen.element vTkns
+                        let pId' = textToPolicyId scriptH
+                            aId' = AssetID $ Text.encodeUtf8 assetId
+                        return ( input
+                               , Value 0 (Map.singleton pId' (Map.singleton aId' minted))
+                               )
+
+genAdditionValue :: Gen (Text, Value (MaryEra StandardCrypto))
+genAdditionValue = do (input, ADDITION) <- genAdditionToken
+                      return (input, Value 0 mempty)
+
+genMaryScriptHash :: Gen (Shelley.ScriptHash (MaryEra StandardCrypto))
+genMaryScriptHash = return . hashTimelockScript $ RequireAllOf Strict.empty
+
+genScriptHashMaryText :: Gen Text
+genScriptHashMaryText = do Shelley.ScriptHash h <- genMaryScriptHash
+                           return $ hashToTextAsHex h
+