module Morley.Runtime
(
originateContract
, runContract
, transfer
, parseContract
, parseExpandContract
, readAndParseContract
, prepareContract
, ContractState (..)
, AddressState (..)
, TxData (..)
, InterpreterOp (..)
, InterpreterRes (..)
, InterpreterError (..)
, interpreterPure
) where
import Control.Lens (at, makeLenses, (%=), (.=), (<>=))
import Control.Monad.Except (Except, runExcept, throwError)
import qualified Data.Map.Strict as Map
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(..), InterpretUntypedError(..), InterpretUntypedResult(..), InterpreterState(..),
RemainingSteps(..))
import Michelson.TypeCheck (TCError)
import Michelson.Typed
(CreateContract(..), Instr, Operation(..), TransferTokens(..), Val(..), convertContract,
unsafeValToValue)
import Michelson.Untyped
(Contract(..), OriginationOperation(..), UntypedContract, UntypedValue, mkContractAddress)
import Morley.Ext (interpretMorleyUntyped, typeCheckMorleyContract)
import Morley.Macro (expandContract)
import qualified Morley.Parser as P
import Morley.Runtime.GState
import Morley.Runtime.TxData
import Morley.Types (MorleyLogs(..), ParsedOp)
import Tezos.Address (Address(..))
import Tezos.Core (Mutez, Timestamp(..), getCurrentTime, unsafeAddMutez, unsafeSubMutez)
import Tezos.Crypto (parseKeyHash)
data InterpreterOp
= OriginateOp !OriginationOperation
| TransferOp Address
TxData
deriving (Show)
data InterpreterRes = InterpreterRes
{ _irGState :: !GState
, _irOperations :: [InterpreterOp]
, _irUpdates :: ![GStateUpdate]
, _irInterpretResults :: [(Address, InterpretUntypedResult MorleyLogs)]
, _irSourceAddress :: !(Maybe Address)
, _irRemainingSteps :: !RemainingSteps
} deriving (Show)
makeLenses ''InterpreterRes
data InterpreterError
= IEUnknownContract !Address
| IEInterpreterFailed !Address
!(InterpretUntypedError MorleyLogs)
| IEAlreadyOriginated !Address
!ContractState
| IEUnknownSender !Address
| IEUnknownManager !Address
| IENotEnoughFunds !Address !Mutez
| IEFailedToApplyUpdates !GStateUpdateError
| IEIllTypedContract !TCError
deriving (Show)
instance Buildable InterpreterError where
build =
\case
IEUnknownContract addr -> "The contract is not originated " +| addr |+ ""
IEInterpreterFailed addr err ->
"Michelson interpreter failed for contract " +| addr |+ ": " +| err |+ ""
IEAlreadyOriginated addr cs ->
"The following contract is already originated: " +| addr |+
", " +| cs |+ ""
IEUnknownSender addr -> "The sender address is unknown " +| addr |+ ""
IEUnknownManager addr -> "The manager address is unknown " +| addr |+ ""
IENotEnoughFunds addr amount ->
"The sender (" +| addr |+
") doesn't have enough funds (has only " +| amount |+ ")"
IEFailedToApplyUpdates err -> "Failed to update GState: " +| err |+ ""
IEIllTypedContract err -> "The contract is ill-typed " +| err |+ ""
instance Exception InterpreterError where
displayException = pretty
parseContract ::
Maybe FilePath -> Text -> Either P.ParserException (Contract ParsedOp)
parseContract mFileName =
first P.ParserException . parse P.program (fromMaybe "<stdin>" mFileName)
parseExpandContract ::
Maybe FilePath -> Text -> Either P.ParserException UntypedContract
parseExpandContract mFileName = fmap expandContract . parseContract mFileName
readAndParseContract :: Maybe FilePath -> IO (Contract ParsedOp)
readAndParseContract mFilename = do
code <- readCode mFilename
either throwM pure $ parseContract mFilename code
where
readCode :: Maybe FilePath -> IO Text
readCode = maybe getContents readFile
prepareContract :: Maybe FilePath -> IO UntypedContract
prepareContract mFile = expandContract <$> readAndParseContract mFile
originateContract ::
FilePath -> OriginationOperation -> "verbose" :! Bool -> IO Address
originateContract dbPath origination verbose =
mkContractAddress origination <$
interpreter Nothing 100500 dbPath [OriginateOp origination] verbose
! defaults
runContract
:: Maybe Timestamp
-> Word64
-> Mutez
-> FilePath
-> UntypedValue
-> UntypedContract
-> TxData
-> "verbose" :! Bool
-> "dryRun" :! Bool
-> IO ()
runContract maybeNow maxSteps initBalance dbPath storageValue contract txData
verbose (arg #dryRun -> dryRun) =
interpreter maybeNow maxSteps dbPath operations verbose ! #dryRun dryRun
where
delegate =
either (error . mappend "runContract can't parse delegate: " . pretty) id $
parseKeyHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47"
origination = OriginationOperation
{ ooManager = genesisKeyHash
, ooDelegate = Just delegate
, ooSpendable = False
, ooDelegatable = False
, 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 =
interpreter maybeNow maxSteps dbPath [TransferOp destination txData]
interpreter ::
Maybe Timestamp
-> Word64
-> FilePath
-> [InterpreterOp]
-> "verbose" :! Bool -> "dryRun" :? Bool -> IO ()
interpreter maybeNow maxSteps dbPath operations
(arg #verbose -> verbose)
(argDef #dryRun False -> dryRun)
= do
now <- maybe getCurrentTime pure maybeNow
gState <- readGState dbPath
let eitherRes =
interpreterPure now (RemainingSteps maxSteps) gState operations
InterpreterRes {..} <- either throwM pure eitherRes
mapM_ printInterpretResult _irInterpretResults
when (verbose && not (null _irUpdates)) $ do
fmtLn $ nameF "Updates:" (blockListF _irUpdates)
putTextLn $ "Remaining gas: " <> pretty _irRemainingSteps
unless dryRun $
writeGState dbPath _irGState
where
printInterpretResult
:: (Address, InterpretUntypedResult MorleyLogs) -> IO ()
printInterpretResult (addr, InterpretUntypedResult {..}) = 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 (unsafeValToValue iurNewStorage)
let MorleyLogs logs = isExtState iurNewState
unless (null logs) $
mapM_ putTextLn logs
putTextLn ""
interpreterPure ::
Timestamp -> RemainingSteps -> GState -> [InterpreterOp] -> Either InterpreterError InterpreterRes
interpreterPure now maxSteps gState ops =
runExcept (execStateT (statefulInterpreter now) initialState)
where
initialState = InterpreterRes
{ _irGState = gState
, _irOperations = ops
, _irUpdates = mempty
, _irInterpretResults = []
, _irSourceAddress = Nothing
, _irRemainingSteps = maxSteps
}
statefulInterpreter
:: Timestamp
-> StateT InterpreterRes (Except InterpreterError) ()
statefulInterpreter now = do
curGState <- use irGState
mSourceAddr <- use irSourceAddress
remainingSteps <- use irRemainingSteps
use irOperations >>= \case
[] -> pass
(op:opsTail) ->
either throwError (processIntRes opsTail) $
interpretOneOp now remainingSteps mSourceAddr curGState op
where
processIntRes opsTail InterpreterRes {..} = do
irGState .= _irGState
irOperations .= opsTail <> _irOperations
irUpdates <>= _irUpdates
irInterpretResults <>= _irInterpretResults
irSourceAddress %= (<|> _irSourceAddress)
irRemainingSteps .= _irRemainingSteps
statefulInterpreter now
interpretOneOp
:: Timestamp
-> RemainingSteps
-> Maybe Address
-> GState
-> InterpreterOp
-> Either InterpreterError InterpreterRes
interpretOneOp _ remainingSteps _ gs (OriginateOp origination) = do
void $ first IEIllTypedContract $
typeCheckMorleyContract (ooContract origination)
let originatorAddress = KeyAddress (ooManager origination)
originatorBalance <- case gsAddresses gs ^. at (originatorAddress) of
Nothing -> Left (IEUnknownManager originatorAddress)
Just (asBalance -> oldBalance)
| oldBalance < ooBalance origination ->
Left (IENotEnoughFunds originatorAddress oldBalance)
| otherwise ->
Right (oldBalance `unsafeSubMutez` ooBalance origination)
let
updates =
[ GSAddAddress address (ASContract contractState)
, GSSetBalance originatorAddress originatorBalance
]
case applyUpdates updates gs of
Left _ -> Left (IEAlreadyOriginated address contractState)
Right newGS -> Right $
InterpreterRes
{ _irGState = newGS
, _irOperations = mempty
, _irUpdates = updates
, _irInterpretResults = []
, _irSourceAddress = Nothing
, _irRemainingSteps = remainingSteps
}
where
contractState = ContractState
{ csBalance = ooBalance origination
, csStorage = ooStorage origination
, csContract = ooContract origination
}
address = mkContractAddress origination
interpretOneOp now remainingSteps mSourceAddr gs (TransferOp addr txData) = do
let sourceAddr = fromMaybe (tdSenderAddress txData) mSourceAddr
let senderAddr = tdSenderAddress txData
decreaseSenderBalance <- case addresses ^. at senderAddr of
Nothing -> Left (IEUnknownSender senderAddr)
Just (asBalance -> balance)
| balance < tdAmount txData ->
Left (IENotEnoughFunds senderAddr balance)
| otherwise ->
Right (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 (IEUnknownContract addr)
(Nothing, KeyAddress _) -> do
let
addrState = ASSimple (tdAmount txData)
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
contract = csContract cs
contractEnv = ContractEnv
{ ceNow = now
, ceMaxSteps = remainingSteps
, ceBalance = csBalance cs
, ceContracts = Map.mapMaybe extractContract addresses
, ceSelf = addr
, ceSource = sourceAddr
, ceSender = senderAddr
, ceAmount = tdAmount txData
}
iur@InterpretUntypedResult
{ iurOps = sideEffects
, iurNewStorage = newValue
, iurNewState = InterpreterState _ newRemainingSteps
}
<- first (IEInterpreterFailed addr) $
interpretMorleyUntyped contract (tdParameter txData)
(csStorage cs) contractEnv
let
newValueU = unsafeValToValue newValue
newBalance = csBalance cs `unsafeAddMutez` tdAmount txData
updBalance = GSSetBalance addr newBalance
updStorage = GSSetStorageValue addr newValueU
updates =
[ updBalance
, updStorage
]
Right (updates, sideEffects, Just iur, newRemainingSteps)
let
updates = decreaseSenderBalance:otherUpdates
newGState <- first IEFailedToApplyUpdates $ applyUpdates updates gs
return InterpreterRes
{ _irGState = newGState
, _irOperations = mapMaybe (convertOp addr) sideEffects
, _irUpdates = updates
, _irInterpretResults = maybe mempty (one . (addr,)) maybeInterpretRes
, _irSourceAddress = Just sourceAddr
, _irRemainingSteps = newRemSteps
}
where
addresses :: Map Address AddressState
addresses = gsAddresses gs
extractContract :: AddressState -> Maybe UntypedContract
extractContract =
\case ASSimple {} -> Nothing
ASContract cs -> Just (csContract cs)
convertOp :: Address -> Operation Instr -> Maybe InterpreterOp
convertOp interpretedAddr =
\case
OpTransferTokens tt ->
let txData =
TxData
{ tdSenderAddress = interpretedAddr
, tdParameter = unsafeValToValue (ttContractParameter tt)
, tdAmount = ttAmount tt
}
VContract destAddress = ttContract tt
in Just (TransferOp destAddress txData)
OpSetDelegate {} -> Nothing
OpCreateAccount {} -> Nothing
OpCreateContract cc ->
let origination = OriginationOperation
{ ooManager = ccManager cc
, ooDelegate = ccDelegate cc
, ooSpendable = ccSpendable cc
, ooDelegatable = ccDelegatable cc
, ooBalance = ccBalance cc
, ooStorage = unsafeValToValue (ccStorageVal cc)
, ooContract = convertContract (ccContractCode cc)
}
in Just (OriginateOp origination)