module Michelson.Runtime
(
originateContract
, runContract
, transfer
, parseContract
, parseExpandContract
, readAndParseContract
, prepareContract
, typeCheckWithDb
, ContractState (..)
, AddressState (..)
, TxData (..)
, ExecutorOp (..)
, ExecutorRes (..)
, ExecutorError' (..)
, ExecutorError
, executorPure
, erInterpretResults
, erUpdates
) where
import Control.Lens (at, makeLenses, (%=))
import Control.Monad.Except (Except, runExcept, throwError)
import Data.Singletons (sing)
import Data.Text.IO (getContents)
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(..), handleContractReturn, interpret)
import Michelson.Macro (ParsedOp, expandContract)
import qualified Michelson.Parser as P
import Michelson.Runtime.GState
import Michelson.Runtime.TxData
import Michelson.TypeCheck
(SomeContract, TCError, typeCheckContract, typeCheckTopLevelType, typeVerifyTopLevelType)
import Michelson.Typed
(CreateContract(..), EpName, Operation'(..), SomeValue'(..), TransferTokens(..), convertContract,
untypeValue)
import qualified Michelson.Typed as T
import Michelson.Untyped (Contract, OriginationOperation(..), mkContractAddress)
import qualified Michelson.Untyped as U
import Tezos.Address (Address(..))
import Tezos.Core (Mutez, Timestamp(..), getCurrentTime, toMutez, unsafeAddMutez, unsafeSubMutez)
import Tezos.Crypto (parseKeyHash)
import Util.IO (readFileUtf8)
data ExecutorOp
= OriginateOp OriginationOperation
| TransferOp Address TxData
deriving stock (Show)
data ExecutorRes = ExecutorRes
{ _erGState :: GState
, _erOperations :: [ExecutorOp]
, _erUpdates :: [GStateUpdate]
, _erInterpretResults :: [(Address, InterpretResult)]
, _erSourceAddress :: Maybe Address
, _erRemainingSteps :: RemainingSteps
} deriving stock (Show)
makeLenses ''ExecutorRes
instance Semigroup ExecutorRes where
a <> b =
b
{ _erUpdates = _erUpdates a <> _erUpdates b
, _erInterpretResults = _erInterpretResults a <> _erInterpretResults b
, _erSourceAddress = _erSourceAddress a <|> _erSourceAddress b
}
data ExecutorError' a
= EEUnknownContract !a
| EEInterpreterFailed !a
!InterpretError
| EEAlreadyOriginated !a
!ContractState
| EEUnknownSender !a
| EEUnknownManager !a
| EENotEnoughFunds !a !Mutez
| EEZeroTransaction !a
| EEFailedToApplyUpdates !GStateUpdateError
| EEIllTypedContract !TCError
| EEIllTypedStorage !TCError
| EEIllTypedParameter !TCError
| EEUnknownEntrypoint EpName
deriving stock (Show)
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 |+ ""
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
parseContract ::
Maybe FilePath -> Text -> Either P.ParserException (U.Contract' ParsedOp)
parseContract mFileName =
first P.ParserException . parse P.program (fromMaybe "<stdin>" mFileName)
parseExpandContract ::
Maybe FilePath -> Text -> Either P.ParserException Contract
parseExpandContract mFileName = fmap expandContract . parseContract mFileName
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
prepareContract :: Maybe FilePath -> IO Contract
prepareContract mFile = expandContract <$> readAndParseContract mFile
originateContract ::
FilePath -> OriginationOperation -> "verbose" :! Bool -> IO Address
originateContract dbPath origination verbose =
mkContractAddress origination <$
executor Nothing 100500 dbPath [OriginateOp origination] verbose
! defaults
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) =
executor maybeNow maxSteps dbPath operations verbose ! #dryRun dryRun
where
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
}
addr = mkContractAddress origination
operations =
[ OriginateOp origination
, TransferOp addr txData
]
transfer ::
Maybe Timestamp
-> Word64
-> FilePath
-> Address
-> TxData
-> "verbose" :! Bool -> "dryRun" :? Bool -> IO ()
transfer maybeNow maxSteps dbPath destination txData =
executor maybeNow maxSteps dbPath [TransferOp destination txData]
executor ::
Maybe Timestamp
-> Word64
-> FilePath
-> [ExecutorOp]
-> "verbose" :! Bool -> "dryRun" :? Bool -> IO ()
executor maybeNow maxSteps dbPath operations
(arg #verbose -> verbose)
(argDef #dryRun False -> dryRun)
= do
now <- maybe getCurrentTime pure maybeNow
gState <- readGState dbPath
let eitherRes =
executorPure now (RemainingSteps maxSteps) gState operations
ExecutorRes {..} <- either throwM pure eitherRes
mapM_ printInterpretResult _erInterpretResults
when (verbose && not (null _erUpdates)) $ do
fmtLn $ nameF "Updates:" (blockListF _erUpdates)
putTextLn $ "Remaining gas: " <> pretty _erRemainingSteps
unless dryRun $
writeGState dbPath _erGState
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 ""
executorPure ::
Timestamp -> RemainingSteps -> GState -> [ExecutorOp] -> Either ExecutorError ExecutorRes
executorPure now maxSteps gState =
foldM step initialState
where
initialState = ExecutorRes
{ _erGState = gState
, _erOperations = []
, _erUpdates = mempty
, _erInterpretResults = []
, _erSourceAddress = Nothing
, _erRemainingSteps = maxSteps
}
step :: ExecutorRes -> ExecutorOp -> Either ExecutorError ExecutorRes
step currentRes op =
let start = currentRes { _erOperations = [op]
, _erUpdates = []
, _erInterpretResults = []
}
in (currentRes <>) <$> runExcept (execStateT (statefulExecutor now) start)
statefulExecutor
:: Timestamp
-> StateT ExecutorRes (Except ExecutorError) ()
statefulExecutor now = do
curGState <- use erGState
mSourceAddr <- use erSourceAddress
remainingSteps <- use erRemainingSteps
use erOperations >>= \case
[] -> pass
(op:opsTail) ->
either throwError (processIntRes opsTail) $
executeOneOp now remainingSteps mSourceAddr curGState op
where
processIntRes opsTail ir = do
id %= (<> ir)
erOperations %= (opsTail <>)
statefulExecutor now
executeOneOp
:: Timestamp
-> RemainingSteps
-> Maybe Address
-> GState
-> ExecutorOp
-> Either ExecutorError ExecutorRes
executeOneOp _ remainingSteps _ gs (OriginateOp origination) = do
typedContract <- first EEIllTypedContract $
typeCheckContract (extractAllContracts gs) (ooContract origination)
typedStorage <- first EEIllTypedStorage $
typeCheckTopLevelType
(extractAllContracts gs) (U.stor $ ooContract origination) (ooStorage origination)
let originatorAddress = ooOriginator origination
originatorBalance <- case gsAddresses gs ^. at (originatorAddress) of
Nothing -> Left (EEUnknownManager originatorAddress)
Just (asBalance -> oldBalance)
| oldBalance < ooBalance origination ->
Left (EENotEnoughFunds originatorAddress oldBalance)
| otherwise ->
Right (oldBalance `unsafeSubMutez` ooBalance origination)
let
updates =
[ GSAddAddress address (ASContract $ mkContractState typedContract typedStorage)
, GSSetBalance originatorAddress originatorBalance
]
case applyUpdates updates gs of
Left _ ->
Left (EEAlreadyOriginated address $ mkContractState typedContract typedStorage)
Right newGS -> Right $
ExecutorRes
{ _erGState = newGS
, _erOperations = mempty
, _erUpdates = updates
, _erInterpretResults = []
, _erSourceAddress = Nothing
, _erRemainingSteps = remainingSteps
}
where
mkContractState typedContract typedStorage = ContractState
{ csBalance = ooBalance origination
, csStorage = ooStorage origination
, csContract = ooContract origination
, csTypedContract = Just typedContract
, csTypedStorage = Just typedStorage
}
address = mkContractAddress origination
executeOneOp now remainingSteps mSourceAddr gs (TransferOp addr txData) = do
let sourceAddr = fromMaybe (tdSenderAddress txData) mSourceAddr
let senderAddr = tdSenderAddress txData
let isKeyAddress (KeyAddress _) = True
isKeyAddress _ = False
let isZeroTransfer = tdAmount txData == toMutez 0
when (isZeroTransfer && isKeyAddress addr) $
Left (EEZeroTransaction addr)
mDecreaseSenderBalance <- case (isZeroTransfer, addresses ^. at senderAddr) of
(True, _) -> pure Nothing
(False, Nothing) -> Left (EEUnknownSender senderAddr)
(False, Just (asBalance -> balance))
| balance < tdAmount txData ->
Left (EENotEnoughFunds senderAddr balance)
| otherwise ->
Right (Just $ GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData))
let onlyUpdates updates = Right (updates, [], Nothing, remainingSteps)
(otherUpdates, sideEffects, maybeInterpretRes, newRemSteps)
<- case (addresses ^. at addr, addr) of
(Nothing, ContractAddress _) ->
Left (EEUnknownContract addr)
(Nothing, KeyAddress _) -> do
let
transferAmount = tdAmount txData
addrState = ASSimple transferAmount
upd = GSAddAddress addr addrState
onlyUpdates [upd]
(Just (ASSimple oldBalance), _) -> do
let
newBalance = oldBalance `unsafeAddMutez` tdAmount txData
upd = GSSetBalance addr newBalance
onlyUpdates [upd]
(Just (ASContract cs), _) -> do
let
existingContracts = extractAllContracts gs
contractEnv = ContractEnv
{ ceNow = now
, ceMaxSteps = remainingSteps
, ceBalance = csBalance cs
, ceContracts = existingContracts
, ceSelf = addr
, ceSource = sourceAddr
, ceSender = senderAddr
, ceAmount = tdAmount txData
, ceChainId = gsChainId gs
}
epName = tdEntrypoint txData
SomeContractAndStorage typedContract typedStorage
<- getTypedContractAndStorage EEIllTypedContract EEIllTypedStorage gs cs
T.MkEntryPointCallRes _ epc
<- T.mkEntryPointCall epName (sing, T.fcParamNotesSafe typedContract)
& maybe (throwError $ EEUnknownEntrypoint epName) pure
typedParameter <- first EEIllTypedParameter $
typeVerifyTopLevelType existingContracts (tdParameter txData)
iur@InterpretResult
{ iurOps = sideEffects
, iurNewStorage = newValue
, iurNewState = InterpreterState _ newRemainingSteps
}
<- first (EEInterpreterFailed addr) $
handleContractReturn $
interpret (T.fcCode typedContract) epc
typedParameter typedStorage contractEnv
let
newValueU = untypeValue newValue
newBalance = csBalance cs `unsafeAddMutez` tdAmount txData
updBalance
| newBalance == csBalance cs = Nothing
| otherwise = Just $ GSSetBalance addr newBalance
updStorage
| SomeValue newValue == SomeValue typedStorage = Nothing
| otherwise = Just $ GSSetStorageValue addr newValueU (SomeValue newValue)
updates = catMaybes
[ updBalance
, updStorage
]
Right (updates, sideEffects, Just iur, newRemainingSteps)
let
updates = maybe id (:) mDecreaseSenderBalance otherUpdates
newGState <- first EEFailedToApplyUpdates $ applyUpdates updates gs
return ExecutorRes
{ _erGState = newGState
, _erOperations = mapMaybe (convertOp addr) sideEffects
, _erUpdates = updates
, _erInterpretResults = maybe mempty (one . (addr,)) maybeInterpretRes
, _erSourceAddress = Just sourceAddr
, _erRemainingSteps = newRemSteps
}
where
addresses :: Map Address AddressState
addresses = gsAddresses gs
typeCheckWithDb
:: FilePath
-> U.Contract
-> IO (Either TCError SomeContract)
typeCheckWithDb dbPath morleyContract = do
gState <- readGState dbPath
pure . typeCheckContract (extractAllContracts gState) $ morleyContract
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 = untypeValue (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 = convertContract (ccContractCode cc)
}
in Just (OriginateOp origination)