Skip to content

Commit cf0a09c

Browse files
samalws-tobsamalws-tob
committed
(WIP) simplify execTx
1 parent bf14ea4 commit cf0a09c

File tree

1 file changed

+143
-114
lines changed

1 file changed

+143
-114
lines changed

‎lib/Echidna/Exec.hs‎

Lines changed: 143 additions & 114 deletions
Original file line numberDiff line numberDiff line change
@@ -97,124 +97,153 @@ execTxWith executeTx tx = do
9797
gasLeftBeforeTx <- gets (.state.gas)
9898
vmResult <- runFully
9999
gasLeftAfterTx <- gets (.state.gas)
100-
handleErrorsAndConstruction vmResult vmBeforeTx
100+
handleErrors vmResult vmBeforeTx
101+
when isCreate $ handleConstruction vmResult tx.dst
101102
pure (vmResult, gasLeftBeforeTx - gasLeftAfterTx)
102103
where
103-
runFully = do
104-
config <- asks (.cfg)
105-
-- TODO: Is the latest block a good default? It makes fuzzing hard to reproduce. Rethink this.
106-
let rpcBlock = maybe EVM.Fetch.Latest (EVM.Fetch.BlockNumber . fromIntegral) config.rpcBlock
104+
isCreate = case tx.call of
105+
(SolCreate _) -> True
106+
_ -> False
107107

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

219248
logMsg :: (MonadIO m, MonadReader Env m) => String -> m ()
220249
logMsg msg = do

0 commit comments

Comments
 (0)