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.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(..),
convertContractCode, 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 (Int -> ExecutorOp -> ShowS
[ExecutorOp] -> ShowS
ExecutorOp -> String
(Int -> ExecutorOp -> ShowS)
-> (ExecutorOp -> String)
-> ([ExecutorOp] -> ShowS)
-> Show ExecutorOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExecutorOp] -> ShowS
$cshowList :: [ExecutorOp] -> ShowS
show :: ExecutorOp -> String
$cshow :: ExecutorOp -> String
showsPrec :: Int -> ExecutorOp -> ShowS
$cshowsPrec :: Int -> ExecutorOp -> ShowS
Show)
data ExecutorRes = ExecutorRes
{ ExecutorRes -> GState
_erGState :: GState
, ExecutorRes -> [ExecutorOp]
_erOperations :: [ExecutorOp]
, ExecutorRes -> [GStateUpdate]
_erUpdates :: [GStateUpdate]
, ExecutorRes -> [(Address, InterpretResult)]
_erInterpretResults :: [(Address, InterpretResult)]
, ExecutorRes -> Maybe Address
_erSourceAddress :: Maybe Address
, ExecutorRes -> RemainingSteps
_erRemainingSteps :: RemainingSteps
} deriving stock (Int -> ExecutorRes -> ShowS
[ExecutorRes] -> ShowS
ExecutorRes -> String
(Int -> ExecutorRes -> ShowS)
-> (ExecutorRes -> String)
-> ([ExecutorRes] -> ShowS)
-> Show ExecutorRes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExecutorRes] -> ShowS
$cshowList :: [ExecutorRes] -> ShowS
show :: ExecutorRes -> String
$cshow :: ExecutorRes -> String
showsPrec :: Int -> ExecutorRes -> ShowS
$cshowsPrec :: Int -> ExecutorRes -> ShowS
Show)
makeLenses ''ExecutorRes
instance Semigroup ExecutorRes where
a :: ExecutorRes
a <> :: ExecutorRes -> ExecutorRes -> ExecutorRes
<> b :: ExecutorRes
b =
ExecutorRes
b
{ _erUpdates :: [GStateUpdate]
_erUpdates = ExecutorRes -> [GStateUpdate]
_erUpdates ExecutorRes
a [GStateUpdate] -> [GStateUpdate] -> [GStateUpdate]
forall a. Semigroup a => a -> a -> a
<> ExecutorRes -> [GStateUpdate]
_erUpdates ExecutorRes
b
, _erInterpretResults :: [(Address, InterpretResult)]
_erInterpretResults = ExecutorRes -> [(Address, InterpretResult)]
_erInterpretResults ExecutorRes
a [(Address, InterpretResult)]
-> [(Address, InterpretResult)] -> [(Address, InterpretResult)]
forall a. Semigroup a => a -> a -> a
<> ExecutorRes -> [(Address, InterpretResult)]
_erInterpretResults ExecutorRes
b
, _erSourceAddress :: Maybe Address
_erSourceAddress = ExecutorRes -> Maybe Address
_erSourceAddress ExecutorRes
a Maybe Address -> Maybe Address -> Maybe Address
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ExecutorRes -> Maybe Address
_erSourceAddress ExecutorRes
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 (Int -> ExecutorError' a -> ShowS
[ExecutorError' a] -> ShowS
ExecutorError' a -> String
(Int -> ExecutorError' a -> ShowS)
-> (ExecutorError' a -> String)
-> ([ExecutorError' a] -> ShowS)
-> Show (ExecutorError' a)
forall a. Show a => Int -> ExecutorError' a -> ShowS
forall a. Show a => [ExecutorError' a] -> ShowS
forall a. Show a => ExecutorError' a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExecutorError' a] -> ShowS
$cshowList :: forall a. Show a => [ExecutorError' a] -> ShowS
show :: ExecutorError' a -> String
$cshow :: forall a. Show a => ExecutorError' a -> String
showsPrec :: Int -> ExecutorError' a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ExecutorError' a -> ShowS
Show)
instance (Buildable a) => Buildable (ExecutorError' a) where
build :: ExecutorError' a -> Builder
build =
\case
EEUnknownContract addr :: a
addr -> "The contract is not originated " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| a
addr a -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
EEInterpreterFailed addr :: a
addr err :: InterpretError
err ->
"Michelson interpreter failed for contract " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| a
addr a -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ": " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| InterpretError
err InterpretError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
EEAlreadyOriginated addr :: a
addr cs :: ContractState
cs ->
"The following contract is already originated: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| a
addr a -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
", " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| ContractState
cs ContractState -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
EEUnknownSender addr :: a
addr -> "The sender address is unknown " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| a
addr a -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
EEUnknownManager addr :: a
addr -> "The manager address is unknown " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| a
addr a -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
EENotEnoughFunds addr :: a
addr amount :: Mutez
amount ->
"The sender (" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| a
addr a -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
") doesn't have enough funds (has only " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Mutez
amount Mutez -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ")"
EEZeroTransaction addr :: a
addr ->
"Transaction of 0ꜩ towards a key address " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| a
addr a -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ " which has no code is prohibited"
EEFailedToApplyUpdates err :: GStateUpdateError
err -> "Failed to update GState: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| GStateUpdateError
err GStateUpdateError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
EEIllTypedContract err :: TCError
err -> "The contract is ill-typed: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| TCError
err TCError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
EEIllTypedStorage err :: TCError
err -> "The contract storage is ill-typed: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| TCError
err TCError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
EEIllTypedParameter err :: TCError
err -> "The contract parameter is ill-typed: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| TCError
err TCError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
EEUnknownEntrypoint epName :: EpName
epName -> "The contract does not contain entrypoint '" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| EpName
epName EpName -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ "'"
type ExecutorError = ExecutorError' Address
instance (Typeable a, Show a, Buildable a) => Exception (ExecutorError' a) where
displayException :: ExecutorError' a -> String
displayException = ExecutorError' a -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty
parseContract ::
Maybe FilePath -> Text -> Either P.ParserException (U.Contract' ParsedOp)
parseContract :: Maybe String -> Text -> Either ParserException (Contract' ParsedOp)
parseContract mFileName :: Maybe String
mFileName =
(ParseErrorBundle Text CustomParserException -> ParserException)
-> Either
(ParseErrorBundle Text CustomParserException) (Contract' ParsedOp)
-> Either ParserException (Contract' ParsedOp)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle Text CustomParserException -> ParserException
P.ParserException (Either
(ParseErrorBundle Text CustomParserException) (Contract' ParsedOp)
-> Either ParserException (Contract' ParsedOp))
-> (Text
-> Either
(ParseErrorBundle Text CustomParserException) (Contract' ParsedOp))
-> Text
-> Either ParserException (Contract' ParsedOp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec CustomParserException Text (Contract' ParsedOp)
-> String
-> Text
-> Either
(ParseErrorBundle Text CustomParserException) (Contract' ParsedOp)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec CustomParserException Text (Contract' ParsedOp)
P.program (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "<stdin>" Maybe String
mFileName)
parseExpandContract ::
Maybe FilePath -> Text -> Either P.ParserException Contract
parseExpandContract :: Maybe String -> Text -> Either ParserException Contract
parseExpandContract mFileName :: Maybe String
mFileName = (Contract' ParsedOp -> Contract)
-> Either ParserException (Contract' ParsedOp)
-> Either ParserException Contract
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Contract' ParsedOp -> Contract
expandContract (Either ParserException (Contract' ParsedOp)
-> Either ParserException Contract)
-> (Text -> Either ParserException (Contract' ParsedOp))
-> Text
-> Either ParserException Contract
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> Text -> Either ParserException (Contract' ParsedOp)
parseContract Maybe String
mFileName
readAndParseContract :: Maybe FilePath -> IO (U.Contract' ParsedOp)
readAndParseContract :: Maybe String -> IO (Contract' ParsedOp)
readAndParseContract mFilename :: Maybe String
mFilename = do
Text
code <- Maybe String -> IO Text
readCode Maybe String
mFilename
(ParserException -> IO (Contract' ParsedOp))
-> (Contract' ParsedOp -> IO (Contract' ParsedOp))
-> Either ParserException (Contract' ParsedOp)
-> IO (Contract' ParsedOp)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParserException -> IO (Contract' ParsedOp)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Contract' ParsedOp -> IO (Contract' ParsedOp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParserException (Contract' ParsedOp)
-> IO (Contract' ParsedOp))
-> Either ParserException (Contract' ParsedOp)
-> IO (Contract' ParsedOp)
forall a b. (a -> b) -> a -> b
$ Maybe String -> Text -> Either ParserException (Contract' ParsedOp)
parseContract Maybe String
mFilename Text
code
where
readCode :: Maybe FilePath -> IO Text
readCode :: Maybe String -> IO Text
readCode = IO Text -> (String -> IO Text) -> Maybe String -> IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Text
getContents String -> IO Text
readFileUtf8
prepareContract :: Maybe FilePath -> IO Contract
prepareContract :: Maybe String -> IO Contract
prepareContract mFile :: Maybe String
mFile = Contract' ParsedOp -> Contract
expandContract (Contract' ParsedOp -> Contract)
-> IO (Contract' ParsedOp) -> IO Contract
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String -> IO (Contract' ParsedOp)
readAndParseContract Maybe String
mFile
originateContract ::
FilePath -> OriginationOperation -> "verbose" :! Bool -> IO Address
originateContract :: String -> OriginationOperation -> ("verbose" :! Bool) -> IO Address
originateContract dbPath :: String
dbPath origination :: OriginationOperation
origination verbose :: "verbose" :! Bool
verbose =
OriginationOperation -> Address
mkContractAddress OriginationOperation
origination Address -> IO () -> IO Address
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$
Maybe Timestamp
-> Word64
-> String
-> [ExecutorOp]
-> ("verbose" :! Bool)
-> ("dryRun" :? Bool)
-> IO ()
executor Maybe Timestamp
forall a. Maybe a
Nothing 100500 String
dbPath [OriginationOperation -> ExecutorOp
OriginateOp OriginationOperation
origination] "verbose" :! Bool
verbose
(("dryRun" :? Bool) -> IO ()) -> Param Defaults -> IO ()
forall p fn fn'. WithParam p fn fn' => fn -> Param p -> fn'
! Param Defaults
defaults
runContract
:: Maybe Timestamp
-> Word64
-> Mutez
-> FilePath
-> U.Value
-> Contract
-> TxData
-> "verbose" :! Bool
-> "dryRun" :! Bool
-> IO ()
runContract :: Maybe Timestamp
-> Word64
-> Mutez
-> String
-> Value
-> Contract
-> TxData
-> ("verbose" :! Bool)
-> ("dryRun" :! Bool)
-> IO ()
runContract maybeNow :: Maybe Timestamp
maybeNow maxSteps :: Word64
maxSteps initBalance :: Mutez
initBalance dbPath :: String
dbPath storageValue :: Value
storageValue contract :: Contract
contract txData :: TxData
txData
verbose :: "verbose" :! Bool
verbose (Name "dryRun" -> ("dryRun" :! Bool) -> Bool
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "dryRun" (Name "dryRun")
Name "dryRun"
#dryRun -> Bool
dryRun) =
Maybe Timestamp
-> Word64
-> String
-> [ExecutorOp]
-> ("verbose" :! Bool)
-> ("dryRun" :? Bool)
-> IO ()
executor Maybe Timestamp
maybeNow Word64
maxSteps String
dbPath [ExecutorOp]
operations "verbose" :! Bool
verbose (("dryRun" :? Bool) -> IO ()) -> Param ("dryRun" :? Bool) -> IO ()
forall p fn fn'. WithParam p fn fn' => fn -> Param p -> fn'
! IsLabel "dryRun" (Bool -> Param ("dryRun" :? Bool))
Bool -> Param ("dryRun" :? Bool)
#dryRun Bool
dryRun
where
delegate :: KeyHash
delegate =
(CryptoParseError -> KeyHash)
-> (KeyHash -> KeyHash)
-> Either CryptoParseError KeyHash
-> KeyHash
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> KeyHash
forall a. HasCallStack => Text -> a
error (Text -> KeyHash)
-> (CryptoParseError -> Text) -> CryptoParseError -> KeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend "runContract can't parse delegate: " (Text -> Text)
-> (CryptoParseError -> Text) -> CryptoParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoParseError -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty) KeyHash -> KeyHash
forall a. a -> a
id (Either CryptoParseError KeyHash -> KeyHash)
-> Either CryptoParseError KeyHash -> KeyHash
forall a b. (a -> b) -> a -> b
$
Text -> Either CryptoParseError KeyHash
parseKeyHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47"
origination :: OriginationOperation
origination = $WOriginationOperation :: Address
-> Maybe KeyHash
-> Mutez
-> Value
-> Contract
-> OriginationOperation
OriginationOperation
{ ooOriginator :: Address
ooOriginator = Address
genesisAddress
, ooDelegate :: Maybe KeyHash
ooDelegate = KeyHash -> Maybe KeyHash
forall a. a -> Maybe a
Just KeyHash
delegate
, ooBalance :: Mutez
ooBalance = Mutez
initBalance
, ooStorage :: Value
ooStorage = Value
storageValue
, ooContract :: Contract
ooContract = Contract
contract
}
addr :: Address
addr = OriginationOperation -> Address
mkContractAddress OriginationOperation
origination
operations :: [ExecutorOp]
operations =
[ OriginationOperation -> ExecutorOp
OriginateOp OriginationOperation
origination
, Address -> TxData -> ExecutorOp
TransferOp Address
addr TxData
txData
]
transfer ::
Maybe Timestamp
-> Word64
-> FilePath
-> Address
-> TxData
-> "verbose" :! Bool -> "dryRun" :? Bool -> IO ()
transfer :: Maybe Timestamp
-> Word64
-> String
-> Address
-> TxData
-> ("verbose" :! Bool)
-> ("dryRun" :? Bool)
-> IO ()
transfer maybeNow :: Maybe Timestamp
maybeNow maxSteps :: Word64
maxSteps dbPath :: String
dbPath destination :: Address
destination txData :: TxData
txData =
Maybe Timestamp
-> Word64
-> String
-> [ExecutorOp]
-> ("verbose" :! Bool)
-> ("dryRun" :? Bool)
-> IO ()
executor Maybe Timestamp
maybeNow Word64
maxSteps String
dbPath [Address -> TxData -> ExecutorOp
TransferOp Address
destination TxData
txData]
executor ::
Maybe Timestamp
-> Word64
-> FilePath
-> [ExecutorOp]
-> "verbose" :! Bool -> "dryRun" :? Bool -> IO ()
executor :: Maybe Timestamp
-> Word64
-> String
-> [ExecutorOp]
-> ("verbose" :! Bool)
-> ("dryRun" :? Bool)
-> IO ()
executor maybeNow :: Maybe Timestamp
maybeNow maxSteps :: Word64
maxSteps dbPath :: String
dbPath operations :: [ExecutorOp]
operations
(Name "verbose" -> ("verbose" :! Bool) -> Bool
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "verbose" (Name "verbose")
Name "verbose"
#verbose -> Bool
verbose)
(Name "dryRun" -> Bool -> ("dryRun" :? Bool) -> Bool
forall (name :: Symbol) a. Name name -> a -> (name :? a) -> a
argDef IsLabel "dryRun" (Name "dryRun")
Name "dryRun"
#dryRun Bool
False -> Bool
dryRun)
= do
Timestamp
now <- IO Timestamp
-> (Timestamp -> IO Timestamp) -> Maybe Timestamp -> IO Timestamp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Timestamp
getCurrentTime Timestamp -> IO Timestamp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Timestamp
maybeNow
GState
gState <- String -> IO GState
readGState String
dbPath
let eitherRes :: Either ExecutorError ExecutorRes
eitherRes =
Timestamp
-> RemainingSteps
-> GState
-> [ExecutorOp]
-> Either ExecutorError ExecutorRes
executorPure Timestamp
now (Word64 -> RemainingSteps
RemainingSteps Word64
maxSteps) GState
gState [ExecutorOp]
operations
ExecutorRes {..} <- (ExecutorError -> IO ExecutorRes)
-> (ExecutorRes -> IO ExecutorRes)
-> Either ExecutorError ExecutorRes
-> IO ExecutorRes
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ExecutorError -> IO ExecutorRes
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ExecutorRes -> IO ExecutorRes
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ExecutorError ExecutorRes
eitherRes
(Element [(Address, InterpretResult)] -> IO ())
-> [(Address, InterpretResult)] -> IO ()
forall t (m :: * -> *) b.
(Container t, Monad m) =>
(Element t -> m b) -> t -> m ()
mapM_ (Address, InterpretResult) -> IO ()
Element [(Address, InterpretResult)] -> IO ()
printInterpretResult [(Address, InterpretResult)]
_erInterpretResults
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
verbose Bool -> Bool -> Bool
&& Bool -> Bool
not ([GStateUpdate] -> Bool
forall t. Container t => t -> Bool
null [GStateUpdate]
_erUpdates)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Builder -> IO ()
forall b. FromBuilder b => Builder -> b
fmtLn (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder -> Builder -> Builder
nameF "Updates:" ([GStateUpdate] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF [GStateUpdate]
_erUpdates)
Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "Remaining gas: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RemainingSteps -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty RemainingSteps
_erRemainingSteps
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dryRun (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> GState -> IO ()
writeGState String
dbPath GState
_erGState
where
printInterpretResult
:: (Address, InterpretResult) -> IO ()
printInterpretResult :: (Address, InterpretResult) -> IO ()
printInterpretResult (addr :: Address
addr, InterpretResult {..}) = do
Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "Executed contract " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Address -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Address
addr
case [Operation]
iurOps of
[] -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn "It didn't return any operations"
_ -> Builder -> IO ()
forall b. FromBuilder b => Builder -> b
fmt (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder -> Builder -> Builder
nameF "It returned operations:" ([Operation] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF [Operation]
iurOps)
Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
"It returned storage: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Value st -> Value
forall (t :: T). (SingI t, HasNoOp t) => Value' Instr t -> Value
untypeValue Value st
iurNewStorage)
let MorleyLogs logs :: [Text]
logs = InterpreterState -> MorleyLogs
isMorleyLogs InterpreterState
iurNewState
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall t. Container t => t -> Bool
null [Text]
logs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
(Element [Text] -> IO ()) -> [Text] -> IO ()
forall t (m :: * -> *) b.
(Container t, Monad m) =>
(Element t -> m b) -> t -> m ()
mapM_ Element [Text] -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn [Text]
logs
Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn ""
executorPure ::
Timestamp -> RemainingSteps -> GState -> [ExecutorOp] -> Either ExecutorError ExecutorRes
executorPure :: Timestamp
-> RemainingSteps
-> GState
-> [ExecutorOp]
-> Either ExecutorError ExecutorRes
executorPure now :: Timestamp
now maxSteps :: RemainingSteps
maxSteps gState :: GState
gState =
(ExecutorRes -> ExecutorOp -> Either ExecutorError ExecutorRes)
-> ExecutorRes -> [ExecutorOp] -> Either ExecutorError ExecutorRes
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ExecutorRes -> ExecutorOp -> Either ExecutorError ExecutorRes
step ExecutorRes
initialState
where
initialState :: ExecutorRes
initialState = $WExecutorRes :: GState
-> [ExecutorOp]
-> [GStateUpdate]
-> [(Address, InterpretResult)]
-> Maybe Address
-> RemainingSteps
-> ExecutorRes
ExecutorRes
{ _erGState :: GState
_erGState = GState
gState
, _erOperations :: [ExecutorOp]
_erOperations = []
, _erUpdates :: [GStateUpdate]
_erUpdates = [GStateUpdate]
forall a. Monoid a => a
mempty
, _erInterpretResults :: [(Address, InterpretResult)]
_erInterpretResults = []
, _erSourceAddress :: Maybe Address
_erSourceAddress = Maybe Address
forall a. Maybe a
Nothing
, _erRemainingSteps :: RemainingSteps
_erRemainingSteps = RemainingSteps
maxSteps
}
step :: ExecutorRes -> ExecutorOp -> Either ExecutorError ExecutorRes
step :: ExecutorRes -> ExecutorOp -> Either ExecutorError ExecutorRes
step currentRes :: ExecutorRes
currentRes op :: ExecutorOp
op =
let start :: ExecutorRes
start = ExecutorRes
currentRes { _erOperations :: [ExecutorOp]
_erOperations = [ExecutorOp
op]
, _erUpdates :: [GStateUpdate]
_erUpdates = []
, _erInterpretResults :: [(Address, InterpretResult)]
_erInterpretResults = []
}
in (ExecutorRes
currentRes ExecutorRes -> ExecutorRes -> ExecutorRes
forall a. Semigroup a => a -> a -> a
<>) (ExecutorRes -> ExecutorRes)
-> Either ExecutorError ExecutorRes
-> Either ExecutorError ExecutorRes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Except ExecutorError ExecutorRes
-> Either ExecutorError ExecutorRes
forall e a. Except e a -> Either e a
runExcept (StateT ExecutorRes (Except ExecutorError) ()
-> ExecutorRes -> Except ExecutorError ExecutorRes
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Timestamp -> StateT ExecutorRes (Except ExecutorError) ()
statefulExecutor Timestamp
now) ExecutorRes
start)
statefulExecutor
:: Timestamp
-> StateT ExecutorRes (Except ExecutorError) ()
statefulExecutor :: Timestamp -> StateT ExecutorRes (Except ExecutorError) ()
statefulExecutor now :: Timestamp
now = do
GState
curGState <- Getting GState ExecutorRes GState
-> StateT ExecutorRes (Except ExecutorError) GState
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting GState ExecutorRes GState
Lens' ExecutorRes GState
erGState
Maybe Address
mSourceAddr <- Getting (Maybe Address) ExecutorRes (Maybe Address)
-> StateT ExecutorRes (Except ExecutorError) (Maybe Address)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Maybe Address) ExecutorRes (Maybe Address)
Lens' ExecutorRes (Maybe Address)
erSourceAddress
RemainingSteps
remainingSteps <- Getting RemainingSteps ExecutorRes RemainingSteps
-> StateT ExecutorRes (Except ExecutorError) RemainingSteps
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting RemainingSteps ExecutorRes RemainingSteps
Lens' ExecutorRes RemainingSteps
erRemainingSteps
Getting [ExecutorOp] ExecutorRes [ExecutorOp]
-> StateT ExecutorRes (Except ExecutorError) [ExecutorOp]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [ExecutorOp] ExecutorRes [ExecutorOp]
Lens' ExecutorRes [ExecutorOp]
erOperations StateT ExecutorRes (Except ExecutorError) [ExecutorOp]
-> ([ExecutorOp] -> StateT ExecutorRes (Except ExecutorError) ())
-> StateT ExecutorRes (Except ExecutorError) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> StateT ExecutorRes (Except ExecutorError) ()
forall (f :: * -> *). Applicative f => f ()
pass
(op :: ExecutorOp
op:opsTail :: [ExecutorOp]
opsTail) ->
(ExecutorError -> StateT ExecutorRes (Except ExecutorError) ())
-> (ExecutorRes -> StateT ExecutorRes (Except ExecutorError) ())
-> Either ExecutorError ExecutorRes
-> StateT ExecutorRes (Except ExecutorError) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ExecutorError -> StateT ExecutorRes (Except ExecutorError) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([ExecutorOp]
-> ExecutorRes -> StateT ExecutorRes (Except ExecutorError) ()
processIntRes [ExecutorOp]
opsTail) (Either ExecutorError ExecutorRes
-> StateT ExecutorRes (Except ExecutorError) ())
-> Either ExecutorError ExecutorRes
-> StateT ExecutorRes (Except ExecutorError) ()
forall a b. (a -> b) -> a -> b
$
Timestamp
-> RemainingSteps
-> Maybe Address
-> GState
-> ExecutorOp
-> Either ExecutorError ExecutorRes
executeOneOp Timestamp
now RemainingSteps
remainingSteps Maybe Address
mSourceAddr GState
curGState ExecutorOp
op
where
processIntRes :: [ExecutorOp]
-> ExecutorRes -> StateT ExecutorRes (Except ExecutorError) ()
processIntRes opsTail :: [ExecutorOp]
opsTail ir :: ExecutorRes
ir = do
(ExecutorRes -> Identity ExecutorRes)
-> ExecutorRes -> Identity ExecutorRes
forall a. a -> a
id ((ExecutorRes -> Identity ExecutorRes)
-> ExecutorRes -> Identity ExecutorRes)
-> (ExecutorRes -> ExecutorRes)
-> StateT ExecutorRes (Except ExecutorError) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (ExecutorRes -> ExecutorRes -> ExecutorRes
forall a. Semigroup a => a -> a -> a
<> ExecutorRes
ir)
([ExecutorOp] -> Identity [ExecutorOp])
-> ExecutorRes -> Identity ExecutorRes
Lens' ExecutorRes [ExecutorOp]
erOperations (([ExecutorOp] -> Identity [ExecutorOp])
-> ExecutorRes -> Identity ExecutorRes)
-> ([ExecutorOp] -> [ExecutorOp])
-> StateT ExecutorRes (Except ExecutorError) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ([ExecutorOp]
opsTail [ExecutorOp] -> [ExecutorOp] -> [ExecutorOp]
forall a. Semigroup a => a -> a -> a
<>)
Timestamp -> StateT ExecutorRes (Except ExecutorError) ()
statefulExecutor Timestamp
now
executeOneOp
:: Timestamp
-> RemainingSteps
-> Maybe Address
-> GState
-> ExecutorOp
-> Either ExecutorError ExecutorRes
executeOneOp :: Timestamp
-> RemainingSteps
-> Maybe Address
-> GState
-> ExecutorOp
-> Either ExecutorError ExecutorRes
executeOneOp _ remainingSteps :: RemainingSteps
remainingSteps _ gs :: GState
gs (OriginateOp origination :: OriginationOperation
origination) = do
SomeContract
typedContract <- (TCError -> ExecutorError)
-> Either TCError SomeContract -> Either ExecutorError SomeContract
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TCError -> ExecutorError
forall a. TCError -> ExecutorError' a
EEIllTypedContract (Either TCError SomeContract -> Either ExecutorError SomeContract)
-> Either TCError SomeContract -> Either ExecutorError SomeContract
forall a b. (a -> b) -> a -> b
$
TcOriginatedContracts -> Contract -> Either TCError SomeContract
typeCheckContract (GState -> TcOriginatedContracts
extractAllContracts GState
gs) (OriginationOperation -> Contract
ooContract OriginationOperation
origination)
SomeValue
typedStorage <- (TCError -> ExecutorError)
-> Either TCError SomeValue -> Either ExecutorError SomeValue
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TCError -> ExecutorError
forall a. TCError -> ExecutorError' a
EEIllTypedStorage (Either TCError SomeValue -> Either ExecutorError SomeValue)
-> Either TCError SomeValue -> Either ExecutorError SomeValue
forall a b. (a -> b) -> a -> b
$
HasCallStack =>
TcOriginatedContracts -> Type -> Value -> Either TCError SomeValue
TcOriginatedContracts -> Type -> Value -> Either TCError SomeValue
typeCheckTopLevelType
(GState -> TcOriginatedContracts
extractAllContracts GState
gs) (Contract -> Type
forall op. Contract' op -> Type
U.contractStorage (Contract -> Type) -> Contract -> Type
forall a b. (a -> b) -> a -> b
$ OriginationOperation -> Contract
ooContract OriginationOperation
origination)
(OriginationOperation -> Value
ooStorage OriginationOperation
origination)
let originatorAddress :: Address
originatorAddress = OriginationOperation -> Address
ooOriginator OriginationOperation
origination
Mutez
originatorBalance <- case GState -> Map Address AddressState
gsAddresses GState
gs Map Address AddressState
-> Getting
(Maybe AddressState)
(Map Address AddressState)
(Maybe AddressState)
-> Maybe AddressState
forall s a. s -> Getting a s a -> a
^. Index (Map Address AddressState)
-> Lens'
(Map Address AddressState)
(Maybe (IxValue (Map Address AddressState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (Index (Map Address AddressState)
Address
originatorAddress) of
Nothing -> ExecutorError -> Either ExecutorError Mutez
forall a b. a -> Either a b
Left (Address -> ExecutorError
forall a. a -> ExecutorError' a
EEUnknownManager Address
originatorAddress)
Just (AddressState -> Mutez
asBalance -> Mutez
oldBalance)
| Mutez
oldBalance Mutez -> Mutez -> Bool
forall a. Ord a => a -> a -> Bool
< OriginationOperation -> Mutez
ooBalance OriginationOperation
origination ->
ExecutorError -> Either ExecutorError Mutez
forall a b. a -> Either a b
Left (Address -> Mutez -> ExecutorError
forall a. a -> Mutez -> ExecutorError' a
EENotEnoughFunds Address
originatorAddress Mutez
oldBalance)
| Bool
otherwise ->
Mutez -> Either ExecutorError Mutez
forall a b. b -> Either a b
Right (Mutez
oldBalance HasCallStack => Mutez -> Mutez -> Mutez
Mutez -> Mutez -> Mutez
`unsafeSubMutez` OriginationOperation -> Mutez
ooBalance OriginationOperation
origination)
let
updates :: [GStateUpdate]
updates =
[ Address -> AddressState -> GStateUpdate
GSAddAddress Address
address (ContractState -> AddressState
ASContract (ContractState -> AddressState) -> ContractState -> AddressState
forall a b. (a -> b) -> a -> b
$ SomeContract -> SomeValue -> ContractState
mkContractState SomeContract
typedContract SomeValue
typedStorage)
, Address -> Mutez -> GStateUpdate
GSSetBalance Address
originatorAddress Mutez
originatorBalance
]
case [GStateUpdate] -> GState -> Either GStateUpdateError GState
applyUpdates [GStateUpdate]
updates GState
gs of
Left _ ->
ExecutorError -> Either ExecutorError ExecutorRes
forall a b. a -> Either a b
Left (Address -> ContractState -> ExecutorError
forall a. a -> ContractState -> ExecutorError' a
EEAlreadyOriginated Address
address (ContractState -> ExecutorError) -> ContractState -> ExecutorError
forall a b. (a -> b) -> a -> b
$ SomeContract -> SomeValue -> ContractState
mkContractState SomeContract
typedContract SomeValue
typedStorage)
Right newGS :: GState
newGS -> ExecutorRes -> Either ExecutorError ExecutorRes
forall a b. b -> Either a b
Right (ExecutorRes -> Either ExecutorError ExecutorRes)
-> ExecutorRes -> Either ExecutorError ExecutorRes
forall a b. (a -> b) -> a -> b
$
$WExecutorRes :: GState
-> [ExecutorOp]
-> [GStateUpdate]
-> [(Address, InterpretResult)]
-> Maybe Address
-> RemainingSteps
-> ExecutorRes
ExecutorRes
{ _erGState :: GState
_erGState = GState
newGS
, _erOperations :: [ExecutorOp]
_erOperations = [ExecutorOp]
forall a. Monoid a => a
mempty
, _erUpdates :: [GStateUpdate]
_erUpdates = [GStateUpdate]
updates
, _erInterpretResults :: [(Address, InterpretResult)]
_erInterpretResults = []
, _erSourceAddress :: Maybe Address
_erSourceAddress = Maybe Address
forall a. Maybe a
Nothing
, _erRemainingSteps :: RemainingSteps
_erRemainingSteps = RemainingSteps
remainingSteps
}
where
mkContractState :: SomeContract -> SomeValue -> ContractState
mkContractState typedContract :: SomeContract
typedContract typedStorage :: SomeValue
typedStorage = $WContractState :: Mutez
-> Value
-> Contract
-> Maybe SomeContract
-> Maybe SomeValue
-> ContractState
ContractState
{ csBalance :: Mutez
csBalance = OriginationOperation -> Mutez
ooBalance OriginationOperation
origination
, csStorage :: Value
csStorage = OriginationOperation -> Value
ooStorage OriginationOperation
origination
, csContract :: Contract
csContract = OriginationOperation -> Contract
ooContract OriginationOperation
origination
, csTypedContract :: Maybe SomeContract
csTypedContract = SomeContract -> Maybe SomeContract
forall a. a -> Maybe a
Just SomeContract
typedContract
, csTypedStorage :: Maybe SomeValue
csTypedStorage = SomeValue -> Maybe SomeValue
forall a. a -> Maybe a
Just SomeValue
typedStorage
}
address :: Address
address = OriginationOperation -> Address
mkContractAddress OriginationOperation
origination
executeOneOp now :: Timestamp
now remainingSteps :: RemainingSteps
remainingSteps mSourceAddr :: Maybe Address
mSourceAddr gs :: GState
gs (TransferOp addr :: Address
addr txData :: TxData
txData) = do
let sourceAddr :: Address
sourceAddr = Address -> Maybe Address -> Address
forall a. a -> Maybe a -> a
fromMaybe (TxData -> Address
tdSenderAddress TxData
txData) Maybe Address
mSourceAddr
let senderAddr :: Address
senderAddr = TxData -> Address
tdSenderAddress TxData
txData
let isKeyAddress :: Address -> Bool
isKeyAddress (KeyAddress _) = Bool
True
isKeyAddress _ = Bool
False
let isZeroTransfer :: Bool
isZeroTransfer = TxData -> Mutez
tdAmount TxData
txData Mutez -> Mutez -> Bool
forall a. Eq a => a -> a -> Bool
== Word32 -> Mutez
toMutez 0
Bool -> Either ExecutorError () -> Either ExecutorError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isZeroTransfer Bool -> Bool -> Bool
&& Address -> Bool
isKeyAddress Address
addr) (Either ExecutorError () -> Either ExecutorError ())
-> Either ExecutorError () -> Either ExecutorError ()
forall a b. (a -> b) -> a -> b
$
ExecutorError -> Either ExecutorError ()
forall a b. a -> Either a b
Left (Address -> ExecutorError
forall a. a -> ExecutorError' a
EEZeroTransaction Address
addr)
Maybe GStateUpdate
mDecreaseSenderBalance <- case (Bool
isZeroTransfer, Map Address AddressState
addresses Map Address AddressState
-> Getting
(Maybe AddressState)
(Map Address AddressState)
(Maybe AddressState)
-> Maybe AddressState
forall s a. s -> Getting a s a -> a
^. Index (Map Address AddressState)
-> Lens'
(Map Address AddressState)
(Maybe (IxValue (Map Address AddressState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Address AddressState)
Address
senderAddr) of
(True, _) -> Maybe GStateUpdate -> Either ExecutorError (Maybe GStateUpdate)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GStateUpdate
forall a. Maybe a
Nothing
(False, Nothing) -> ExecutorError -> Either ExecutorError (Maybe GStateUpdate)
forall a b. a -> Either a b
Left (Address -> ExecutorError
forall a. a -> ExecutorError' a
EEUnknownSender Address
senderAddr)
(False, Just (AddressState -> Mutez
asBalance -> Mutez
balance))
| Mutez
balance Mutez -> Mutez -> Bool
forall a. Ord a => a -> a -> Bool
< TxData -> Mutez
tdAmount TxData
txData ->
ExecutorError -> Either ExecutorError (Maybe GStateUpdate)
forall a b. a -> Either a b
Left (Address -> Mutez -> ExecutorError
forall a. a -> Mutez -> ExecutorError' a
EENotEnoughFunds Address
senderAddr Mutez
balance)
| Bool
otherwise ->
Maybe GStateUpdate -> Either ExecutorError (Maybe GStateUpdate)
forall a b. b -> Either a b
Right (GStateUpdate -> Maybe GStateUpdate
forall a. a -> Maybe a
Just (GStateUpdate -> Maybe GStateUpdate)
-> GStateUpdate -> Maybe GStateUpdate
forall a b. (a -> b) -> a -> b
$ Address -> Mutez -> GStateUpdate
GSSetBalance Address
senderAddr (Mutez
balance HasCallStack => Mutez -> Mutez -> Mutez
Mutez -> Mutez -> Mutez
`unsafeSubMutez` TxData -> Mutez
tdAmount TxData
txData))
let onlyUpdates :: [GStateUpdate]
-> Either
ExecutorError
([GStateUpdate], [Operation], Maybe InterpretResult,
RemainingSteps)
onlyUpdates updates :: [GStateUpdate]
updates = ([GStateUpdate], [Operation], Maybe InterpretResult,
RemainingSteps)
-> Either
ExecutorError
([GStateUpdate], [Operation], Maybe InterpretResult,
RemainingSteps)
forall a b. b -> Either a b
Right ([GStateUpdate]
updates, [], Maybe InterpretResult
forall a. Maybe a
Nothing, RemainingSteps
remainingSteps)
(otherUpdates :: [GStateUpdate]
otherUpdates, sideEffects :: [Operation]
sideEffects, maybeInterpretRes :: Maybe InterpretResult
maybeInterpretRes, newRemSteps :: RemainingSteps
newRemSteps)
<- case (Map Address AddressState
addresses Map Address AddressState
-> Getting
(Maybe AddressState)
(Map Address AddressState)
(Maybe AddressState)
-> Maybe AddressState
forall s a. s -> Getting a s a -> a
^. Index (Map Address AddressState)
-> Lens'
(Map Address AddressState)
(Maybe (IxValue (Map Address AddressState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Address AddressState)
Address
addr, Address
addr) of
(Nothing, ContractAddress _) ->
ExecutorError
-> Either
ExecutorError
([GStateUpdate], [Operation], Maybe InterpretResult,
RemainingSteps)
forall a b. a -> Either a b
Left (Address -> ExecutorError
forall a. a -> ExecutorError' a
EEUnknownContract Address
addr)
(Nothing, KeyAddress _) -> do
let
transferAmount :: Mutez
transferAmount = TxData -> Mutez
tdAmount TxData
txData
addrState :: AddressState
addrState = Mutez -> AddressState
ASSimple Mutez
transferAmount
upd :: GStateUpdate
upd = Address -> AddressState -> GStateUpdate
GSAddAddress Address
addr AddressState
addrState
[GStateUpdate]
-> Either
ExecutorError
([GStateUpdate], [Operation], Maybe InterpretResult,
RemainingSteps)
onlyUpdates [GStateUpdate
upd]
(Just (ASSimple oldBalance :: Mutez
oldBalance), _) -> do
let
newBalance :: Mutez
newBalance = Mutez
oldBalance HasCallStack => Mutez -> Mutez -> Mutez
Mutez -> Mutez -> Mutez
`unsafeAddMutez` TxData -> Mutez
tdAmount TxData
txData
upd :: GStateUpdate
upd = Address -> Mutez -> GStateUpdate
GSSetBalance Address
addr Mutez
newBalance
[GStateUpdate]
-> Either
ExecutorError
([GStateUpdate], [Operation], Maybe InterpretResult,
RemainingSteps)
onlyUpdates [GStateUpdate
upd]
(Just (ASContract cs :: ContractState
cs), _) -> do
let
existingContracts :: TcOriginatedContracts
existingContracts = GState -> TcOriginatedContracts
extractAllContracts GState
gs
newBalance :: Mutez
newBalance = ContractState -> Mutez
csBalance ContractState
cs HasCallStack => Mutez -> Mutez -> Mutez
Mutez -> Mutez -> Mutez
`unsafeAddMutez` TxData -> Mutez
tdAmount TxData
txData
contractEnv :: ContractEnv
contractEnv = $WContractEnv :: Timestamp
-> RemainingSteps
-> Mutez
-> TcOriginatedContracts
-> Address
-> Address
-> Address
-> Mutez
-> ChainId
-> ContractEnv
ContractEnv
{ ceNow :: Timestamp
ceNow = Timestamp
now
, ceMaxSteps :: RemainingSteps
ceMaxSteps = RemainingSteps
remainingSteps
, ceBalance :: Mutez
ceBalance = Mutez
newBalance
, ceContracts :: TcOriginatedContracts
ceContracts = TcOriginatedContracts
existingContracts
, ceSelf :: Address
ceSelf = Address
addr
, ceSource :: Address
ceSource = Address
sourceAddr
, ceSender :: Address
ceSender = Address
senderAddr
, ceAmount :: Mutez
ceAmount = TxData -> Mutez
tdAmount TxData
txData
, ceChainId :: ChainId
ceChainId = GState -> ChainId
gsChainId GState
gs
}
epName :: EpName
epName = TxData -> EpName
tdEntrypoint TxData
txData
SomeContractAndStorage typedContract :: FullContract cp st
typedContract typedStorage :: Value st
typedStorage
<- (TCError -> ExecutorError)
-> (TCError -> ExecutorError)
-> GState
-> ContractState
-> Either ExecutorError SomeContractAndStorage
forall err.
(TCError -> err)
-> (TCError -> err)
-> GState
-> ContractState
-> Either err SomeContractAndStorage
getTypedContractAndStorage TCError -> ExecutorError
forall a. TCError -> ExecutorError' a
EEIllTypedContract TCError -> ExecutorError
forall a. TCError -> ExecutorError' a
EEIllTypedStorage GState
gs ContractState
cs
T.MkEntryPointCallRes _ epc :: EntryPointCallT cp arg
epc
<- EpName -> ParamNotes cp -> Maybe (MkEntryPointCallRes cp)
forall (param :: T).
ParameterScope param =>
EpName -> ParamNotes param -> Maybe (MkEntryPointCallRes param)
T.mkEntryPointCall EpName
epName (FullContract cp st -> ParamNotes cp
forall (cp :: T) (st :: T). FullContract cp st -> ParamNotes cp
T.fcParamNotes FullContract cp st
typedContract)
Maybe (MkEntryPointCallRes cp)
-> (Maybe (MkEntryPointCallRes cp)
-> Either ExecutorError (MkEntryPointCallRes cp))
-> Either ExecutorError (MkEntryPointCallRes cp)
forall a b. a -> (a -> b) -> b
& Either ExecutorError (MkEntryPointCallRes cp)
-> (MkEntryPointCallRes cp
-> Either ExecutorError (MkEntryPointCallRes cp))
-> Maybe (MkEntryPointCallRes cp)
-> Either ExecutorError (MkEntryPointCallRes cp)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ExecutorError -> Either ExecutorError (MkEntryPointCallRes cp)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ExecutorError -> Either ExecutorError (MkEntryPointCallRes cp))
-> ExecutorError -> Either ExecutorError (MkEntryPointCallRes cp)
forall a b. (a -> b) -> a -> b
$ EpName -> ExecutorError
forall a. EpName -> ExecutorError' a
EEUnknownEntrypoint EpName
epName) MkEntryPointCallRes cp
-> Either ExecutorError (MkEntryPointCallRes cp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Value arg
typedParameter <- (TCError -> ExecutorError)
-> Either TCError (Value arg) -> Either ExecutorError (Value arg)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TCError -> ExecutorError
forall a. TCError -> ExecutorError' a
EEIllTypedParameter (Either TCError (Value arg) -> Either ExecutorError (Value arg))
-> Either TCError (Value arg) -> Either ExecutorError (Value arg)
forall a b. (a -> b) -> a -> b
$
TcOriginatedContracts -> Value -> Either TCError (Value arg)
forall (t :: T).
(SingI t, HasCallStack) =>
TcOriginatedContracts -> Value -> Either TCError (Value t)
typeVerifyTopLevelType TcOriginatedContracts
existingContracts (TxData -> Value
tdParameter TxData
txData)
iur :: InterpretResult
iur@InterpretResult
{ iurOps :: InterpretResult -> [Operation]
iurOps = [Operation]
sideEffects
, iurNewStorage :: ()
iurNewStorage = Value st
newValue
, iurNewState :: InterpretResult -> InterpreterState
iurNewState = InterpreterState _ newRemainingSteps :: RemainingSteps
newRemainingSteps
}
<- (InterpretError -> ExecutorError)
-> Either InterpretError InterpretResult
-> Either ExecutorError InterpretResult
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Address -> InterpretError -> ExecutorError
forall a. a -> InterpretError -> ExecutorError' a
EEInterpreterFailed Address
addr) (Either InterpretError InterpretResult
-> Either ExecutorError InterpretResult)
-> Either InterpretError InterpretResult
-> Either ExecutorError InterpretResult
forall a b. (a -> b) -> a -> b
$
ContractReturn st -> Either InterpretError InterpretResult
forall (st :: T).
StorageScope st =>
ContractReturn st -> Either InterpretError InterpretResult
handleContractReturn (ContractReturn st -> Either InterpretError InterpretResult)
-> ContractReturn st -> Either InterpretError InterpretResult
forall a b. (a -> b) -> a -> b
$
ContractCode cp st
-> EntryPointCallT cp arg
-> Value arg
-> Value st
-> ContractEnv
-> ContractReturn st
forall (cp :: T) (st :: T) (arg :: T).
ContractCode cp st
-> EntryPointCallT cp arg
-> Value arg
-> Value st
-> ContractEnv
-> ContractReturn st
interpret (FullContract cp st -> ContractCode cp st
forall (cp :: T) (st :: T).
FullContract cp st -> ContractCode cp st
T.fcCode FullContract cp st
typedContract) EntryPointCallT cp arg
epc
Value arg
typedParameter Value st
typedStorage ContractEnv
contractEnv
let
newValueU :: Value
newValueU = Value st -> Value
forall (t :: T). (SingI t, HasNoOp t) => Value' Instr t -> Value
untypeValue Value st
newValue
updBalance :: Maybe GStateUpdate
updBalance
| Mutez
newBalance Mutez -> Mutez -> Bool
forall a. Eq a => a -> a -> Bool
== ContractState -> Mutez
csBalance ContractState
cs = Maybe GStateUpdate
forall a. Maybe a
Nothing
| Bool
otherwise = GStateUpdate -> Maybe GStateUpdate
forall a. a -> Maybe a
Just (GStateUpdate -> Maybe GStateUpdate)
-> GStateUpdate -> Maybe GStateUpdate
forall a b. (a -> b) -> a -> b
$ Address -> Mutez -> GStateUpdate
GSSetBalance Address
addr Mutez
newBalance
updStorage :: Maybe GStateUpdate
updStorage
| Value st -> SomeValue
forall (t :: T) (instr :: [T] -> [T] -> *).
(Typeable t, SingI t) =>
Value' instr t -> SomeValue' instr
SomeValue Value st
newValue SomeValue -> SomeValue -> Bool
forall a. Eq a => a -> a -> Bool
== Value st -> SomeValue
forall (t :: T) (instr :: [T] -> [T] -> *).
(Typeable t, SingI t) =>
Value' instr t -> SomeValue' instr
SomeValue Value st
typedStorage = Maybe GStateUpdate
forall a. Maybe a
Nothing
| Bool
otherwise = GStateUpdate -> Maybe GStateUpdate
forall a. a -> Maybe a
Just (GStateUpdate -> Maybe GStateUpdate)
-> GStateUpdate -> Maybe GStateUpdate
forall a b. (a -> b) -> a -> b
$ Address -> Value -> SomeValue -> GStateUpdate
GSSetStorageValue Address
addr Value
newValueU (Value st -> SomeValue
forall (t :: T) (instr :: [T] -> [T] -> *).
(Typeable t, SingI t) =>
Value' instr t -> SomeValue' instr
SomeValue Value st
newValue)
updates :: [GStateUpdate]
updates = [Maybe GStateUpdate] -> [GStateUpdate]
forall a. [Maybe a] -> [a]
catMaybes
[ Maybe GStateUpdate
updBalance
, Maybe GStateUpdate
updStorage
]
([GStateUpdate], [Operation], Maybe InterpretResult,
RemainingSteps)
-> Either
ExecutorError
([GStateUpdate], [Operation], Maybe InterpretResult,
RemainingSteps)
forall a b. b -> Either a b
Right ([GStateUpdate]
updates, [Operation]
sideEffects, InterpretResult -> Maybe InterpretResult
forall a. a -> Maybe a
Just InterpretResult
iur, RemainingSteps
newRemainingSteps)
let
updates :: [GStateUpdate]
updates = ([GStateUpdate] -> [GStateUpdate])
-> (GStateUpdate -> [GStateUpdate] -> [GStateUpdate])
-> Maybe GStateUpdate
-> [GStateUpdate]
-> [GStateUpdate]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [GStateUpdate] -> [GStateUpdate]
forall a. a -> a
id (:) Maybe GStateUpdate
mDecreaseSenderBalance [GStateUpdate]
otherUpdates
GState
newGState <- (GStateUpdateError -> ExecutorError)
-> Either GStateUpdateError GState -> Either ExecutorError GState
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first GStateUpdateError -> ExecutorError
forall a. GStateUpdateError -> ExecutorError' a
EEFailedToApplyUpdates (Either GStateUpdateError GState -> Either ExecutorError GState)
-> Either GStateUpdateError GState -> Either ExecutorError GState
forall a b. (a -> b) -> a -> b
$ [GStateUpdate] -> GState -> Either GStateUpdateError GState
applyUpdates [GStateUpdate]
updates GState
gs
return $WExecutorRes :: GState
-> [ExecutorOp]
-> [GStateUpdate]
-> [(Address, InterpretResult)]
-> Maybe Address
-> RemainingSteps
-> ExecutorRes
ExecutorRes
{ _erGState :: GState
_erGState = GState
newGState
, _erOperations :: [ExecutorOp]
_erOperations = (Operation -> Maybe ExecutorOp) -> [Operation] -> [ExecutorOp]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Address -> Operation -> Maybe ExecutorOp
convertOp Address
addr) [Operation]
sideEffects
, _erUpdates :: [GStateUpdate]
_erUpdates = [GStateUpdate]
updates
, _erInterpretResults :: [(Address, InterpretResult)]
_erInterpretResults = [(Address, InterpretResult)]
-> (InterpretResult -> [(Address, InterpretResult)])
-> Maybe InterpretResult
-> [(Address, InterpretResult)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(Address, InterpretResult)]
forall a. Monoid a => a
mempty ((Address, InterpretResult) -> [(Address, InterpretResult)]
forall x. One x => OneItem x -> x
one ((Address, InterpretResult) -> [(Address, InterpretResult)])
-> (InterpretResult -> (Address, InterpretResult))
-> InterpretResult
-> [(Address, InterpretResult)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Address
addr,)) Maybe InterpretResult
maybeInterpretRes
, _erSourceAddress :: Maybe Address
_erSourceAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
sourceAddr
, _erRemainingSteps :: RemainingSteps
_erRemainingSteps = RemainingSteps
newRemSteps
}
where
addresses :: Map Address AddressState
addresses :: Map Address AddressState
addresses = GState -> Map Address AddressState
gsAddresses GState
gs
typeCheckWithDb
:: FilePath
-> U.Contract
-> IO (Either TCError SomeContract)
typeCheckWithDb :: String -> Contract -> IO (Either TCError SomeContract)
typeCheckWithDb dbPath :: String
dbPath morleyContract :: Contract
morleyContract = do
GState
gState <- String -> IO GState
readGState String
dbPath
Either TCError SomeContract -> IO (Either TCError SomeContract)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either TCError SomeContract -> IO (Either TCError SomeContract))
-> (Contract -> Either TCError SomeContract)
-> Contract
-> IO (Either TCError SomeContract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcOriginatedContracts -> Contract -> Either TCError SomeContract
typeCheckContract (GState -> TcOriginatedContracts
extractAllContracts GState
gState) (Contract -> IO (Either TCError SomeContract))
-> Contract -> IO (Either TCError SomeContract)
forall a b. (a -> b) -> a -> b
$ Contract
morleyContract
convertOp :: Address -> T.Operation -> Maybe ExecutorOp
convertOp :: Address -> Operation -> Maybe ExecutorOp
convertOp interpretedAddr :: Address
interpretedAddr =
\case
OpTransferTokens tt :: TransferTokens Instr p
tt ->
case TransferTokens Instr p -> Value' Instr ('TContract p)
forall (instr :: [T] -> [T] -> *) (p :: T).
TransferTokens instr p -> Value' instr ('TContract p)
ttContract TransferTokens Instr p
tt of
T.VContract destAddress :: Address
destAddress sepc :: SomeEntryPointCallT arg
sepc ->
let txData :: TxData
txData =
$WTxData :: Address -> Value -> EpName -> Mutez -> TxData
TxData
{ tdSenderAddress :: Address
tdSenderAddress = Address
interpretedAddr
, tdEntrypoint :: EpName
tdEntrypoint = SomeEntryPointCallT arg -> EpName
forall (arg :: T). SomeEntryPointCallT arg -> EpName
T.sepcName SomeEntryPointCallT arg
sepc
, tdParameter :: Value
tdParameter = Value' Instr p -> Value
forall (t :: T). (SingI t, HasNoOp t) => Value' Instr t -> Value
untypeValue (TransferTokens Instr p -> Value' Instr p
forall (instr :: [T] -> [T] -> *) (p :: T).
TransferTokens instr p -> Value' instr p
ttTransferArgument TransferTokens Instr p
tt)
, tdAmount :: Mutez
tdAmount = TransferTokens Instr p -> Mutez
forall (instr :: [T] -> [T] -> *) (p :: T).
TransferTokens instr p -> Mutez
ttAmount TransferTokens Instr p
tt
}
in ExecutorOp -> Maybe ExecutorOp
forall a. a -> Maybe a
Just (Address -> TxData -> ExecutorOp
TransferOp Address
destAddress TxData
txData)
OpSetDelegate {} -> Maybe ExecutorOp
forall a. Maybe a
Nothing
OpCreateContract cc :: CreateContract Instr cp st
cc ->
let origination :: OriginationOperation
origination = $WOriginationOperation :: Address
-> Maybe KeyHash
-> Mutez
-> Value
-> Contract
-> OriginationOperation
OriginationOperation
{ ooOriginator :: Address
ooOriginator = CreateContract Instr cp st -> Address
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
CreateContract instr cp st -> Address
ccOriginator CreateContract Instr cp st
cc
, ooDelegate :: Maybe KeyHash
ooDelegate = CreateContract Instr cp st -> Maybe KeyHash
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
CreateContract instr cp st -> Maybe KeyHash
ccDelegate CreateContract Instr cp st
cc
, ooBalance :: Mutez
ooBalance = CreateContract Instr cp st -> Mutez
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
CreateContract instr cp st -> Mutez
ccBalance CreateContract Instr cp st
cc
, ooStorage :: Value
ooStorage = Value' Instr st -> Value
forall (t :: T). (SingI t, HasNoOp t) => Value' Instr t -> Value
untypeValue (CreateContract Instr cp st -> Value' Instr st
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
CreateContract instr cp st -> Value' instr st
ccStorageVal CreateContract Instr cp st
cc)
, ooContract :: Contract
ooContract = ContractCode cp st -> Contract
forall (param :: T) (store :: T).
(SingI param, SingI store) =>
ContractCode param store -> Contract
convertContractCode (CreateContract Instr cp st -> ContractCode cp st
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
CreateContract instr cp st
-> instr (ContractInp cp st) (ContractOut st)
ccContractCode CreateContract Instr cp st
cc)
}
in ExecutorOp -> Maybe ExecutorOp
forall a. a -> Maybe a
Just (OriginationOperation -> ExecutorOp
OriginateOp OriginationOperation
origination)