module Michelson.Runtime
(
originateContract
, runContract
, transfer
, parseContract
, parseExpandContract
, readAndParseContract
, prepareContract
, typeCheckWithDb
, ContractState (..)
, AddressState (..)
, TxData (..)
, InterpreterOp (..)
, InterpreterRes (..)
, InterpreterError' (..)
, InterpreterError
, interpreterPure
, irInterpretResults
, irUpdates
) where
import Control.Lens (at, makeLenses, (%=))
import Control.Monad.Except (Except, runExcept, throwError)
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(..),
MorleyLogs(..), RemainingSteps(..), interpretUntyped)
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)
import Michelson.Typed
(CreateContract(..), Operation'(..), 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, unsafeAddMutez, unsafeSubMutez)
import Tezos.Crypto (parseKeyHash)
import Util.IO (readFileUtf8)
data InterpreterOp
= OriginateOp !OriginationOperation
| TransferOp Address
TxData
deriving (Show)
data InterpreterRes = InterpreterRes
{ _irGState :: !GState
, _irOperations :: [InterpreterOp]
, _irUpdates :: ![GStateUpdate]
, _irInterpretResults :: [(Address, InterpretUntypedResult)]
, _irSourceAddress :: !(Maybe Address)
, _irRemainingSteps :: !RemainingSteps
} deriving (Show)
makeLenses ''InterpreterRes
instance Semigroup InterpreterRes where
a <> b =
InterpreterRes
{ _irGState = _irGState b
, _irOperations = _irOperations b
, _irUpdates = _irUpdates a <> _irUpdates b
, _irInterpretResults = _irInterpretResults a <> _irInterpretResults b
, _irSourceAddress = _irSourceAddress a <|> _irSourceAddress b
, _irRemainingSteps = _irRemainingSteps b
}
data InterpreterError' a
= IEUnknownContract !a
| IEInterpreterFailed !a
!InterpretUntypedError
| IEAlreadyOriginated !a
!ContractState
| IEUnknownSender !a
| IEUnknownManager !a
| IENotEnoughFunds !a !Mutez
| IEFailedToApplyUpdates !GStateUpdateError
| IEIllTypedContract !TCError
deriving (Show)
instance (Buildable a) => Buildable (InterpreterError' a) 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 |+ ""
type InterpreterError = InterpreterError' Address
instance (Typeable a, Show a, Buildable a) => Exception (InterpreterError' 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 <$
interpreter 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) =
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) -> 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 (untypeValue iurNewStorage)
let MorleyLogs logs = isMorleyLogs iurNewState
unless (null logs) $
mapM_ putTextLn logs
putTextLn ""
interpreterPure ::
Timestamp -> RemainingSteps -> GState -> [InterpreterOp] -> Either InterpreterError InterpreterRes
interpreterPure now maxSteps gState =
foldM step initialState
where
initialState = InterpreterRes
{ _irGState = gState
, _irOperations = []
, _irUpdates = mempty
, _irInterpretResults = []
, _irSourceAddress = Nothing
, _irRemainingSteps = maxSteps
}
step :: InterpreterRes -> InterpreterOp -> Either InterpreterError InterpreterRes
step currentRes op =
let start = currentRes { _irOperations = [op] }
in (currentRes <>) <$> runExcept (execStateT (statefulInterpreter now) start)
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 ir = do
id %= (<> ir)
irOperations %= (opsTail <>)
statefulInterpreter now
interpretOneOp
:: Timestamp
-> RemainingSteps
-> Maybe Address
-> GState
-> InterpreterOp
-> Either InterpreterError InterpreterRes
interpretOneOp _ remainingSteps _ gs (OriginateOp origination) = do
void $ first IEIllTypedContract $
typeCheckContract (extractAllContracts gs) (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
existingContracts = extractAllContracts gs
contractEnv = ContractEnv
{ ceNow = now
, ceMaxSteps = remainingSteps
, ceBalance = csBalance cs
, ceContracts = existingContracts
, ceSelf = addr
, ceSource = sourceAddr
, ceSender = senderAddr
, ceAmount = tdAmount txData
}
iur@InterpretUntypedResult
{ iurOps = sideEffects
, iurNewStorage = newValue
, iurNewState = InterpreterState _ newRemainingSteps
}
<- first (IEInterpreterFailed addr) $
interpretUntyped contract (tdParameter txData)
(csStorage cs) contractEnv
let
newValueU = untypeValue 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
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 InterpreterOp
convertOp interpretedAddr =
\case
OpTransferTokens tt ->
let txData =
TxData
{ tdSenderAddress = interpretedAddr
, tdParameter = untypeValue (ttContractParameter tt)
, tdAmount = ttAmount tt
}
T.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 = untypeValue (ccStorageVal cc)
, ooContract = convertContract (ccContractCode cc)
}
in Just (OriginateOp origination)