morley-1.19.1: app/Main.hs

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

module Main
  ( main
  ) where

import Data.Default (def)
import Data.Singletons (demote)
import Data.Text.Lazy.IO.Utf8 qualified as Utf8 (writeFile)
import Data.Version (showVersion)
import Fmt (pretty, unlinesF)
import Named (paramF)
import Options.Applicative
  (execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long, progDesc, short,
  subparser, switch)
import Options.Applicative qualified as Opt
import Options.Applicative.Help.Pretty (Doc, linebreak)
import Paths_morley (version)
import Text.Hex (encodeHex)

import Morley.CLI
import Morley.Michelson.Analyzer (analyze)
import Morley.Michelson.Interpret (RemainingSteps(..))
import Morley.Michelson.Optimizer (OptimizerConf(..), optimizeVerboseWithConf)
import Morley.Michelson.Printer (printSomeContract, printTypedContract, printUntypedContract)
import Morley.Michelson.Runtime
import Morley.Michelson.Runtime.GState (genesisAddress)
import Morley.Michelson.TypeCheck (tcVerbose, typeCheckContract, typeCheckValue, typeCheckingWith)
import Morley.Michelson.TypeCheck qualified as TypeCheck
import Morley.Michelson.Typed (Contract'(..), SomeContract(..), unContractCode)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.Contract (mapContractCodeM)
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias
import Morley.Tezos.Core (Mutez, tz)
import Morley.Tezos.Crypto.Timelock (chestBytes, chestKeyBytes, createChestAndChestKey)
import Morley.Util.CLI (mkCLOptionParser, mkCommandParser, outputOption)
import Morley.Util.Main (wrapMain)
import Morley.Util.Named
import REPL

data DryRunOrWrite = DryRun | Write

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

argParser :: Opt.Parser (IO ())
argParser = subparser $ mconcat
  [ printSubCmd
  , typecheckSubCmd
  , emulateSubCmd
  , optimizeSubCmd
  , analyzeSubCmd
  , createChestSubCmd
  , replSubCmd
  ]

--------------------------------------------------------------------------------
-- Subcommands
--------------------------------------------------------------------------------

-- NB: in case this looks mysterious, in IOCmd functions, outer 'do' is
-- Opt.Parser using ApplicativeDo, which then returns an IO action, i.e. inner
-- 'do' is 'IO ()'. -- @lierdakil

type IOCmd = Opt.Mod Opt.CommandFields (IO ())

typecheckSubCmd :: IOCmd
typecheckSubCmd = mkCommandParser' "typecheck" "Typecheck passed contract." do
  contractFile <- optional contractFileOption
  tcOptions <- typeCheckOptionsOption
  pure do
    morleyContract <- prepareContract contractFile
    -- At the moment of writing, 'tcStrict' option does not change anything
    -- because it affects only values parsing; but this may change
    contract <- either throwM pure . typeCheckingWith tcOptions
      $ typeCheckContract morleyContract
    when (TypeCheck.tcVerbose tcOptions) $
      putStrLn $ printSomeContract False contract
    putTextLn "Contract is well-typed"

printSubCmd :: IOCmd
printSubCmd = mkCommandParser' "print"
  "Parse a Morley contract and print corresponding Michelson \
  \contract that can be parsed by the OCaml reference client: octez-client."
  do
    mInputFile <- optional contractFileOption
    mOutputFile <- outputOption
    forceSingleLine <- onelineOption
    pure do
      contract <- prepareContract mInputFile
      let write = maybe putStrLn Utf8.writeFile mOutputFile
      write $ printUntypedContract forceSingleLine contract

emulateSubCmd :: IOCmd
emulateSubCmd = mkCommandParser' "emulate" "Set of commands to run in an emulated environment." $
  subparser $ mconcat
    [ runSubCmd
    , originateSubCmd
    , transferSubCmd
    , transferTicketSubCmd
    , runViewSubCmd
    ]

runSubCmd :: IOCmd
runSubCmd = mkCommandParser' "run"
  "Run passed contract. It's originated first and then a transaction is sent to it." do
    txData <- txDataOption
    contract <- contractSimpleOriginationDataOption
    cro <- commonRunOptions Write
    pure do
      michelsonContract <- traverse prepareContract contract
      void $ runContract cro michelsonContract txData

runViewSubCmd :: IOCmd
runViewSubCmd = mkCommandParser' "view"
  "Run some view on a contract either supplied directly or identified \
  \by an address. It's originated first if supplied directly." do
    cro <- commonRunOptions Write
    addressOrContract <-
      ContractSpecAddressOrAlias <$> addressOrAliasOption Nothing
        ! #name "contract-addr"
        ! #help "Contract address to call view on."
      <|> ContractSpecOrigination <$> contractSimpleOriginationDataOption
    viewName <- mkCLOptionParser Nothing
      ! #name "name"
      ! #help "View name."
    sender <- someAddressOrAliasOption
        (Just $ SAOAKindSpecified $ AddressResolved genesisAddress)
      ! #name "sender"
      ! #help "Sender address."
    viewArg <- TxUntypedParam <$> valueOption Nothing
      ! #name "arg"
      ! #help "View call argument."
    pure do
      contractSpec <- (traverse . traverse) prepareContract addressOrContract
      void $ runView cro contractSpec viewName sender viewArg

replSubCmd :: IOCmd
replSubCmd = mkCommandParser' "repl" "Start a Morley REPL." $ pure runRepl

originateSubCmd :: IOCmd
originateSubCmd = mkCommandParser' "originate" "Originate passed contract. Add it to passed DB." do
  simpleOriginationData <- contractSimpleOriginationDataOption
  dbPath <- dbPathOption
  tcOptions <- typeCheckOptionsOption
  verbose <- verboseFlag
  originator <- addressOption (Just genesisAddress)
    ! #name "originator"
    ! #help "Contract's originator."
  alias <- optional (aliasOption "alias")
  delegate <- optional $ keyHashOption Nothing
    ! #name "delegate"
    ! #help "Contract's optional delegate."
  pure do
    michelsonContract <- traverse prepareContract simpleOriginationData
    addr <-
      originateContract
        ! #dbPath dbPath
        ! #tcOpts tcOptions
        ! #originator originator
        ! paramF #alias alias
        ! paramF #delegate delegate
        ! #csod michelsonContract
        ! #verbose verbose
    putTextLn $ "Originated contract " <> pretty addr

transferSubCmd :: IOCmd
transferSubCmd = mkCommandParser' "transfer" "Transfer tokens to given address." do
  destination <- someAddressOrAliasOption Nothing
    ! #name "to"
    ! #help "Address or alias of the transfer's destination."
  txData <- txDataOption
  cro <- commonRunOptions DryRun
  pure $ transfer cro destination txData

transferTicketSubCmd :: IOCmd
transferTicketSubCmd = mkCommandParser' "transfer-ticket" "Transfer ticket to given address." do
  destination <- someAddressOrAliasOption Nothing
    ! #name "to"
    ! #help "Address or alias of the transfer's destination."
  tdSenderAddress :: L1Address <- Constrained <$> addressOption (Just genesisAddress)
    ! #name "sender" ! #help "Sender address"
  ticketer <- mkCLOptionParser @Address Nothing
    ! #name "ticketer" ! #help "Ticketer"
  value <- valueOption Nothing
    ! #name "value" ! #help "Ticket value"
  ty <- mkCLOptionParser Nothing
    ! #name "type" ! #help "Ticket argument type"
  tAmount <- mkCLOptionParser @Natural Nothing
    ! #name "amount" ! #help "Amount of tickets"
  tdAmount <- mutezOption (Just minBound)
    ! #name "mutez" ! #help "Mutez amount additionally sent by a transaction. \
    \Note that on network, as of Mumbai, implicit accounts can't send tickets \
    \and mutez in the same operation, however the Morley emulator allows it."
  tdEntrypoint <- entrypointOption
    ! #name "entrypoint" ! #help "Entrypoint to call"
  cro <- commonRunOptions DryRun
  pure $ T.withUType ty \(_ :: T.Notes t) -> do
    tValue <- either throwM pure . typeCheckingWith (croTCOpts cro) $
      typeCheckValue @t value
    T.Dict <- either (throwM . TypeCheck.UnsupportedTypeForScope (demote @t)) pure $
      T.checkScope @(T.ParameterScope t, T.Comparable t)
    let tdParameter = TxTypedParam $ T.VTicket ticketer tValue tAmount
    transfer cro destination TxData{..}

optimizeSubCmd :: IOCmd
optimizeSubCmd = mkCommandParser' "optimize" "Optimize the contract." do
  contractFile <- optional contractFileOption
  output <- outputOption
  singleLine <- onelineOption
  maxStageIterations <- mkCLOptionParser (Just $ ocMaxIterations def)
    ! #name "max-stage-iterations"
    ! #help "Maximum number of iterations per optimizer stage. \
        \The default is usually adequate, but you want to try raising it \
        \to see if it affects the result."
  verbose <- verboseFlag
  pure do
    untypedContract <- prepareContract contractFile
    SomeContract checkedContract <-
      either throwM pure . typeCheckingWith laxTcOptions $
        typeCheckContract untypedContract
    let (logs, optimizedContract) =
          mapContractCodeM (optimizeVerboseWithConf conf) checkedContract
        conf = def { ocMaxIterations = maxStageIterations }
    maybe putStrLn Utf8.writeFile output $ printTypedContract singleLine optimizedContract
    when verbose $ hPutStrLn stderr $ pretty @_ @Text $ unlinesF logs

analyzeSubCmd :: IOCmd
analyzeSubCmd = mkCommandParser' "analyze" "Analyze the contract." do
  contractFile <- optional contractFileOption
  pure do
    untypedContract <- prepareContract contractFile
    SomeContract contract <-
      either throwM pure . typeCheckingWith laxTcOptions $
        typeCheckContract untypedContract
    putTextLn $ pretty $ analyze (unContractCode $ cCode contract)

createChestSubCmd :: IOCmd
createChestSubCmd = mkCommandParser' "create_chest" "Create a timelocked chest and key." do
  payload <- payloadOption
  time <- timeOption
  pure do
    (chest, key) <- createChestAndChestKey payload time
    putStrLn $ "Chest: 0x" <> encodeHex (chestBytes chest)
    putStrLn $ "Key: 0x" <> encodeHex (chestKeyBytes key)

--------------------------------------------------------------------------------
-- Parsers
--------------------------------------------------------------------------------

verboseFlag :: Opt.Parser Bool
verboseFlag = switch $
  short 'v' <>
  long "verbose" <>
  help "Whether output should be verbose."

typeCheckOptionsOption :: Opt.Parser TypeCheck.TypeCheckOptions
typeCheckOptionsOption = do
  tcVerbose <- verboseFlag
  tcStrict <- fmap not . switch $
    long "typecheck-lax" <>
    help "Whether actions permitted in `octez-client run` but forbidden in \
          \e.g. `octez-client originate` should be allowed here."
  return TypeCheck.TypeCheckOptions{..}

commonRunOptions :: DryRunOrWrite -> Opt.Parser CommonRunOptions
commonRunOptions defaultDryRun = do
  croNow <- nowOption
  croLevel <- fromMaybe (croLevel def) <$> levelOption
  croMinBlockTime <- fromMaybe (croMinBlockTime def) <$> minBlockTimeOption
  croMaxSteps <- RemainingSteps <$> maxStepsOption
  croDBPath <- dbPathOption
  croTCOpts <- typeCheckOptionsOption
  croVerbose <- verboseFlag
  croDryRun <- case defaultDryRun of
    Write -> fmap not . switch $
      long "write" <>
      help "Write updated DB to the DB file."
    DryRun -> switch $
      long "dry-run" <>
      help "Do not write updated DB to the DB file."
  pure CommonRunOptions{..}

contractSimpleOriginationDataOption :: Opt.Parser (ContractSimpleOriginationData (Maybe FilePath))
contractSimpleOriginationDataOption = do
  csodStorage <- valueOption Nothing
    ! #name "storage"
    ! #help "Initial storage of the contract."
  csodContract <- optional contractFileOption
  csodBalance <- mutezOption (Just defaultBalance)
    ! #name "balance"
    ! #help "Initial balance of the contract."
  pure ContractSimpleOriginationData{..}

--------------------------------------------------------------------------------
-- Constants
--------------------------------------------------------------------------------

defaultBalance :: Mutez
defaultBalance = [tz|4|]

-- | Most permitting options, when we don't care much about typechecking.
laxTcOptions :: TypeCheck.TypeCheckOptions
laxTcOptions = TypeCheck.TypeCheckOptions
  { TypeCheck.tcVerbose = False
  , TypeCheck.tcStrict = False
  }

--------------------------------------------------------------------------------
-- Actual main
--------------------------------------------------------------------------------

main :: IO ()
main = wrapMain $ join $ execParser programInfo
  where
    programInfo = info (helper <*> versionOption <*> argParser) $
      mconcat
      [ fullDesc
      , progDesc "Morley: Haskell implementation of Michelson typechecker and interpreter"
      , header "Morley tools"
      , footerDoc $ usageDoc
      ]

    versionOption = infoOption ("morley-" <> showVersion version)
      (long "version" <> help "Show version.")

usageDoc :: Maybe Doc
usageDoc = Just $ mconcat
   [ "You can use help for specific COMMAND", linebreak
   , "EXAMPLE:", linebreak
   , "  morley emulate run --help", linebreak
   , linebreak
   , "Documentation for morley tools can be found at the following links:", linebreak
   , "  https://gitlab.com/morley-framework/morley/blob/master/README.md", linebreak
   , "  https://gitlab.com/morley-framework/morley/tree/master/docs", linebreak
   , linebreak
   , "Sample contracts for running can be found at the following link:", linebreak
   , "  https://gitlab.com/morley-framework/morley/tree/master/contracts", linebreak
   , linebreak
   , "USAGE EXAMPLE:", linebreak
   , "  morley parse --contract add1.tz", linebreak
   , linebreak
   , "  This command will parse contract stored in add1.tz", linebreak
   , "  and return its representation in haskell types", linebreak
   , linebreak
   , "  morley emulate originate --contract add1.tz --storage 1 --verbose", linebreak
   , linebreak
   , "  This command will originate contract with code stored in add1.tz", linebreak
   , "  with initial storage value set to 1 and return info about", linebreak
   , "  originated contract: its balance, storage and contract code"]