(WIP) simplify execTx

lib/Echidna/Exec.hs

@@ -93,121 +93,150 @@ execTxWith executeTx tx = do
  gasLeftBeforeTx <- gets (.state.gas)
  vmResult <- runFully
  gasLeftAfterTx <- gets (.state.gas)
- handleErrorsAndConstruction vmResult vmBeforeTx
+ handleErrors vmResult vmBeforeTx
+ when isCreate $ handleConstruction vmResult tx.dst
  pure (vmResult, gasLeftBeforeTx - gasLeftAfterTx)
  where
- runFully = do
- config <- asks (.cfg)
- -- TODO: Is the latest block a good default? It makes fuzzing hard to reproduce. Rethink this.
- let rpcBlock = maybe EVM.Fetch.Latest (EVM.Fetch.BlockNumber . fromIntegral) config.rpcBlock
+ isCreate = case tx.call of
+ (SolCreate _) -> True
+ _ -> False
 
+ runFully = do
  vmResult <- executeTx
- -- For queries, we halt execution because the VM needs some additional
- -- information from the outside. We provide this information and resume
- -- the execution by recursively calling `runFully`.
- case getQuery vmResult of
- -- A previously unknown contract is required
- Just q@(PleaseFetchContract addr _ continuation) -> do
- cacheRef <- asks (.fetchContractCache)
- cache <- liftIO $ readIORef cacheRef
- case Map.lookup addr cache of
- Just (Just contract) -> fromEVM (continuation contract)
- Just Nothing -> do
- v <- get
- v' <- liftIO $ stToIO $ execStateT (continuation emptyAccount) v
- put v'
- Nothing -> do
- logMsg $ "INFO: Performing RPC: " <> show q
- case config.rpcUrl of
- Just rpcUrl -> do
- ret <- liftIO $ safeFetchContractFrom rpcBlock rpcUrl addr
- case ret of
- -- TODO: fix hevm to not return an empty contract in case of an error
- Just contract | contract.code /= RuntimeCode (ConcreteRuntimeCode "") -> do
- fromEVM (continuation contract)
- liftIO $ atomicWriteIORef cacheRef $ Map.insert addr (Just contract) cache
- _ -> do
- -- TODO: better error reporting in HEVM, when intermmittent
- -- network error then retry
- liftIO $ atomicWriteIORef cacheRef $ Map.insert addr Nothing cache
- logMsg $ "ERROR: Failed to fetch contract: " <> show q
- -- TODO: How should we fail here? It could be a network error,
- -- RPC server returning junk etc.
- fromEVM (continuation emptyAccount)
- Nothing -> do
- liftIO $ atomicWriteIORef cacheRef $ Map.insert addr Nothing cache
- logMsg $ "ERROR: Requested RPC but it is not configured: " <> show q
- -- TODO: How should we fail here? RPC is not configured but VM
- -- wants to fetch
- fromEVM (continuation emptyAccount)
- runFully -- resume execution
-
- -- A previously unknown slot is required
- Just q@(PleaseFetchSlot addr slot continuation) -> do
- cacheRef <- asks (.fetchSlotCache)
- cache <- liftIO $ readIORef cacheRef
- case Map.lookup addr cache >>= Map.lookup slot of
- Just (Just value) -> fromEVM (continuation value)
- Just Nothing -> fromEVM (continuation 0)
- Nothing -> do
- logMsg $ "INFO: Performing RPC: " <> show q
- case config.rpcUrl of
- Just rpcUrl -> do
- ret <- liftIO $ safeFetchSlotFrom rpcBlock rpcUrl addr slot
- case ret of
- Just value -> do
- fromEVM (continuation value)
- liftIO $ atomicWriteIORef cacheRef $
- Map.insertWith Map.union addr (Map.singleton slot (Just value)) cache
- Nothing -> do
- -- TODO: How should we fail here? It could be a network error,
- -- RPC server returning junk etc.
- logMsg $ "ERROR: Failed to fetch slot: " <> show q
- liftIO $ atomicWriteIORef cacheRef $
- Map.insertWith Map.union addr (Map.singleton slot Nothing) cache
- fromEVM (continuation 0)
- Nothing -> do
- logMsg $ "ERROR: Requested RPC but it is not configured: " <> show q
- -- Use the zero slot
- fromEVM (continuation 0)
- runFully -- resume execution
-
- -- Execute a FFI call
- Just (PleaseDoFFI (cmd : args) continuation) -> do
- (_, stdout, _) <- liftIO $ readProcessWithExitCode cmd args ""
- let encodedResponse = encodeAbiValue $
- AbiTuple (V.fromList [AbiBytesDynamic . hexText . T.pack $ stdout])
- fromEVM (continuation encodedResponse)
- runFully
-
- -- No queries to answer, the tx is fully executed and the result is final
- _ -> pure vmResult
-
- -- | Handles reverts, failures and contract creations that might be the result
- -- (`vmResult`) of executing transaction `tx`.
- handleErrorsAndConstruction vmResult vmBeforeTx = case (vmResult, tx.call) of
- (Reversion, _) -> do
- tracesBeforeVMReset <- gets (.traces)
- codeContractBeforeVMReset <- gets (.state.codeContract)
- calldataBeforeVMReset <- gets (.state.calldata)
- callvalueBeforeVMReset <- gets (.state.callvalue)
- -- If a transaction reverts reset VM to state before the transaction.
- put vmBeforeTx
- -- Undo reset of some of the VM state.
- -- Otherwise we'd loose all information about the reverted transaction like
- -- contract address, calldata, result and traces.
- #result ?= vmResult
- #state % #calldata .= calldataBeforeVMReset
- #state % #callvalue .= callvalueBeforeVMReset
- #traces .= tracesBeforeVMReset
- #state % #codeContract .= codeContractBeforeVMReset
- (VMFailure x, _) -> vmExcept x
- (VMSuccess (ConcreteBuf bytecode'), SolCreate _) -> do
- -- Handle contract creation.
- #env % #contracts % at (LitAddr tx.dst) % _Just % #code .= InitCode mempty mempty
- fromEVM $ replaceCodeOfSelf (RuntimeCode (ConcreteRuntimeCode bytecode'))
- modify' $ execState $ loadContract (LitAddr tx.dst)
- _ -> pure ()
+ maybe (pure vmResult) (\q -> handleQuery q >> runFully) (getQuery vmResult)
+
+getRpcInfo
+ :: (MonadReader Env m)
+ => m (Maybe T.Text, EVM.Fetch.BlockNumber)
+getRpcInfo = do
+ config <- asks (.cfg)
+ -- TODO: Is the latest block a good default? It makes fuzzing hard to reproduce. Rethink this.
+ let rpcBlock = maybe EVM.Fetch.Latest (EVM.Fetch.BlockNumber . fromIntegral) config.rpcBlock
+ return (config.rpcUrl, rpcBlock)
+
+handleQuery
+ :: (MonadIO m, MonadState (VM Concrete RealWorld) m, MonadReader Env m, MonadThrow m)
+ => Query Concrete RealWorld
+ -> m ()
+
+-- For queries, we halt execution because the VM needs some additional
+-- information from the outside. We provide this information and resume
+-- the execution by recursively calling `runFully`.
+handleQuery q@(PleaseFetchContract addr _ continuation) = do
+ -- A previously unknown contract is required
+ cacheRef <- asks (.fetchContractCache)
+ cache <- liftIO $ readIORef cacheRef
+ case Map.lookup addr cache of
+ Just (Just contract) -> fromEVM (continuation contract)
+ Just Nothing -> do
+ v <- get
+ v' <- liftIO $ stToIO $ execStateT (continuation emptyAccount) v
+ put v'
+ Nothing -> do
+ logMsg $ "INFO: Performing RPC: " <> show q
+ (maybeRpcUrl, rpcBlock) <- getRpcInfo
+ case maybeRpcUrl of
+ Just rpcUrl -> do
+ ret <- liftIO $ safeFetchContractFrom rpcBlock rpcUrl addr
+ case ret of
+ -- TODO: fix hevm to not return an empty contract in case of an error
+ Just contract | contract.code /= RuntimeCode (ConcreteRuntimeCode "") -> do
+ fromEVM (continuation contract)
+ liftIO $ atomicWriteIORef cacheRef $ Map.insert addr (Just contract) cache
+ _ -> do
+ -- TODO: better error reporting in HEVM, when intermmittent
+ -- network error then retry
+ liftIO $ atomicWriteIORef cacheRef $ Map.insert addr Nothing cache
+ logMsg $ "ERROR: Failed to fetch contract: " <> show q
+ -- TODO: How should we fail here? It could be a network error,
+ -- RPC server returning junk etc.
+ fromEVM (continuation emptyAccount)
+ Nothing -> do
+ liftIO $ atomicWriteIORef cacheRef $ Map.insert addr Nothing cache
+ logMsg $ "ERROR: Requested RPC but it is not configured: " <> show q
+ -- TODO: How should we fail here? RPC is not configured but VM
+ -- wants to fetch
+ fromEVM (continuation emptyAccount)
+
+-- A previously unknown slot is required
+handleQuery q@(PleaseFetchSlot addr slot continuation) = do
+ cacheRef <- asks (.fetchSlotCache)
+ cache <- liftIO $ readIORef cacheRef
+ case Map.lookup addr cache >>= Map.lookup slot of
+ Just (Just value) -> fromEVM (continuation value)
+ Just Nothing -> fromEVM (continuation 0)
+ Nothing -> do
+ logMsg $ "INFO: Performing RPC: " <> show q
+ (maybeRpcUrl, rpcBlock) <- getRpcInfo
+ case maybeRpcUrl of
+ Just rpcUrl -> do
+ ret <- liftIO $ safeFetchSlotFrom rpcBlock rpcUrl addr slot
+ case ret of
+ Just value -> do
+ fromEVM (continuation value)
+ liftIO $ atomicWriteIORef cacheRef $
+ Map.insertWith Map.union addr (Map.singleton slot (Just value)) cache
+ Nothing -> do
+ -- TODO: How should we fail here? It could be a network error,
+ -- RPC server returning junk etc.
+ logMsg $ "ERROR: Failed to fetch slot: " <> show q
+ liftIO $ atomicWriteIORef cacheRef $
+ Map.insertWith Map.union addr (Map.singleton slot Nothing) cache
+ fromEVM (continuation 0)
+ Nothing -> do
+ logMsg $ "ERROR: Requested RPC but it is not configured: " <> show q
+ -- Use the zero slot
+ fromEVM (continuation 0)
+
+-- Execute a FFI call
+handleQuery (PleaseDoFFI (cmd : args) continuation) = do
+ (_, stdout, _) <- liftIO $ readProcessWithExitCode cmd args ""
+ let encodedResponse = encodeAbiValue $
+ AbiTuple (V.fromList [AbiBytesDynamic . hexText . T.pack $ stdout])
+ fromEVM (continuation encodedResponse)
+
+handleQuery (PleaseDoFFI [] _) = error "Malformed FFI call"
+
+handleErrors
+ :: (MonadIO m, MonadState (VM Concrete RealWorld) m, MonadReader Env m, MonadThrow m)
+ => VMResult Concrete RealWorld
+ -> VM Concrete RealWorld
+ -> m ()
+
+-- | Handles reverts, failures and contract creations that might be the result
+-- (`vmResult`) of executing transaction `tx`.
+handleErrors vmResult@Reversion vmBeforeTx = do
+ tracesBeforeVMReset <- gets (.traces)
+ codeContractBeforeVMReset <- gets (.state.codeContract)
+ calldataBeforeVMReset <- gets (.state.calldata)
+ callvalueBeforeVMReset <- gets (.state.callvalue)
+ -- If a transaction reverts reset VM to state before the transaction.
+ put vmBeforeTx
+ -- Undo reset of some of the VM state.
+ -- Otherwise we'd loose all information about the reverted transaction like
+ -- contract address, calldata, result and traces.
+ #result ?= vmResult
+ #state % #calldata .= calldataBeforeVMReset
+ #state % #callvalue .= callvalueBeforeVMReset
+ #traces .= tracesBeforeVMReset
+ #state % #codeContract .= codeContractBeforeVMReset
+handleErrors (VMFailure x) _ = vmExcept x
+handleErrors _ _ = pure ()
+
+handleConstruction
+ :: (MonadIO m, MonadState (VM Concrete RealWorld) m, MonadReader Env m, MonadThrow m)
+ => VMResult Concrete s
+ -> Addr
+ -> m ()
+
+-- | Handles reverts, failures and contract creations that might be the result
+-- (`vmResult`) of executing transaction `tx`.
+handleConstruction (VMSuccess (ConcreteBuf bytecode')) dst = do
+ -- Handle contract creation.
+ #env % #contracts % at (LitAddr dst) % _Just % #code .= InitCode mempty mempty
+ fromEVM $ replaceCodeOfSelf (RuntimeCode (ConcreteRuntimeCode bytecode'))
+ modify' $ execState $ loadContract (LitAddr dst)
+handleConstruction _ _ = pure ()
 
 logMsg :: (MonadIO m, MonadReader Env m) => String -> m ()
 logMsg msg = do