diff --git a/lib/Echidna/Exec.hs b/lib/Echidna/Exec.hs index afedf6245..bab39a35e 100644 --- a/lib/Echidna/Exec.hs +++ b/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