diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 9bd1f57e5..77234ba5c 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -28,3 +28,5 @@ jobs: run: nix-build - name: run rpc tests run: nix-shell --pure --command "cabal run rpc-tests" + - name: run ethereum tests + run: nix-shell --command "cabal run ethereum-tests" diff --git a/.gitmodules b/.gitmodules deleted file mode 100644 index e69de29bb..000000000 diff --git a/flake.lock b/flake.lock index 85e4fa85a..21cec52ce 100644 --- a/flake.lock +++ b/flake.lock @@ -1,5 +1,22 @@ { "nodes": { + "ethereum-tests": { + "flake": false, + "locked": { + "lastModified": 1668955227, + "narHash": "sha256-t9GV1TUfXr6xwgRvCaf43oGhBLdlYJwNCmaR4rIYV1M=", + "owner": "ethereum", + "repo": "tests", + "rev": "a16217cff68fa587a4a8b8b008e5cf374a6086b5", + "type": "github" + }, + "original": { + "owner": "ethereum", + "ref": "v11.2", + "repo": "tests", + "type": "github" + } + }, "flake-compat": { "flake": false, "locked": { @@ -48,6 +65,7 @@ }, "root": { "inputs": { + "ethereum-tests": "ethereum-tests", "flake-compat": "flake-compat", "flake-utils": "flake-utils", "nixpkgs": "nixpkgs", diff --git a/flake.nix b/flake.nix index daef546cd..c480d7021 100644 --- a/flake.nix +++ b/flake.nix @@ -12,9 +12,13 @@ url = "github:ethereum/solidity/1c8745c54a239d20b6fb0f79a8bd2628d779b27e"; flake = false; }; + ethereum-tests = { + url = "github:ethereum/tests/v11.2"; + flake = false; + }; }; - outputs = { self, nixpkgs, flake-utils, solidity, ... }: + outputs = { self, nixpkgs, flake-utils, solidity, ethereum-tests, ... }: flake-utils.lib.eachDefaultSystem (system: let pkgs = nixpkgs.legacyPackages.${system}; @@ -49,6 +53,7 @@ haskell.lib.dontHaddock ]).overrideAttrs(final: prev: { HEVM_SOLIDITY_REPO = solidity; + HEVM_ETHEREUM_TESTS_REPO = ethereum-tests; }); hevmWrapped = with pkgs; symlinkJoin { name = "hevm"; @@ -92,6 +97,7 @@ # NOTE: hacks for bugged cabal new-repl LD_LIBRARY_PATH = libraryPath; HEVM_SOLIDITY_REPO = solidity; + HEVM_ETHEREUM_TESTS_REPO = ethereum-tests; shellHook = lib.optionalString stdenv.isDarwin '' export DYLD_LIBRARY_PATH="${libraryPath}"; ''; diff --git a/hevm-cli/hevm-cli.hs b/hevm-cli/hevm-cli.hs index fbc15c6b7..c79a95d5c 100644 --- a/hevm-cli/hevm-cli.hs +++ b/hevm-cli/hevm-cli.hs @@ -1,9 +1,7 @@ -- Main file of the hevm CLI program -{-# Language CPP #-} {-# Language DataKinds #-} {-# Language DeriveAnyClass #-} -{-# Language GADTs #-} module Main where @@ -14,13 +12,8 @@ import qualified EVM.FeeSchedule as FeeSchedule import qualified EVM.Fetch import qualified EVM.Stepper - -import qualified EVM.VMTest as VMTest - - import EVM.SymExec import EVM.Debug -import EVM.ABI import qualified EVM.Expr as Expr import EVM.SMT import qualified EVM.TTY as TTY @@ -31,37 +24,25 @@ import EVM.UnitTest (UnitTestOptions, coverageReport, coverageForUnitTestContrac import EVM.Dapp (findUnitTests, dappInfo, DappInfo, emptyDapp) import GHC.Natural import EVM.Format (showTraceTree, formatExpr) -import qualified EVM.Patricia as Patricia -import Data.Map (Map) import Data.Word (Word64) import qualified EVM.Facts as Facts import qualified EVM.Facts.Git as Git import qualified EVM.UnitTest -import GHC.Stack import GHC.Conc -import Control.Concurrent.Async (async, waitCatch) import Control.Lens hiding (pre, passing) import Control.Monad (void, when, forM_, unless) import Control.Monad.State.Strict (execStateT, liftIO) import Data.ByteString (ByteString) import Data.List (intercalate, isSuffixOf) import Data.Text (unpack, pack) -import Data.Text.Encoding (encodeUtf8) import Data.Maybe (fromMaybe, fromJust, mapMaybe) import Data.Version (showVersion) import Data.DoubleWord (Word256) -import System.IO (hFlush, stdout, stderr) +import System.IO (stderr) import System.Directory (withCurrentDirectory, listDirectory) import System.Exit (exitFailure, exitWith, ExitCode(..)) -import System.Process (callProcess) -import qualified Data.Aeson as JSON -import qualified Data.Aeson.Types as JSON -import Data.Aeson (FromJSON (..), (.:)) -import Data.Aeson.Lens hiding (values) -import qualified Data.Vector as V -import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as Char8 @@ -69,11 +50,11 @@ import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.IO as T -import qualified System.Timeout as Timeout import qualified Paths_hevm as Paths import Options.Generic as Options +import qualified EVM.Transaction -- This record defines the program's command-line options -- automatically via the `optparse-generic` package. @@ -186,25 +167,6 @@ data Command w , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" , askSmtIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 5)" } - | BcTest -- Run an Ethereum Blockchain/GeneralState test - { file :: w ::: String "Path to .json test file" - , test :: w ::: [String] "Test case filter - only run specified test method(s)" - , debug :: w ::: Bool "Run interactively" - , jsontrace :: w ::: Bool "Print json trace output at every step" - , diff :: w ::: Bool "Print expected vs. actual state on failure" - , timeout :: w ::: Maybe Int "Execution timeout (default: 10 sec.)" - } - | Compliance -- Run Ethereum Blockchain compliance report - { tests :: w ::: String "Path to Ethereum Tests directory" - , group :: w ::: Maybe String "Report group to run: VM or Blockchain (default: Blockchain)" - , match :: w ::: Maybe String "Test case filter - only run methods matching regex" - , skip :: w ::: Maybe String "Test case filter - skip tests containing string" - , html :: w ::: Bool "Output html report" - , timeout :: w ::: Maybe Int "Execution timeout (default: 10 sec.)" - } - | MerkleTest -- Insert a set of key values and check against the given root - { file :: w ::: String "Path to .json test file" - } | Version deriving (Options.Generic) @@ -300,8 +262,6 @@ main = do Equivalence {} -> equivalence cmd Exec {} -> launchExec cmd - BcTest {} -> - launchTest cmd DappTest {} -> withCurrentDirectory root $ do cores <- num <$> getNumProcessors @@ -315,25 +275,6 @@ main = do (False, Debug) -> liftIO $ TTY.main testOpts root testFile (False, JsonTrace) -> error "json traces not implemented for dappTest" (True, _) -> liftIO $ dappCoverage testOpts (optsMode cmd) testFile - Compliance {} -> - case (group cmd) of - Just "Blockchain" -> launchScript "/run-blockchain-tests" cmd - Just "VM" -> launchScript "/run-consensus-tests" cmd - _ -> launchScript "/run-blockchain-tests" cmd - MerkleTest {} -> merkleTest cmd - -launchScript :: String -> Command Options.Unwrapped -> IO () -launchScript script cmd = - withCurrentDirectory (tests cmd) $ do - dataDir <- Paths.getDataDir - callProcess "bash" - [ dataDir ++ script - , "." - , show (html cmd) - , fromMaybe "" (match cmd) - , fromMaybe "" (skip cmd) - , show $ fromMaybe 10 (timeout cmd) - ] findJsonFile :: Maybe String -> IO String findJsonFile (Just s) = pure s @@ -378,19 +319,6 @@ equivalence cmd = do putStrLn $ "Not equivalent. Counterexample(s):" <> show res exitFailure -checkForVMErrors :: [EVM.VM] -> [String] -checkForVMErrors [] = [] -checkForVMErrors (vm:vms) = - case view EVM.result vm of - Just (EVM.VMFailure (EVM.UnexpectedSymbolicArg pc msg _)) -> - ("Unexpected symbolic argument at opcode: " - <> show pc - <> ". " - <> msg - ) : checkForVMErrors vms - _ -> - checkForVMErrors vms - getSrcInfo :: Command Options.Unwrapped -> IO DappInfo getSrcInfo cmd = let root = fromMaybe "." (dappRoot cmd) @@ -575,65 +503,6 @@ launchExec cmd = do where block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) rpcinfo = (,) block' <$> rpc cmd -data Testcase = Testcase { - _entries :: [(Text, Maybe Text)], - _root :: Text -} deriving Show - -parseTups :: JSON.Value -> JSON.Parser [(Text, Maybe Text)] -parseTups (JSON.Array arr) = do - tupList <- mapM parseJSON (V.toList arr) - mapM (\[k, v] -> do - rhs <- parseJSON v - lhs <- parseJSON k - return (lhs, rhs)) - tupList -parseTups invalid = JSON.typeMismatch "Malformed array" invalid - - -parseTrieTest :: JSON.Object -> JSON.Parser Testcase -parseTrieTest p = do - kvlist <- p .: "in" - entries <- parseTups kvlist - root <- p .: "root" - return $ Testcase entries root - -instance FromJSON Testcase where - parseJSON (JSON.Object p) = parseTrieTest p - parseJSON invalid = JSON.typeMismatch "Merkle test case" invalid - -parseTrieTests :: Lazy.ByteString -> Either String (Map String Testcase) -parseTrieTests = JSON.eitherDecode' - -merkleTest :: Command Options.Unwrapped -> IO () -merkleTest cmd = do - parsed <- parseTrieTests <$> LazyByteString.readFile (file cmd) - case parsed of - Left err -> print err - Right testcases -> mapM_ runMerkleTest testcases - -runMerkleTest :: Testcase -> IO () -runMerkleTest (Testcase entries root) = - case Patricia.calcRoot entries' of - Nothing -> - error "Test case failed" - Just n -> - case n == strip0x (hexText root) of - True -> - putStrLn "Test case success" - False -> - error ("Test case failure; expected " <> show root - <> " but got " <> show (ByteStringS n)) - where entries' = fmap (\(k, v) -> - (tohexOrText k, - tohexOrText (fromMaybe mempty v))) - entries - -tohexOrText :: Text -> ByteString -tohexOrText s = case "0x" `Char8.isPrefixOf` encodeUtf8 s of - True -> hexText s - False -> encodeUtf8 s - -- | Creates a (concrete) VM from command line options vmFromCommand :: Command Options.Unwrapped -> IO EVM.VM vmFromCommand cmd = do @@ -681,7 +550,7 @@ vmFromCommand cmd = do Just t -> t Nothing -> error "unexpected symbolic timestamp when executing vm test" - return $ VMTest.initTx $ withCache (vm0 baseFee miner ts' blockNum prevRan contract) + return $ EVM.Transaction.initTx $ withCache (vm0 baseFee miner ts' blockNum prevRan contract) where block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) value' = word value 0 @@ -778,7 +647,7 @@ symvmFromCommand cmd calldata' = do (_, _, Nothing) -> error "must provide at least (rpc + address) or code" - return $ (VMTest.initTx $ withCache $ vm0 baseFee miner ts blockNum prevRan calldata' callvalue' caller' contract') + return $ (EVM.Transaction.initTx $ withCache $ vm0 baseFee miner ts blockNum prevRan calldata' callvalue' caller' contract') & set (EVM.env . EVM.storage) store where @@ -819,65 +688,3 @@ symvmFromCommand cmd calldata' = do word f def = fromMaybe def (f cmd) addr f def = fromMaybe def (f cmd) word64 f def = fromMaybe def (f cmd) - -launchTest :: HasCallStack => Command Options.Unwrapped -> IO () -launchTest cmd = do - parsed <- VMTest.parseBCSuite <$> LazyByteString.readFile (file cmd) - case parsed of - Left "No cases to check." -> putStrLn "no-cases ok" - Left err -> print err - Right allTests -> - let testFilter = - if null (test cmd) - then id - else filter (\(x, _) -> elem x (test cmd)) - in - mapM_ (runVMTest (diff cmd) (optsMode cmd) (timeout cmd)) $ - testFilter (Map.toList allTests) - -runVMTest :: HasCallStack => Bool -> Mode -> Maybe Int -> (String, VMTest.Case) -> IO Bool -runVMTest diffmode mode timelimit (name, x) = - do - let vm0 = VMTest.vmForCase x - putStr (name ++ " ") - hFlush stdout - result <- do - action <- async $ - case mode of - Run -> - Timeout.timeout (1000000 * (fromMaybe 10 timelimit)) $ - execStateT (EVM.Stepper.interpret (EVM.Fetch.zero 0 (Just 0)) . void $ EVM.Stepper.execFully) vm0 - Debug -> - withSolvers Z3 0 Nothing $ \solvers -> Just <$> TTY.runFromVM solvers Nothing Nothing emptyDapp vm0 - JsonTrace -> - error "JsonTrace: implement me" - -- Just <$> execStateT (EVM.UnitTest.interpretWithCoverage EVM.Fetch.zero EVM.Stepper.runFully) vm0 - waitCatch action - case result of - Right (Just vm1) -> do - ok <- VMTest.checkExpectation diffmode x vm1 - putStrLn (if ok then "ok" else "") - return ok - Right Nothing -> do - putStrLn "timeout" - return False - Left e -> do - putStrLn $ "error: " ++ if diffmode - then show e - else (head . lines . show) e - return False - -parseAbi :: (AsValue s) => s -> (Text, [AbiType]) -parseAbi abijson = - (signature abijson, snd - <$> parseMethodInput - <$> V.toList - (fromMaybe (error "Malformed function abi") (abijson ^? key "inputs" . _Array))) - -abiencode :: (AsValue s) => Maybe s -> [String] -> ByteString -abiencode Nothing _ = error "missing required argument: abi" -abiencode (Just abijson) args = - let (sig', declarations) = parseAbi abijson - in if length declarations == length args - then abiMethod sig' $ AbiTuple . V.fromList $ zipWith makeAbiValue declarations args - else error $ "wrong number of arguments:" <> show (length args) <> ": " <> show args diff --git a/hevm.cabal b/hevm.cabal index 0eea76e47..9e259a6bd 100644 --- a/hevm.cabal +++ b/hevm.cabal @@ -22,9 +22,6 @@ category: Ethereum build-type: Simple -data-files: - run-blockchain-tests - run-consensus-tests extra-source-files: CHANGELOG.md test/contracts/lib/test.sol @@ -110,7 +107,6 @@ library EVM.TTYCenteredList, EVM.Types, EVM.UnitTest, - EVM.VMTest other-modules: Paths_hevm autogen-modules: @@ -251,12 +247,15 @@ common test-base HUnit >= 1.6, QuickCheck, quickcheck-instances, + aeson, base, base16-bytestring, binary, containers, directory, bytestring, + filemanip, + filepath, here, hevm, lens, @@ -274,6 +273,7 @@ common test-base time, array, vector, + witherable, smt2-parser >= 0.1.0.1 library test-utils @@ -288,9 +288,11 @@ common test-common build-depends: test-utils if os(darwin) - extra-libraries: c++ + extra-libraries: c++ + -- https://gitlab.haskell.org/ghc/ghc/-/issues/11829 + ld-options: -Wl,-keep_dwarf_unwind else - extra-libraries: stdc++ + extra-libraries: stdc++ --- Test Suites --- @@ -311,3 +313,11 @@ test-suite rpc-tests exitcode-stdio-1.0 main-is: rpc.hs + +test-suite ethereum-tests + import: + test-common + type: + exitcode-stdio-1.0 + main-is: + BlockchainTests.hs diff --git a/run-blockchain-tests b/run-blockchain-tests deleted file mode 100755 index b97f2cad6..000000000 --- a/run-blockchain-tests +++ /dev/null @@ -1,150 +0,0 @@ -#!/usr/bin/env bash -set -e - -# Invoke with hevm e.g. -# hevm compliance --tests ~/ethereum-tests --skip modexp --timeout 20 --html - -HEVM=${HEVM:-hevm} - -if [[ "$#" -lt 1 ]]; then - echo >&2 "usage: $(basename "$0") " - exit 1 -fi - -tests=$1 -html=$2 -match=$3 -skip=$4 -timeout=${5:-10} - -_html () { -cat <<. - -hevm test results - -
-

hevm consensus test report

-

$(date +%Y-%m-%d)

-

$(echo "$npass passed, $nbal bad-balance, $nnon bad-nonce, $nstr bad-storage, $nfail failed, $nskip skipped, $ntime timeout")

-(Test suite: GeneralStateTests for Berlin) -
-

Failed tests

- - -$(echo $noncefailed) -$(echo $storagefailed) -$(echo $failed) -
-

Failed tests (due to balance only)

- - -$(echo $balancefailed) -
-

Timeout tests

- - -$(echo $timeouts) -
-

Skipped tests

- - -$(echo $skipped) -
-

Passed tests

- - -$(echo $passed) -
-. -} - -shopt -s nocasematch -{ - cd "$tests" - for x in BlockchainTests/GeneralStateTests/*/*; do - if [ -d $x ]; then - for y in $x/*; do - if [[ $y =~ .*$match.* ]] && [[ -n $skip && $y =~ .*$skip.* ]]; then - for job in $(<$y jq '.|keys[]' -r); do - echo -n "$job " ; echo "skip" - done - elif [[ $y =~ .*$match.* ]]; then - set +e - "$HEVM" bc-test --file $y --timeout $timeout 2>&1 - set -e - fi - done - else - if [[ $x =~ .*$match.* ]] && [[ -n $skip && $x =~ .*$skip.* ]]; then - for job in $(<$x jq '.|keys[]' -r); do - echo -n "$job " ; echo "skip" - done - elif [[ $x =~ .*$match.* ]]; then - set +e - "$HEVM" bc-test --file $x --timeout $timeout 2>&1 - set -e - fi - fi - done -} | { - while read test outcome; do - echo >&2 "$test $outcome" - row="$test$outcome" - row+=$'\n' - case $outcome in - ok) passed+=$row ;; - bad-balance) balancefailed+=$row ;; - bad-nonce) noncefailed+=$row ;; - bad-storage) storagefailed+=$row ;; - timeout) timeouts+=$row ;; - skip) skipped+=$row ;; - *) failed+=$row ;; - esac - done - - sum () { echo -ne "$1" | wc -l | awk '{print $1}'; } - - npass=$(sum "$passed") - nbal=$(sum "$balancefailed") - nnon=$(sum "$noncefailed") - nstr=$(sum "$storagefailed") - nfail=$(sum "$failed") - ntime=$(sum "$timeouts") - nskip=$(sum "$skipped") - - echo >&2 "passed: $npass" - echo >&2 "bad-balance: $nbal" - echo >&2 "bad-nonce: $nnon" - echo >&2 "bad-storage: $nstr" - echo >&2 "failed: $nfail" - echo >&2 "timeout: $ntime" - echo >&2 "skipped: $nskip" - - if [[ $html == "True" ]]; then - _html - fi - - nbad=$(($nbal + $nnon + $nstr + $nfail)) - - [[ $nbad -gt 0 ]] && exit 1 || exit 0 -} diff --git a/run-consensus-tests b/run-consensus-tests deleted file mode 100755 index b183b679e..000000000 --- a/run-consensus-tests +++ /dev/null @@ -1,110 +0,0 @@ -#!/usr/bin/env bash -set -e - -# Invoke with hevm e.g. -# hevm compliance --tests ~/ethereum-tests --group VM --skip quadratic --html - -HEVM=${HEVM:-hevm} - -if [[ "$#" -lt 1 ]]; then - echo >&2 "usage: $(basename "$0") " - exit 1 -fi - -tests=$1 -html=$2 -match=$3 -skip=$4 -timeout=${5:-10} - -_html() { -cat <<. - -hevm test results - -
-

hevm consensus test report

-

$(date +%Y-%m-%d)

-

$(echo "$npass passed, $nfail failed, $nskip skipped")

-(Test suite: VMTests for ConstantinopleFix) -
-

Failed tests

- - -$(echo $failed) -
-

Skipped tests

- - -$(echo $skipped) -
-

Passed tests

- - -$(echo $passed) -
-. -} - -{ - cd "$tests" - for x in VMTests/*/*; do - if [[ $x =~ .*$match.* ]] && [[ -n $skip && $x =~ .*$skip.* ]]; then - for job in $(<$x jq '.|keys[]' -r); do - echo "$x $job skip" - done - elif [[ $x =~ .*$match.* ]]; then - echo -n "$x " ; "$HEVM" vm-test --file $x --timeout $timeout 2>&1 - fi - done -} | { - while read path test outcome; do - echo >&2 "$path $test $outcome" - category=$(dirname "$path") - testcase=$(basename "${path%.json}") - row="$testcase$outcome$category" - row+=$'\n' - case $outcome in - ok) passed+=$row ;; - skip) skipped+=$row ;; - timeout) timouts+=row ;; - *) failed+=$row ;; - esac - done - - sum () { echo -ne "$1" | wc -l | awk '{print $1}'; } - - nfail=$(sum "$failed") - npass=$(sum "$passed") - nskip=$(sum "$skipped") - ntime=$(sum "$timeouts") - - echo >&2 "passed: $npass" - echo >&2 "failed: $nfail" - echo >&2 "timeout: $ntime" - echo >&2 "skipped: $nskip" - - if [[ $html == "True" ]]; then - _html - fi - - [[ $nfail -gt 0 ]] && exit 1 || exit 0 -} diff --git a/src/EVM/VMTest.hs b/test/BlockchainTests.hs similarity index 68% rename from src/EVM/VMTest.hs rename to test/BlockchainTests.hs index 10c47f333..acc432eda 100644 --- a/src/EVM/VMTest.hs +++ b/test/BlockchainTests.hs @@ -1,46 +1,46 @@ -{-# Language CPP #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE TupleSections #-} -module EVM.VMTest - ( Case - , BlockchainCase - - , parseBCSuite - - , initTx - , setupTx - , vmForCase - , checkExpectation - ) where +module Main where import Prelude hiding (Word) -import qualified EVM +import EVM qualified import EVM (contractcode, storage, origStorage, balance, nonce, initialContract, StorageBase(..)) +import EVM.Concrete qualified as EVM +import EVM.Dapp (emptyDapp) import EVM.Expr (litCode, litAddr) -import qualified EVM.Concrete as EVM -import qualified EVM.FeeSchedule - +import EVM.FeeSchedule qualified +import EVM.Fetch qualified +import EVM.Stepper qualified +import EVM.SMT (withSolvers, Solver(Z3)) import EVM.Transaction +import EVM.TTY qualified as TTY import EVM.Types import Control.Arrow ((***), (&&&)) import Control.Lens import Control.Monad - -import GHC.Stack - +import Control.Monad.State.Strict (execStateT) import Data.Aeson ((.:), (.:?), FromJSON (..)) +import Data.Aeson qualified as JSON +import Data.Aeson.Types qualified as JSON +import Data.ByteString.Lazy qualified as Lazy +import Data.ByteString.Lazy qualified as LazyByteString +import Data.List (isInfixOf) import Data.Map (Map) -import Data.Maybe (fromMaybe, isNothing) -import Data.Witherable (Filterable, catMaybes) - -import qualified Data.Map as Map -import qualified Data.Aeson as JSON -import qualified Data.Aeson.Types as JSON -import qualified Data.ByteString.Lazy as Lazy -import qualified Data.Vector as V +import Data.Map qualified as Map +import Data.Maybe (fromMaybe, isNothing, isJust) +import Data.Vector qualified as V import Data.Word (Word64) +import System.Environment (lookupEnv, getEnv) +import System.FilePath.Find qualified as Find +import System.FilePath.Posix (makeRelative, ()) +import Witherable (Filterable, catMaybes) + +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit type Storage = Map W256 W256 @@ -69,14 +69,111 @@ data BlockchainCase = BlockchainCase , blockchainNetwork :: String } deriving Show +main :: IO () +main = do + tests <- prepareTests + defaultMain tests + +prepareTests :: IO TestTree +prepareTests = do + repo <- getEnv "HEVM_ETHEREUM_TESTS_REPO" + let testsDir = "BlockchainTests/GeneralStateTests" + let dir = repo testsDir + jsonFiles <- Find.find Find.always (Find.extension Find.==? ".json") dir + putStrLn "Loading and parsing json files from ethereum-tests..." + isCI <- isJust <$> lookupEnv "CI" + let problematicTests = if isCI then commonProblematicTests <> ciProblematicTests else commonProblematicTests + let ignoredFiles = if isCI then ciIgnoredFiles else [] + groups <- mapM (\f -> testGroup (makeRelative repo f) <$> (if any (`isInfixOf` f) ignoredFiles then pure [] else testsFromFile f problematicTests)) jsonFiles + putStrLn "Loaded." + pure $ testGroup "ethereum-tests" groups + +testsFromFile :: String -> Map String (TestTree -> TestTree) -> IO [TestTree] +testsFromFile file problematicTests = do + parsed <- parseBCSuite <$> LazyByteString.readFile file + case parsed of + Left "No cases to check." -> pure [] -- error "no-cases ok" + Left _err -> pure [] -- error err + Right allTests -> pure $ + (\(name, x) -> testCase' name $ runVMTest False (name, x)) <$> Map.toList allTests + where + testCase' name assertion = + case Map.lookup name problematicTests of + Just f -> f (testCase name assertion) + Nothing -> testCase name assertion + +-- CI has issues with some heaver tests, disable in bulk +ciIgnoredFiles :: [String] +ciIgnoredFiles = + [ "BlockchainTests/GeneralStateTests/VMTests/vmPerformance" + , "BlockchainTests/GeneralStateTests/stQuadraticComplexityTest" + , "BlockchainTests/GeneralStateTests/stStaticCall" + ] + +commonProblematicTests :: Map String (TestTree -> TestTree) +commonProblematicTests = Map.fromList + [ ("twoOps_d0g0v0_London", expectFailBecause "TODO: regression") + , ("sar_2^256-1_0_d0g0v0_London", expectFailBecause "TODO: regression") + , ("shiftCombinations_d0g0v0_London", expectFailBecause "TODO: regression") + , ("shiftSignedCombinations_d0g0v0_London", expectFailBecause "TODO: regression") + , ("bufferSrcOffset_d14g0v0_London", expectFailBecause "TODO: regression") + , ("bufferSrcOffset_d38g0v0_London", expectFailBecause "TODO: regression") + , ("loopMul_d0g0v0_London", ignoreTestBecause "hevm is too slow") + , ("loopMul_d1g0v0_London", ignoreTestBecause "hevm is too slow") + , ("loopMul_d2g0v0_London", ignoreTestBecause "hevm is too slow") + , ("CALLBlake2f_MaxRounds_d0g0v0_London", ignoreTestBecause "very slow, bypasses timeout due time spent in FFI") + ] + +ciProblematicTests :: Map String (TestTree -> TestTree) +ciProblematicTests = Map.fromList + [ ("Return50000_d0g1v0_London", ignoreTest) + , ("Return50000_2_d0g1v0_London", ignoreTest) + , ("randomStatetest177_d0g0v0_London", ignoreTest) + , ("static_Call50000_d0g0v0_London", ignoreTest) + , ("static_Call50000_d1g0v0_London", ignoreTest) + , ("static_Call50000bytesContract50_1_d1g0v0_London", ignoreTest) + , ("static_Call50000bytesContract50_2_d1g0v0_London", ignoreTest) + , ("static_Return50000_2_d0g0v0_London", ignoreTest) + , ("loopExp_d10g0v0_London", ignoreTest) + , ("loopExp_d11g0v0_London", ignoreTest) + , ("loopExp_d12g0v0_London", ignoreTest) + , ("loopExp_d13g0v0_London", ignoreTest) + , ("loopExp_d14g0v0_London", ignoreTest) + , ("loopExp_d8g0v0_London", ignoreTest) + , ("loopExp_d9g0v0_London", ignoreTest) + ] + +runVMTest :: Bool -> (String, Case) -> IO () +runVMTest diffmode (_name, x) = + do + let vm0 = vmForCase x + result <- execStateT (EVM.Stepper.interpret (EVM.Fetch.zero 0 (Just 0)) . void $ EVM.Stepper.execFully) vm0 + maybeReason <- checkExpectation diffmode x result + case maybeReason of + Just reason -> assertFailure reason + Nothing -> pure () + +-- | Example usage: +-- | $ cabal new-repl ethereum-tests +-- | ghci> debugVMTest "BlockchainTests/GeneralStateTests/VMTests/vmArithmeticTest/twoOps.json" "twoOps_d0g0v0_London" +debugVMTest :: String -> String -> IO () +debugVMTest file test = do + repo <- getEnv "HEVM_ETHEREUM_TESTS_REPO" + Right allTests <- parseBCSuite <$> LazyByteString.readFile (repo file) + let [(_, x)] = filter (\(name, _) -> name == test) $ Map.toList allTests + let vm0 = vmForCase x + result <- withSolvers Z3 0 Nothing $ \solvers -> + TTY.runFromVM solvers Nothing Nothing emptyDapp vm0 + void $ checkExpectation True x result + splitEithers :: (Filterable f) => f (Either a b) -> (f a, f b) splitEithers = (catMaybes *** catMaybes) . (fmap fst &&& fmap snd) . (fmap (preview _Left &&& preview _Right)) -checkStateFail :: Bool -> Case -> EVM.VM -> (Bool, Bool, Bool, Bool, Bool) -> IO Bool -checkStateFail diff x vm (okState, okMoney, okNonce, okData, okCode) = do +checkStateFail :: Bool -> Case -> EVM.VM -> (Bool, Bool, Bool, Bool) -> IO String +checkStateFail diff x vm (okMoney, okNonce, okData, okCode) = do let printContracts :: Map Addr (EVM.Contract, Storage) -> IO () printContracts cs = putStrLn $ Map.foldrWithKey (\k (c, s) acc -> @@ -87,35 +184,35 @@ checkStateFail diff x vm (okState, okMoney, okNonce, okData, okCode) = do ++ "\n") "" cs reason = map fst (filter (not . snd) - [ ("bad-state", okMoney || okNonce || okData || okCode || okState) - , ("bad-balance", not okMoney || okNonce || okData || okCode || okState) - , ("bad-nonce", not okNonce || okMoney || okData || okCode || okState) - , ("bad-storage", not okData || okMoney || okNonce || okCode || okState) - , ("bad-code", not okCode || okMoney || okNonce || okData || okState) + [ ("bad-state", okMoney || okNonce || okData || okCode) + , ("bad-balance", not okMoney || okNonce || okData || okCode) + , ("bad-nonce", not okNonce || okMoney || okData || okCode) + , ("bad-storage", not okData || okMoney || okNonce || okCode) + , ("bad-code", not okCode || okMoney || okNonce || okData) ]) check = checkContracts x expected = testExpectation x actual = Map.map (,mempty) $ view (EVM.env . EVM.contracts) vm -- . to (fmap (clearZeroStorage.clearOrigStorage))) vm printStorage = show -- TODO: fixme - putStr (unwords reason) - when (diff && (not okState)) $ do + when diff $ do + putStr (unwords reason) putStrLn "\nPre balance/state: " printContracts check putStrLn "\nExpected balance/state: " printContracts expected putStrLn "\nActual balance/state: " printContracts actual - return okState + pure (unwords reason) -checkExpectation :: HasCallStack => Bool -> Case -> EVM.VM -> IO Bool +checkExpectation :: Bool -> Case -> EVM.VM -> IO (Maybe String) checkExpectation diff x vm = do let expectation = testExpectation x (okState, b2, b3, b4, b5) = checkExpectedContracts vm expectation - putStrLn $ show expectation - unless okState $ void $ checkStateFail - diff x vm (okState, b2, b3, b4, b5) - return okState + if okState then + pure Nothing + else + Just <$> checkStateFail diff x vm (b2, b3, b4, b5) -- quotient account state by nullness (~=) :: Map Addr (EVM.Contract, Storage) -> Map Addr (EVM.Contract, Storage) -> Bool @@ -135,7 +232,7 @@ checkExpectation diff x vm = do (EVM.RuntimeCode a', EVM.RuntimeCode b') -> a' == b' _ -> error "unexpected code" -checkExpectedContracts :: HasCallStack => EVM.VM -> Map Addr (EVM.Contract, Storage) -> (Bool, Bool, Bool, Bool, Bool) +checkExpectedContracts :: EVM.VM -> Map Addr (EVM.Contract, Storage) -> (Bool, Bool, Bool, Bool, Bool) checkExpectedContracts vm expected = let cs = zipWithStorages $ vm ^. EVM.env . EVM.contracts -- . to (fmap (clearZeroStorage.clearOrigStorage)) expectedCs = clearStorage <$> expected @@ -167,8 +264,6 @@ clearNonce (c, s) = (set nonce 0 c, s) clearCode :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) clearCode (c, s) = (set contractcode (EVM.RuntimeCode mempty) c, s) - - newtype ContractWithStorage = ContractWithStorage { unContractWithStorage :: (EVM.Contract, Storage) } instance FromJSON ContractWithStorage where @@ -302,7 +397,7 @@ fromBlockchainCase' block tx preState postState = toCode = Map.lookup toAddr preState theCode = if isCreate then EVM.InitCode (txData tx) mempty - else maybe (EVM.RuntimeCode mempty) (view contractcode) (fst <$> toCode) + else maybe (EVM.RuntimeCode mempty) (view contractcode . fst) toCode effectiveGasPrice = effectiveprice tx (blockBaseFee block) cd = if isCreate then mempty