morley-upgradeable-0.3: app/Main.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

module Main
  ( main
  ) where

import Data.Constraint (Dict(..))
import Data.Version (showVersion)
import Fmt (build, fmtLn, pretty)
import Main.Utf8 (withUtf8)
import Options.Applicative (Parser, ReadM)
import qualified Options.Applicative as Opt
import Paths_morley_upgradeable (version)

import Lorentz.Contracts.Upgradeable.Client
import Lorentz.Value
import qualified Michelson.Macro as U
import qualified Michelson.Parser as P
import Michelson.Printer.Util
import Michelson.Text
import Michelson.TypeCheck as TC
import qualified Michelson.Typed as T
import Michelson.Typed.Scope
import qualified Michelson.Untyped as U
import Morley.Client
import Tezos.Address

data PrintCmd
  = PrintField MText U.Ty
  | PrintEntrypoint MText
  | PrintSubmap MText U.ParsedValue U.Ty U.Ty

data CmdLnArgs = CmdLnArgs MorleyClientConfig Address PrintCmd

argParser :: Parser CmdLnArgs
argParser =
  CmdLnArgs <$> clientConfigParser (pure Nothing) <*> contractOption <*> cmdOption
  where
    contractOption = Opt.option (Opt.eitherReader parseAddrDo) . mconcat $
      [ Opt.long "contract"
      , Opt.short 'c'
      , Opt.metavar "ADDRESS"
      , Opt.help "Upgradeable contract address"
      ]
      where
      parseAddrDo addr =
        either (Left . mappend "Failed to parse address: " . pretty) Right $
        parseAddress $ toText addr

    cmdOption = Opt.hsubparser $ mconcat
      [ printFieldSubCmd
      , printEntrypointSubCmd
      , printSubmapSubCmd
      ]

    printFieldSubCmd =
      Opt.command "print-field" $
      Opt.info
        (PrintField <$> fieldNameOption <*> typeOption "type" "field value")
        (Opt.progDesc "Get field value.")

    printEntrypointSubCmd =
      Opt.command "print-entrypoint" $
      Opt.info
        (PrintEntrypoint <$> fieldNameOption)
        (Opt.progDesc "Get map value.")

    printSubmapSubCmd =
      Opt.command "print-map-value" $
      Opt.info
        (PrintSubmap
         <$> fieldNameOption
         <*> submapKeyOption
         <*> typeOption "key-type" "submap key"
         <*> typeOption "value-type" "submap value"
         )
        (Opt.progDesc "Get map value.")

    fieldNameOption = Opt.option mtextReadM $ mconcat
      [ Opt.long "field"
      , Opt.short 'f'
      , Opt.metavar "NAME"
      , Opt.help "Name of upgradeable storage field"
      ]

    typeOption name helpName = Opt.option typeReadM $ mconcat
      [ Opt.long name
      , Opt.metavar "MICHELSON TYPE"
      , Opt.help $ "Type of " <> helpName
      ]

    submapKeyOption = Opt.option valueReadM $ mconcat
      [ Opt.long "key"
      , Opt.short 'k'
      , Opt.metavar "MICHELSON VALUE"
      , Opt.help "Key in upgradeable storage submap"
      ]

    valueReadM = parsingReadM P.value

    mtextReadM :: ReadM MText
    mtextReadM = Opt.eitherReader $
      first toString . mkMText . toText

    typeReadM :: ReadM U.Ty
    typeReadM = parsingReadM P.type_

    parsingReadM :: P.Parser a -> ReadM a
    parsingReadM parser = Opt.eitherReader $
      first P.errorBundlePretty .
      P.parseNoEnv parser "command line arguments" .
      toText

programInfo :: Opt.ParserInfo CmdLnArgs
programInfo = Opt.info (Opt.helper <*> versionOption <*> argParser) $
  mconcat
  [ Opt.fullDesc
  , Opt.progDesc "Morley-ustore-reader: a tool for reading upgradeable \
                 \contract storage contents."
  , Opt.header "Morley tools"
  , Opt.footerDoc $ Just
      "NOTE: when using this tool, take into account that storage fields \
      \may differ from what appears in code, check whether some \
      \preprocessing takes place upon contract printing."
  ]
  where
    versionOption =
      Opt.infoOption ("morley-ustore-reader-" <> showVersion version)
        (Opt.long "version" <> Opt.help "Show version.")

mainImpl
  :: Address
  -> PrintCmd
  -> MorleyClientM ()
mainImpl contract cmd = do
  case cmd of
    PrintField field (T.AsUType (_ :: T.Notes ty)) -> do
      case checkScope @(UnpackedValScope ty) of
        Right Dict -> do
          val <- readContractUStore @ty contract (UrField field)
          liftIO . fmtLn $ build val
        Left bad ->
          die $ "Value type is invalid: " <> pretty bad

    PrintEntrypoint field -> do
      instrs <- readContractUStoreEntrypoint contract field
      liftIO . fmtLn . printDocB False $ renderOpsList False instrs

    PrintSubmap field key (T.AsUType (_ :: T.Notes kt))
                          (T.AsUType (_ :: T.Notes vt)) -> do
      case (checkScope @(PackedValScope kt), checkScope @(UnpackedValScope vt)) of
        (Right Dict, Right Dict) -> do
          keyT <-
            either (die . pretty) pure $
            runTypeCheckInstrIsolated $
            typeCheckValue @kt (U.expandValue key)
          let keyT' = T.SomeConstrainedValue keyT
          val <- readContractUStore @vt contract (UrSubmap field keyT')
          liftIO . fmtLn $ build val
        (Left bad, _) ->
          die $ "Key type is invalid: " <> pretty bad
        (_, Left bad) ->
          die $ "Value type is invalid: " <> pretty bad

main :: IO ()
main = withUtf8 $ do
  CmdLnArgs parsedConfig contract cmd <- Opt.execParser programInfo
  env <- mkMorleyClientEnv parsedConfig
  runMorleyClientM env (mainImpl contract cmd)