morley-client-0.3.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 (blockListF, 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
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
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 OverwriteDuplicateAlias oaContractName originator oaInitialBalance
          contract oaInitialStorage oaMbFee oaDelegate

      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 :: OperationHash, contractEvents :: [IntOpEvent]) <- case destAddress of
        Constrained destContract@ContractAddress{} -> do
          contract <- getContract destContract
          SomeContract fullContract <-
            throwLeft $ pure $ typeCheckingWith def $ typeCheckContract contract
          case fullContract of
            (Contract{} :: Contract cp st) -> do
              let addrs = extractAddressesFromValue taParameter & mapMaybe \case
                    MkAddress x@ContractAddress{} -> Just x
                    _ -> Nothing
              tcOriginatedContracts <- getContractsParameterTypes addrs
              parameter <- throwLeft $ pure $ typeCheckingWith def $
                typeVerifyParameter @cp tcOriginatedContracts taParameter
              transfer sendAddress destContract taAmount U.DefEpName parameter taMbFee
        Constrained 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

    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)