-- | Executor and typechecker of a contract in Morley language.

module Michelson.Runtime
  (
    -- * High level interface for end user
    originateContract
  , runContract
  , transfer

  -- * Other helpers
  , parseContract
  , parseExpandContract
  , readAndParseContract
  , prepareContract
  , typeCheckWithDb

  -- * Re-exports
  , ContractState (..)
  , AddressState (..)
  , TxData (..)

  -- * For testing
  , ExecutorOp (..)
  , ExecutorRes (..)
  , ExecutorError' (..)
  , ExecutorError
  , executorPure

  -- * To avoid warnings (can't generate lenses only for some fields)
  , 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)

----------------------------------------------------------------------------
-- Auxiliary types
----------------------------------------------------------------------------

-- | Operations executed by interpreter.
-- In our model one Michelson's operation (`operation` type in Michelson)
-- corresponds to 0 or 1 interpreter operation.
--
-- Note: 'Address' is not part of 'TxData', because 'TxData' is
-- supposed to be provided by the user, while 'Address' can be
-- computed by our code.
data ExecutorOp
  = OriginateOp OriginationOperation
  -- ^ Originate a contract.
  | TransferOp Address TxData
  -- ^ Send a transaction to given address which is assumed to be the
  -- address of an originated contract.
  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)

-- | Result of a single execution of interpreter.
data ExecutorRes = ExecutorRes
  { ExecutorRes -> GState
_erGState :: GState
  -- ^ New 'GState'.
  , ExecutorRes -> [ExecutorOp]
_erOperations :: [ExecutorOp]
  -- ^ List of operations to be added to the operations queue.
  , ExecutorRes -> [GStateUpdate]
_erUpdates :: [GStateUpdate]
  -- ^ Updates applied to 'GState'.
  , ExecutorRes -> [(Address, InterpretResult)]
_erInterpretResults :: [(Address, InterpretResult)]
  -- ^ During execution a contract can print logs and in the end it returns
  -- a pair. All logs and returned values are kept until all called contracts
  -- are executed. In the end they are printed.
  , ExecutorRes -> Maybe Address
_erSourceAddress :: Maybe Address
  -- ^ As soon as transfer operation is encountered, this address is
  -- set to its input.
  , ExecutorRes -> RemainingSteps
_erRemainingSteps :: RemainingSteps
  -- ^ Now much gas all remaining executions can consume.
  } 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

-- Note that it's not commutative.
-- It applies to the case when we have some ExecutorRes already
-- and get a new one after performing some operations.
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
      }

-- | Errors that can happen during contract interpreting.
-- Type parameter @a@ determines how contracts will be represented
-- in these errors, e.g. @Address@
data ExecutorError' a
  = EEUnknownContract !a
  -- ^ The interpreted contract hasn't been originated.
  | EEInterpreterFailed !a
                        !InterpretError
  -- ^ Interpretation of Michelson contract failed.
  | EEAlreadyOriginated !a
                        !ContractState
  -- ^ A contract is already originated.
  | EEUnknownSender !a
  -- ^ Sender address is unknown.
  | EEUnknownManager !a
  -- ^ Manager address is unknown.
  | EENotEnoughFunds !a !Mutez
  -- ^ Sender doesn't have enough funds.
  | EEZeroTransaction !a
  -- ^ Sending 0tz towards an address.
  | EEFailedToApplyUpdates !GStateUpdateError
  -- ^ Failed to apply updates to GState.
  | EEIllTypedContract !TCError
  -- ^ A contract is ill-typed.
  | EEIllTypedStorage !TCError
  -- ^ Contract storage is ill-typed.
  | EEIllTypedParameter !TCError
  -- ^ Contract parameter is ill-typed.
  | EEUnknownEntrypoint EpName
  -- ^ Specified entrypoint to run is not found.
  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

----------------------------------------------------------------------------
-- Interface
----------------------------------------------------------------------------

-- | Parse a contract from 'Text'.
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)

-- | Parse a contract from 'Text' and expand macros.
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

-- | Read and parse a contract from give path or `stdin` (if the
-- argument is 'Nothing'). The contract is not expanded.
readAndParseContract :: Maybe FilePath -> IO (U.Contract' ParsedOp)
readAndParseContract :: 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

-- | Read a contract using 'readAndParseContract', expand and
-- flatten. The contract is not type checked.
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

-- | Originate a contract. Returns the address of the originated
-- contract.
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 =
  -- pass 100500 as maxSteps, because it doesn't matter for origination,
  -- as well as 'now'
  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

-- | Run a contract. The contract is originated first (if it's not
-- already) and then we pretend that we send a transaction to it.
runContract
  :: Maybe Timestamp
  -> 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
    -- We hardcode some random key hash here as delegate to make sure that:
    -- 1. Contract's address won't clash with already originated one (because
    -- it may have different storage value which may be confusing).
    -- 2. If one uses this functionality twice with the same contract and
    -- other data, the contract will have the same address.
    delegate :: KeyHash
delegate =
      (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
      ]

-- | Send a transaction to given address with given parameters.
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
----------------------------------------------------------------------------

-- | Execute a contract on some global state (read from file) and
-- transaction data (passed explicitly).
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 "" -- extra break line to separate logs from two sequence contracts

-- | Implementation of executor outside 'IO'.  It reads operations,
-- executes them one by one and updates state accordingly.
-- Each operation from the passed list is fully executed before
-- the next one is considered.
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
    -- Note that we can't just put all operations into '_erOperations'
    -- and call 'statefulExecutor' once, because in this case the
    -- order of operations will be wrong. We need to consider
    -- top-level operations (passed to this function) and operations returned by contracts separatety.
    -- Specifically, suppose that we want to interpreter two 'TransferOp's: [t1, t2].
    -- If t1 returns an operation, it should be performed before t2, but if we just
    -- pass [t1, t2] as '_erOperations' then 't2' will done immediately after 't1'.
    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
      -- Not using `<>=` because it requires `Monoid` for no reason.
      (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

-- | Execute only one operation and update 'GState' accordingly.
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 ->
        -- Subtraction is safe because we have checked its
        -- precondition in guard.
        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

    -- Transferring 0 XTZ to a key address is prohibited.
    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 ->
          -- Subtraction is safe because we have checked its
          -- precondition in guard.
          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
        -- can't overflow if global state is correct (because we can't
        -- create money out of nowhere)
        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
          -- can't overflow if global state is correct (because we can't
          -- create money out of nowhere)
          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

----------------------------------------------------------------------------
-- TypeCheck
----------------------------------------------------------------------------
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

----------------------------------------------------------------------------
-- Simple helpers
----------------------------------------------------------------------------

-- The argument is the address of the contract that generation this operation.
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)