Skip to content

Commit 9ba5e52

Browse files
blishkoblishko
authored
Merge pull request #947 from argotorg/cache-hits
[RFC] Track failures, expose stats, return cache info
2 parents 88efa8a + 21f614d commit 9ba5e52

File tree

3 files changed

+168
-73
lines changed

3 files changed

+168
-73
lines changed

‎cli/cli.hs‎

Lines changed: 15 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -646,10 +646,13 @@ vmFromCommand cOpts cExecOpts cFileOpts execOpts sess = do
646646
exitFailure
647647
else
648648
Fetch.fetchContractWithSession conf sess block url addr' >>= \case
649-
Nothing -> do
649+
Fetch.FetchFailure _ -> do
650650
putStrLn $ "Error: contract not found: " <> show address
651651
exitFailure
652-
Just rpcContract ->
652+
Fetch.FetchError e -> do
653+
putStrLn $ "Error: RPC failure: " <> show e
654+
exitFailure
655+
Fetch.FetchSuccess rpcContract _ ->
653656
-- if both code and url is given,
654657
-- fetch the contract and overwrite the code
655658
pure $ initialContract (mkCode $ fromJust code)
@@ -658,10 +661,13 @@ vmFromCommand cOpts cExecOpts cFileOpts execOpts sess = do
658661

659662
(Just url, Just addr', Nothing) ->
660663
liftIO $ Fetch.fetchContractWithSession conf sess block url addr' >>= \case
661-
Nothing -> do
664+
Fetch.FetchFailure _ -> do
662665
putStrLn $ "Error, contract not found: " <> show address
663666
exitFailure
664-
Just rpcContract -> pure $ Fetch.makeContractFromRPC rpcContract
667+
Fetch.FetchError e -> do
668+
putStrLn $ "Error: RPC failure: " <> show e
669+
exitFailure
670+
Fetch.FetchSuccess rpcContract _ -> pure $ Fetch.makeContractFromRPC rpcContract
665671

666672
(_, _, Just c) -> do
667673
let code = hexByteString $ strip0x c
@@ -759,10 +765,13 @@ symvmFromCommand cExecOpts sOpts cFileOpts sess calldata = do
759765
contract <- case (cExecOpts.rpc, cExecOpts.address, codeWrapped) of
760766
(Just url, Just addr', _) ->
761767
liftIO $ Fetch.fetchContractWithSession conf sess block url addr' >>= \case
762-
Nothing -> do
768+
Fetch.FetchFailure _ -> do
763769
putStrLn "Error, contract not found."
764770
exitFailure
765-
Just rpcContract' -> case codeWrapped of
771+
Fetch.FetchError e -> do
772+
putStrLn $ "Error: RPC failure: " <> show e
773+
exitFailure
774+
Fetch.FetchSuccess rpcContract' _ -> case codeWrapped of
766775
Nothing -> pure $ Fetch.makeContractFromRPC rpcContract'
767776
-- if both code and url is given,
768777
-- fetch the contract and overwrite the code

‎src/EVM/Fetch.hs‎

Lines changed: 150 additions & 65 deletions
Original file line numberDiff line numberDiff line change
@@ -19,10 +19,13 @@ module EVM.Fetch
1919
, saveCache
2020
, RPCContract (..)
2121
, makeContractFromRPC
22-
-- Below 3 are needed for Echidna
22+
-- Below 4 are needed for Echidna
2323
, fetchSlotWithSession
2424
, fetchSlotWithCache
2525
, fetchWithSession
26+
, getCacheState
27+
, FetchStatus(..)
28+
, FetchResult(..)
2629
) where
2730

2831
import Prelude hiding (Foldable(..))
@@ -46,15 +49,16 @@ import qualified Data.ByteString.Lazy as BSL
4649
import Data.Bifunctor (first)
4750
import Control.Exception (try, SomeException)
4851

49-
import Control.Monad.Trans.Maybe
5052
import Data.Aeson hiding (Error)
5153
import Data.Aeson.Optics
5254
import Data.ByteString qualified as BS
5355
import Data.Text (Text, unpack, pack)
5456
import Data.Text qualified as T
5557
import Data.Foldable (Foldable(..))
5658
import Data.Map.Strict qualified as Map
57-
import Data.Maybe (fromMaybe, isJust, fromJust, isNothing)
59+
import Data.Maybe (fromMaybe, fromJust, isNothing)
60+
import Data.Set qualified as Set
61+
import Data.Set (Set)
5862
import Data.Vector qualified as RegularVector
5963
import Network.Wreq
6064
import Network.Wreq.Session qualified as NetSession
@@ -69,11 +73,24 @@ import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)
6973

7074
type Fetcher t m = App m => Query t -> m (EVM t ())
7175

76+
data FetchStatus = Cached | Fresh
77+
deriving (Show, Eq)
78+
79+
data FetchResult a
80+
= FetchSuccess a FetchStatus
81+
| FetchFailure FetchStatus
82+
| FetchError Text
83+
deriving (Show, Eq)
84+
7285
data Session = Session
73-
{ sess :: NetSession.Session
74-
, latestBlockNum :: MVar (Maybe W256)
75-
, sharedCache :: MVar FetchCache
76-
, cacheDir :: Maybe FilePath
86+
{ sess :: NetSession.Session
87+
, latestBlockNum :: MVar (Maybe W256)
88+
, sharedCache :: MVar FetchCache
89+
, cacheDir :: Maybe FilePath
90+
-- Track ephemeral failures (network errors, not found, etc.)
91+
-- These are NOT persisted to disk
92+
, failedContracts :: MVar (Set Addr)
93+
, failedSlots :: MVar (Set (Addr, W256))
7794
}
7895

7996
data FetchCache = FetchCache
@@ -178,39 +195,33 @@ addFetchCache sess address ctrct = do
178195
fetchQuery
179196
:: Show a
180197
=> BlockNumber
181-
-> (Value -> IO (Maybe Value))
198+
-> (Value -> IO (Either Text Value))
182199
-> RpcQuery a
183-
-> IO (Maybe a)
200+
-> IO (Either Text a)
184201
fetchQuery n f q =
185202
case q of
186203
QueryCode addr -> do
187204
m <- f (rpc "eth_getCode" [toRPC addr, toRPC n])
188-
pure $ do
189-
t <- preview _String <$> m
190-
hexText <$> t
205+
pure $ m >>= \v -> maybeToRight "Parse error" (hexText <$> preview _String v)
191206
QueryNonce addr -> do
192207
m <- f (rpc "eth_getTransactionCount" [toRPC addr, toRPC n])
193-
pure $ do
194-
t <- preview _String <$> m
195-
readText <$> t
208+
pure $ m >>= \v -> maybeToRight "Parse error" (readText <$> preview _String v)
196209
QueryBlock -> do
197210
m <- f (rpc "eth_getBlockByNumber" [toRPC n, toRPC False])
198-
pure $ m >>= parseBlock
211+
pure $ m >>= \v -> maybeToRight "Parse error" (parseBlock v)
199212
QueryBalance addr -> do
200213
m <- f (rpc "eth_getBalance" [toRPC addr, toRPC n])
201-
pure $ do
202-
t <- preview _String <$> m
203-
readText <$> t
214+
pure $ m >>= \v -> maybeToRight "Parse error" (readText <$> preview _String v)
204215
QuerySlot addr slot -> do
205216
m <- f (rpc "eth_getStorageAt" [toRPC addr, toRPC slot, toRPC n])
206-
pure $ do
207-
t <- preview _String <$> m
208-
readText <$> t
217+
pure $ m >>= \v -> maybeToRight "Parse error" (readText <$> preview _String v)
209218
QueryChainId -> do
210219
m <- f (rpc "eth_chainId" [toRPC n])
211-
pure $ do
212-
t <- preview _String <$> m
213-
readText <$> t
220+
pure $ m >>= \v -> maybeToRight "Parse error" (readText <$> preview _String v)
221+
222+
maybeToRight :: b -> Maybe a -> Either b a
223+
maybeToRight _ (Just x) = Right x
224+
maybeToRight y Nothing = Left y
214225

215226
parseBlock :: (AsValue s, Show s) => s -> Maybe Block
216227
parseBlock j = do
@@ -265,31 +276,55 @@ instance FromJSON Block where
265276
<*> v .: "maxCodeSize"
266277
<*> pure feeSchedule
267278

268-
fetchWithSession :: Text -> NetSession.Session -> Value -> IO (Maybe Value)
279+
fetchWithSession :: Text -> NetSession.Session -> Value -> IO (Either Text Value)
269280
fetchWithSession url sess x = do
270281
r <- asValue =<< NetSession.post sess (unpack url) x
271-
pure (r ^? (lensVL responseBody) % key "result")
272-
273-
fetchContractWithSession :: Config -> Session -> BlockNumber -> Text -> Addr -> IO (Maybe RPCContract)
282+
let body = r ^. (lensVL responseBody)
283+
case body ^? key "result" of
284+
Just val -> pure $ Right val
285+
Nothing -> case body ^? key "error" of
286+
Just err -> pure $ Left $ pack $ show err
287+
Nothing -> pure $ Left "Unknown RPC error"
288+
289+
fetchContractWithSession :: Config -> Session -> BlockNumber -> Text -> Addr -> IO (FetchResult RPCContract)
274290
fetchContractWithSession conf sess nPre url addr = do
275291
n <- getLatestBlockNum conf sess nPre url
292+
-- Check successful cache first
276293
cache <- readMVar sess.sharedCache
277294
case Map.lookup addr cache.contractCache of
278295
Just c -> do
279296
when (conf.debug) $ putStrLn $ "-> Using cached contract at " ++ show addr
280-
pure $ Just c
297+
pure (FetchSuccess c Cached)
281298
Nothing -> do
282-
when (conf.debug) $ putStrLn $ "-> Fetching contract at " ++ show addr
283-
runMaybeT $ do
284-
let fetch :: Show a => RpcQuery a -> IO (Maybe a)
299+
-- Check failure cache
300+
failures <- readMVar sess.failedContracts
301+
if Set.member addr failures
302+
then do
303+
when (conf.debug) $ putStrLn $ "-> Skipping previously failed contract " ++ show addr
304+
pure (FetchFailure Cached)
305+
else do
306+
-- Attempt fetch
307+
when (conf.debug) $ putStrLn $ "-> Fetching contract at " ++ show addr
308+
let fetch :: Show a => RpcQuery a -> IO (Either Text a)
285309
fetch = fetchQuery n (fetchWithSession url sess.sess)
286-
code <- MaybeT $ fetch (QueryCode addr)
287-
nonce <- MaybeT $ fetch (QueryNonce addr)
288-
balance <- MaybeT $ fetch (QueryBalance addr)
289-
let contr = RPCContract (ByteStringS code) nonce balance
290-
liftIO $ modifyMVar_ sess.sharedCache $ \c ->
291-
pure $ c { contractCache = Map.insert addr contr c.contractCache }
292-
pure contr
310+
311+
codeRes <- fetch (QueryCode addr)
312+
nonceRes <- fetch (QueryNonce addr)
313+
balRes <- fetch (QueryBalance addr)
314+
315+
case (codeRes, nonceRes, balRes) of
316+
(Right c, Right no, Right ba) -> do
317+
let contr = RPCContract (ByteStringS c) no ba
318+
if c /= BS.empty
319+
then do
320+
modifyMVar_ sess.sharedCache $ \x -> pure $ x { contractCache = Map.insert addr contr x.contractCache }
321+
pure (FetchSuccess contr Fresh)
322+
else do
323+
modifyMVar_ sess.failedContracts $ \f -> pure $ Set.insert addr f
324+
pure (FetchFailure Fresh)
325+
(Left e, _, _) -> pure (FetchError e)
326+
(_, Left e, _) -> pure (FetchError e)
327+
(_, _, Left e) -> pure (FetchError e)
293328

294329
-- In case the user asks for Latest, and we have not yet established what Latest is,
295330
-- we fetch the block to find out. Otherwise, we update Latest to the value we have stored
@@ -319,23 +354,69 @@ makeContractFromRPC (RPCContract (ByteStringS code) nonce balance) =
319354
& set #external True
320355

321356
-- Needed for Echidna only
322-
fetchSlotWithCache :: Config -> Session -> BlockNumber -> Text -> Addr -> W256 -> IO (Maybe W256)
357+
fetchSlotWithCache :: Config -> Session -> BlockNumber -> Text -> Addr -> W256 -> IO (FetchResult W256)
323358
fetchSlotWithCache conf sess nPre url addr slot = do
324359
n <- getLatestBlockNum conf sess nPre url
360+
-- Check successful cache
325361
cache <- readMVar sess.sharedCache
326362
case Map.lookup (addr, slot) cache.slotCache of
327363
Just s -> do
328364
when (conf.debug) $ putStrLn $ "-> Using cached slot value for slot " <> show slot <> " at " <> show addr
329-
pure $ Just s
365+
pure (FetchSuccess s Cached)
330366
Nothing -> do
331-
when (conf.debug) $ putStrLn $ "-> Fetching slot " <> show slot <> " at " <> show addr
332-
ret <- fetchSlotWithSession sess.sess n url addr slot
333-
when (isJust ret) $ let val = fromJust ret in
334-
modifyMVar_ sess.sharedCache $ \c ->
335-
pure $ c { slotCache = Map.insert (addr, slot) val c.slotCache }
336-
pure ret
337-
338-
fetchSlotWithSession :: NetSession.Session -> BlockNumber -> Text -> Addr -> W256 -> IO (Maybe W256)
367+
-- Check failure cache
368+
failures <- readMVar sess.failedSlots
369+
if Set.member (addr, slot) failures
370+
then do
371+
when (conf.debug) $ putStrLn $ "-> Skipping previously failed slot " <> show slot <> " at " <> show addr
372+
pure (FetchFailure Cached)
373+
else do
374+
-- Attempt fetch
375+
when (conf.debug) $ putStrLn $ "-> Fetching slot " <> show slot <> " at " <> show addr
376+
ret <- fetchSlotWithSession sess.sess n url addr slot
377+
case ret of
378+
Right val -> do
379+
-- Success: cache it
380+
modifyMVar_ sess.sharedCache $ \c ->
381+
pure $ c { slotCache = Map.insert (addr, slot) val c.slotCache }
382+
pure (FetchSuccess val Fresh)
383+
Left err -> do
384+
pure (FetchError err)
385+
386+
-- | Get the complete cache state including both successes and failures
387+
-- Returns in the format expected by Echidna's UI:
388+
-- - Map Addr (Maybe Contract): Just = success, Nothing = failure
389+
-- - Map Addr (Map W256 (Maybe W256)): Just = success, Nothing = failure
390+
getCacheState
391+
:: Session
392+
-> IO (Map.Map Addr (Maybe Contract), Map.Map Addr (Map.Map W256 (Maybe W256)))
393+
getCacheState sess = do
394+
cache <- readMVar sess.sharedCache
395+
failedContracts <- readMVar sess.failedContracts
396+
failedSlots <- readMVar sess.failedSlots
397+
398+
-- Convert contract cache
399+
let successfulContracts = fmap (Just . makeContractFromRPC) cache.contractCache
400+
let allContracts = successfulContracts
401+
<> Map.fromSet (const Nothing) failedContracts
402+
403+
-- Convert slot cache: group by address
404+
let successfulSlotsByAddr = Map.foldrWithKey
405+
(\(addr, slot) value acc ->
406+
Map.insertWith Map.union addr (Map.singleton slot (Just value)) acc)
407+
Map.empty
408+
cache.slotCache
409+
410+
-- Add failed slots
411+
let allSlots = Set.foldr
412+
(\(addr, slot) acc ->
413+
Map.insertWith Map.union addr (Map.singleton slot Nothing) acc)
414+
successfulSlotsByAddr
415+
failedSlots
416+
417+
pure (allContracts, allSlots)
418+
419+
fetchSlotWithSession :: NetSession.Session -> BlockNumber -> Text -> Addr -> W256 -> IO (Either Text W256)
339420
fetchSlotWithSession sess n url addr slot =
340421
fetchQuery n (fetchWithSession url sess) (QuerySlot addr slot)
341422

@@ -357,12 +438,12 @@ internalBlockFetch conf sess n url = do
357438
when (conf.debug) $ putStrLn $ "Fetching block " ++ show n ++ " from " ++ unpack url
358439
ret <- fetchQuery n (fetchWithSession url sess.sess) QueryBlock
359440
case ret of
360-
Nothing -> pure ret
361-
Just b -> do
441+
Left _ -> pure Nothing
442+
Right b -> do
362443
let bn = forceLit b.number
363444
liftIO $ modifyMVar_ sess.sharedCache $ \c ->
364445
pure $ c { blockCache = Map.insert bn b c.blockCache }
365-
pure ret
446+
pure (Just b)
366447

367448
cacheFileName :: W256 -> FilePath
368449
cacheFileName n = "rpc-cache-" ++ T.unpack (showDec Unsigned n) ++ ".json"
@@ -405,7 +486,10 @@ mkSession cacheDir mblock = do
405486
_ -> pure emptyCache
406487
cache <- liftIO $ newMVar initialCache
407488
latestBlockNum <- liftIO $ newMVar Nothing
408-
pure $ Session sess latestBlockNum cache cacheDir
489+
-- Initialize ephemeral failure tracking
490+
failedContracts <- liftIO $ newMVar Set.empty
491+
failedSlots <- liftIO $ newMVar Set.empty
492+
pure $ Session sess latestBlockNum cache cacheDir failedContracts failedSlots
409493

410494
mkSessionWithoutCache :: App m => m Session
411495
mkSessionWithoutCache = mkSession Nothing Nothing
@@ -460,10 +544,11 @@ oracle solvers preSess rpcInfo q = do
460544
Nothing -> do
461545
when (conf.debug) $ liftIO $ putStrLn $ "Fetching contract at " ++ show addr
462546
let (block, url) = fromJust rpcInfo.blockNumURL
463-
contract <- liftIO $ fmap (fmap makeContractFromRPC) $ fetchContractWithSession conf sess block url addr
464-
case contract of
465-
Just x -> pure $ continue x
466-
Nothing -> internalError $ "oracle error: " ++ show q
547+
res <- liftIO $ fetchContractWithSession conf sess block url addr
548+
case res of
549+
FetchSuccess x _ -> pure $ continue (makeContractFromRPC x)
550+
FetchFailure _ -> internalError $ "oracle error: " ++ show q
551+
FetchError e -> internalError $ "oracle error: " ++ show e
467552
where
468553
nothingContract = case base of
469554
AbstractBase -> unknownContract (LitAddr addr)
@@ -485,21 +570,21 @@ oracle solvers preSess rpcInfo q = do
485570
let (block, url) = fromJust rpcInfo.blockNumURL
486571
n <- liftIO $ getLatestBlockNum conf sess block url
487572
ret <- liftIO $ fetchSlotWithSession sess.sess n url addr slot
488-
when (isJust ret) $ let val = fromJust ret in
489-
liftIO $ modifyMVar_ sess.sharedCache $ \c ->
490-
pure $ c { slotCache = Map.insert (addr, slot) val c.slotCache }
491573
case ret of
492-
Just x -> pure $ continue x
493-
Nothing -> internalError $ "oracle error: " ++ show q
574+
Right val -> do
575+
liftIO $ modifyMVar_ sess.sharedCache $ \c ->
576+
pure $ c { slotCache = Map.insert (addr, slot) val c.slotCache }
577+
pure $ continue val
578+
Left err -> internalError $ "oracle error: " ++ show err
494579

495580
PleaseReadEnv variable continue -> do
496581
value <- liftIO $ lookupEnv variable
497582
pure . continue $ fromMaybe "" value
498583

499584
where
500585
-- special values such as 0, 0xdeadbeef, 0xacab, hevm cheatcodes, and the precompile addresses
501-
isAddressSpecial addr = addr <= 0xdeadbeef || addr == 0x7109709ECfa91a80626fF3989D68f67F5b1DD12D
502-
586+
isAddressSpecial addr = addr <= 0xdeadbeef || addr == 0x7109709ECfa91a80626fF3989D68f67F5b1DD12D
587+
503588

504589
getSolutions :: forall m . App m => SolverGroup -> Expr EWord -> Int -> Prop -> m (Maybe [W256])
505590
getSolutions solvers symExprPreSimp numBytes pathconditions = do

‎test/rpc.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -129,8 +129,9 @@ vmFromRpc :: App m => Session -> BlockNumber -> (Expr Buf, [Prop]) -> Expr EWord
129129
vmFromRpc sess blockNum calldata callvalue caller address = do
130130
conf <- readConfig
131131
ctrct <- liftIO $ fetchContractWithSession conf sess blockNum testRpc address >>= \case
132-
Nothing -> internalError $ "contract not found: " <> show address
133-
Just contract' -> pure contract'
132+
FetchFailure _ -> internalError $ "contract not found: " <> show address
133+
FetchError e -> internalError $ "rpc error: " <> show e
134+
FetchSuccess contract' _ -> pure contract'
134135

135136
liftIO $ addFetchCache sess address ctrct
136137
blk <- liftIO $ fetchBlockWithSession conf sess blockNum testRpc >>= \case

0 commit comments

Comments
 (0)