morley-1.15.0: src/Michelson/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 (..)
, VotingPowers
, mkVotingPowers
, mkVotingPowersFromMap
, TxData (..)
, TxParam (..)
-- * For testing
, ExecutorOp (..)
, ExecutorRes (..)
, ExecutorError' (..)
, ExecutorError
, ExecutorM
, runExecutorM
, runExecutorMWithDB
, executeGlobalOperations
, executeGlobalOrigination
, executeOrigination
, executeTransfer
-- * To avoid warnings (can't generate lenses only for some fields)
, erInterpretResults
, erUpdates
, erGState
, erRemainingSteps
, elInterpreterResults
, elUpdates
) where
import Control.Lens (assign, at, makeLenses, (+=), (.=), (<>=))
import Control.Monad.Except (Except, liftEither, runExcept, throwError)
import Data.Binary.Put (putWord64be, runPut)
import qualified Data.ByteString.Lazy as BSL
import Data.Semigroup.Generic
import Data.Text.IO (getContents)
import qualified Data.Text.IO.Utf8 as Utf8 (readFile)
import Fmt (Buildable(build), blockListF, fmt, fmtLn, nameF, pretty, (+|), (|+))
import Named (arg, argDef, defaults, (!), (:!), (:?))
import Text.Megaparsec (parse)
import Michelson.Interpret
(ContractEnv(..), InterpretError(..), InterpretResult(..), InterpreterState(..), MorleyLogs(..),
RemainingSteps(..), assignBigMapIds, handleContractReturn, interpret)
import qualified Michelson.Interpret.Pack as Pack
import Michelson.Macro (ParsedOp, expandContract)
import qualified Michelson.Parser as P
import Michelson.Runtime.GState
import Michelson.Runtime.TxData
import Michelson.TypeCheck
import Michelson.Typed
(CreateContract(..), EntrypointCallT, EpAddress(..), EpName, Operation'(..), ParameterScope,
SomeContractAndStorage(..), SomeStorage(..), SomeValue(..), TransferTokens(..), starNotes,
starParamNotes, untypeValue)
import qualified Michelson.Typed as T
import Michelson.Typed.Origination
(OperationHash(..), OriginationOperation(..), mkContractAddress, mkOriginationOperationHash)
import Michelson.Untyped (Contract)
import qualified Michelson.Untyped as U
import Tezos.Address (Address(..), OriginationIndex(..))
import Tezos.Core
(Mutez, Timestamp(..), getCurrentTime, unMutez, unsafeAddMutez, unsafeSubMutez, zeroMutez)
import Tezos.Crypto (KeyHash, blake2b, parseKeyHash)
import Util.Named ((.!))
----------------------------------------------------------------------------
-- 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
{ _eeNow :: Timestamp
, _eeLevel :: Natural
}
deriving stock (Show, Generic)
data ExecutorState = ExecutorState
{ _esGState :: GState
, _esRemainingSteps :: RemainingSteps
, _esOriginationNonce :: Int32
, _esSourceAddress :: Maybe Address
, _esLog :: ExecutorLog
, _esOperationHash :: ~OperationHash
}
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.
| EEIllTypedParameter a TCError
-- ^ Contract parameter is ill-typed.
| EEUnexpectedParameterType a 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.
| EETransactionFromContract a Mutez
-- ^ A transaction from an originated contract was attempted as a global operation.
| EEWrongParameterType a
-- ^ Type of parameter in transfer to an implicit account is not Unit.
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 |+ ""
EEIllTypedParameter _ err -> "The contract parameter is ill-typed: " +| err |+ ""
EEUnexpectedParameterType _ actualT expectedT ->
"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 |+ "'"
EETransactionFromContract addr amount ->
"Global transaction of funds (" +| amount |+ ") from an originated contract (" +| addr |+ ") is prohibited."
EEWrongParameterType addr ->
"Bad contract parameter for: " +| addr |+ ""
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 Utf8.readFile
-- | 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
-> TypeCheckOptions
-> Address
-> Maybe KeyHash
-> Mutez
-> U.Value
-> U.Contract
-> "verbose" :! Bool
-> IO Address
originateContract dbPath tcOpts originator delegate balance uStorage uContract verbose = do
origination <- either throwM pure . typeCheckingWith tcOpts $
mkOrigination <$> typeCheckContractAndStorage uContract uStorage
-- pass 100500 as maxSteps, because it doesn't matter for origination,
-- as well as 'now'
fmap snd $ runExecutorMWithDB Nothing Nothing dbPath 100500 verbose ! defaults $ do
executeGlobalOrigination origination
where
mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation
{ ooOriginator = originator
, ooDelegate = delegate
, ooBalance = balance
, ooStorage = storage
, ooContract = contract
}
-- | 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
-> Maybe Natural
-> Word64
-> Mutez
-> FilePath
-> TypeCheckOptions
-> U.Value
-> U.Contract
-> TxData
-> "verbose" :! Bool
-> "dryRun" :! Bool
-> IO SomeStorage
runContract maybeNow maybeLevel maxSteps initBalance dbPath tcOpts uStorage uContract txData
verbose (arg #dryRun -> dryRun) = do
origination <- either throwM pure . typeCheckingWith tcOpts $
mkOrigination <$> typeCheckContractAndStorage uContract uStorage
(_, newSt) <- runExecutorMWithDB maybeNow maybeLevel dbPath (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do
-- Here we are safe to bypass executeGlobalOperations for origination,
-- since origination can't generate more operations.
addr <- executeGlobalOrigination origination
let transferOp = TransferOp addr txData
executeGlobalOperations tcOpts [transferOp]
getContractStorage addr
return newSt
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"
mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation
{ ooOriginator = genesisAddress
, ooDelegate = Just delegate
, ooBalance = initBalance
, ooStorage = storage
, ooContract = contract
}
getContractStorage :: Address -> ExecutorM SomeStorage
getContractStorage addr = do
addrs <- use (esGState . gsAddressesL)
case addrs ^. at addr of
Nothing -> error $ pretty addr <> " is unknown"
Just (ASSimple {}) -> error $ pretty addr <> " is a simple address"
Just (ASContract (ContractState{..})) -> return $ SomeStorage csStorage
-- | Send a transaction to given address with given parameters.
transfer ::
Maybe Timestamp
-> Maybe Natural
-> Word64
-> FilePath
-> TypeCheckOptions
-> Address
-> TxData
-> "verbose" :! Bool
-> "dryRun" :? Bool
-> IO ()
transfer maybeNow maybeLevel maxSteps dbPath tcOpts destination txData verbose dryRun = do
void $ runExecutorMWithDB maybeNow maybeLevel dbPath (RemainingSteps maxSteps) verbose dryRun $
executeGlobalOperations tcOpts [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 @#isGlobalOp .! True@
-- to specify this hash. Otherwise it is initialized with 'error'.
runExecutorM
:: Timestamp
-> Natural
-> RemainingSteps
-> GState
-> ExecutorM a
-> Either ExecutorError (ExecutorRes, a)
runExecutorM now level remainingSteps gState action =
fmap preResToRes
$ runExcept
$ runStateT (runReaderT action $ ExecutorEnv now level)
initialState
where
initialOpHash = error "Initial OperationHash touched"
initialState = ExecutorState
{ _esGState = gState
, _esRemainingSteps = remainingSteps
, _esOriginationNonce = 0
, _esSourceAddress = Nothing
, _esLog = mempty
, _esOperationHash = initialOpHash
}
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
-> Maybe Natural
-> FilePath
-> RemainingSteps
-> "verbose" :! Bool
-> "dryRun" :? Bool
-> ExecutorM a
-> IO (ExecutorRes, a)
runExecutorMWithDB maybeNow maybeLevel dbPath remainingSteps
(arg #verbose -> verbose)
(argDef #dryRun False -> dryRun)
action = do
gState <- readGState dbPath
now <- maybe getCurrentTime pure maybeNow
let level = fromMaybe 0 maybeLevel
(res@ExecutorRes{..}, a) <- either throwM pure $ runExecutorM now level 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
-- | Execute a list of global operations, discarding their results.
executeGlobalOperations
:: TypeCheckOptions
-> [ExecutorOp]
-> ExecutorM ()
executeGlobalOperations tcOpts = mapM_ $ \op ->
executeMany (#isGlobalOp .! True) [op]
where
-- | Execute a list of operations and additional operations they return, until there are none.
executeMany :: "isGlobalOp" :! Bool -> [ExecutorOp] -> ExecutorM ()
executeMany isGlobalOp = \case
[] -> pass
(op:opsTail) -> do
case op of
OriginateOp origination -> void $ executeOrigination isGlobalOp origination
TransferOp addr txData -> do
moreOps <- executeTransfer isGlobalOp tcOpts addr txData
executeMany (#isGlobalOp .! False) $ moreOps <> opsTail
-- | Execute a global origination operation.
executeGlobalOrigination :: OriginationOperation -> ExecutorM Address
executeGlobalOrigination = executeOrigination ! #isGlobalOp True
-- | Execute an origination operation.
executeOrigination
:: "isGlobalOp" :! Bool
-> OriginationOperation
-> ExecutorM Address
executeOrigination (arg #isGlobalOp -> isGlobalOp) origination@(OriginationOperation _ _ bal st contract) = do
when isGlobalOp $ do
beginGlobalOperation
assign esOperationHash $ mkOriginationOperationHash origination
opHash <- use esOperationHash
gs <- use esGState
originationNonce <- use esOriginationNonce
-- Add big_map IDS to storage
let bigMapCounter0 = gs ^. gsBigMapCounterL
let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds st) bigMapCounter0
let contractState = ContractState bal contract storageWithIds
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) (gsCounter gs)
updates =
catMaybes
[ Just $ GSAddAddress address (ASContract contractState)
, Just $ GSSetBalance originatorAddress originatorBalance
, Just $ GSIncrementCounter
, if bigMapCounter0 == bigMapCounter1
then Nothing
else Just $ GSSetBigMapCounter bigMapCounter1
]
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
:: "isGlobalOp" :! Bool
-> TypeCheckOptions
-> Address
-> TxData
-> ExecutorM [ExecutorOp]
executeTransfer (arg #isGlobalOp -> isGlobalOp) tcOpts addr txData = do
when isGlobalOp $
beginGlobalOperation
now <- view eeNow
level <- view eeLevel
gs <- use esGState
remainingSteps <- use esRemainingSteps
mSourceAddr <- use esSourceAddress
let addresses = gsAddresses gs
let senderAddr = tdSenderAddress txData
let sourceAddr = fromMaybe senderAddr mSourceAddr
let isKeyAddress (KeyAddress _) = True
isKeyAddress _ = False
let isZeroTransfer = tdAmount txData == zeroMutez
when (badParamToImplicitAccount addr $ tdParameter txData) $
throwError $ EEWrongParameterType addr
-- 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)
when (not (isKeyAddress senderAddr) && isGlobalOp && not isZeroTransfer) $
throwError $ EETransactionFromContract senderAddr $ 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
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) -> do
T.castM @t @epArg typedVal (throwError ... EEUnexpectedParameterType addr)
TxUntypedParam untypedVal ->
liftEither $ first (EEIllTypedParameter addr) $ typeCheckingWith tcOpts $
typeVerifyParameter @epArg existingContracts untypedVal
let bigMapCounter0 = gs ^. gsBigMapCounterL
let (typedParameterWithIds, bigMapCounter1) = runState (assignBigMapIds typedParameter) bigMapCounter0
-- I'm not entirely sure why we need to pattern match on `()` here,
-- but, if we don't, we get a compiler error that I suspect is somehow related
-- to the existential types we're matching on a few lines above.
--
-- • Couldn't match type ‘a0’
-- with ‘(InterpretResult, RemainingSteps, [Operation], [GStateUpdate])’
-- ‘a0’ is untouchable inside the constraints: StorageScope st1
() <- when isGlobalOp $
esOperationHash .= mkTransferOperationHash
addr
typedParameterWithIds
(tdEntrypoint txData)
(tdAmount txData)
opHash <- use esOperationHash
let
contractEnv = ContractEnv
{ ceNow = now
, ceMaxSteps = remainingSteps
, ceBalance = newBalance
, ceContracts = existingContracts
, ceSelf = addr
, ceSource = sourceAddr
, ceSender = senderAddr
, ceAmount = tdAmount txData
, ceVotingPowers = gsVotingPowers gs
, ceChainId = gsChainId gs
, ceOperationHash = Just opHash
, ceGlobalCounter = gsCounter gs
, ceLevel = level
}
iur@InterpretResult
{ iurOps = sideEffects
, iurNewStorage = newValue
, iurNewState = InterpreterState _ newRemainingSteps _ bigMapCounter2
}
<- liftEither $ first (EEInterpreterFailed addr) $
handleContractReturn $
interpret
csContract
epc
typedParameterWithIds
csStorage
bigMapCounter1
contractEnv
let
updBalance
| newBalance == csBalance = Nothing
| otherwise = Just $ GSSetBalance addr newBalance
updStorage
| SomeValue newValue == SomeValue csStorage = Nothing
| otherwise = Just $ GSSetStorageValue addr newValue
updBigMapCounter
| bigMapCounter0 == bigMapCounter2 = Nothing
| otherwise = Just $ GSSetBigMapCounter bigMapCounter2
updates = catMaybes
[ updBalance
, updStorage
, updBigMapCounter
]
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
----------------------------------------------------------------------------
mkTransferOperationHash :: ParameterScope t => Address -> T.Value t -> EpName -> Mutez -> OperationHash
mkTransferOperationHash to param epName amount =
OperationHash $ blake2b packedOperation
where
-- In Tezos, transfer operations are encoded as 4-tuple of
-- (amount, destination, entrypoint, value)
--
-- See https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L275-282
packedOperation =
BSL.toStrict $
(runPut $ putWord64be $ unMutez amount)
<> (Pack.toBinary $ T.toVal (EpAddress to epName))
<> Pack.toBinary param
-- The argument is the address of the contract that generated 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 = ccStorageVal cc
, ooContract =
T.Contract
{ cCode = ccContractCode cc
, cParamNotes = starParamNotes
, cStoreNotes = starNotes
, cEntriesOrder = U.canonicalEntriesOrder
}
}
in Just (OriginateOp origination)
-- | Reset nonce and source address before executing a global operation.
beginGlobalOperation :: ExecutorM ()
beginGlobalOperation = do
esOriginationNonce .= 0
esSourceAddress .= Nothing
-- | Return True if address is an implicit account yet the param is not Unit.
badParamToImplicitAccount :: Address -> TxParam -> Bool
badParamToImplicitAccount (ContractAddress _) _ = False
badParamToImplicitAccount (KeyAddress _) (TxTypedParam T.VUnit) = False
badParamToImplicitAccount (KeyAddress _) (TxUntypedParam U.ValueUnit) = False
badParamToImplicitAccount _ _ = True