Skip to content

Commit 158bd74

Browse files
samalws-tobsamalws-tob
committed
(WIP) simplify execTx
1 parent 882c699 commit 158bd74

File tree

1 file changed

+140
-111
lines changed

1 file changed

+140
-111
lines changed

Diff for: ‎lib/Echidna/Exec.hs

+140-111
Original file line numberDiff line numberDiff line change
@@ -93,121 +93,150 @@ execTxWith executeTx tx = do
9393
gasLeftBeforeTx <- gets (.state.gas)
9494
vmResult <- runFully
9595
gasLeftAfterTx <- gets (.state.gas)
96-
handleErrorsAndConstruction vmResult vmBeforeTx
96+
handleErrors vmResult vmBeforeTx
97+
when isCreate $ handleConstruction vmResult tx.dst
9798
pure (vmResult, gasLeftBeforeTx - gasLeftAfterTx)
9899
where
99-
runFully = do
100-
config <- asks (.cfg)
101-
-- TODO: Is the latest block a good default? It makes fuzzing hard to reproduce. Rethink this.
102-
let rpcBlock = maybe EVM.Fetch.Latest (EVM.Fetch.BlockNumber . fromIntegral) config.rpcBlock
100+
isCreate = case tx.call of
101+
(SolCreate _) -> True
102+
_ -> False
103103

104+
runFully = do
104105
vmResult <- executeTx
105-
-- For queries, we halt execution because the VM needs some additional
106-
-- information from the outside. We provide this information and resume
107-
-- the execution by recursively calling `runFully`.
108-
case getQuery vmResult of
109-
-- A previously unknown contract is required
110-
Just q@(PleaseFetchContract addr _ continuation) -> do
111-
cacheRef <- asks (.fetchContractCache)
112-
cache <- liftIO $ readIORef cacheRef
113-
case Map.lookup addr cache of
114-
Just (Just contract) -> fromEVM (continuation contract)
115-
Just Nothing -> do
116-
v <- get
117-
v' <- liftIO $ stToIO $ execStateT (continuation emptyAccount) v
118-
put v'
119-
Nothing -> do
120-
logMsg $ "INFO: Performing RPC: " <> show q
121-
case config.rpcUrl of
122-
Just rpcUrl -> do
123-
ret <- liftIO $ safeFetchContractFrom rpcBlock rpcUrl addr
124-
case ret of
125-
-- TODO: fix hevm to not return an empty contract in case of an error
126-
Just contract | contract.code /= RuntimeCode (ConcreteRuntimeCode "") -> do
127-
fromEVM (continuation contract)
128-
liftIO $ atomicWriteIORef cacheRef $ Map.insert addr (Just contract) cache
129-
_ -> do
130-
-- TODO: better error reporting in HEVM, when intermmittent
131-
-- network error then retry
132-
liftIO $ atomicWriteIORef cacheRef $ Map.insert addr Nothing cache
133-
logMsg $ "ERROR: Failed to fetch contract: " <> show q
134-
-- TODO: How should we fail here? It could be a network error,
135-
-- RPC server returning junk etc.
136-
fromEVM (continuation emptyAccount)
137-
Nothing -> do
138-
liftIO $ atomicWriteIORef cacheRef $ Map.insert addr Nothing cache
139-
logMsg $ "ERROR: Requested RPC but it is not configured: " <> show q
140-
-- TODO: How should we fail here? RPC is not configured but VM
141-
-- wants to fetch
142-
fromEVM (continuation emptyAccount)
143-
runFully -- resume execution
144-
145-
-- A previously unknown slot is required
146-
Just q@(PleaseFetchSlot addr slot continuation) -> do
147-
cacheRef <- asks (.fetchSlotCache)
148-
cache <- liftIO $ readIORef cacheRef
149-
case Map.lookup addr cache >>= Map.lookup slot of
150-
Just (Just value) -> fromEVM (continuation value)
151-
Just Nothing -> fromEVM (continuation 0)
152-
Nothing -> do
153-
logMsg $ "INFO: Performing RPC: " <> show q
154-
case config.rpcUrl of
155-
Just rpcUrl -> do
156-
ret <- liftIO $ safeFetchSlotFrom rpcBlock rpcUrl addr slot
157-
case ret of
158-
Just value -> do
159-
fromEVM (continuation value)
160-
liftIO $ atomicWriteIORef cacheRef $
161-
Map.insertWith Map.union addr (Map.singleton slot (Just value)) cache
162-
Nothing -> do
163-
-- TODO: How should we fail here? It could be a network error,
164-
-- RPC server returning junk etc.
165-
logMsg $ "ERROR: Failed to fetch slot: " <> show q
166-
liftIO $ atomicWriteIORef cacheRef $
167-
Map.insertWith Map.union addr (Map.singleton slot Nothing) cache
168-
fromEVM (continuation 0)
169-
Nothing -> do
170-
logMsg $ "ERROR: Requested RPC but it is not configured: " <> show q
171-
-- Use the zero slot
172-
fromEVM (continuation 0)
173-
runFully -- resume execution
174-
175-
-- Execute a FFI call
176-
Just (PleaseDoFFI (cmd : args) continuation) -> do
177-
(_, stdout, _) <- liftIO $ readProcessWithExitCode cmd args ""
178-
let encodedResponse = encodeAbiValue $
179-
AbiTuple (V.fromList [AbiBytesDynamic . hexText . T.pack $ stdout])
180-
fromEVM (continuation encodedResponse)
181-
runFully
182-
183-
-- No queries to answer, the tx is fully executed and the result is final
184-
_ -> pure vmResult
185-
186-
-- | Handles reverts, failures and contract creations that might be the result
187-
-- (`vmResult`) of executing transaction `tx`.
188-
handleErrorsAndConstruction vmResult vmBeforeTx = case (vmResult, tx.call) of
189-
(Reversion, _) -> do
190-
tracesBeforeVMReset <- gets (.traces)
191-
codeContractBeforeVMReset <- gets (.state.codeContract)
192-
calldataBeforeVMReset <- gets (.state.calldata)
193-
callvalueBeforeVMReset <- gets (.state.callvalue)
194-
-- If a transaction reverts reset VM to state before the transaction.
195-
put vmBeforeTx
196-
-- Undo reset of some of the VM state.
197-
-- Otherwise we'd loose all information about the reverted transaction like
198-
-- contract address, calldata, result and traces.
199-
#result ?= vmResult
200-
#state % #calldata .= calldataBeforeVMReset
201-
#state % #callvalue .= callvalueBeforeVMReset
202-
#traces .= tracesBeforeVMReset
203-
#state % #codeContract .= codeContractBeforeVMReset
204-
(VMFailure x, _) -> vmExcept x
205-
(VMSuccess (ConcreteBuf bytecode'), SolCreate _) -> do
206-
-- Handle contract creation.
207-
#env % #contracts % at (LitAddr tx.dst) % _Just % #code .= InitCode mempty mempty
208-
fromEVM $ replaceCodeOfSelf (RuntimeCode (ConcreteRuntimeCode bytecode'))
209-
modify' $ execState $ loadContract (LitAddr tx.dst)
210-
_ -> pure ()
106+
maybe (pure vmResult) (\q -> handleQuery q >> runFully) (getQuery vmResult)
107+
108+
getRpcInfo
109+
:: (MonadReader Env m)
110+
=> m (Maybe T.Text, EVM.Fetch.BlockNumber)
111+
getRpcInfo = do
112+
config <- asks (.cfg)
113+
-- TODO: Is the latest block a good default? It makes fuzzing hard to reproduce. Rethink this.
114+
let rpcBlock = maybe EVM.Fetch.Latest (EVM.Fetch.BlockNumber . fromIntegral) config.rpcBlock
115+
return (config.rpcUrl, rpcBlock)
116+
117+
handleQuery
118+
:: (MonadIO m, MonadState (VM Concrete RealWorld) m, MonadReader Env m, MonadThrow m)
119+
=> Query Concrete RealWorld
120+
-> m ()
121+
122+
-- For queries, we halt execution because the VM needs some additional
123+
-- information from the outside. We provide this information and resume
124+
-- the execution by recursively calling `runFully`.
125+
handleQuery q@(PleaseFetchContract addr _ continuation) = do
126+
-- A previously unknown contract is required
127+
cacheRef <- asks (.fetchContractCache)
128+
cache <- liftIO $ readIORef cacheRef
129+
case Map.lookup addr cache of
130+
Just (Just contract) -> fromEVM (continuation contract)
131+
Just Nothing -> do
132+
v <- get
133+
v' <- liftIO $ stToIO $ execStateT (continuation emptyAccount) v
134+
put v'
135+
Nothing -> do
136+
logMsg $ "INFO: Performing RPC: " <> show q
137+
(maybeRpcUrl, rpcBlock) <- getRpcInfo
138+
case maybeRpcUrl of
139+
Just rpcUrl -> do
140+
ret <- liftIO $ safeFetchContractFrom rpcBlock rpcUrl addr
141+
case ret of
142+
-- TODO: fix hevm to not return an empty contract in case of an error
143+
Just contract | contract.code /= RuntimeCode (ConcreteRuntimeCode "") -> do
144+
fromEVM (continuation contract)
145+
liftIO $ atomicWriteIORef cacheRef $ Map.insert addr (Just contract) cache
146+
_ -> do
147+
-- TODO: better error reporting in HEVM, when intermmittent
148+
-- network error then retry
149+
liftIO $ atomicWriteIORef cacheRef $ Map.insert addr Nothing cache
150+
logMsg $ "ERROR: Failed to fetch contract: " <> show q
151+
-- TODO: How should we fail here? It could be a network error,
152+
-- RPC server returning junk etc.
153+
fromEVM (continuation emptyAccount)
154+
Nothing -> do
155+
liftIO $ atomicWriteIORef cacheRef $ Map.insert addr Nothing cache
156+
logMsg $ "ERROR: Requested RPC but it is not configured: " <> show q
157+
-- TODO: How should we fail here? RPC is not configured but VM
158+
-- wants to fetch
159+
fromEVM (continuation emptyAccount)
160+
161+
-- A previously unknown slot is required
162+
handleQuery q@(PleaseFetchSlot addr slot continuation) = do
163+
cacheRef <- asks (.fetchSlotCache)
164+
cache <- liftIO $ readIORef cacheRef
165+
case Map.lookup addr cache >>= Map.lookup slot of
166+
Just (Just value) -> fromEVM (continuation value)
167+
Just Nothing -> fromEVM (continuation 0)
168+
Nothing -> do
169+
logMsg $ "INFO: Performing RPC: " <> show q
170+
(maybeRpcUrl, rpcBlock) <- getRpcInfo
171+
case maybeRpcUrl of
172+
Just rpcUrl -> do
173+
ret <- liftIO $ safeFetchSlotFrom rpcBlock rpcUrl addr slot
174+
case ret of
175+
Just value -> do
176+
fromEVM (continuation value)
177+
liftIO $ atomicWriteIORef cacheRef $
178+
Map.insertWith Map.union addr (Map.singleton slot (Just value)) cache
179+
Nothing -> do
180+
-- TODO: How should we fail here? It could be a network error,
181+
-- RPC server returning junk etc.
182+
logMsg $ "ERROR: Failed to fetch slot: " <> show q
183+
liftIO $ atomicWriteIORef cacheRef $
184+
Map.insertWith Map.union addr (Map.singleton slot Nothing) cache
185+
fromEVM (continuation 0)
186+
Nothing -> do
187+
logMsg $ "ERROR: Requested RPC but it is not configured: " <> show q
188+
-- Use the zero slot
189+
fromEVM (continuation 0)
190+
191+
-- Execute a FFI call
192+
handleQuery (PleaseDoFFI (cmd : args) continuation) = do
193+
(_, stdout, _) <- liftIO $ readProcessWithExitCode cmd args ""
194+
let encodedResponse = encodeAbiValue $
195+
AbiTuple (V.fromList [AbiBytesDynamic . hexText . T.pack $ stdout])
196+
fromEVM (continuation encodedResponse)
197+
198+
handleQuery (PleaseDoFFI [] _) = error "Malformed FFI call"
199+
200+
handleErrors
201+
:: (MonadIO m, MonadState (VM Concrete RealWorld) m, MonadReader Env m, MonadThrow m)
202+
=> VMResult Concrete RealWorld
203+
-> VM Concrete RealWorld
204+
-> m ()
205+
206+
-- | Handles reverts, failures and contract creations that might be the result
207+
-- (`vmResult`) of executing transaction `tx`.
208+
handleErrors vmResult@Reversion vmBeforeTx = do
209+
tracesBeforeVMReset <- gets (.traces)
210+
codeContractBeforeVMReset <- gets (.state.codeContract)
211+
calldataBeforeVMReset <- gets (.state.calldata)
212+
callvalueBeforeVMReset <- gets (.state.callvalue)
213+
-- If a transaction reverts reset VM to state before the transaction.
214+
put vmBeforeTx
215+
-- Undo reset of some of the VM state.
216+
-- Otherwise we'd loose all information about the reverted transaction like
217+
-- contract address, calldata, result and traces.
218+
#result ?= vmResult
219+
#state % #calldata .= calldataBeforeVMReset
220+
#state % #callvalue .= callvalueBeforeVMReset
221+
#traces .= tracesBeforeVMReset
222+
#state % #codeContract .= codeContractBeforeVMReset
223+
handleErrors (VMFailure x) _ = vmExcept x
224+
handleErrors _ _ = pure ()
225+
226+
handleConstruction
227+
:: (MonadIO m, MonadState (VM Concrete RealWorld) m, MonadReader Env m, MonadThrow m)
228+
=> VMResult Concrete s
229+
-> Addr
230+
-> m ()
231+
232+
-- | Handles reverts, failures and contract creations that might be the result
233+
-- (`vmResult`) of executing transaction `tx`.
234+
handleConstruction (VMSuccess (ConcreteBuf bytecode')) dst = do
235+
-- Handle contract creation.
236+
#env % #contracts % at (LitAddr dst) % _Just % #code .= InitCode mempty mempty
237+
fromEVM $ replaceCodeOfSelf (RuntimeCode (ConcreteRuntimeCode bytecode'))
238+
modify' $ execState $ loadContract (LitAddr dst)
239+
handleConstruction _ _ = pure ()
211240

212241
logMsg :: (MonadIO m, MonadReader Env m) => String -> m ()
213242
logMsg msg = do

0 commit comments

Comments
 (0)