RunCode.hs

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

-- | Emulation of @run_code@.

module Morley.Michelson.Runtime.RunCode
  ( runCode
  , RunCodeParameters(..)
  , runCodeParameters
  , resolveRunCodeBigMaps
  ) where

import Data.Default (def)
import Data.Map qualified as Map

import Morley.Michelson.Interpret
import Morley.Michelson.Runtime.Dummy
import Morley.Michelson.Runtime.GState
import Morley.Michelson.TypeCheck
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.Operation
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Core (ChainId, Mutez, Timestamp(..), dummyChainId, zeroMutez)
import Morley.Tezos.Crypto (KeyHash)

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

-- | Data required for calling 'runCode'.
type RunCodeParameters :: T.T -> T.T -> T.T -> Type
data RunCodeParameters cp epArg st = RunCodeParameters
  { rcScript :: T.Contract cp st
    -- ^ Contract code to run
  , rcStorage :: T.Value st
    -- ^ Initial contract storage
  , rcInput :: T.Value epArg
    -- ^ Parameter to call the contract
  , rcEntryPoint :: T.EntrypointCallT cp epArg
    -- ^ Entrypoint to call. Use 'T.mkEntrypointCall' to construct.
  , rcAmount :: Mutez
    -- ^ Transfer amount
  , rcBalance :: Mutez
    -- ^ Contract initial balance
  , rcChainId :: ChainId
    -- ^ Chain id
  , rcNow :: Timestamp
    -- ^ The result of @NOW@ instruction
  , rcLevel :: Natural
    -- ^ The result of @LEVEL@ instruction
  , rcMinBlockTime :: Natural
    -- ^ The result of @MIN_BLOCK_TIME@ instruction
  , rcSource :: L1Address
    -- ^ Transfer source
  , rcSender :: L1Address
    -- ^ Transfer sender
  , rcKnownContracts :: Map ContractAddress ContractState
    -- ^ Known contracts and their state. If you only know parameter types and
    -- don't need to run contract's views, you can use 'dummyContractState' to
    -- construct the state.
  , rcSelf :: Maybe ContractAddress
    -- ^ Address returned by the @SELF@ instruction, will be auto-generated if
    -- 'Nothing'
  , rcDelegate :: Maybe KeyHash
    -- ^ Contract's delegate
  , rcVotingPowers :: VotingPowers
    -- ^ Voting powers
  }

-- | Construct 'RunCodeParameters' with some reasonable defaults.
--
-- Prepare untyped storage and parameter with 'resolveRunCodeBigMaps'.
--
-- Use 'T.mkEntrypointCall' or 'T.mkDefEntrypointCall' to construct the entrypoint
-- call specification.
runCodeParameters
  :: T.Contract cp st -- ^ Contract to run
  -> T.Value st -- ^ Contract storage
  -> T.EntrypointCallT cp epArg -- ^ Entrypoint call specification
  -> T.Value epArg -- ^ Entrypoint argument
  -> RunCodeParameters cp epArg st
runCodeParameters rcScript rcStorage rcEntryPoint rcInput = RunCodeParameters
  { rcAmount = zeroMutez
  , rcBalance = zeroMutez
  , rcChainId = dummyChainId
  , rcNow = dummyNow
  , rcLevel = dummyLevel
  , rcMinBlockTime = dummyMinBlockTime
  , rcSource = Constrained genesisAddress
  , rcSender = Constrained genesisAddress
  , rcKnownContracts = mempty
  , rcSelf = Nothing
  , rcDelegate = Nothing
  , rcVotingPowers = dummyVotingPowers
  , ..
  }

-- | Emulate @run_code@ RPC endpoint to an extent. Unlike @runContract@, runs
-- the contract through the emulator directly, without doing any operations.
-- This includes not doing the origination operation, and not applying the
-- operations produced by the transfer.
runCode
  :: RunCodeParameters cp epArg st
  -> Either (InterpretError Void) ([T.Operation], T.Value st)
runCode (RunCodeParameters
  -- NB: explicit match to ensure all fields are consumed; ugly, but there are no real alternatives
  rcScript@T.Contract{}
  rcStorage
  rcInput
  rcEntryPoint
  rcAmount
  rcBalance
  rcChainId
  rcNow
  rcLevel
  rcMinBlockTime
  rcSource
  rcSender
  rcKnownContracts
  rcSelf
  rcDelegate
  rcVotingPowers
  ) = fmap (extractValOps . rslResult) . handleReturn $
    interpret rcScript rcEntryPoint input storage dummyGlobalCounter bigMapCtr contractEnv
  where
    selfState = ContractState
      { csBalance = rcBalance
      , csContract = rcScript
      , csStorage = rcStorage
      , csDelegate = rcDelegate
      }
    dummyOriginationHash = mkOriginationOperationHash $
      dummyOrigination rcStorage rcScript dummyGlobalCounter
    self = fromMaybe
      (mkContractAddress dummyOriginationHash dummyGlobalCounter)
      rcSelf
    ((input, storage), bigMapCtr) = usingState dummyBigMapCounter $
      (,) <$> assignBigMapIds False rcInput <*> assignBigMapIds False rcStorage
    contractMap = Map.insert self selfState rcKnownContracts
    contractEnv = ContractEnv
      { ceNow = rcNow
      , ceBalance = rcBalance
      , ceSelf = self
      , ceAmount = rcAmount
      , ceMinBlockTime = rcMinBlockTime
      , ceContracts = pure . flip Map.lookup contractMap
      , ceMaxSteps = dummyMaxSteps
      , ceSource = rcSource
      , ceSender = rcSender
      , ceChainId = rcChainId
      , ceOperationHash = Nothing
      , ceLevel = rcLevel
      , ceErrorSrcPos = def
      , ceVotingPowers = rcVotingPowers
      , ceMetaWrapper = id
      }

-- | Given an untyped value, possibly containing @big_map@ ids, typecheck it,
-- resolving ids to the corresponding @big_map@s.
--
-- 'BigMapFinder' can be constructed using 'Morley.Michelson.Runtime.mkBigMapFinder'.
resolveRunCodeBigMaps
  :: T.SingI t => BigMapFinder -> U.Value -> Either TcError (T.Value t)
resolveRunCodeBigMaps = typeCheckingWith def{tcStrict=False} ... typeCheckValueRunCodeCompat