-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# OPTIONS_GHC -Wno-orphans #-}

-- | Utilities for parsing Morley types using @optparse-applicative@.

module Morley.CLI
  ( -- * Full parsers
    parserInfo
    -- * Options
  , contractFileOption
  , nowOption
  , levelOption
  , maxStepsOption
  , dbPathOption
  , txDataOption
  , keyHashOption
  , secretKeyOption
  , valueOption
  , mutezOption
  , addressOption
  , onelineOption
  , entrypointOption
  , mTextOption
  ) where

import Named (arg)
import Options.Applicative
  (footerDoc, fullDesc, header, help, helper, info, long, metavar, option, progDesc, strOption,
  switch)
import qualified Options.Applicative as Opt
import Text.Read (read)
import Options.Applicative.Help.Pretty (Doc)

import qualified Michelson.Parser as P
import Michelson.Runtime (TxData(..), TxParam(..))
import Michelson.Runtime.GState (genesisAddress)
import Michelson.Text (MText)
import Michelson.Untyped (EpName)
import qualified Michelson.Untyped as U
import Tezos.Address (Address)
import Tezos.Core (Mutez, Timestamp, parseTimestamp, timestampFromSeconds)
import Tezos.Crypto
import Util.CLI
import Util.Named

----------------------------------------------------------------------------
-- These options are mostly specifications of 'mkCLOptionParser'
-- for concrete types (with more specific names).
----------------------------------------------------------------------------

-- | Full parser for a client.
parserInfo
  :: "usage" :! Doc
  -> "description" :! String
  -> "header" :! String
  -> "parser" :! Opt.Parser s
  -> Opt.ParserInfo s
parserInfo :: ("usage" :! Doc)
-> ("description" :! String)
-> ("header" :! String)
-> ("parser" :! Parser s)
-> ParserInfo s
parserInfo
  (Name "usage" -> ("usage" :! Doc) -> Doc
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "usage" (Name "usage")
Name "usage"
#usage -> Doc
usage)
  (Name "description" -> ("description" :! String) -> String
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "description" (Name "description")
Name "description"
#description -> String
description)
  (Name "header" -> ("header" :! String) -> String
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "header" (Name "header")
Name "header"
#header -> String
clientHeader)
  (Name "parser" -> ("parser" :! Parser s) -> Parser s
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "parser" (Name "parser")
Name "parser"
#parser -> Parser s
parser) =
  Parser s -> InfoMod s -> ParserInfo s
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser (s -> s)
forall a. Parser (a -> a)
helper Parser (s -> s) -> Parser s -> Parser s
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser s
parser) (InfoMod s -> ParserInfo s) -> InfoMod s -> ParserInfo s
forall a b. (a -> b) -> a -> b
$
  [InfoMod s] -> InfoMod s
forall a. Monoid a => [a] -> a
mconcat
    [ InfoMod s
forall a. InfoMod a
fullDesc
    , String -> InfoMod s
forall a. String -> InfoMod a
progDesc String
description
    , String -> InfoMod s
forall a. String -> InfoMod a
header String
clientHeader
    , Maybe Doc -> InfoMod s
forall a. Maybe Doc -> InfoMod a
footerDoc (Maybe Doc -> InfoMod s) -> Maybe Doc -> InfoMod s
forall a b. (a -> b) -> a -> b
$ Doc -> Maybe Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc
usage
    ]

-- | Parser for path to a contract code.
contractFileOption :: Opt.Parser FilePath
contractFileOption :: Parser String
contractFileOption = Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Mod OptionFields String -> Parser String)
-> Mod OptionFields String -> Parser String
forall a b. (a -> b) -> a -> b
$
  String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "contract" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar "FILEPATH" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help "Path to contract file"

-- | Parser for the time returned by @NOW@ instruction.
nowOption :: Opt.Parser (Maybe Timestamp)
nowOption :: Parser (Maybe Timestamp)
nowOption = Parser Timestamp -> Parser (Maybe Timestamp)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Timestamp -> Parser (Maybe Timestamp))
-> Parser Timestamp -> Parser (Maybe Timestamp)
forall a b. (a -> b) -> a -> b
$ ReadM Timestamp -> Mod OptionFields Timestamp -> Parser Timestamp
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Timestamp
parser (Mod OptionFields Timestamp -> Parser Timestamp)
-> Mod OptionFields Timestamp -> Parser Timestamp
forall a b. (a -> b) -> a -> b
$
  String -> Mod OptionFields Timestamp
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "now" Mod OptionFields Timestamp
-> Mod OptionFields Timestamp -> Mod OptionFields Timestamp
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod OptionFields Timestamp
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar "TIMESTAMP" Mod OptionFields Timestamp
-> Mod OptionFields Timestamp -> Mod OptionFields Timestamp
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod OptionFields Timestamp
forall (f :: * -> *) a. String -> Mod f a
help "Timestamp that you want the runtime interpreter to use (default is now)"
  where
    parser :: ReadM Timestamp
parser =
      (Integer -> Timestamp
timestampFromSeconds (Integer -> Timestamp) -> ReadM Integer -> ReadM Timestamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM Integer
forall a. Read a => ReadM a
Opt.auto) ReadM Timestamp -> ReadM Timestamp -> ReadM Timestamp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      (String -> Maybe Timestamp) -> ReadM Timestamp
forall a. (String -> Maybe a) -> ReadM a
Opt.maybeReader (Text -> Maybe Timestamp
parseTimestamp (Text -> Maybe Timestamp)
-> (String -> Text) -> String -> Maybe Timestamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText)


levelOption :: Opt.Parser (Maybe Natural)
levelOption :: Parser (Maybe Natural)
levelOption = Parser Natural -> Parser (Maybe Natural)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Natural -> Parser (Maybe Natural))
-> Parser Natural -> Parser (Maybe Natural)
forall a b. (a -> b) -> a -> b
$ ReadM Natural -> Mod OptionFields Natural -> Parser Natural
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Natural
parser (Mod OptionFields Natural -> Parser Natural)
-> Mod OptionFields Natural -> Parser Natural
forall a b. (a -> b) -> a -> b
$
  String -> Mod OptionFields Natural
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "level" Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod OptionFields Natural
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar "NATURAL" Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod OptionFields Natural
forall (f :: * -> *) a. String -> Mod f a
help "Level of the block in transaction chain"
  where
    parser :: ReadM Natural
parser = (String -> Maybe Natural) -> ReadM Natural
forall a. (String -> Maybe a) -> ReadM a
Opt.maybeReader (Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Maybe Natural)
-> (String -> Natural) -> String -> Maybe Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Natural
forall a. Read a => String -> a
read)

-- | Parser for gas limit on contract execution.
maxStepsOption :: Opt.Parser Word64
maxStepsOption :: Parser Word64
maxStepsOption = Maybe Word64
-> ("name" :! String) -> ("help" :! String) -> Parser Word64
forall a.
(Buildable a, HasCLReader a) =>
Maybe a -> ("name" :! String) -> ("help" :! String) -> Parser a
mkCLOptionParser
  (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just 100500)
  (IsLabel "name" (Name "name")
Name "name"
#name Name "name" -> String -> "name" :! String
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! "max-steps")
  (IsLabel "help" (Name "help")
Name "help"
#help Name "help" -> String -> "help" :! String
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! "Max steps that you want the runtime interpreter to use")

-- | Parser for path to database with Morley state.
dbPathOption :: Opt.Parser FilePath
dbPathOption :: Parser String
dbPathOption = Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
Opt.strOption (Mod OptionFields String -> Parser String)
-> Mod OptionFields String -> Parser String
forall a b. (a -> b) -> a -> b
$
  String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "db" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar "FILEPATH" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod OptionFields String
forall (f :: * -> *) a. HasValue f => a -> Mod f a
Opt.value "db.json" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help "Path to DB with data which is used instead of real blockchain data" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
  Mod OptionFields String
forall a (f :: * -> *). Show a => Mod f a
Opt.showDefault

-- | Parser for transaction parameters.
txDataOption :: Opt.Parser TxData
txDataOption :: Parser TxData
txDataOption =
  Address -> Value -> Mutez -> EpName -> TxData
mkTxData
    (Address -> Value -> Mutez -> EpName -> TxData)
-> Parser Address -> Parser (Value -> Mutez -> EpName -> TxData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Address
-> ("name" :! String) -> ("help" :! String) -> Parser Address
addressOption (Address -> Maybe Address
forall a. a -> Maybe a
Just Address
genesisAddress)
      (IsLabel "name" (Name "name")
Name "name"
#name Name "name" -> String -> "name" :! String
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! "sender") (IsLabel "help" (Name "help")
Name "help"
#help Name "help" -> String -> "help" :! String
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! "Sender address")
    Parser (Value -> Mutez -> EpName -> TxData)
-> Parser Value -> Parser (Mutez -> EpName -> TxData)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Value
-> ("name" :! String) -> ("help" :! String) -> Parser Value
valueOption Maybe Value
forall a. Maybe a
Nothing
      (IsLabel "name" (Name "name")
Name "name"
#name Name "name" -> String -> "name" :! String
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! "parameter") (IsLabel "help" (Name "help")
Name "help"
#help Name "help" -> String -> "help" :! String
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! "Parameter of passed contract")
    Parser (Mutez -> EpName -> TxData)
-> Parser Mutez -> Parser (EpName -> TxData)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Mutez
-> ("name" :! String) -> ("help" :! String) -> Parser Mutez
mutezOption (Mutez -> Maybe Mutez
forall a. a -> Maybe a
Just Mutez
forall a. Bounded a => a
minBound)
      (IsLabel "name" (Name "name")
Name "name"
#name Name "name" -> String -> "name" :! String
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! "amount") (IsLabel "help" (Name "help")
Name "help"
#help Name "help" -> String -> "help" :! String
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! "Amount sent by a transaction")
    Parser (EpName -> TxData) -> Parser EpName -> Parser TxData
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ("name" :! String) -> ("help" :! String) -> Parser EpName
entrypointOption (IsLabel "name" (Name "name")
Name "name"
#name Name "name" -> String -> "name" :! String
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! "entrypoint") (IsLabel "help" (Name "help")
Name "help"
#help Name "help" -> String -> "help" :! String
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! "Entrypoint to call")
  where
    mkTxData :: Address -> U.Value -> Mutez -> EpName -> TxData
    mkTxData :: Address -> Value -> Mutez -> EpName -> TxData
mkTxData addr :: Address
addr param :: Value
param amount :: Mutez
amount epName :: EpName
epName =
      $WTxData :: Address -> TxParam -> EpName -> Mutez -> TxData
TxData
        { tdSenderAddress :: Address
tdSenderAddress = Address
addr
        , tdParameter :: TxParam
tdParameter = Value -> TxParam
TxUntypedParam Value
param
        , tdEntrypoint :: EpName
tdEntrypoint = EpName
epName
        , tdAmount :: Mutez
tdAmount = Mutez
amount
        }

-- | Generic parser to read an option of 'KeyHash' type.
keyHashOption ::
  Maybe KeyHash -> "name" :! String -> "help" :! String -> Opt.Parser KeyHash
keyHashOption :: Maybe KeyHash
-> ("name" :! String) -> ("help" :! String) -> Parser KeyHash
keyHashOption = Maybe KeyHash
-> ("name" :! String) -> ("help" :! String) -> Parser KeyHash
forall a.
(Buildable a, HasCLReader a) =>
Maybe a -> ("name" :! String) -> ("help" :! String) -> Parser a
mkCLOptionParser

-- | Generic parser to read an option of 'SecretKey' type.
secretKeyOption ::
  Maybe SecretKey -> "name" :! String -> "help" :! String -> Opt.Parser SecretKey
secretKeyOption :: Maybe SecretKey
-> ("name" :! String) -> ("help" :! String) -> Parser SecretKey
secretKeyOption = Maybe SecretKey
-> ("name" :! String) -> ("help" :! String) -> Parser SecretKey
forall a.
(Buildable a, HasCLReader a) =>
Maybe a -> ("name" :! String) -> ("help" :! String) -> Parser a
mkCLOptionParser

-- | Generic parser to read an option of 'U.Value' type.
valueOption ::
  Maybe U.Value -> "name" :! String -> "help" :! String -> Opt.Parser U.Value
valueOption :: Maybe Value
-> ("name" :! String) -> ("help" :! String) -> Parser Value
valueOption = Maybe Value
-> ("name" :! String) -> ("help" :! String) -> Parser Value
forall a.
(Buildable a, HasCLReader a) =>
Maybe a -> ("name" :! String) -> ("help" :! String) -> Parser a
mkCLOptionParser

-- | Generic parser to read an option of 'Mutez' type.
mutezOption ::
  Maybe Mutez -> "name" :! String -> "help" :! String -> Opt.Parser Mutez
mutezOption :: Maybe Mutez
-> ("name" :! String) -> ("help" :! String) -> Parser Mutez
mutezOption = Maybe Mutez
-> ("name" :! String) -> ("help" :! String) -> Parser Mutez
forall a.
(Buildable a, HasCLReader a) =>
Maybe a -> ("name" :! String) -> ("help" :! String) -> Parser a
mkCLOptionParser

-- | Generic parser to read an option of 'Address' type.
addressOption ::
  Maybe Address -> "name" :! String -> "help" :! String -> Opt.Parser Address
addressOption :: Maybe Address
-> ("name" :! String) -> ("help" :! String) -> Parser Address
addressOption = Maybe Address
-> ("name" :! String) -> ("help" :! String) -> Parser Address
forall a.
(Buildable a, HasCLReader a) =>
Maybe a -> ("name" :! String) -> ("help" :! String) -> Parser a
mkCLOptionParser

-- | @--oneline@ flag.
onelineOption :: Opt.Parser Bool
onelineOption :: Parser Bool
onelineOption = Mod FlagFields Bool -> Parser Bool
switch (
  String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "oneline" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help "Force single line output")

-- | Generic parser to read an option of 'EpName' type.
entrypointOption :: "name" :! String -> "help" :! String -> Opt.Parser EpName
entrypointOption :: ("name" :! String) -> ("help" :! String) -> Parser EpName
entrypointOption = Maybe EpName
-> ("name" :! String) -> ("help" :! String) -> Parser EpName
forall a.
(Buildable a, HasCLReader a) =>
Maybe a -> ("name" :! String) -> ("help" :! String) -> Parser a
mkCLOptionParser (EpName -> Maybe EpName
forall a. a -> Maybe a
Just EpName
U.DefEpName)

-- | Generic parser to read an option of 'MText' type.
mTextOption ::
  Maybe MText -> "name" :! String -> "help" :! String -> Opt.Parser MText
mTextOption :: Maybe MText
-> ("name" :! String) -> ("help" :! String) -> Parser MText
mTextOption = Maybe MText
-> ("name" :! String) -> ("help" :! String) -> Parser MText
forall a.
(Buildable a, HasCLReader a) =>
Maybe a -> ("name" :! String) -> ("help" :! String) -> Parser a
mkCLOptionParser

----------------------------------------------------------------------------
-- 'HasCLReader' orphan instances (better to avoid)
----------------------------------------------------------------------------

-- This instance uses parser which is not in the place where 'U.Value'
-- is defined, hence it is orphan.
instance HasCLReader U.Value where
  getReader :: ReadM Value
getReader = (String -> Either String Value) -> ReadM Value
forall a. (String -> Either String a) -> ReadM a
eitherReader String -> Either String Value
parseValue
    where
      parseValue :: String -> Either String U.Value
      parseValue :: String -> Either String Value
parseValue =
        (ParserException -> String)
-> Either ParserException Value -> Either String Value
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> String -> String
forall a. Monoid a => a -> a -> a
mappend "Failed to parse value: " (String -> String)
-> (ParserException -> String) -> ParserException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserException -> String
forall e. Exception e => e -> String
displayException) (Either ParserException Value -> Either String Value)
-> (String -> Either ParserException Value)
-> String
-> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        Text -> Either ParserException Value
P.parseExpandValue (Text -> Either ParserException Value)
-> (String -> Text) -> String -> Either ParserException Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> Text
forall a. ToText a => a -> Text
toText
  getMetavar :: String
getMetavar = "MICHELSON VALUE"