morley-1.16.3: app/Main.hs

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

-- TODO [#712]: Remove this next major release
{-# OPTIONS_GHC -Wno-deprecations #-}

module Main
  ( main
  ) where

import Data.Text.Lazy.IO.Utf8 qualified as Utf8 (writeFile)
import Data.Version (showVersion)
import Fmt (pretty)
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.Optimizer (optimize)
import Morley.Michelson.Printer (printSomeContract, printUntypedContract)
import Morley.Michelson.Runtime
  (TxData(..), originateContract, prepareContract, prepareContractExt, runContract, transfer)
import Morley.Michelson.Runtime.GState (genesisAddress)
import Morley.Michelson.TypeCheck (tcVerbose, typeCheckContract, typeCheckingWith)
import Morley.Michelson.TypeCheck qualified as TypeCheck
import Morley.Michelson.TypeCheck.Types (mapSomeContract)
import Morley.Michelson.Typed (Contract'(..), SomeContract(..))
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address (Address)
import Morley.Tezos.Core (Mutez, Timestamp(..), tz)
import Morley.Tezos.Crypto
import Morley.Tezos.Crypto.Timelock (chestBytes, chestKeyBytes, createChestAndChestKey)
import Morley.Util.CLI (mkCommandParser, outputOption)
import Morley.Util.Main (wrapMain)
import Morley.Util.Named
import REPL

----------------------------------------------------------------------------
-- Command line options
----------------------------------------------------------------------------

data CmdLnArgs
  = Print ("input" :? FilePath) ("output" :? FilePath) ("singleLine" :! Bool)
  | Optimize OptimizeOptions
  | Analyze AnalyzeOptions
  | TypeCheck TypeCheckOptions
  | Run RunOptions
  | Originate OriginateOptions
  | Transfer TransferOptions
  | CreateChest CreateChestOptions
  | REPL

data OptimizeOptions = OptimizeOptions
  { optoContractFile :: Maybe FilePath
  , optoOutput :: Maybe FilePath
  , optoSingleLine :: Bool
  }

data AnalyzeOptions = AnalyzeOptions
  { aoContractFile :: Maybe FilePath
  }

data CreateChestOptions = CreateChestOptions
  { ccPayload :: ByteString
  , ccTime :: TLTime
  }

data TypeCheckOptions = TypeCheckOptions
  { tcoContractFile :: Maybe FilePath
  , tcoTcOptions    :: TypeCheck.TypeCheckOptions
  }

data RunOptions = RunOptions
  { roContractFile :: Maybe FilePath
  , roDBPath :: FilePath
  , roTcOptions :: TypeCheck.TypeCheckOptions
  , roStorageValue :: U.Value
  , roTxData :: TxData
  , roVerbose :: Bool
  , roNow :: Maybe Timestamp
  , roLevel :: Maybe Natural
  , roMaxSteps :: Word64
  , roInitBalance :: Mutez
  , roWrite :: Bool
  }

data OriginateOptions = OriginateOptions
  { ooContractFile :: Maybe FilePath
  , ooDBPath :: FilePath
  , ooTcOptions :: TypeCheck.TypeCheckOptions
  , ooOriginator :: Address
  , ooDelegate :: Maybe KeyHash
  , ooStorageValue :: U.Value
  , ooBalance :: Mutez
  , ooVerbose :: Bool
  }

data TransferOptions = TransferOptions
  { toDBPath :: FilePath
  , toTcOptions :: TypeCheck.TypeCheckOptions
  , toDestination :: Address
  , toTxData :: TxData
  , toNow :: Maybe Timestamp
  , toLevel :: Maybe Natural
  , toMaxSteps :: Word64
  , toVerbose :: Bool
  , toDryRun :: Bool
  }

argParser :: Opt.Parser (Bool, CmdLnArgs)
argParser = ((,) <$> enableExtsOption <*>) . subparser $
  printSubCmd <>
  typecheckSubCmd <>
  emulateSubCmd <>
  optimizeSubCmd <>
  analyzeSubCmd <>
  createChestSubCmd <>
  replSubCmd
  where
    enableExtsOption = switch $
      long "deprecated-morley-extensions" <>
      help "Enable parsing deprecated Morley extensions"

    typecheckSubCmd =
      mkCommandParser "typecheck"
        (TypeCheck <$> typeCheckOptions) $
        ("Typecheck passed contract")

    printSubCmd =
      mkCommandParser "print"
      (Print <$> (#input <:?> optional contractFileOption)
             <*> (#output <:?> outputOption)
             <*> (#singleLine <:!> onelineOption))
      ("Parse a Morley contract and print corresponding Michelson " <>
       "contract that can be parsed by the OCaml reference client: tezos-client")

    emulateSubCmd =
      mkCommandParser "emulate"
      (subparser $ runSubCmd
                <> originateSubCmd
                <> transferSubCmd)
      ("Set of commands to run in an emulated environment")

    runSubCmd =
      mkCommandParser "run"
      (Run <$> runOptions) $
      "Run passed contract. \
      \It's originated first and then a transaction is sent to it"

    replSubCmd =
      mkCommandParser "repl"
      (pure REPL)
      "Start a Morley REPL"

    originateSubCmd =
      mkCommandParser "originate"
      (Originate <$> originateOptions)
      "Originate passed contract. Add it to passed DB"

    transferSubCmd =
      mkCommandParser "transfer"
      (Transfer <$> transferOptions)
      "Transfer tokens to given address"

    optimizeSubCmd =
      mkCommandParser "optimize"
      (Optimize <$> optimizeOptions)
      "Optimize the contract."

    analyzeSubCmd =
      mkCommandParser "analyze"
      (Analyze <$> analyzeOptions)
      "Analyze the contract."

    createChestSubCmd =
      mkCommandParser "create_chest"
      (CreateChest <$> createChestOptions)
      "Create a timelocked chest and key."

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

    writeFlag :: Opt.Parser Bool
    writeFlag = switch $
      long "write" <>
      help "Whether updated DB should be written to DB file"

    dryRunFlag :: Opt.Parser Bool
    dryRunFlag = switch $
      long "dry-run" <>
      help "Do not write updated DB to DB file"

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

    typeCheckOptions :: Opt.Parser TypeCheckOptions
    typeCheckOptions = TypeCheckOptions
      <$> optional contractFileOption
      <*> typeCheckOptionsOption

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

    optimizeOptions :: Opt.Parser OptimizeOptions
    optimizeOptions = OptimizeOptions
      <$> optional contractFileOption
      <*> outputOption
      <*> onelineOption

    analyzeOptions :: Opt.Parser AnalyzeOptions
    analyzeOptions = AnalyzeOptions <$> optional contractFileOption

    createChestOptions :: Opt.Parser CreateChestOptions
    createChestOptions = CreateChestOptions <$> payloadOption <*> timeOption

    runOptions :: Opt.Parser RunOptions
    runOptions =
      RunOptions
        <$> optional contractFileOption
        <*> dbPathOption
        <*> typeCheckOptionsOption
        <*> valueOption Nothing (#name :! "storage")
            (#help :! "Initial storage of a running contract")
        <*> txDataOption
        <*> verboseFlag
        <*> nowOption
        <*> levelOption
        <*> maxStepsOption
        <*> mutezOption (Just defaultBalance)
            (#name :! "balance") (#help :! "Initial balance of this contract")
        <*> writeFlag

    originateOptions :: Opt.Parser OriginateOptions
    originateOptions =
      OriginateOptions
        <$> optional contractFileOption
        <*> dbPathOption
        <*> typeCheckOptionsOption
        <*> addressOption (Just genesisAddress)
            (#name :! "originator") (#help :! "Contract's originator")
        <*> optional
            (keyHashOption Nothing
              (#name :! "delegate") (#help :! "Contract's optional delegate")
            )
        <*> valueOption Nothing
            (#name :! "storage") (#help :! "Initial storage of an originating contract")
        <*> mutezOption (Just defaultBalance)
            (#name :! "balance") (#help :! "Initial balance of an originating contract")
        <*> verboseFlag

    transferOptions :: Opt.Parser TransferOptions
    transferOptions = do
      toDBPath <- dbPathOption
      toTcOptions <- typeCheckOptionsOption
      toDestination <-
        addressOption Nothing
        (#name :! "to") (#help :! "Destination address")
      toTxData <- txDataOption
      toNow <- nowOption
      toLevel <- levelOption
      toMaxSteps <- maxStepsOption
      toVerbose <- verboseFlag
      toDryRun <- dryRunFlag
      pure TransferOptions {..}

-- | 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 $ do
  (exts, cmdLnArgs) <- execParser programInfo
  run exts cmdLnArgs
  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.")

    run :: Bool -> CmdLnArgs -> IO ()
    run exts args = case args of
      Print (argF #input -> mInputFile)
            (argF #output -> mOutputFile)
            (arg #singleLine -> forceSingleLine) -> do
        contract <- prepareContract' mInputFile
        let write = maybe putStrLn Utf8.writeFile mOutputFile
        write $ printUntypedContract forceSingleLine contract
      Optimize OptimizeOptions{..} -> do
        untypedContract <- prepareContract' optoContractFile
        checkedContract <-
          either throwM pure . typeCheckingWith laxTcOptions $
            typeCheckContract untypedContract
        let optimizedContract = mapSomeContract optimize checkedContract
        let write = maybe putStrLn Utf8.writeFile optoOutput
        write $ printSomeContract optoSingleLine optimizedContract
      Analyze AnalyzeOptions{..} -> do
        untypedContract <- prepareContract' aoContractFile
        SomeContract contract <-
          either throwM pure . typeCheckingWith laxTcOptions $
            typeCheckContract untypedContract
        putTextLn $ pretty $ analyze (cCode contract)
      TypeCheck TypeCheckOptions{..} -> do
        morleyContract <- prepareContract' tcoContractFile
        -- 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 tcoTcOptions
          $ typeCheckContract morleyContract
        when (TypeCheck.tcVerbose tcoTcOptions) $
          putStrLn $ printSomeContract False contract
        putTextLn "Contract is well-typed"
      Run RunOptions {..} -> do
        michelsonContract <- prepareContract' roContractFile
        void $ runContract roNow roLevel roMaxSteps roInitBalance roDBPath roTcOptions roStorageValue michelsonContract roTxData
          ! #verbose roVerbose
          ! #dryRun (not roWrite)
      Originate OriginateOptions {..} -> do
        michelsonContract <- prepareContract' ooContractFile
        addr <-
          originateContract
            ooDBPath
            ooTcOptions
            ooOriginator
            ooDelegate
            ooBalance
            ooStorageValue
            michelsonContract
            ! #verbose ooVerbose
        putTextLn $ "Originated contract " <> pretty addr
      Transfer TransferOptions {..} -> do
        transfer toNow toLevel toMaxSteps toDBPath toTcOptions toDestination toTxData
          ! #verbose toVerbose
          ! #dryRun toDryRun
      REPL -> runRepl
      CreateChest CreateChestOptions {..} -> do
        (chest, key) <- createChestAndChestKey ccPayload ccTime
        putStrLn $ "Chest: 0x" <> encodeHex (chestBytes chest)
        putStrLn $ "Key: 0x" <> encodeHex (chestKeyBytes key)
      where
        -- TODO [#712]: Remove this next major release
        prepareContract'
          | exts = prepareContractExt
          | otherwise = prepareContract


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