-- 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
  , 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 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)

-- | 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"