morley-client-0.2.0: app/Main.hs

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

module Main
  ( main
  ) where

import Control.Exception.Safe (throwString)
import Data.Aeson qualified as Aeson
import Data.Default (def)
import Fmt (pretty)
import GHC.IO.Encoding (setFileSystemEncoding)
import Options.Applicative qualified as Opt
import System.IO (utf8)

import Morley.Client
import Morley.Client.Parser
import Morley.Client.RPC (BlockOperation(..), OperationResp(..), OperationRespWithMeta(..))
import Morley.Client.RPC.Getters
import Morley.Client.Util (extractAddressesFromValue)
import Morley.Michelson.Runtime (prepareContract)
import Morley.Michelson.TypeCheck
  (typeCheckContract, typeCheckContractAndStorage, typeCheckingWith, typeVerifyParameter)
import Morley.Michelson.Typed (Contract, Contract'(..), SomeContract(..))
import Morley.Michelson.Typed.Value (Value'(..))
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address (Address(..), formatAddress)
import Morley.Tezos.Core (prettyTez)
import Morley.Util.Exception (throwLeft)
import Morley.Util.Main (wrapMain)

mainImpl :: ClientArgsRaw -> MorleyClientM ()
mainImpl cmd =
  case cmd of
    Originate OriginateArgs{..} -> do
      contract <- liftIO $ prepareContract oaMbContractFile
      let originator = oaOriginateFrom
      (operationHash, contractAddr) <-
        originateUntypedContract True oaContractName originator oaInitialBalance
        contract oaInitialStorage oaMbFee

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

    Transfer TransferArgs{..} -> do
      sendAddress <- resolveAddress taSender
      destAddress <- resolveAddress taDestination
      operationHash <- case destAddress of
        ContractAddress _ -> do
          contract <- getContract destAddress
          SomeContract fullContract <-
            throwLeft $ pure $ typeCheckingWith def $ typeCheckContract contract
          case fullContract of
            (Contract{} :: Contract cp st) -> do
              let addrs = extractAddressesFromValue taParameter
              tcOriginatedContracts <- getContractsParameterTypes addrs
              parameter <- throwLeft $ pure $ typeCheckingWith def $
                typeVerifyParameter @cp tcOriginatedContracts taParameter
              transfer sendAddress destAddress taAmount U.DefEpName parameter taMbFee
        KeyAddress _ -> case taParameter of
          U.ValueUnit -> transfer sendAddress destAddress taAmount U.DefEpName VUnit Nothing
          _ -> throwString ("The transaction parameter must be 'Unit' "
            <> "when transferring to an implicit account")
        TransactionRollupAddress _ -> throwString "Only smart contracts can call txr1 addresses"

      putTextLn $ "Transaction was successfully sent.\nOperation hash " <> pretty operationHash <> "."

    GetBalance addrOrAlias -> do
      balance <- getBalance =<< resolveAddress addrOrAlias
      putTextLn $ prettyTez balance

    GetBlockHeader blockId -> do
      blockHeader <- getBlockHeader blockId
      putStrLn $ Aeson.encode blockHeader

    GetScriptSize GetScriptSizeArgs{..} -> do
      contract <- liftIO $ prepareContract (Just ssScriptFile)
      void . throwLeft . pure . typeCheckingWith def $
        typeCheckContractAndStorage contract ssStorage
      size <- computeUntypedContractSize contract ssStorage
      print size

    GetBlockOperations blockId -> do
      operationLists <- getBlockOperations blockId
      forM_ operationLists $ \operations -> do
        forM_ operations $ \BlockOperation {..} -> do
          putTextLn $ "Hash: " <> boHash
          putTextLn $ "Contents: "
          forM_ (orwmResponse <$> boContents) \case
            TransactionOpResp to -> putStrLn $ Aeson.encode to
            OtherOpResp -> putTextLn "Non-transaction operation"
          putTextLn ""
      putTextLn "——————————————————————————————————————————————————\n"

main :: IO ()
main = wrapMain $ do
  -- grepcake: the following line is needed to parse CL arguments (argv) in
  -- utf-8. It might be necessary to add the similar line to other
  -- executables. However, I've filed the issue for `with-utf8`
  -- (https://github.com/serokell/haskell-with-utf8/issues/8). If it gets fixed
  -- in upstream, this line should be safe to remove. In that case, FIXME.
  setFileSystemEncoding utf8

  disableAlphanetWarning
  ClientArgs parsedConfig cmd <- Opt.execParser morleyClientInfo
  env <- mkMorleyClientEnv parsedConfig
  runMorleyClientM env (mainImpl cmd)