Parser.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

module Morley.Client.Parser
  ( clientParser
  , clientConfigParser
  , argsRawParser

    -- * Internals
  , mbContractFileOption
  , contractNameOption
  , feeOption
  , baseUrlReader
  , OriginateArgs(..)
  , originateArgsOption

    -- * Re-exports
  , parserInfo
  ) where

import Control.Exception.Safe (throwString)
import Data.Aeson qualified as Aeson
import Data.Default (def)
import Data.Singletons (demote, fromSing)
import Data.Type.Equality (pattern Refl)
import Fmt (blockListF, build, nameF, pretty, (+|), (|+))
import Options.Applicative
  (ReadM, eitherReader, help, long, metavar, option, short, strOption, subparser, value)
import Options.Applicative qualified as Opt
import Servant.Client (BaseUrl(..), parseBaseUrl)

import Morley.App.CLI qualified as Morley
import Morley.CLI
  (addressOrAliasOption, keyHashOption, mutezOption, parserInfo, someAddressOrAliasOption,
  valueOption)
import Morley.Client.Action
import Morley.Client.Full
import Morley.Client.RPC
import Morley.Client.TezosClient
import Morley.Client.Util (extractAddressesFromValue)
import Morley.Micheline (fromExpression, toExpression, unStringEncode)
import Morley.Michelson.Runtime (prepareContract)
import Morley.Michelson.TypeCheck qualified as TC
import Morley.Michelson.Typed (Contract, Contract'(..), SomeContract(..))
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.Value (Value'(..))
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias
import Morley.Tezos.Address.Kinds
import Morley.Tezos.Core
import Morley.Tezos.Crypto
import Morley.Util.CLI (mkCLOptionParser, mkCommandParser)
import Morley.Util.Constrained
import Morley.Util.Exception (throwLeft)
import Morley.Util.Named

mkCommandParser' :: String -> String -> Opt.Parser a -> Opt.Mod Opt.CommandFields a
mkCommandParser' = flip . mkCommandParser

type ClientMCmd = Opt.Mod Opt.CommandFields (MorleyClientM ())

originateCmd :: ClientMCmd
originateCmd = mkCommandParser' "originate" "Originate passed contract on real network." do
  oas <- originateArgsOption
  pure let OriginateArgs{..} = oas in do
    contract <- liftIO $ prepareContract oaMbContractFile
    let originator = oaOriginateFrom
    originatorAA <- resolveAddressWithAlias originator
    (operationHash, contractAddr) <-
      originateUntypedContract OverwriteDuplicateAlias oaContractName originatorAA oaInitialBalance
        contract oaInitialStorage oaMbFee oaDelegate

    putTextLn "Contract was successfully deployed."
    putTextLn $ "Operation hash: " <> pretty operationHash
    putTextLn $ "Contract address: " <> formatAddress contractAddr

transferCmd :: ClientMCmd
transferCmd = mkCommandParser' "transfer"
  "Perform a transfer to the given contract with given amount and parameter." do
  taSender <- addressOrAliasOption @'AddressKindImplicit Nothing
    ! #name "from"
    ! #help "Address or alias from which transfer is performed."
  taDestination <- someAddressOrAliasOption Nothing
    ! #name "to"
    ! #help "Address or alias of the transfer's destination."
  taAmount <- mutezOption (Just zeroMutez)
    ! #name "amount"
    ! #help "Transfer amount."
  taParameter <- valueOption Nothing
    ! #name "parameter"
    ! #help "Transfer parameter."
  taMbFee <- feeOption
  pure do
    sendAddress <- resolveAddressWithAlias taSender
    destAddress <- resolveAddress taDestination
    (operationHash, contractEvents) :: (OperationHash, [WithSource EventOperation]) <-
      withConstrained destAddress \case
        destContract@ContractAddress{} -> do
          contract <- getContract destContract
          SomeContract (Contract{} :: Contract cp st) <-
            throwLeft $ pure $ TC.typeCheckingWith def $ TC.typeCheckContract contract
          let addrs = extractAddressesFromValue taParameter & mapMaybe \case
                MkAddress x@ContractAddress{} -> Just x
                _ -> Nothing
          tcOriginatedContracts <- getContractsParameterTypes addrs
          parameter <- throwLeft $ pure $ TC.typeCheckingWith def $
            TC.typeVerifyParameter @cp tcOriginatedContracts taParameter
          transfer sendAddress destContract taAmount U.DefEpName parameter taMbFee
        destImplicit@ImplicitAddress {} -> case taParameter of
          U.ValueUnit -> transfer sendAddress destImplicit taAmount U.DefEpName VUnit Nothing
          _ -> throwString ("The transaction parameter must be 'Unit' "
            <> "when transferring to an implicit account")


    putTextLn $ "Transaction was successfully sent.\nOperation hash " <> pretty operationHash <> "."
    unless (null contractEvents) do
      putTextLn $ "Additionally, the following contract events were emitted:"
      putTextLn $ pretty $ blockListF contractEvents

getBalanceCmd :: ClientMCmd
getBalanceCmd = mkCommandParser' "get-balance" "Get balance for given address" do
  addrOrAlias <- someAddressOrAliasOption Nothing
    ! #name "addr"
    ! #help "Contract or implicit address or alias to get balance for."
  pure do
    Constrained addr <- resolveAddress addrOrAlias
    balance <- getBalance addr
    putTextLn $ prettyTez balance

getBlockHeaderCmd :: ClientMCmd
getBlockHeaderCmd = mkCommandParser' "get-block-header" "Get header of a block" do
  blockId <- blockIdOption
  pure do
    blockHeader <- getBlockHeader blockId
    putStrLn $ Aeson.encode blockHeader

getScriptSizeCmd :: ClientMCmd
getScriptSizeCmd = mkCommandParser' "compute-script-size" "Compute script size" do
  ssScriptFile <- scriptFileOption
  ssStorage <- valueOption Nothing
    ! #name "storage"
    ! #help "Contract storage value."
  pure do
    contract <- liftIO $ prepareContract (Just ssScriptFile)
    void . throwLeft . pure . TC.typeCheckingWith def $
      TC.typeCheckContractAndStorage contract ssStorage
    size <- computeUntypedContractSize contract ssStorage
    print size

getBlockOperationsCmd :: ClientMCmd
getBlockOperationsCmd = mkCommandParser' "get-block-operations"
  "Get operations contained in a block" do
  blockId <- blockIdOption
  pure do
    operationLists <- getBlockOperations blockId
    forM_ operationLists $ \operations -> do
      forM_ operations $ \BlockOperation {..} -> do
        putTextLn $ "Hash: " <> boHash
        putTextLn $ "Contents: "
        forM_ (orwmResponse <$> boContents) \case
          TransactionOpResp op -> putStrLn $ Aeson.encode op
          TransferTicketOpResp op -> putStrLn $ Aeson.encode op
          OriginationOpResp op -> putStrLn $ Aeson.encode op
          DelegationOpResp op  -> putStrLn $ Aeson.encode op
          RevealOpResp op      -> putStrLn $ Aeson.encode op
          EventOpResp op       -> putStrLn $ Aeson.encode op
          OtherOpResp kind     -> putTextLn $ "Unknown operation kind: " <> kind
        putTextLn ""
    putTextLn "——————————————————————————————————————————————————\n"

getTicketBalanceCmd :: ClientMCmd
getTicketBalanceCmd = mkCommandParser' "ticket-balance" "Get ticket balance for specific tickets" do
  owner' <- ownerOption someAddressOrAliasOption
  tbaTicketer <- mkCLOptionParser Nothing
    ! #name "ticketer"
    ! #help "The contract that issued the ticket."
  tbaContentType <- mkCLOptionParser @U.Ty Nothing
    ! #name "content-type"
    ! #help "Content type."
  tbaContent <- valueOption Nothing
    ! #name "content"
    ! #help "Ticket content."
  pure do
    owner <- resolveAddress owner'
    bal <- getTicketBalance owner GetTicketBalance
      { gtbContent = toExpression tbaContent
      , gtbContentType = toExpression tbaContentType
      , gtbTicketer = tbaTicketer
      }
    print bal

getAllTicketBalancesCmd :: ClientMCmd
getAllTicketBalancesCmd = mkCommandParser' "all-ticket-balances" "Get all ticket balances" do
  owner' <- ownerOption $ addressOrAliasOption @'AddressKindContract
  pure do
    owner <- resolveAddress owner'
    bals <- getAllTicketBalances owner
    forM_ bals \GetAllTicketBalancesResponse{..} -> do
      content <- either throwM pure $ fromExpression @U.Value gatbrContent
      ty <- either throwM pure $ fromExpression @U.Ty gatbrContentType
      putTextLn $
        nameF "Ticketer" (build gatbrTicketer) |+ ", "
        +| nameF "content" (build content) |+ ", "
        +| nameF "type" (build ty) |+ ", "
        +| nameF "amount" (build $ unStringEncode gatbrAmount)


transferTicketCmd :: ClientMCmd
transferTicketCmd = mkCommandParser' "transfer-ticket"
  "Perform a ticket transfer to the given contract with given amount and parameter." do
  ttaSender <- addressOrAliasOption @'AddressKindImplicit Nothing
    ! #name "from"
    ! #help "Address or alias from which transfer is performed."
  ttaTicketAmount <- mkCLOptionParser @Natural Nothing
    ! #name "amount"
    ! #help "Ticket amount."
  ttaTicketContents <- mkCLOptionParser @U.Value Nothing
    ! #name "value"
    ! #help "Ticket value."
  ttaTicketType <- mkCLOptionParser @U.Ty Nothing
    ! #name "type"
    ! #help "Ticket type."
  ttaTicketTicketer <- mkCLOptionParser @ContractAddressOrAlias Nothing
    ! #name "ticketer"
    ! #help "Ticketer address or alias."
  ttaDestination <- someAddressOrAliasOption Nothing
    ! #name "to"
    ! #help "Address or alias of the transfer's destination."
  ttaMbFee <- feeOption
  pure $ T.withUType ttaTicketType \(_ :: T.Notes t) -> do
    T.Dict <- throwLeft $ pure $ first (TC.UnsupportedTypeForScope (demote @t))
      $ T.checkScope @(T.ParameterScope t, T.Comparable t)
    sendAddress <- resolveAddressWithAlias ttaSender
    destAddress <- resolveAddress ttaDestination
    ticketer <- resolveAddress ttaTicketTicketer
    (operationHash, contractEvents) :: (OperationHash, [WithSource EventOperation]) <-
      withConstrained destAddress \case
        destContract@ContractAddress{} -> do
          contract <- getContract destContract
          SomeContract (Contract{} :: Contract cp st) <-
            throwLeft $ pure $ TC.typeCheckingWith def $ TC.typeCheckContract contract
          Constrained (_ :: T.SingT t') :: Constrained T.SingI T.SingT <- case T.sing @cp of
            T.STTicket x -> pure $ Constrained @T.SingI x
            x -> throwM $ TC.TcContractError @U.ExpandedOp
              ("Expected contract to accept tickets, but it had type " <> pretty (fromSing x))
              $ Just $ TC.UnexpectedType (one $ one $ "ticket 'a")
          Refl <- T.requireEq @t @t' $ throwM . TC.TypeEqError
          parameter <- throwLeft $ pure $ TC.typeCheckingWith def $ do
            TC.typeCheckValue @t' ttaTicketContents
          transferTicket @_ @t' sendAddress destContract ticketer parameter ttaTicketAmount
            U.DefEpName ttaMbFee
        destImplicit@ImplicitAddress{} -> do
          parameter <- throwLeft $ pure $ TC.typeCheckingWith def $
                TC.typeCheckValue @t ttaTicketContents
          transferTicket sendAddress destImplicit ticketer parameter ttaTicketAmount
                U.DefEpName ttaMbFee

    putTextLn $ "Tickets successfully sent.\nOperation hash " <> pretty operationHash <> "."
    unless (null contractEvents) do
      putTextLn $ "Additionally, the following contract events were emitted:"
      putTextLn $ pretty $ blockListF contractEvents

-- | Parser for the @morley-client@ executable.
clientParser :: Opt.Parser (IO ())
clientParser = runMorleyClientM' <$> clientConfigParser <*> argsRawParser <|> Morley.argParser
  where
    runMorleyClientM' envConfig action = do
      env <- mkMorleyClientEnv envConfig
      runMorleyClientM env action

argsRawParser :: Opt.Parser (MorleyClientM ())
argsRawParser = subparser $ mconcat
  [ originateCmd
  , transferCmd
  , transferTicketCmd
  , getBalanceCmd
  , getScriptSizeCmd
  , getBlockHeaderCmd
  , getBlockOperationsCmd
  , getTicketBalanceCmd
  , getAllTicketBalancesCmd
  ]

clientConfigParser :: Opt.Parser MorleyClientConfig
clientConfigParser = do
  let mccSecretKey = Nothing
  mccEndpointUrl <- endpointOption
  mccTezosClientPath <- pathOption
  mccMbTezosClientDataDir <- dataDirOption
  mccVerbosity <- genericLength <$> many verboseSwitch
  pure MorleyClientConfig{..}
  where
    verboseSwitch :: Opt.Parser ()
    verboseSwitch = Opt.flag' () . mconcat $
      [ short 'V'
      , help "Increase verbosity (pass several times to increase further)."
      ]

data OriginateArgs = OriginateArgs
  { oaMbContractFile :: Maybe FilePath
  , oaContractName   :: ContractAlias
  , oaInitialBalance :: Mutez
  , oaInitialStorage :: U.Value
  , oaOriginateFrom  :: ImplicitAddressOrAlias
  , oaMbFee :: Maybe Mutez
  , oaDelegate :: Maybe KeyHash
  }

originateArgsOption :: Opt.Parser OriginateArgs
originateArgsOption = do
  oaMbContractFile <- mbContractFileOption
  oaContractName <- contractNameOption
  oaInitialBalance <- mutezOption (Just zeroMutez)
    ! #name "initial-balance"
    ! #help "Initial balance of the contract."
  oaInitialStorage <- valueOption Nothing
    ! #name "initial-storage"
    ! #help "Initial contract storage value."
  oaOriginateFrom <- addressOrAliasOption Nothing
    ! #name "from"
    ! #help "Address or alias of address from which origination is performed."
  oaMbFee <- feeOption
  oaDelegate <- optional $ keyHashOption Nothing
    ! #name "delegate"
    ! #help "Key hash of the contract's delegate"
  pure OriginateArgs{..}


blockIdOption :: Opt.Parser BlockId
blockIdOption = mkCLOptionParser (Just HeadId)
  ! #name "block-id"
  ! #help "Id of the block whose header will be queried."

-- | Parses URL of the Tezos node.
endpointOption :: Opt.Parser (Maybe BaseUrl)
endpointOption = optional . option baseUrlReader $
  long "endpoint"
  <> short 'E'
  <> help "URL of the remote Tezos node."
  <> metavar "URL"

pathOption :: Opt.Parser FilePath
pathOption = strOption $
  mconcat [ short 'I', long "client-path", metavar "PATH"
          , help "Path to `octez-client` binary."
          , value "octez-client"
          , Opt.showDefault
          ]

dataDirOption :: Opt.Parser (Maybe FilePath)
dataDirOption = optional $ strOption $
  mconcat [ short 'd', long "data-dir", metavar "PATH"
          , help "Path to `octez-client` data directory."
          ]

feeOption :: Opt.Parser (Maybe Mutez)
feeOption = optional $ mutezOption Nothing
  ! #name "fee"
  ! #help "Fee that is going to be used for the transaction. \
          \By default fee will be computed automatically."

mbContractFileOption :: Opt.Parser (Maybe FilePath)
mbContractFileOption = optional . strOption $ mconcat
  [ long "contract", metavar "FILEPATH"
  , help "Path to contract file."
  ]

scriptFileOption :: Opt.Parser FilePath
scriptFileOption = strOption $ mconcat
  [ long "script", metavar "FILEPATH"
  , help "Path to script file."
  ]

contractNameOption :: Opt.Parser ContractAlias
contractNameOption = fmap ContractAlias . strOption $ mconcat
  [ long "contract-name"
  , value "stdin"
  , help "Alias of originated contract."
  ]

ownerOption
  :: (Maybe a -> ("name" :! String) -> ("help" :! String) -> Opt.Parser r)
  -> Opt.Parser r
ownerOption f = f Nothing
  ! #name "owner"
  ! #help "Ticket owner"

--------------------------------------------------------------------------------
-- Parser utilities
--------------------------------------------------------------------------------

-- | Utility reader to use in parsing 'BaseUrl'.
baseUrlReader :: ReadM BaseUrl
baseUrlReader = eitherReader $ first displayException . parseBaseUrl