morley-1.18.0: src/Morley/Michelson/Runtime.hs
-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
-- | Executor and typechecker of a contract in Morley language.
module Morley.Michelson.Runtime
(
-- * High level interface for end user
originateContract
, runContract
, transfer
-- * Other helpers
, parseContract
, parseExpandContract
, readAndParseContract
, prepareContract
-- * Re-exports
, ContractState (..)
, VotingPowers
, mkVotingPowers
, mkVotingPowersFromMap
, TxData (..)
, TxParam (..)
-- * For testing
, ExecutorOp (..)
, ExecutorRes (..)
, erGState
, erUpdates
, erInterpretResults
, erRemainingSteps
, ExecutorError' (..)
, ExecutorError
, ExecutorM
, runExecutorM
, runExecutorMWithDB
, executeGlobalOperations
, executeGlobalOrigination
, executeOrigination
, executeTransfer
, ExecutorState(..)
, esGState
, esRemainingSteps
, esSourceAddress
, esLog
, esOperationHash
, esPrevCounters
, ExecutorLog(..)
, elInterpreterResults
, elUpdates
) where
import Control.Lens (assign, at, makeLenses, (.=), (<>=))
import Control.Monad.Except (Except, liftEither, runExcept, throwError)
import Data.Constraint (Dict(..), (\\))
import Data.Default (def)
import Data.HashSet qualified as HS
import Data.Semigroup.Generic (GenericSemigroupMonoid(..))
import Data.Singletons (demote)
import Data.Text.IO (getContents)
import Data.Text.IO.Utf8 qualified as Utf8 (readFile)
import Data.Type.Equality (pattern Refl)
import Fmt (Buildable(build), blockListF, fmt, fmtLn, indentF, nameF, pretty, (+|), (|+))
import Text.Megaparsec (parse)
import Morley.Michelson.Interpret
(ContractEnv(..), InterpretError(..), InterpretResult(..), InterpreterState(..), MorleyLogs(..),
RemainingSteps(..), assignBigMapIds, handleContractReturn, interpret)
import Morley.Michelson.Macro (ParsedOp, expandContract)
import Morley.Michelson.Parser qualified as P
import Morley.Michelson.Runtime.Dummy
import Morley.Michelson.Runtime.GState
import Morley.Michelson.Runtime.TxData
import Morley.Michelson.TypeCheck
import Morley.Michelson.Typed
(CreateContract(..), EntrypointCallT, EpName, Operation'(..), SomeConstrainedValue(..),
SomeContractAndStorage(..), SomeStorage, TransferTokens(..), untypeValue)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.Operation
import Morley.Michelson.Untyped (Contract)
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias
import Morley.Tezos.Address.Kinds
import Morley.Tezos.Core
(Mutez, Timestamp(..), getCurrentTime, unsafeAddMutez, unsafeSubMutez, zeroMutez)
import Morley.Tezos.Crypto (KeyHash, parseHash)
import Morley.Util.MismatchError
import Morley.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 TransferOperation
-- ^ Transfer tokens to the address.
| SetDelegateOp SetDelegateOperation
-- ^ Set the delegate of a contract.
| EmitOp EmitOperation
-- ^ Emit contract event.
deriving stock (Show)
instance Buildable ExecutorOp where
build = \case
TransferOp (TransferOperation addr TxData{..} _)->
"Transfer " +| tdAmount |+ " tokens from " +| tdSenderAddress |+ " to " +| addr |+ ""
OriginateOp OriginationOperation{..} ->
"Originate a contract with" <>
" delegate " +| maybe "<nobody>" build ooDelegate |+
" and balance = " +| ooBalance |+ ""
SetDelegateOp SetDelegateOperation{..} ->
"Set delegate of contract " +| sdoContract |+
" to " +| maybe "<nobody>" build sdoDelegate |+ ""
EmitOp (EmitOperation source T.Emit{..}) ->
"Emit event " +| emTag |+
" from contract " +| source |+
" with type " +| emNotes |+
" and value " +| emValue |+ ""
-- | 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
, _eeMinBlockTime :: Natural
}
deriving stock (Show, Generic)
data ExecutorState = ExecutorState
{ _esGState :: GState
, _esRemainingSteps :: RemainingSteps
, _esSourceAddress :: Maybe L1Address
, _esLog :: ExecutorLog
, _esOperationHash :: ~OperationHash
, _esPrevCounters :: HashSet GlobalCounter
}
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.
| EEUnknownAddressAlias SomeAlias
-- ^ Given alias doesn't refer to any address.
| EEUnknownSender a
-- ^ Sender address is unknown.
| EEUnknownManager a
-- ^ Manager address is unknown.
| EENotEnoughFunds a Mutez
-- ^ Sender doesn't have enough funds.
| EEEmptyImplicitContract a
-- ^ Sender is an implicit address with the balance of 0. We mimic tezos-client in calling it
-- "Empty implicit contract".
| 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 (MismatchError 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.
| EEOperationReplay ExecutorOp
-- ^ An attempt to perform the operation duplicated with @DUP@ instruction.
| EEGlobalOperationSourceNotImplicit Address
-- ^ Attempted to initiate global operation from a non-implicit address.
| EEGlobalEmitOp
-- ^ Trying to run emit operation as a global operation, which should be impossible.
deriving stock (Show, Functor, Foldable, Traversable)
instance (Buildable a) => Buildable (ExecutorError' a) where
build =
\case
EEUnknownAddressAlias (SomeAlias (alias :: Alias kind)) ->
("The alias " +| alias |+ " doesn't have any associated " +| demote @kind |+ " addresses")
\\ aliasKindSanity alias
EEUnknownContract addr -> "The contract is not originated " +| addr |+ ""
EEInterpreterFailed addr err ->
"Michelson interpreter failed for contract " +| addr |+ ": " +| err |+ ""
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 |+ ")"
EEEmptyImplicitContract addr ->
"Empty implicit contract (" +| addr |+ ")"
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 _ merr ->
"The contract parameter is well-typed, but did not match the contract's entrypoint's type.\n"
+| merr |+ ""
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 |+ ""
EEOperationReplay op ->
"Operation replay attempt:\n" +| indentF 2 (build op) |+ ""
EEGlobalOperationSourceNotImplicit addr ->
"Attempted to initiate global operation from a non-implicit address " +| addr |+ ""
EEGlobalEmitOp ->
"Attempted to run emit event as a global operation, this should be impossible."
type ExecutorError = ExecutorError' Address
instance (Typeable a, Show a, Buildable a) => Exception (ExecutorError' a) where
displayException = pretty
----------------------------------------------------------------------------
-- Interface
----------------------------------------------------------------------------
-- | Parse a contract from 'Text'.
parseContract
:: P.MichelsonSource -> Text -> Either P.ParserException (U.Contract' ParsedOp)
parseContract source =
first P.ParserException . parse P.program (pretty source)
-- | Parse a contract from 'Text' and expand macros.
parseExpandContract
:: P.MichelsonSource -> Text -> Either P.ParserException Contract
parseExpandContract = fmap expandContract ... parseContract
-- | 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 (toSrc mFilename) code
where
readCode :: Maybe FilePath -> IO Text
readCode = maybe getContents Utf8.readFile
toSrc :: Maybe FilePath -> P.MichelsonSource
toSrc = maybe P.MSUnspecified P.MSFile
-- | 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
-> ImplicitAddress
-> Maybe ContractAlias
-> Maybe KeyHash
-> Mutez
-> U.Value
-> U.Contract
-> "verbose" :! Bool
-> IO ContractAddress
originateContract dbPath tcOpts originator mbAlias 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 Nothing dbPath 100500 verbose (#dryRun :? Nothing) $ do
executeGlobalOrigination origination
where
mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation
{ ooOriginator = originator
, ooDelegate = delegate
, ooBalance = balance
, ooStorage = storage
, ooContract = contract
, ooCounter = 0
, ooAlias = mbAlias
}
-- | 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
-> Maybe Natural
-> Word64
-> Mutez
-> FilePath
-> TypeCheckOptions
-> U.Value
-> U.Contract
-> TxData
-> "verbose" :! Bool
-> "dryRun" :! Bool
-> IO SomeStorage
runContract maybeNow maybeLevel maybeMinBlockTime 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 maybeMinBlockTime 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 $ TransferOperation (MkAddress addr) txData 1
void $ 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 :: KeyHash
delegate =
either (error . mappend "runContract can't parse delegate: " . pretty) id $
parseHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47"
mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation
{ ooOriginator = genesisAddress
, ooDelegate = Just delegate
, ooBalance = initBalance
, ooStorage = storage
, ooContract = contract
, ooCounter = 0
, ooAlias = Nothing
}
getContractStorage :: ContractAddress -> ExecutorM SomeStorage
getContractStorage addr = do
addrs <- use (esGState . gsContractAddressesL)
case addrs ^. at addr of
Nothing -> error $ pretty addr <> " is unknown"
Just ContractState{..} -> return $ SomeStorage csStorage
-- | Send a transaction to given address with given parameters.
transfer
:: Maybe Timestamp
-> Maybe Natural
-> Maybe Natural
-> Word64
-> FilePath
-> TypeCheckOptions
-> AddressOrAlias kind
-> TxData
-> "verbose" :! Bool
-> "dryRun" :? Bool
-> IO ()
transfer maybeNow maybeLevel maybeMinBlockTime maxSteps dbPath tcOpts destination txData verbose dryRun = do
void $ runExecutorMWithDB maybeNow maybeLevel maybeMinBlockTime dbPath (RemainingSteps maxSteps) verbose dryRun $ do
destAddr <- MkAddress <$> resolveAddress destination
executeGlobalOperations tcOpts [TransferOp $ TransferOperation destAddr txData 0]
----------------------------------------------------------------------------
-- 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
-> Natural
-> RemainingSteps
-> GState
-> ExecutorM a
-> Either ExecutorError (ExecutorRes, a)
runExecutorM now level minBlockTime remainingSteps gState action =
fmap preResToRes
$ runExcept
$ runStateT (runReaderT action $ ExecutorEnv now level minBlockTime)
initialState
where
initialOpHash = error "Initial OperationHash touched"
initialState = ExecutorState
{ _esGState = gState
, _esRemainingSteps = remainingSteps
, _esSourceAddress = Nothing
, _esLog = mempty
, _esOperationHash = initialOpHash
, _esPrevCounters = 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
-> Maybe Natural
-> Maybe Natural
-> FilePath
-> RemainingSteps
-> "verbose" :! Bool
-> "dryRun" :? Bool
-> ExecutorM a
-> IO (ExecutorRes, a)
runExecutorMWithDB maybeNow maybeLevel maybeMinBlockTime dbPath remainingSteps
(arg #verbose -> verbose)
(argDef #dryRun False -> dryRun)
action = do
gState <- readGState dbPath
now <- maybe getCurrentTime pure maybeNow
let level = fromMaybe 0 maybeLevel
mbt = fromMaybe dummyMinBlockTime maybeMinBlockTime
(res@ExecutorRes{..}, a) <- either throwM pure $
runExecutorM now level mbt 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 = iurMorleyLogs
unless (null logs) $ do
putTextLn "And produced logs:"
mapM_ putTextLn logs
putTextLn "" -- extra break line to separate logs from two sequence contracts
-- | Resolves 'AddressOrAlias' type to 'KindedAddress' of the appropriate kind.
resolveAddress
:: forall kind. AddressOrAlias kind
-> ExecutorM (KindedAddress kind)
resolveAddress (AddressResolved addr) = pure addr
resolveAddress (AddressAlias alias) = do
let s :: SingAddressKind kind = T.sing @kind \\ aliasKindSanity alias
addrMb <- use $ case s of
SAddressKindImplicit -> esGState . gsImplicitAddressAliasesL . at alias
SAddressKindContract -> esGState . gsContractAddressAliasesL . at alias
case addrMb of
Just addr -> pure addr
Nothing -> throwError $ EEUnknownAddressAlias $ SomeAlias alias
-- | Execute a list of global operations, returning a list of generated events.
executeGlobalOperations
:: TypeCheckOptions
-> [ExecutorOp]
-> ExecutorM [EmitOperation]
executeGlobalOperations tcOpts = concatMapM $ \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 [EmitOperation]
executeMany isGlobalOp = \case
[] -> pure []
(op:opsTail) -> do
case op of
OriginateOp origination -> do
void $ executeOrigination isGlobalOp origination
executeMany (#isGlobalOp :! False) opsTail
SetDelegateOp operation -> do
executeDelegation isGlobalOp operation
executeMany (#isGlobalOp :! False) opsTail
TransferOp transferOperation -> do
moreOps <- executeTransfer isGlobalOp Nothing tcOpts transferOperation
executeMany (#isGlobalOp :! False) $ moreOps <> opsTail
EmitOp emitOperation -> do
liftM2 (:) (executeEmit isGlobalOp emitOperation) $
executeMany (#isGlobalOp :! False) opsTail
-- | Execute a global origination operation.
executeGlobalOrigination :: OriginationOperation -> ExecutorM ContractAddress
executeGlobalOrigination = executeOrigination ! #isGlobalOp True
-- | Execute an origination operation.
executeOrigination
:: "isGlobalOp" :! Bool
-> OriginationOperation
-> ExecutorM ContractAddress
executeOrigination (arg #isGlobalOp -> isGlobalOp) origination@(OriginationOperation{..}) = do
when isGlobalOp $ do
beginGlobalOperation
assign esOperationHash $ mkOriginationOperationHash origination
checkOperationReplay $ OriginateOp origination
opHash <- use esOperationHash
gs <- use esGState
-- Add big_map IDS to storage
let bigMapCounter0 = gs ^. gsBigMapCounterL
let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds False ooStorage) bigMapCounter0
let contractState = ContractState ooBalance ooContract storageWithIds ooDelegate
let originatorAddress = ooOriginator
originatorBalance <- case lookupBalance originatorAddress gs of
Nothing -> throwError $ EEUnknownManager $ MkAddress ooOriginator
Just oldBalance
| oldBalance < ooBalance ->
throwError $ EENotEnoughFunds (MkAddress ooOriginator) oldBalance
| otherwise ->
-- Subtraction is safe because we have checked its
-- precondition in guard.
return $ oldBalance `unsafeSubMutez` ooBalance
let
address = mkContractAddress opHash ooCounter
updates =
catMaybes
[ liftA2 GSAddContractAddressAlias ooAlias (Just address)
, Just $ GSAddContractAddress address contractState
, Just $ GSSetBalance originatorAddress originatorBalance
, Just GSIncrementCounter
, if bigMapCounter0 == bigMapCounter1
then Nothing
else Just $ GSSetBigMapCounter bigMapCounter1
]
case applyUpdates updates gs of
Left err -> throwError $ EEFailedToApplyUpdates err
Right newGS -> do
esGState .= newGS
esLog <>= ExecutorLog updates []
return address
-- | Execute delegation operation.
executeDelegation
:: "isGlobalOp" :! Bool
-> SetDelegateOperation
-> ExecutorM ()
executeDelegation (arg #isGlobalOp -> isGlobalOp) delegation@SetDelegateOperation{..} = do
when isGlobalOp $ do
beginGlobalOperation
assign esOperationHash $ mkDelegationOperationHash delegation
checkOperationReplay $ SetDelegateOp delegation
gs <- use esGState
let updates = [GSSetDelegate sdoContract sdoDelegate]
case applyUpdates updates gs of
Left err -> throwError $ EEFailedToApplyUpdates err
Right newGS -> do
esGState .= newGS
esLog <>= ExecutorLog updates []
return ()
-- | Execute delegation operation.
executeEmit
:: "isGlobalOp" :! Bool
-> EmitOperation
-> ExecutorM EmitOperation
executeEmit (arg #isGlobalOp -> isGlobalOp) op = do
when isGlobalOp $ throwError EEGlobalEmitOp
checkOperationReplay $ EmitOp op
pure op
-- | Execute a transfer operation.
executeTransfer
:: "isGlobalOp" :! Bool
-> Maybe Mutez
-- ^ Whether to override the destination's balance.
--
-- When it's a `Just`, the destination's balance will be set to the given amount
-- and no tz will be debited from the sender's account.
-- This is useful to emulate the behaviour of the Tezos RPC's @/run_code@ endpoint.
-> TypeCheckOptions
-> TransferOperation
-> ExecutorM [ExecutorOp]
executeTransfer (arg #isGlobalOp -> isGlobalOp)
overrideBalanceMb tcOpts
transferOperation@(
TransferOperation (MkAddress (addr :: KindedAddress kind))
txData@TxData{tdSenderAddress=MkConstrainedAddress senderAddr,..} _) = do
when isGlobalOp $
beginGlobalOperation
now <- view eeNow
level <- view eeLevel
mbt <- view eeMinBlockTime
gs <- use esGState
remainingSteps <- use esRemainingSteps
sourceAddr <- fromMaybe (tdSenderAddress txData) <$> use esSourceAddress
let globalCounter = gsCounter gs
let addresses :: Map (KindedAddress kind) (AddressStateFam kind)
addresses = case addr of
ImplicitAddress{} -> gsImplicitAddresses gs
ContractAddress{} -> gsContractAddresses gs
TxRollupAddress{} -> gsTxRollupAddresses gs
let isZeroTransfer = tdAmount == zeroMutez
let senderBalance = lookupBalance senderAddr gs
checkOperationReplay $ TransferOp transferOperation
-- Implicit addresses can't be senders with a balance of 0tz even when the transfer amount
-- is zero.
case isImplicitAddress senderAddr of
Nothing -> do
when (isGlobalOp && not isZeroTransfer) $
throwError $ EETransactionFromContract (MkAddress senderAddr) tdAmount
Just Refl -> do
when (isNothing overrideBalanceMb) $
case senderBalance of
Nothing -> throwError $ EEEmptyImplicitContract $ MkAddress senderAddr
Just balance | balance == zeroMutez ->
throwError $ EEEmptyImplicitContract $ MkAddress senderAddr
_ -> pass
case isImplicitAddress addr of
Nothing -> pass
Just Refl -> do
when (badParamToImplicitAccount tdParameter) $
throwError $ EEWrongParameterType $ MkAddress addr
-- Transferring 0 XTZ to a key address is prohibited.
when (isZeroTransfer) $
throwError $ EEZeroTransaction $ MkAddress addr
mDecreaseSenderBalance <-
if isNothing overrideBalanceMb && not isZeroTransfer
then case senderBalance of
Nothing -> throwError $ EEUnknownSender $ MkAddress senderAddr
Just balance
| balance < tdAmount ->
throwError $ EENotEnoughFunds (MkAddress senderAddr) balance
| otherwise -> do
-- Subtraction is safe because we have checked its
-- precondition in guard.
let newBal = balance `unsafeSubMutez` tdAmount
pure $ Just $ GSSetBalance senderAddr newBal
else pure Nothing
let commonFinishup
:: Dict (L1AddressKind kind)
-- NB: this is a Dict and not a constraint because GHC desugars these
-- let-bindings such that it expects this constraint at the definition
-- site.
-> [GStateUpdate]
-> [T.Operation]
-> Maybe InterpretResult
-> RemainingSteps
-> ExecutorM [ExecutorOp]
commonFinishup Dict otherUpdates sideEffects maybeInterpretRes newRemSteps = do
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 . (MkAddress addr, )) maybeInterpretRes)
mapM (convertOp addr) $ sideEffects
onlyUpdates :: Dict (L1AddressKind kind) -> [GStateUpdate] -> ExecutorM [ExecutorOp]
onlyUpdates dict updates = commonFinishup dict updates [] Nothing remainingSteps
case addr of
TxRollupAddress{} ->
-- TODO [#838]: support transaction rollups on the emulator
throwError $ EEUnknownContract (MkAddress addr)
ImplicitAddress{} -> case addresses ^. at addr of
Nothing -> do
let
transferAmount = tdAmount
addrState = transferAmount
upd = GSAddImplicitAddress addr addrState
onlyUpdates Dict [upd]
Just oldBalance -> do
let
-- Calculate the account's new balance, unless `overrideBalanceMb` is used.
-- Note: `unsafeAddMutez` can't overflow if global state is correct (because we can't
-- create money out of nowhere)
newBalance =
fromMaybe
(oldBalance `unsafeAddMutez` tdAmount)
overrideBalanceMb
upd = GSSetBalance addr newBalance
onlyUpdates Dict [upd]
ContractAddress{} -> case addresses ^. at addr of
Nothing -> throwError $ EEUnknownContract (MkAddress addr)
Just ContractState{..} -> do
let
existingContracts = extractAllContracts gs
newBalance =
-- Calculate the contract's new balance, unless `overrideBalanceMb` is used.
-- Note: `unsafeAddMutez` can't overflow if global state is correct (because we can't
-- create money out of nowhere)
fromMaybe
(csBalance `unsafeAddMutez` tdAmount)
overrideBalanceMb
epName = tdEntrypoint
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 of
TxTypedParam (typedVal :: T.Value t) ->
T.castM @t @epArg typedVal $
throwError . EEUnexpectedParameterType (MkAddress addr)
TxUntypedParam untypedVal ->
liftEither $ first (EEIllTypedParameter $ MkAddress addr) $
typeCheckingWith tcOpts $
typeVerifyParameter @epArg existingContracts untypedVal
let bigMapCounter0 = gs ^. gsBigMapCounterL
let (typedParameterWithIds, bigMapCounter1) = runState (assignBigMapIds False 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
tdAmount
opHash <- use esOperationHash
let
contractEnv = ContractEnv
{ ceNow = now
, ceMaxSteps = remainingSteps
, ceBalance = newBalance
, ceContracts = gsContractAddresses gs
, ceSelf = addr
, ceSource = sourceAddr
, ceSender = MkConstrainedAddress senderAddr
, ceAmount = tdAmount
, ceVotingPowers = gsVotingPowers gs
, ceChainId = gsChainId gs
, ceOperationHash = Just opHash
, ceLevel = level
, ceErrorSrcPos = def
, ceMinBlockTime = mbt
}
iur@InterpretResult
{ iurOps = sideEffects
, iurNewStorage = newValue
, iurNewState = InterpreterState newRemainingSteps globalCounter2 bigMapCounter2
}
<- liftEither $ first (EEInterpreterFailed (MkAddress addr)) $
handleContractReturn $
interpret
csContract
epc
typedParameterWithIds
csStorage
(gsCounter gs)
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
updGlobalCounter
| globalCounter == globalCounter2 = Nothing
| otherwise = Just $ GSUpdateCounter globalCounter2
updates = catMaybes
[ updBalance
, updStorage
, updBigMapCounter
, updGlobalCounter
]
commonFinishup Dict updates sideEffects (Just iur) newRemainingSteps
----------------------------------------------------------------------------
-- Simple helpers
----------------------------------------------------------------------------
checkOperationReplay :: ExecutorOp -> ExecutorM ()
checkOperationReplay op = do
let
opCounter = op & \case
OriginateOp OriginationOperation{..} -> ooCounter
TransferOp TransferOperation{..} -> toCounter
SetDelegateOp SetDelegateOperation{..} -> sdoCounter
EmitOp (EmitOperation _ T.Emit{..}) -> emCounter
prevCounters <- use esPrevCounters
when (opCounter `HS.member` prevCounters) $
throwError $ EEOperationReplay op
esPrevCounters <>= one opCounter
-- The argument is the address of the contract that generated this operation.
convertOp :: L1AddressKind kind => KindedAddress kind -> T.Operation -> ExecutorM ExecutorOp
convertOp interpretedAddr =
\case
OpTransferTokens tt ->
pure $ case ttContract tt of
T.VContract destAddress sepc ->
let txData =
TxData
{ tdSenderAddress = MkConstrainedAddress interpretedAddr
, tdEntrypoint = T.sepcName sepc
, tdParameter = TxTypedParam (ttTransferArgument tt)
, tdAmount = ttAmount tt
}
transferOperation =
TransferOperation
{ toDestination = destAddress
, toTxData = txData
, toCounter = ttCounter tt
}
in TransferOp transferOperation
OpSetDelegate T.SetDelegate{..} -> case interpretedAddr of
addr@ContractAddress{} -> pure $ SetDelegateOp SetDelegateOperation
{ sdoContract = addr
, sdoDelegate = sdMbKeyHash
, sdoCounter = sdCounter
}
_ -> throwError $ EEUnknownContract $ MkAddress interpretedAddr
OpCreateContract CreateContract{ccOriginator=MkConstrainedAddress ccOriginator, ..} ->
pure $ OriginateOp OriginationOperation
{ ooOriginator = ccOriginator
, ooDelegate = ccDelegate
, ooBalance = ccBalance
, ooStorage = ccStorageVal
, ooContract = ccContract
, ooCounter = ccCounter
, ooAlias = Nothing
}
OpEmit emit -> case interpretedAddr of
ContractAddress{} -> pure $ EmitOp $ EmitOperation interpretedAddr emit
_ -> throwError $ EEUnknownContract $ MkAddress interpretedAddr
-- | Reset source address before executing a global operation.
beginGlobalOperation :: ExecutorM ()
beginGlobalOperation =
esSourceAddress .= Nothing
-- | Return True if the param is not Unit.
badParamToImplicitAccount :: TxParam -> Bool
badParamToImplicitAccount (TxTypedParam T.VUnit) = False
badParamToImplicitAccount (TxUntypedParam U.ValueUnit) = False
badParamToImplicitAccount _ = True