Skip to content

Commit 42401b1

Browse files
msoosethmsooseth
authored
Merge pull request #915 from argotorg/tidy-up-bctests
Test: Small reorganization of blockchain tests
2 parents 5bfac68 + e5a70ab commit 42401b1

File tree

2 files changed

+59
-147
lines changed

2 files changed

+59
-147
lines changed

‎bench/bench.hs‎

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -81,9 +81,7 @@ runBCTest x =
8181
vm0 <- liftIO $ BCTests.vmForCase x
8282
result <- Stepper.interpret (Fetch.zero 0 Nothing) vm0 Stepper.runFully
8383
writeTrace vm0
84-
85-
maybeReason <- BCTests.checkExpectation x result
86-
pure $ isNothing maybeReason
84+
pure $ isNothing $ BCTests.checkExpectation x result
8785

8886

8987
--- Helpers ----------------------------------------------------------------------------------------

‎test/EVM/Test/BlockchainTests.hs‎

Lines changed: 58 additions & 144 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
module EVM.Test.BlockchainTests where
1+
module EVM.Test.BlockchainTests (prepareTests, parseBCSuite, commonProblematicTests, Case(..), vmForCase, checkExpectation) where
22

33
import EVM (initialContract, makeVm, setEIP4788Storage)
44
import EVM.Concrete qualified as EVM
@@ -8,8 +8,6 @@ import EVM.FeeSchedule (feeSchedule)
88
import EVM.Fetch qualified
99
import EVM.Solvers (withSolvers, Solver(..))
1010
import EVM.Stepper qualified
11-
import EVM.Test.FuzzSymExec (compareTraces, EVMToolTraceOutput(..), decodeTraceOutputHelper)
12-
import EVM.Tracing qualified as Tracing
1311
import EVM.Transaction
1412
import EVM.Types hiding (Block, Case, Env)
1513
import EVM.UnitTest (writeTrace)
@@ -25,19 +23,14 @@ import Data.Aeson qualified as JSON
2523
import Data.Aeson.Types qualified as JSON
2624
import Data.ByteString qualified as BS
2725
import Data.ByteString.Lazy qualified as Lazy
28-
import Data.List (isInfixOf, isPrefixOf)
2926
import Data.Map (Map)
3027
import Data.Map qualified as Map
3128
import Data.Maybe (fromJust, fromMaybe, isNothing, isJust)
3229
import Data.Word (Word64)
3330
import GHC.Generics (Generic)
34-
import GHC.IO.Exception (ExitCode(ExitSuccess))
35-
import System.Environment (lookupEnv, getEnv)
31+
import System.Environment (getEnv)
3632
import System.FilePath.Find qualified as Find
3733
import System.FilePath.Posix (makeRelative, (</>))
38-
import System.IO (hPutStr, hClose)
39-
import System.IO.Temp (withSystemTempFile)
40-
import System.Process (readProcessWithExitCode)
4134
import Witch (into, unsafeInto)
4235
import Witherable (Filterable, catMaybes)
4336

@@ -101,27 +94,15 @@ data BlockchainCase = BlockchainCase
10194
, network :: String
10295
} deriving Show
10396

104-
105-
testEnv :: Env
106-
testEnv = Env { config = defaultConfig }
107-
108-
main :: IO ()
109-
main = do
110-
tests <- runEnv testEnv prepareTests
111-
defaultMain tests
112-
11397
prepareTests :: App m => m TestTree
11498
prepareTests = do
11599
repo <- liftIO $ getEnv "HEVM_ETHEREUM_TESTS_REPO"
116100
let testsDir = "BlockchainTests/GeneralStateTests"
117101
let dir = repo </> testsDir
118102
jsonFiles <- liftIO $ Find.find Find.always (Find.extension Find.==? ".json") dir
119103
liftIO $ putStrLn $ "Loading and parsing json files from ethereum-tests from " <> show dir
120-
isCI <- liftIO $ isJust <$> lookupEnv "CI"
121-
let problematicTests = if isCI then commonProblematicTests <> ciProblematicTests else commonProblematicTests
122-
let ignoredFiles = if isCI then ciIgnoredFiles else []
123104
session <- EVM.Fetch.mkSessionWithoutCache
124-
groups <- mapM (\f -> testGroup (makeRelative repo f) <$> (if any (`isInfixOf` f) ignoredFiles then pure [] else testsFromFile f problematicTests session)) jsonFiles
105+
groups <- mapM (\f -> testGroup (makeRelative repo f) <$> (testsFromFile f commonProblematicTests session)) jsonFiles
125106
liftIO $ putStrLn "Loaded."
126107
pure $ testGroup "ethereum-tests" groups
127108

@@ -148,10 +129,6 @@ testsFromFile fname problematicTests session = do
148129
Just f -> f (testCase name (liftIO assertion))
149130
Nothing -> testCase name (liftIO assertion)
150131

151-
-- CI has issues with some heaver tests, disable in bulk
152-
ciIgnoredFiles :: [String]
153-
ciIgnoredFiles = []
154-
155132
commonProblematicTests :: Map String (TestTree -> TestTree)
156133
commonProblematicTests = Map.fromList
157134
[ ("loopMul_d0g0v0_Cancun", ignoreTestBecause "hevm is too slow")
@@ -190,70 +167,70 @@ commonProblematicTests = Map.fromList
190167
, ("failed_tx_xcf416c53_d0g0v0_Cancun", ignoreTestBecause "EIP-4844 not implemented")
191168
]
192169

193-
ciProblematicTests :: Map String (TestTree -> TestTree)
194-
ciProblematicTests = Map.fromList
195-
[ ("Return50000_d0g1v0_Cancun", ignoreTest)
196-
, ("Return50000_2_d0g1v0_Cancun", ignoreTest)
197-
, ("randomStatetest177_d0g0v0_Cancun", ignoreTest)
198-
, ("static_Call50000_d0g0v0_Cancun", ignoreTest)
199-
, ("static_Call50000_d1g0v0_Cancun", ignoreTest)
200-
, ("static_Call50000bytesContract50_1_d1g0v0_Cancun", ignoreTest)
201-
, ("static_Call50000bytesContract50_2_d1g0v0_Cancun", ignoreTest)
202-
, ("static_Return50000_2_d0g0v0_Cancun", ignoreTest)
203-
, ("loopExp_d10g0v0_Cancun", ignoreTest)
204-
, ("loopExp_d11g0v0_Cancun", ignoreTest)
205-
, ("loopExp_d12g0v0_Cancun", ignoreTest)
206-
, ("loopExp_d13g0v0_Cancun", ignoreTest)
207-
, ("loopExp_d14g0v0_Cancun", ignoreTest)
208-
, ("loopExp_d8g0v0_Cancun", ignoreTest)
209-
, ("loopExp_d9g0v0_Cancun", ignoreTest)
210-
]
211170

212171
runVMTest :: App m => EVM.Fetch.Fetcher Concrete m RealWorld -> Case -> m ()
213172
runVMTest fetcher x = do
214173
-- traceVsGeth fname name x
215174
vm0 <- liftIO $ vmForCase x
216175
result <- EVM.Stepper.interpret fetcher vm0 EVM.Stepper.runFully
217176
writeTrace result
218-
maybeReason <- checkExpectation x result
219-
liftIO $ forM_ maybeReason assertFailure
220-
221-
222-
-- | Run a vm test and output a geth style per opcode trace
223-
traceVMTest :: App m => Case -> m [Tracing.VMTraceStep]
224-
traceVMTest x = do
225-
vm0 <- liftIO $ vmForCase x
226-
(_, (_, ts)) <- runStateT (Tracing.interpretWithTrace (EVM.Fetch.zero 0 (Just 0)) EVM.Stepper.runFully) (vm0, [])
227-
pure ts
228-
229-
-- | given a path to a test file, a test case from within that file, and a trace from geth from running that test, compare the traces and show where we differ
230-
-- This would need a few tweaks to geth to make this really usable (i.e. evm statetest show allow running a single test from within the test file).
231-
traceVsGeth :: App m => String -> String -> Case -> m ()
232-
traceVsGeth fname name x = do
233-
liftIO $ putStrLn "-> Running `evm --json blocktest` tool."
234-
(exitCode, evmtoolStdout, evmtoolStderr) <- liftIO $ readProcessWithExitCode "evm" [
235-
"--json"
236-
, "blocktest"
237-
, "--run", name
238-
, fname
239-
] ""
240-
when (exitCode /= ExitSuccess) $ liftIO $ do
241-
putStrLn $ "evmtool exited with code " <> show exitCode
242-
putStrLn $ "evmtool stderr output:" <> show evmtoolStderr
243-
putStrLn $ "evmtool stdout output:" <> show evmtoolStdout
244-
hevm <- traceVMTest x
245-
decodedContents <- liftIO $ withSystemTempFile "trace.jsonl" $ \traceFile hdl -> do
246-
hPutStr hdl $ filterInfoLines evmtoolStderr
247-
hClose hdl
248-
decodeTraceOutputHelper traceFile
249-
let EVMToolTraceOutput ts _ = fromJust decodedContents
250-
liftIO $ putStrLn "Comparing traces."
251-
_ <- liftIO $ compareTraces hevm ts
252-
pure ()
177+
let maybeReason = checkExpectation x result
178+
liftIO $ forM_ maybeReason (liftIO >=> assertFailure)
253179

180+
checkExpectation :: Case -> VM Concrete RealWorld -> Maybe (IO String)
181+
checkExpectation x vm = let (okState, okBal, okNonce, okStor, okCode) = checkExpectedContracts vm x.testExpectation in
182+
if okState then Nothing else Just $ checkStateFail x (okBal, okNonce, okStor, okCode)
254183
where
255-
filterInfoLines :: String -> String
256-
filterInfoLines input = unlines $ filter (not . isPrefixOf "INFO") (lines input)
184+
checkExpectedContracts :: VM Concrete RealWorld -> BlockchainContracts -> (Bool, Bool, Bool, Bool, Bool)
185+
checkExpectedContracts vm' expected =
186+
let cs = fmap (asBCContract . clearZeroStorage) $ forceConcreteAddrs vm'.env.contracts
187+
in ( (expected ~= cs)
188+
, (clearBalance <$> expected) ~= (clearBalance <$> cs)
189+
, (clearNonce <$> expected) ~= (clearNonce <$> cs)
190+
, (clearStorage <$> expected) ~= (clearStorage <$> cs)
191+
, (clearCode <$> expected) ~= (clearCode <$> cs)
192+
)
193+
194+
-- quotient account state by nullness
195+
(~=) :: BlockchainContracts -> BlockchainContracts -> Bool
196+
(~=) cs1 cs2 =
197+
let nullAccount = asBCContract $ EVM.initialContract (RuntimeCode (ConcreteRuntimeCode ""))
198+
padNewAccounts cs ks = Map.union cs $ Map.fromList [(k, nullAccount) | k <- ks]
199+
padded_cs1 = padNewAccounts cs1 (Map.keys cs2)
200+
padded_cs2 = padNewAccounts cs2 (Map.keys cs1)
201+
in and $ zipWith (==) (Map.elems padded_cs1) (Map.elems padded_cs2)
202+
203+
checkStateFail :: Case -> (Bool, Bool, Bool, Bool) -> IO String
204+
checkStateFail x' (okBal, okNonce, okData, okCode) = do
205+
let
206+
printContracts :: BlockchainContracts -> IO ()
207+
printContracts cs = putStrLn $ Map.foldrWithKey (\k c acc ->
208+
acc ++ "-->" <> show k ++ " : "
209+
++ (show c.nonce) ++ " "
210+
++ (show c.balance) ++ " "
211+
++ (show c.storage)
212+
++ "\n") "" cs
213+
214+
reason = map fst (filter (not . snd)
215+
[ ("bad-state", okBal || okNonce || okData || okCode)
216+
, ("bad-balance", not okBal || okNonce || okData || okCode)
217+
, ("bad-nonce", not okNonce || okBal || okData || okCode)
218+
, ("bad-storage", not okData || okBal || okNonce || okCode)
219+
, ("bad-code", not okCode || okBal || okNonce || okData)
220+
])
221+
check = x'.checkContracts
222+
expected = x'.testExpectation
223+
actual = fmap (asBCContract . clearZeroStorage) $ forceConcreteAddrs vm.env.contracts
224+
225+
putStrLn $ "-> Failing because of: " <> (unwords reason)
226+
putStrLn "-> Pre balance/state: "
227+
printContracts check
228+
putStrLn "-> Expected balance/state: "
229+
printContracts expected
230+
putStrLn "-> Actual balance/state: "
231+
printContracts actual
232+
pure (unwords reason)
233+
257234

258235
splitEithers :: (Filterable f) => f (Either a b) -> (f a, f b)
259236
splitEithers =
@@ -265,69 +242,6 @@ fromConcrete :: Expr Storage -> Map W256 W256
265242
fromConcrete (ConcreteStore s) = s
266243
fromConcrete s = internalError $ "unexpected abstract store: " <> show s
267244

268-
checkStateFail :: Case -> VM Concrete RealWorld -> (Bool, Bool, Bool, Bool) -> IO String
269-
checkStateFail x vm (okBal, okNonce, okData, okCode) = do
270-
let
271-
printContracts :: BlockchainContracts -> IO ()
272-
printContracts cs = putStrLn $ Map.foldrWithKey (\k c acc ->
273-
acc ++ "-->" <> show k ++ " : "
274-
++ (show c.nonce) ++ " "
275-
++ (show c.balance) ++ " "
276-
++ (show c.storage)
277-
++ "\n") "" cs
278-
279-
reason = map fst (filter (not . snd)
280-
[ ("bad-state", okBal || okNonce || okData || okCode)
281-
, ("bad-balance", not okBal || okNonce || okData || okCode)
282-
, ("bad-nonce", not okNonce || okBal || okData || okCode)
283-
, ("bad-storage", not okData || okBal || okNonce || okCode)
284-
, ("bad-code", not okCode || okBal || okNonce || okData)
285-
])
286-
check = x.checkContracts
287-
expected = x.testExpectation
288-
actual = fmap (asBCContract . clearZeroStorage) $ forceConcreteAddrs vm.env.contracts
289-
290-
putStrLn $ "-> Failing because of: " <> (unwords reason)
291-
putStrLn "-> Pre balance/state: "
292-
printContracts check
293-
putStrLn "-> Expected balance/state: "
294-
printContracts expected
295-
putStrLn "-> Actual balance/state: "
296-
printContracts actual
297-
pure (unwords reason)
298-
299-
checkExpectation
300-
:: App m
301-
=> Case -> VM Concrete RealWorld -> m (Maybe String)
302-
checkExpectation x vm = do
303-
let expectation = x.testExpectation
304-
(okState, okBal, okNonce, okStor, okCode) = checkExpectedContracts vm expectation
305-
if okState then do
306-
pure Nothing
307-
else liftIO $ Just <$> checkStateFail x vm (okBal, okNonce, okStor, okCode)
308-
309-
-- quotient account state by nullness
310-
(~=) :: BlockchainContracts -> BlockchainContracts -> Bool
311-
(~=) cs1 cs2 =
312-
let nullAccount = asBCContract $ EVM.initialContract (RuntimeCode (ConcreteRuntimeCode ""))
313-
padNewAccounts cs ks = Map.union cs $ Map.fromList [(k, nullAccount) | k <- ks]
314-
padded_cs1 = padNewAccounts cs1 (Map.keys cs2)
315-
padded_cs2 = padNewAccounts cs2 (Map.keys cs1)
316-
in and $ zipWith (==) (Map.elems padded_cs1) (Map.elems padded_cs2)
317-
318-
checkExpectedContracts :: VM Concrete RealWorld -> BlockchainContracts -> (Bool, Bool, Bool, Bool, Bool)
319-
checkExpectedContracts vm expected =
320-
let cs = fmap (asBCContract . clearZeroStorage) $ forceConcreteAddrs vm.env.contracts
321-
in ( (expected ~= cs)
322-
, (clearBalance <$> expected) ~= (clearBalance <$> cs)
323-
, (clearNonce <$> expected) ~= (clearNonce <$> cs)
324-
, (clearStorage <$> expected) ~= (clearStorage <$> cs)
325-
, (clearCode <$> expected) ~= (clearCode <$> cs)
326-
)
327-
328-
clearOrigStorage :: Contract -> Contract
329-
clearOrigStorage = set #origStorage (ConcreteStore mempty)
330-
331245
clearZeroStorage :: Contract -> Contract
332246
clearZeroStorage c = case c.storage of
333247
ConcreteStore m -> let store = Map.filter (/= 0) m

0 commit comments

Comments
 (0)