Runtime.hs

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

-- | Executor and typechecker of a contract in Morley language.

module Michelson.Runtime
  (
    -- * High level interface for end user
    originateContract
  , runContract
  , transfer

  -- * Other helpers
  , parseContract
  , parseExpandContract
  , readAndParseContract
  , prepareContract

  -- * Re-exports
  , ContractState (..)
  , AddressState (..)
  , TxData (..)
  , TxParam (..)

  -- * For testing
  , ExecutorOp (..)
  , ExecutorRes (..)
  , ExecutorError' (..)
  , ExecutorError
  , ExecutorM
  , runExecutorM
  , runExecutorMWithDB
  , withGlobalOperation
  , executeGlobalOperations
  , executeOrigination
  , executeTransfer

  -- * To avoid warnings (can't generate lenses only for some fields)
  , erInterpretResults
  , erUpdates
  , erGState
  , erRemainingSteps
  , elInterpreterResults
  , elUpdates
  ) where

import Control.Lens (at, makeLenses, (+=), (.=), (<>=))
import Control.Monad.Except (Except, liftEither, runExcept, throwError)
import qualified Data.Aeson as Aeson
import Data.Binary.Put (putWord64be, runPut)
import qualified Data.ByteString.Lazy as BSL
import Data.Semigroup.Generic
import Data.Text.IO (getContents)
import Fmt (Buildable(build), blockListF, fmt, fmtLn, nameF, pretty, (+|), (|+))
import Named ((:!), (:?), arg, argDef, defaults, (!))
import Text.Megaparsec (parse)

import Data.Singletons (demote)
import Data.Typeable (gcast)
import Michelson.Interpret
  (ContractEnv(..), InterpretError(..), InterpretResult(..), InterpreterState(..), MorleyLogs(..),
  RemainingSteps(..), handleContractReturn, interpret)
import Michelson.Macro (ParsedOp, expandContract)
import qualified Michelson.Parser as P
import Michelson.Runtime.GState
import Michelson.Runtime.TxData
import Michelson.TypeCheck (TCError, typeVerifyParameter)
import Michelson.Typed
  (CreateContract(..), EntrypointCallT, EpName, Operation'(..), SomeValue'(..), TransferTokens(..),
  convertContractCode, untypeValue)
import qualified Michelson.Typed as T
import Michelson.Untyped
  (Contract, GlobalCounter(..), OperationHash(..), OriginationOperation(..),
  mkOriginationOperationHash)
import qualified Michelson.Untyped as U
import Tezos.Address (Address(..), OriginationIndex(..), mkContractAddress)
import Tezos.Core (Mutez, Timestamp(..), getCurrentTime, toMutez, unsafeAddMutez, unsafeSubMutez)
import Tezos.Crypto (blake2b, parseKeyHash)
import Util.IO (readFileUtf8)

----------------------------------------------------------------------------
-- Auxiliary types
----------------------------------------------------------------------------

-- | Operations executed by interpreter.
-- In our model one Michelson's operation (`operation` type in Michelson)
-- corresponds to 0 or 1 interpreter operation.
--
-- Note: 'Address' is not part of 'TxData', because 'TxData' is
-- supposed to be provided by the user, while 'Address' can be
-- computed by our code.
data ExecutorOp
  = OriginateOp OriginationOperation
  -- ^ Originate a contract.
  | TransferOp Address TxData
  -- ^ Send a transaction to given address which is assumed to be the
  -- address of an originated contract.
  deriving stock (Show)

-- | Result of a single execution of interpreter.
data ExecutorRes = ExecutorRes
  { _erGState :: GState
  -- ^ New 'GState'.
  , _erUpdates :: [GStateUpdate]
  -- ^ Updates applied to 'GState'.
  , _erInterpretResults :: [(Address, InterpretResult)]
  -- ^ During execution a contract can print logs and in the end it returns
  -- a pair. All logs and returned values are kept until all called contracts
  -- are executed. In the end they are printed.
  , _erRemainingSteps :: RemainingSteps
  -- ^ Now much gas all remaining executions can consume.
  } deriving stock (Show)

data ExecutorEnv = ExecutorEnv
  { _eeOperationHash :: ~OperationHash
  , _eeNow :: Timestamp
  }
  deriving stock (Show, Generic)

data ExecutorState = ExecutorState
  { _esGState :: GState
  , _esRemainingSteps :: RemainingSteps
  , _esOriginationNonce :: Int32
  , _esSourceAddress :: Maybe Address
  , _esLog :: ExecutorLog
  }
  deriving stock (Show, Generic)

data ExecutorLog = ExecutorLog
  { _elUpdates :: [GStateUpdate]
  , _elInterpreterResults :: [(Address, InterpretResult)]
  }
  deriving stock (Show, Generic)
  deriving (Semigroup, Monoid) via GenericSemigroupMonoid ExecutorLog

makeLenses ''ExecutorRes
makeLenses ''ExecutorEnv
makeLenses ''ExecutorState
makeLenses ''ExecutorLog

-- | Errors that can happen during contract interpreting.
-- Type parameter @a@ determines how contracts will be represented
-- in these errors, e.g. 'Address'.
data ExecutorError' a
  = EEUnknownContract !a
  -- ^ The interpreted contract hasn't been originated.
  | EEInterpreterFailed !a
                        !InterpretError
  -- ^ Interpretation of Michelson contract failed.
  | EEAlreadyOriginated !a
                        !ContractState
  -- ^ A contract is already originated.
  | EEUnknownSender !a
  -- ^ Sender address is unknown.
  | EEUnknownManager !a
  -- ^ Manager address is unknown.
  | EENotEnoughFunds !a !Mutez
  -- ^ Sender doesn't have enough funds.
  | EEZeroTransaction !a
  -- ^ Sending 0tz towards an address.
  | EEFailedToApplyUpdates !GStateUpdateError
  -- ^ Failed to apply updates to GState.
  | EEIllTypedContract !TCError
  -- ^ A contract is ill-typed.
  | EEIllTypedStorage !TCError
  -- ^ Contract storage is ill-typed.
  | EEIllTypedParameter !TCError
  -- ^ Contract parameter is ill-typed.
  | EEUnexpectedParameterType T.T T.T
  -- ^ Contract parameter is well-typed, but its type does
  -- not match the entrypoint's type.
  | EEUnknownEntrypoint EpName
  -- ^ Specified entrypoint to run is not found.
  deriving stock (Show, Functor)

instance (Buildable a) => Buildable (ExecutorError' a) where
  build =
    \case
      EEUnknownContract addr -> "The contract is not originated " +| addr |+ ""
      EEInterpreterFailed addr err ->
        "Michelson interpreter failed for contract " +| addr |+ ": " +| err |+ ""
      EEAlreadyOriginated addr cs ->
        "The following contract is already originated: " +| addr |+
        ", " +| cs |+ ""
      EEUnknownSender addr -> "The sender address is unknown " +| addr |+ ""
      EEUnknownManager addr -> "The manager address is unknown " +| addr |+ ""
      EENotEnoughFunds addr amount ->
        "The sender (" +| addr |+
        ") doesn't have enough funds (has only " +| amount |+ ")"
      EEZeroTransaction addr ->
        "Transaction of 0ꜩ towards a key address " +| addr |+ " which has no code is prohibited"
      EEFailedToApplyUpdates err -> "Failed to update GState: " +| err |+ ""
      EEIllTypedContract err -> "The contract is ill-typed: " +| err |+ ""
      EEIllTypedStorage err -> "The contract storage is ill-typed: " +| err |+ ""
      EEIllTypedParameter err -> "The contract parameter is ill-typed: " +| err |+ ""
      EEUnexpectedParameterType expectedT actualT ->
        "The contract parameter is well-typed, but did not match the contract's entrypoint's type.\n" <>
        "Expected: " +| expectedT |+ "\n" <>
        "Got: " +| actualT |+ ""
      EEUnknownEntrypoint epName -> "The contract does not contain entrypoint '" +| epName |+ "'"

type ExecutorError = ExecutorError' Address

instance (Typeable a, Show a, Buildable a) => Exception (ExecutorError' a) where
  displayException = pretty

----------------------------------------------------------------------------
-- Interface
----------------------------------------------------------------------------

-- | Parse a contract from 'Text'.
parseContract ::
     Maybe FilePath -> Text -> Either P.ParserException (U.Contract' ParsedOp)
parseContract mFileName =
  first P.ParserException . parse P.program (fromMaybe "<stdin>" mFileName)

-- | Parse a contract from 'Text' and expand macros.
parseExpandContract ::
     Maybe FilePath -> Text -> Either P.ParserException Contract
parseExpandContract mFileName = fmap expandContract . parseContract mFileName

-- | Read and parse a contract from give path or `stdin` (if the
-- argument is 'Nothing'). The contract is not expanded.
readAndParseContract :: Maybe FilePath -> IO (U.Contract' ParsedOp)
readAndParseContract mFilename = do
  code <- readCode mFilename
  either throwM pure $ parseContract mFilename code
  where
    readCode :: Maybe FilePath -> IO Text
    readCode = maybe getContents readFileUtf8

-- | Read a contract using 'readAndParseContract', expand and
-- flatten. The contract is not type checked.
prepareContract :: Maybe FilePath -> IO Contract
prepareContract mFile = expandContract <$> readAndParseContract mFile

-- | Originate a contract. Returns the address of the originated
-- contract.
originateContract ::
     FilePath -> OriginationOperation -> "verbose" :! Bool -> IO Address
originateContract dbPath origination verbose =
  -- pass 100500 as maxSteps, because it doesn't matter for origination,
  -- as well as 'now'
  fmap snd $ runExecutorMWithDB Nothing dbPath 100500 verbose ! defaults $ do
    withGlobalOperation (OriginateOp origination)
      $ executeOrigination origination

-- | Run a contract. The contract is originated first (if it's not
-- already) and then we pretend that we send a transaction to it.
runContract
  :: Maybe Timestamp
  -> Word64
  -> Mutez
  -> FilePath
  -> U.Value
  -> Contract
  -> TxData
  -> "verbose" :! Bool
  -> "dryRun" :! Bool
  -> IO ()
runContract maybeNow maxSteps initBalance dbPath storageValue contract txData
  verbose (arg #dryRun -> dryRun) = do
  void $ runExecutorMWithDB maybeNow dbPath (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do
    -- Here we are safe to bypass executeGlobalOperations for origination,
    -- since origination can't generate more operations.
    addr <- withGlobalOperation (OriginateOp origination)
      $ executeOrigination origination
    let transferOp = TransferOp addr txData
    executeGlobalOperations [transferOp]
  where
    -- We hardcode some random key hash here as delegate to make sure that:
    -- 1. Contract's address won't clash with already originated one (because
    -- it may have different storage value which may be confusing).
    -- 2. If one uses this functionality twice with the same contract and
    -- other data, the contract will have the same address.
    delegate =
      either (error . mappend "runContract can't parse delegate: " . pretty) id $
      parseKeyHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47"
    origination = OriginationOperation
      { ooOriginator = genesisAddress
      , ooDelegate = Just delegate
      , ooBalance = initBalance
      , ooStorage = storageValue
      , ooContract = contract
      }

-- | Send a transaction to given address with given parameters.
transfer ::
     Maybe Timestamp
  -> Word64
  -> FilePath
  -> Address
  -> TxData
  -> "verbose" :! Bool
  -> "dryRun" :? Bool
  -> IO ()
transfer maybeNow maxSteps dbPath destination txData verbose dryRun = do
  void $ runExecutorMWithDB maybeNow dbPath (RemainingSteps maxSteps) verbose dryRun $
    executeGlobalOperations [TransferOp destination txData]

----------------------------------------------------------------------------
-- Executor
----------------------------------------------------------------------------

-- | A monad in which contract executor runs.
type ExecutorM =
  ReaderT ExecutorEnv
    (StateT ExecutorState
      (Except ExecutorError)
    )

-- | Run some executor action, returning its result and final executor state in 'ExecutorRes'.
--
-- The action has access to the hash of currently executed global operation, in order to construct
-- addresses of originated contracts. It is expected that the action uses 'withGlobalOperation'
-- to specify this hash. Otherwise it is initialized with 'error'.
runExecutorM
  :: Timestamp
  -> RemainingSteps
  -> GState
  -> ExecutorM a
  -> Either ExecutorError (ExecutorRes, a)
runExecutorM now remainingSteps gState action =
  fmap preResToRes
    $ runExcept
    $ runStateT (runReaderT action $ ExecutorEnv initialOpHash now)
      initialState
  where
    initialOpHash = error "Initial OperationHash touched"

    initialState = ExecutorState
      { _esGState = gState
      , _esRemainingSteps = remainingSteps
      , _esOriginationNonce = 0
      , _esSourceAddress = Nothing
      , _esLog = mempty
      }

    preResToRes :: (a, ExecutorState) -> (ExecutorRes, a)
    preResToRes (r, ExecutorState{..}) =
      ( ExecutorRes
          { _erGState = _esGState
          , _erUpdates = _esLog ^. elUpdates
          , _erInterpretResults = _esLog ^. elInterpreterResults
          , _erRemainingSteps = _esRemainingSteps
          }
      , r
      )

-- | Run some executor action, reading state from the DB on disk.
--
-- Unless @dryRun@ is @False@, the final state is written back to the disk.
--
-- If the executor fails with 'ExecutorError' it will be thrown as an exception.
runExecutorMWithDB
  :: Maybe Timestamp
  -> FilePath
  -> RemainingSteps
  -> "verbose" :! Bool
  -> "dryRun" :? Bool
  -> ExecutorM a
  -> IO (ExecutorRes, a)
runExecutorMWithDB maybeNow dbPath remainingSteps
  (arg #verbose -> verbose)
  (argDef #dryRun False -> dryRun)
  action = do
  gState <- readGState dbPath
  now <- maybe getCurrentTime pure maybeNow
  (res@ExecutorRes{..}, a) <- either throwM pure $ runExecutorM now remainingSteps gState action

  unless dryRun $
    writeGState dbPath _erGState

  mapM_ printInterpretResult _erInterpretResults
  when (verbose && not (null _erUpdates)) $ do
    fmtLn $ nameF "Updates" (blockListF _erUpdates)
    putTextLn $ "Remaining gas: " <> pretty _erRemainingSteps <> "."

  return (res, a)
  where
    printInterpretResult
      :: (Address, InterpretResult) -> IO ()
    printInterpretResult (addr, InterpretResult {..}) = do
      putTextLn $ "Executed contract " <> pretty addr
      case iurOps of
        [] -> putTextLn "It didn't return any operations."
        _ -> fmt $ nameF "It returned operations" (blockListF iurOps)
      putTextLn $
        "It returned storage: " <> pretty (untypeValue iurNewStorage) <> "."
      let MorleyLogs logs = isMorleyLogs iurNewState
      unless (null logs) $
        mapM_ putTextLn logs
      putTextLn "" -- extra break line to separate logs from two sequence contracts

-- | Run some executor action in a context of global operation.
--
-- Use this function to execute one global operation, potentially with its internal
-- suboperations.
withGlobalOperation
  :: ExecutorOp
  -> ExecutorM a
  -> ExecutorM a
withGlobalOperation op action = do
  counter <- use $ esGState . gsCounterL
  -- Reset nonce and source address before executing a global operation.
  esOriginationNonce .= 0
  esSourceAddress .= Nothing
  local (set eeOperationHash $ mkExecutorOpHash op $ GlobalCounter counter)
    $ action

-- | Execute a list of global operation, discarding their results.
--
-- Uses 'withGlobalOperation' internally.
executeGlobalOperations
  :: [ExecutorOp]
  -> ExecutorM ()
executeGlobalOperations = mapM_ $ \op ->
  withGlobalOperation op $ executeMany [op]
  where
    -- | Execute a list of operations and additional operations they return, until there are none.
    executeMany :: [ExecutorOp] -> ExecutorM ()
    executeMany = \case
        [] -> pass
        (op:opsTail) -> do
          case op of
            OriginateOp origination -> void $ executeOrigination origination
            TransferOp addr txData -> do
              moreOps <- executeTransfer addr txData
              -- TODO why does opsTail go before moreOps?
              executeMany $ opsTail <> moreOps

-- | Execute an origination operation.
executeOrigination
  :: OriginationOperation
  -> ExecutorM Address
executeOrigination origination = do
  opHash <- view eeOperationHash
  gs <- use esGState
  originationNonce <- use esOriginationNonce

  contractState <- liftEither $ mkContractState EEIllTypedContract EEIllTypedStorage
    (ooBalance origination, ooContract origination, ooStorage origination)
  let originatorAddress = ooOriginator origination
  originatorBalance <- case gsAddresses gs ^. at originatorAddress of
    Nothing -> throwError (EEUnknownManager originatorAddress)
    Just (asBalance -> oldBalance)
      | oldBalance < ooBalance origination ->
        throwError $ EENotEnoughFunds originatorAddress oldBalance
      | otherwise ->
        -- Subtraction is safe because we have checked its
        -- precondition in guard.
        return $ oldBalance `unsafeSubMutez` ooBalance origination
  let
    address = mkContractAddress opHash $ OriginationIndex originationNonce
    updates =
      [ GSAddAddress address (ASContract contractState)
      , GSSetBalance originatorAddress originatorBalance
      , GSIncrementCounter
      ]
  case applyUpdates updates gs of
    Left _ ->
      throwError $ EEAlreadyOriginated address contractState
    Right newGS -> do
      esGState .= newGS
      esOriginationNonce += 1

      esLog <>= ExecutorLog updates []

      return address

-- | Execute a transfer operation.
executeTransfer
  :: Address
  -> TxData
  -> ExecutorM [ExecutorOp]
executeTransfer addr txData = do
    now <- view eeNow
    gs <- use esGState
    remainingSteps <- use esRemainingSteps
    mSourceAddr <- use esSourceAddress

    opHash <- view eeOperationHash
    let addresses = gsAddresses gs
    let sourceAddr = fromMaybe (tdSenderAddress txData) mSourceAddr
    let senderAddr = tdSenderAddress txData
    let isKeyAddress (KeyAddress _) = True
        isKeyAddress _  = False
    let isZeroTransfer = tdAmount txData == toMutez 0

    -- Transferring 0 XTZ to a key address is prohibited.
    when (isZeroTransfer && isKeyAddress addr) $
      throwError $ EEZeroTransaction addr
    mDecreaseSenderBalance <- case (isZeroTransfer, addresses ^. at senderAddr) of
      (True, _) -> pure Nothing
      (False, Nothing) -> throwError $ EEUnknownSender senderAddr
      (False, Just (asBalance -> balance))
        | balance < tdAmount txData ->
          throwError $ EENotEnoughFunds senderAddr balance
        | otherwise ->
          -- Subtraction is safe because we have checked its
          -- precondition in guard.
          return $ Just $ GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData)
    let onlyUpdates updates = return (updates, [], Nothing, remainingSteps)
    (otherUpdates, sideEffects, maybeInterpretRes :: Maybe InterpretResult, newRemSteps)
        <- case (addresses ^. at addr, addr) of
      (Nothing, ContractAddress _) ->
        throwError $ EEUnknownContract addr
      (Nothing, KeyAddress _) -> do
        let
          transferAmount = tdAmount txData
          addrState = ASSimple transferAmount
          upd = GSAddAddress addr addrState
        onlyUpdates [upd]
      (Just (ASSimple oldBalance), _) -> do
        -- can't overflow if global state is correct (because we can't
        -- create money out of nowhere)
        let
          newBalance = oldBalance `unsafeAddMutez` tdAmount txData
          upd = GSSetBalance addr newBalance
        onlyUpdates [upd]
      (Just (ASContract (ContractState {..})), _) -> do
        let
          existingContracts = extractAllContracts gs
          -- can't overflow if global state is correct (because we can't
          -- create money out of nowhere)
          newBalance = csBalance `unsafeAddMutez` tdAmount txData
          contractEnv = ContractEnv
            { ceNow = now
            , ceMaxSteps = remainingSteps
            , ceBalance = newBalance
            , ceContracts = existingContracts
            , ceSelf = addr
            , ceSource = sourceAddr
            , ceSender = senderAddr
            , ceAmount = tdAmount txData
            , ceChainId = gsChainId gs
            , ceOperationHash = Just opHash
            }
          epName = tdEntrypoint txData

        T.MkEntrypointCallRes _ (epc :: EntrypointCallT cp epArg)
          <- T.mkEntrypointCall epName (T.cParamNotes csContract)
             & maybe (throwError $ EEUnknownEntrypoint epName) pure

        -- If the parameter has already been typechecked, simply check if
        -- its type matches the contract's entrypoint's type.
        -- Otherwise (e.g. if it was parsed from stdin via the CLI),
        -- we need to typecheck the parameter.
        typedParameter <-
          case tdParameter txData of
            TxTypedParam (typedVal :: T.Value t) ->
              maybe (throwError $ EEUnexpectedParameterType (demote @epArg) (demote @t)) pure $
                gcast @t @epArg typedVal
            TxUntypedParam untypedVal ->
              liftEither $ first EEIllTypedParameter $
                typeVerifyParameter @epArg existingContracts untypedVal

        iur@InterpretResult
          { iurOps = sideEffects
          , iurNewStorage = newValue
          , iurNewState = InterpreterState _ newRemainingSteps _
          }
          <- liftEither $ first (EEInterpreterFailed addr) $
             handleContractReturn $
                interpret (T.cCode csContract) epc
                typedParameter csStorage contractEnv
        let
          updBalance
            | newBalance == csBalance = Nothing
            | otherwise = Just $ GSSetBalance addr newBalance
          updStorage
            | SomeValue newValue == SomeValue csStorage = Nothing
            | otherwise = Just $ GSSetStorageValue addr newValue
          updates = catMaybes
            [ updBalance
            , updStorage
            ]
        return (updates, sideEffects, Just iur, newRemainingSteps)

    let
      -- According to the reference implementation, counter is incremented for transfers as well.
      updates = (maybe id (:) mDecreaseSenderBalance otherUpdates) ++ [GSIncrementCounter]

    newGState <- liftEither $ first EEFailedToApplyUpdates $ applyUpdates updates gs

    esGState .= newGState
    esRemainingSteps .= newRemSteps
    esSourceAddress .= Just sourceAddr

    esLog <>= ExecutorLog updates (maybe mempty (one . (addr, )) maybeInterpretRes)

    return $ mapMaybe (convertOp addr) sideEffects

----------------------------------------------------------------------------
-- Simple helpers
----------------------------------------------------------------------------

mkExecutorOpHash :: ExecutorOp -> GlobalCounter -> OperationHash
mkExecutorOpHash (OriginateOp op) counter = mkOriginationOperationHash op counter
mkExecutorOpHash (TransferOp addr txData) counter = mkTransferOperationHash addr txData counter

-- TODO [#235] replace JSON-based encoding of transfer operation hash with
-- one more close to reference Tezos implementation.
mkTransferOperationHash :: Address -> TxData -> GlobalCounter -> OperationHash
mkTransferOperationHash addr txData (GlobalCounter counter) =
  OperationHash $ blake2b
  $ BSL.toStrict
  $ Aeson.encode addr <> Aeson.encode txData <> runPut (putWord64be counter)

-- The argument is the address of the contract that generation this operation.
convertOp :: Address -> T.Operation -> Maybe ExecutorOp
convertOp interpretedAddr =
  \case
    OpTransferTokens tt ->
      case ttContract tt of
        T.VContract destAddress sepc ->
          let txData =
                TxData
                  { tdSenderAddress = interpretedAddr
                  , tdEntrypoint = T.sepcName sepc
                  , tdParameter = TxTypedParam (ttTransferArgument tt)
                  , tdAmount = ttAmount tt
                  }
          in Just (TransferOp destAddress txData)
    OpSetDelegate {} -> Nothing
    OpCreateContract cc ->
      let origination = OriginationOperation
            { ooOriginator = ccOriginator cc
            , ooDelegate = ccDelegate cc
            , ooBalance = ccBalance cc
            , ooStorage = untypeValue (ccStorageVal cc)
            , ooContract = convertContractCode (ccContractCode cc)
            }
       in Just (OriginateOp origination)