diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,20 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.50.5] - 2023-03-18 + +## Changed + +- The `--storage-model` parameter has been replaced with `--initial-storage` +- The `--smttimeout` argument now expects a value in seconds not milliseconds +- The default smt timeout has been set to 5 minutes +- `hevm symbolic` now searches only for user defined assertions by default + +### Fixed + +- The `prank` cheatcode now transfers value from the correct address +- Fixed an off-by-one error in `EVM.Debug.srcMapCodePos` + ## [0.50.4] - 2023-03-17 ### Fixed @@ -23,8 +37,8 @@ - Implemented a shrinking algorithm for counterexamples - A new differential fuzzing test harness that compares the concrete semantics, as well as parts of the symbolic semantics against the geth evm implementation - The `hevm` library can now be built on Windows systems. -- Support for function pointers in ABI - `equivalence` can now be checked for fully or partially concrete calldata +- Support for function pointers in ABI ## [0.50.3] - 2023-02-17 diff --git a/bench/bench.hs b/bench/bench.hs --- a/bench/bench.hs +++ b/bench/bench.hs @@ -1,15 +1,23 @@ module Main where import GHC.Natural +import Control.Monad +import Data.Maybe +import System.Environment (lookupEnv, getEnv) import qualified Paths_hevm as Paths -import Test.Tasty (localOption) +import Test.Tasty (localOption, withResource) import Test.Tasty.Bench import Data.Functor import Data.String.Here import Data.ByteString (ByteString) +import System.FilePath.Posix +import Control.Monad.State.Strict +import qualified Data.Map.Strict as Map import qualified Data.Text as T +import qualified System.FilePath.Find as Find +import qualified Data.ByteString.Lazy as LazyByteString import EVM (StorageModel(..)) import EVM.SymExec @@ -19,7 +27,76 @@ import EVM.Dapp import EVM.Types import qualified EVM.TTY as TTY +import qualified EVM.Stepper as Stepper +import qualified EVM.Fetch as Fetch +import EVM.Test.BlockchainTests qualified as BCTests + +main :: IO () +main = defaultMain + [ mkbench erc20 "erc20" Nothing [1] + , mkbench (pure vat) "vat" Nothing [4] + , mkbench (pure deposit) "deposit" (Just 32) [4] + , mkbench (pure uniV2Pair) "uniV2" (Just 10) [4] + , withResource bcjsons (pure . const ()) blockchainTests + ] + + +--- General State Tests ---------------------------------------------------------------------------- + + +-- | loads and parses all blockchain test files +-- We pull this out into a separate stage to ensure that we only benchmark the +-- actual time spent executing tests, and not the IO & parsing overhead +bcjsons :: IO (Map.Map FilePath (Map.Map String BCTests.Case)) +bcjsons = do + repo <- getEnv "HEVM_ETHEREUM_TESTS_REPO" + let testsDir = "BlockchainTests/GeneralStateTests" + dir = repo testsDir + jsons <- Find.find Find.always (Find.extension Find.==? ".json") dir + Map.fromList <$> mapM parseSuite jsons + where + parseSuite path = do + contents <- LazyByteString.readFile path + case BCTests.parseBCSuite contents of + Left e -> pure (path, mempty) + Right tests -> pure (path, tests) + +-- | executes all provided bc tests in sequence and accumulates a boolean value representing their success. +-- the accumulated value ensures that we actually have to execute all the tests as a part of this benchmark +blockchainTests :: IO (Map.Map FilePath (Map.Map String BCTests.Case)) -> Benchmark +blockchainTests ts = bench "blockchain-tests" $ nfIO $ do + tests <- ts + putStrLn "\n executing tests:" + let cases = concat . Map.elems . (fmap Map.toList) $ tests + ignored = Map.keys BCTests.commonProblematicTests + foldM (\acc (n, c) -> + if n `elem` ignored + then pure True + else do + res <- runBCTest c + putStrLn $ " " <> n + pure $ acc && res + ) True cases + +-- | executes a single test case and returns a boolean value representing its success +runBCTest :: BCTests.Case -> IO Bool +runBCTest x = + do + let vm0 = BCTests.vmForCase x + result <- execStateT (Stepper.interpret (Fetch.zero 0 (Just 0)) . void $ Stepper.execFully) vm0 + maybeReason <- BCTests.checkExpectation False x result + pure $ isNothing maybeReason + + +--- Helpers ---------------------------------------------------------------------------------------- + + +debugContract :: ByteString -> IO () +debugContract c = withSolvers CVC5 4 Nothing $ \solvers -> do + let prestate = abstractVM (mkCalldata Nothing []) c Nothing SymbolicS + void $ TTY.runFromVM solvers Nothing Nothing emptyDapp prestate + findPanics :: Solver -> Natural -> Maybe Integer -> ByteString -> IO () findPanics solver count iters c = do (_, res) <- withSolvers solver count Nothing $ \s -> do @@ -44,23 +121,6 @@ ] | i <- counts ] - -main :: IO () -main = defaultMain - [ mkbench erc20 "erc20" Nothing [1] - , mkbench (pure vat) "vat" Nothing [4] - , mkbench (pure deposit) "deposit" (Just 32) [4] - , mkbench (pure uniV2Pair) "uniV2" (Just 10) [4] - ] - - ---- Helpers ---------------------------------------------------------------------------------------- - - -debugContract :: ByteString -> IO () -debugContract c = withSolvers CVC5 4 Nothing $ \solvers -> do - let prestate = abstractVM (mkCalldata Nothing []) c Nothing SymbolicS - void $ TTY.runFromVM solvers Nothing Nothing emptyDapp prestate --- Bytecodes -------------------------------------------------------------------------------------- diff --git a/hevm-cli/hevm-cli.hs b/hevm-cli/hevm-cli.hs --- a/hevm-cli/hevm-cli.hs +++ b/hevm-cli/hevm-cli.hs @@ -5,7 +5,6 @@ module Main where -import EVM (StorageModel(..)) import qualified EVM import EVM.Concrete (createAddress) import qualified EVM.FeeSchedule as FeeSchedule @@ -20,20 +19,22 @@ import EVM.Solidity import EVM.Expr (litAddr) import EVM.Types hiding (word) -import EVM.UnitTest (UnitTestOptions, coverageReport, coverageForUnitTestContract, getParametersFromEnvironmentVariables, testNumber, dappTest) +import EVM.UnitTest (UnitTestOptions, coverageReport, coverageForUnitTestContract, getParametersFromEnvironmentVariables, dappTest) import EVM.Dapp (findUnitTests, dappInfo, DappInfo, emptyDapp) import GHC.Natural import EVM.Format (showTraceTree, formatExpr) import Data.Word (Word64) +import Data.Bifunctor (second) +import qualified Data.Map as Map import qualified EVM.Facts as Facts import qualified EVM.Facts.Git as Git import qualified EVM.UnitTest import GHC.Conc -import Control.Lens hiding (pre, passing) +import Optics.Core hiding (pre, Empty) import Control.Monad (void, when, forM_, unless) -import Control.Monad.State.Strict (execStateT, liftIO) +import Control.Monad.State.Strict (liftIO) import Data.ByteString (ByteString) import Data.List (intercalate, isSuffixOf, intersperse) import Data.Text (unpack, pack) @@ -47,7 +48,6 @@ import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as Char8 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 @@ -89,14 +89,14 @@ -- symbolic execution opts , jsonFile :: w ::: Maybe String "Filename or path to dapp build output (default: out/*.solc.json)" , dappRoot :: w ::: Maybe String "Path to dapp project root directory (default: . )" - , storageModel :: w ::: Maybe StorageModel "Select storage model: ConcreteS, SymbolicS (default) or InitialS" + , initialStorage :: w ::: Maybe (InitialStorage) "Starting state for storage: Empty, Abstract, Concrete (default Abstract)" , sig :: w ::: Maybe Text "Signature of types to decode / encode" , arg :: w ::: [String] "Values to encode" , debug :: w ::: Bool "Run interactively" , getModels :: w ::: Bool "Print example testcase for each execution path" , showTree :: w ::: Bool "Print branches explored in tree view" , showReachableTree :: w ::: Bool "Print only reachable branches explored in tree view" - , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in milliseconds (default: 60000)" + , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in seconds (default: 300)" , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc5" , smtdebug :: w ::: Bool "Print smt queries sent to the solver" @@ -110,7 +110,7 @@ , sig :: w ::: Maybe Text "Signature of types to decode / encode" , arg :: w ::: [String] "Values to encode" , calldata :: w ::: Maybe ByteString "Tx: calldata" - , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in milliseconds (default: 60000)" + , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in seconds (default: 300)" , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc5" , smtoutput :: w ::: Bool "Print verbose smt output" @@ -165,7 +165,7 @@ , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc5" , smtdebug :: w ::: Bool "Print smt queries sent to the solver" , ffi :: w ::: Bool "Allow the usage of the hevm.ffi() cheatcode (WARNING: this allows test authors to execute arbitrary code on your machine)" - , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in milliseconds (default: 60000)" + , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in seconds (default: 300)" , 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)" } @@ -187,6 +187,12 @@ parseRecord = Options.parseRecordWithModifiers Options.lispCaseModifiers +data InitialStorage + = Empty + | Concrete [(W256, [(W256, W256)])] + | Abstract + deriving (Show, Read, Options.ParseField) + optsMode :: Command Options.Unwrapped -> Mode optsMode x | x.debug = Debug @@ -224,7 +230,7 @@ params <- getParametersFromEnvironmentVariables cmd.rpc let - testn = params.testNumber + testn = params.number block' = if 0 == testn then EVM.Fetch.Latest else EVM.Fetch.BlockNumber testn @@ -262,8 +268,7 @@ Version {} -> putStrLn (showVersion Paths.version) Symbolic {} -> withCurrentDirectory root $ assert cmd Equivalence {} -> equivalence cmd - Exec {} -> - launchExec cmd + Exec {} -> launchExec cmd DappTest {} -> withCurrentDirectory root $ do cores <- num <$> getNumProcessors @@ -372,8 +377,8 @@ assert cmd = do let block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block rpcinfo = (,) block' <$> cmd.rpc - calldata' <- buildCalldata cmd - preState <- symvmFromCommand cmd calldata' + calldata <- buildCalldata cmd + preState <- symvmFromCommand cmd calldata let errCodes = fromMaybe defaultPanicCodes cmd.assertions cores <- num <$> getNumProcessors let solverCount = fromMaybe cores cmd.numSolvers @@ -391,7 +396,9 @@ let opts = VeriOpts { simp = True, debug = cmd.smtdebug, maxIter = cmd.maxIterations, askSmtIters = cmd.askSmtIterations, rpcInfo = rpcinfo} (expr, res) <- verify solvers opts preState (Just $ checkAssertions errCodes) case res of - [Qed _] -> putStrLn "\nQED: No reachable property violations discovered\n" + [Qed _] -> do + putStrLn "\nQED: No reachable property violations discovered\n" + showExtras solvers cmd calldata expr _ -> do let cexs = snd <$> mapMaybe getCex res timeouts = mapMaybe getTimeout res @@ -401,7 +408,7 @@ [ "" , "Discovered the following counterexamples:" , "" - ] <> fmap (formatCex (fst calldata')) cexs + ] <> fmap (formatCex (fst calldata)) cexs unknowns | null timeouts = [] | otherwise = @@ -410,21 +417,25 @@ , "" ] <> fmap (formatExpr) timeouts T.putStrLn $ T.unlines (counterexamples <> unknowns) + showExtras solvers cmd calldata expr exitFailure - when cmd.showTree $ do - putStrLn "=== Expression ===\n" - T.putStrLn $ formatExpr expr - putStrLn "" - when cmd.showReachableTree $ do - reached <- reachable solvers expr - putStrLn "=== Reachable Expression ===\n" - T.putStrLn (formatExpr . snd $ reached) - putStrLn "" - when cmd.getModels $ do - putStrLn $ "=== Models for " <> show (Expr.numBranches expr) <> " branches ===\n" - ms <- produceModels solvers expr - forM_ ms (showModel (fst calldata')) +showExtras :: SolverGroup -> Command Options.Unwrapped -> (Expr Buf, [Prop]) -> Expr End -> IO () +showExtras solvers cmd calldata expr = do + when cmd.showTree $ do + putStrLn "=== Expression ===\n" + T.putStrLn $ formatExpr expr + putStrLn "" + when cmd.showReachableTree $ do + reached <- reachable solvers expr + putStrLn "=== Reachable Expression ===\n" + T.putStrLn (formatExpr . snd $ reached) + putStrLn "" + when cmd.getModels $ do + putStrLn $ "=== Models for " <> show (Expr.numBranches expr) <> " branches ===\n" + ms <- produceModels solvers expr + forM_ ms (showModel (fst calldata)) + getCex :: ProofResult a b c -> Maybe b getCex (Cex c) = Just c getCex _ = Nothing @@ -480,9 +491,9 @@ withSolvers Z3 0 Nothing $ \solvers -> do case optsMode cmd of Run -> do - vm' <- execStateT (EVM.Stepper.interpret (EVM.Fetch.oracle solvers rpcinfo) . void $ EVM.Stepper.execFully) vm + vm' <- EVM.Stepper.interpret (EVM.Fetch.oracle solvers rpcinfo) vm EVM.Stepper.runFully when cmd.trace $ T.hPutStr stderr (showTraceTree dapp vm') - case view EVM.result vm' of + case vm'.result of Nothing -> error "internal error; no EVM result" Just (EVM.VMFailure (EVM.Revert msg)) -> do @@ -506,13 +517,13 @@ case cmd.cache of Nothing -> pure () Just path -> - Git.saveFacts (Git.RepoAt path) (Facts.cacheFacts (view EVM.cache vm')) + Git.saveFacts (Git.RepoAt path) (Facts.cacheFacts vm'.cache) Debug -> void $ TTY.runFromVM solvers rpcinfo Nothing dapp vm --JsonTrace -> void $ execStateT (interpretWithTrace fetcher EVM.Stepper.runFully) vm _ -> error "TODO" - where block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block - rpcinfo = (,) block' <$> cmd.rpc + where block = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block + rpcinfo = (,) block <$> cmd.rpc -- | Creates a (concrete) VM from command line options vmFromCommand :: Command Options.Unwrapped -> IO EVM.VM @@ -521,34 +532,34 @@ (miner,ts,baseFee,blockNum,prevRan) <- case cmd.rpc of Nothing -> return (0,Lit 0,0,0,0) - Just url -> EVM.Fetch.fetchBlockFrom block' url >>= \case + Just url -> EVM.Fetch.fetchBlockFrom block url >>= \case Nothing -> error "Could not fetch block" - Just EVM.Block{..} -> return (_coinbase - , _timestamp - , _baseFee - , _number - , _prevRandao + Just EVM.Block{..} -> return ( coinbase + , timestamp + , baseFee + , number + , prevRandao ) contract <- case (cmd.rpc, cmd.address, cmd.code) of (Just url, Just addr', Just c) -> do - EVM.Fetch.fetchContractFrom block' url addr' >>= \case + EVM.Fetch.fetchContractFrom block url addr' >>= \case Nothing -> - error $ "contract not found: " <> show address' - Just contract' -> + error $ "contract not found: " <> show address + Just contract -> -- if both code and url is given, -- fetch the contract and overwrite the code return $ EVM.initialContract (mkCode $ hexByteString "--code" $ strip0x c) - & set EVM.balance (view EVM.balance contract') - & set EVM.nonce (view EVM.nonce contract') - & set EVM.external (view EVM.external contract') + & set #balance (contract.balance) + & set #nonce (contract.nonce) + & set #external (contract.external) (Just url, Just addr', Nothing) -> - EVM.Fetch.fetchContractFrom block' url addr' >>= \case + EVM.Fetch.fetchContractFrom block url addr' >>= \case Nothing -> - error $ "contract not found: " <> show address' - Just contract' -> return contract' + error $ "contract not found: " <> show address + Just contract -> return contract (_, _, Just c) -> return $ @@ -563,43 +574,43 @@ return $ EVM.Transaction.initTx $ withCache (vm0 baseFee miner ts' blockNum prevRan contract) where - block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block - value' = word (.value) 0 - caller' = addr (.caller) 0 - origin' = addr (.origin) 0 - calldata' = ConcreteBuf $ bytes (.calldata) "" + block = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block + value = word (.value) 0 + caller = addr (.caller) 0 + origin = addr (.origin) 0 + calldata = ConcreteBuf $ bytes (.calldata) "" decipher = hexByteString "bytes" . strip0x mkCode bs = if cmd.create then EVM.InitCode bs mempty else EVM.RuntimeCode (EVM.ConcreteRuntimeCode bs) - address' = if cmd.create - then addr (.address) (createAddress origin' (word (.nonce) 0)) + address = if cmd.create + then addr (.address) (createAddress origin (word (.nonce) 0)) else addr (.address) 0xacab vm0 baseFee miner ts blockNum prevRan c = EVM.makeVm $ EVM.VMOpts - { vmoptContract = c - , vmoptCalldata = (calldata', []) - , vmoptValue = Lit value' - , vmoptAddress = address' - , vmoptCaller = litAddr caller' - , vmoptOrigin = origin' - , vmoptGas = word64 (.gas) 0xffffffffffffffff - , vmoptBaseFee = baseFee - , vmoptPriorityFee = word (.priorityFee) 0 - , vmoptGaslimit = word64 (.gaslimit) 0xffffffffffffffff - , vmoptCoinbase = addr (.coinbase) miner - , vmoptNumber = word (.number) blockNum - , vmoptTimestamp = Lit $ word (.timestamp) ts - , vmoptBlockGaslimit = word64 (.gaslimit) 0xffffffffffffffff - , vmoptGasprice = word (.gasprice) 0 - , vmoptMaxCodeSize = word (.maxcodesize) 0xffffffff - , vmoptPrevRandao = word (.prevRandao) prevRan - , vmoptSchedule = FeeSchedule.berlin - , vmoptChainId = word (.chainid) 1 - , vmoptCreate = (.create) cmd - , vmoptStorageBase = EVM.Concrete - , vmoptTxAccessList = mempty -- TODO: support me soon - , vmoptAllowFFI = False + { contract = c + , calldata = (calldata, []) + , value = Lit value + , address = address + , caller = litAddr caller + , origin = origin + , gas = word64 (.gas) 0xffffffffffffffff + , baseFee = baseFee + , priorityFee = word (.priorityFee) 0 + , gaslimit = word64 (.gaslimit) 0xffffffffffffffff + , coinbase = addr (.coinbase) miner + , number = word (.number) blockNum + , timestamp = Lit $ word (.timestamp) ts + , blockGaslimit = word64 (.gaslimit) 0xffffffffffffffff + , gasprice = word (.gasprice) 0 + , maxCodeSize = word (.maxcodesize) 0xffffffff + , prevRandao = word (.prevRandao) prevRan + , schedule = FeeSchedule.berlin + , chainId = word (.chainid) 1 + , create = (.create) cmd + , initialStorage = EmptyStore + , txAccessList = mempty -- TODO: support me soon + , allowFFI = False } word f def = fromMaybe def (f cmd) word64 f def = fromMaybe def (f cmd) @@ -607,37 +618,28 @@ bytes f def = maybe def decipher (f cmd) symvmFromCommand :: Command Options.Unwrapped -> (Expr Buf, [Prop]) -> IO (EVM.VM) -symvmFromCommand cmd calldata' = do +symvmFromCommand cmd calldata = do (miner,blockNum,baseFee,prevRan) <- case cmd.rpc of Nothing -> return (0,0,0,0) - Just url -> EVM.Fetch.fetchBlockFrom block' url >>= \case + Just url -> EVM.Fetch.fetchBlockFrom block url >>= \case Nothing -> error "Could not fetch block" - Just EVM.Block{..} -> return (_coinbase - , _number - , _baseFee - , _prevRandao + Just EVM.Block{..} -> return ( coinbase + , number + , baseFee + , prevRandao ) let - caller' = Caller 0 + caller = Caller 0 ts = maybe Timestamp Lit cmd.timestamp - callvalue' = maybe (CallValue 0) Lit cmd.value + callvalue = maybe (CallValue 0) Lit cmd.value -- TODO: rework this, ConcreteS not needed anymore - let store = case cmd.storageModel of - -- InitialS and SymbolicS can read and write to symbolic locations - -- ConcreteS cannot (instead values can be fetched from rpc!) - -- Initial defaults to 0 for uninitialized storage slots, - -- whereas the values of SymbolicS are unconstrained. - Just InitialS -> EmptyStore - Just ConcreteS -> ConcreteStore mempty - Just SymbolicS -> AbstractStore - Nothing -> if cmd.create then EmptyStore else AbstractStore - + let store = maybe AbstractStore parseInitialStorage (cmd.initialStorage) withCache <- applyCache (cmd.state, cmd.cache) - contract' <- case (cmd.rpc, cmd.address, cmd.code) of + contract <- case (cmd.rpc, cmd.address, cmd.code) of (Just url, Just addr', _) -> - EVM.Fetch.fetchContractFrom block' url addr' >>= \case + EVM.Fetch.fetchContractFrom block url addr' >>= \case Nothing -> error "contract not found." Just contract' -> return contract'' @@ -649,53 +651,59 @@ Just c -> EVM.initialContract (mkCode $ decipher c) -- TODO: fix this -- & set EVM.origStorage (view EVM.origStorage contract') - & set EVM.balance (view EVM.balance contract') - & set EVM.nonce (view EVM.nonce contract') - & set EVM.external (view EVM.external contract') + & set #balance (contract'.balance) + & set #nonce (contract'.nonce) + & set #external (contract'.external) (_, _, Just c) -> return (EVM.initialContract . mkCode $ decipher c) (_, _, Nothing) -> error "must provide at least (rpc + address) or code" - return $ (EVM.Transaction.initTx $ withCache $ vm0 baseFee miner ts blockNum prevRan calldata' callvalue' caller' contract') - & set (EVM.env . EVM.storage) store + return $ (EVM.Transaction.initTx $ withCache $ vm0 baseFee miner ts blockNum prevRan calldata callvalue caller contract) + & set (#env % #storage) store where decipher = hexByteString "bytes" . strip0x - block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block - origin' = addr (.origin) 0 + block = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block + origin = addr (.origin) 0 mkCode bs = if cmd.create then EVM.InitCode bs mempty else EVM.RuntimeCode (EVM.ConcreteRuntimeCode bs) - address' = if cmd.create - then addr (.address) (createAddress origin' (word (.nonce) 0)) + address = if cmd.create + then addr (.address) (createAddress origin (word (.nonce) 0)) else addr (.address) 0xacab - vm0 baseFee miner ts blockNum prevRan cd' callvalue' caller' c = EVM.makeVm $ EVM.VMOpts - { vmoptContract = c - , vmoptCalldata = cd' - , vmoptValue = callvalue' - , vmoptAddress = address' - , vmoptCaller = caller' - , vmoptOrigin = origin' - , vmoptGas = word64 (.gas) 0xffffffffffffffff - , vmoptGaslimit = word64 (.gaslimit) 0xffffffffffffffff - , vmoptBaseFee = baseFee - , vmoptPriorityFee = word (.priorityFee) 0 - , vmoptCoinbase = addr (.coinbase) miner - , vmoptNumber = word (.number) blockNum - , vmoptTimestamp = ts - , vmoptBlockGaslimit = word64 (.gaslimit) 0xffffffffffffffff - , vmoptGasprice = word (.gasprice) 0 - , vmoptMaxCodeSize = word (.maxcodesize) 0xffffffff - , vmoptPrevRandao = word (.prevRandao) prevRan - , vmoptSchedule = FeeSchedule.berlin - , vmoptChainId = word (.chainid) 1 - , vmoptCreate = (.create) cmd - , vmoptStorageBase = EVM.Symbolic - , vmoptTxAccessList = mempty - , vmoptAllowFFI = False + vm0 baseFee miner ts blockNum prevRan cd callvalue caller c = EVM.makeVm $ EVM.VMOpts + { contract = c + , calldata = cd + , value = callvalue + , address = address + , caller = caller + , origin = origin + , gas = word64 (.gas) 0xffffffffffffffff + , gaslimit = word64 (.gaslimit) 0xffffffffffffffff + , baseFee = baseFee + , priorityFee = word (.priorityFee) 0 + , coinbase = addr (.coinbase) miner + , number = word (.number) blockNum + , timestamp = ts + , blockGaslimit = word64 (.gaslimit) 0xffffffffffffffff + , gasprice = word (.gasprice) 0 + , maxCodeSize = word (.maxcodesize) 0xffffffff + , prevRandao = word (.prevRandao) prevRan + , schedule = FeeSchedule.berlin + , chainId = word (.chainid) 1 + , create = (.create) cmd + , initialStorage = maybe AbstractStore parseInitialStorage (cmd.initialStorage) + , txAccessList = mempty + , allowFFI = False } word f def = fromMaybe def (f cmd) addr f def = fromMaybe def (f cmd) word64 f def = fromMaybe def (f cmd) + +parseInitialStorage :: InitialStorage -> Expr Storage +parseInitialStorage = \case + Empty -> EmptyStore + Concrete s -> ConcreteStore (Map.fromList $ fmap (second Map.fromList) s) + Abstract -> AbstractStore diff --git a/hevm.cabal b/hevm.cabal --- a/hevm.cabal +++ b/hevm.cabal @@ -2,7 +2,7 @@ name: hevm version: - 0.50.4 + 0.50.5 synopsis: Ethereum virtual machine evaluator description: @@ -61,6 +61,11 @@ ghc-options: -Werror if flag(devel) ghc-options: -j + ghc-options: + -Wall + -Wno-unticked-promoted-constructors + -Wno-orphans + -Wno-ambiguous-fields default-language: GHC2021 default-extensions: DuplicateRecordFields @@ -68,6 +73,7 @@ NoFieldSelectors OverloadedRecordDot OverloadedStrings + OverloadedLabels RecordWildCards TypeFamilies ViewPatterns @@ -81,7 +87,6 @@ EVM.Concrete, EVM.Dapp, EVM.Debug, - EVM.Demand, EVM.Dev, EVM.Expr, EVM.SMT, @@ -116,7 +121,6 @@ Paths_hevm autogen-modules: Paths_hevm - ghc-options: -Wall -Wno-deprecations -Wno-unticked-promoted-constructors -Wno-orphans if os(linux) || os(windows) extra-libraries: stdc++ extra-libraries: @@ -158,8 +162,10 @@ free >= 5.1.3 && < 5.2, haskeline >= 0.8.0 && < 0.9, process >= 1.6.5 && < 1.7, - lens >= 5.1.1 && < 5.2, - lens-aeson >= 1.2.2 && < 1.3, + optics-core >= 0.4.1 && < 0.5, + optics-extra >= 0.4.2.1 && < 0.5, + optics-th >= 0.4.1 && < 0.5, + aeson-optics >= 1.2.0.1 && < 1.3, monad-par >= 0.3.5 && < 0.4, async >= 2.2.4 && < 2.3, multiset >= 0.3.4 && < 0.4, @@ -193,7 +199,7 @@ hevm-cli main-is: hevm-cli.hs - ghc-options: -Wall -threaded -with-rtsopts=-N -Wno-unticked-promoted-constructors -Wno-orphans + ghc-options: -threaded -with-rtsopts=-N other-modules: Paths_hevm if os(darwin) @@ -219,8 +225,6 @@ filepath, free, hevm, - lens, - lens-aeson, memory, mtl, optparse-generic, @@ -234,7 +238,8 @@ vector, vty, stm, - spawn + spawn, + optics-core if os(windows) buildable: False @@ -242,7 +247,6 @@ common test-base import: shared - ghc-options: -Wall -Wno-unticked-promoted-constructors -Wno-orphans hs-source-dirs: test extra-libraries: @@ -266,7 +270,6 @@ filepath, here, hevm, - lens, mtl, data-dword, process, @@ -286,13 +289,17 @@ spawn >= 0.3, witherable, smt2-parser >= 0.1.0.1, - operational + operational, + optics-core, + optics-extra library test-utils import: test-base exposed-modules: - EVM.TestUtils + EVM.Test.Utils + EVM.Test.Tracing + EVM.Test.BlockchainTests if os(windows) buildable: False @@ -304,8 +311,9 @@ build-depends: test-utils other-modules: - EVM.TestUtils - EVM.Tracing + EVM.Test.Utils + EVM.Test.Tracing + EVM.Test.BlockchainTests if os(windows) buildable: False if os(darwin) @@ -353,6 +361,8 @@ bench.hs hs-source-dirs: bench + ghc-options: + -O2 if os(darwin) extra-libraries: c++ else @@ -368,4 +378,9 @@ bytestring, text, hevm, - here + here, + test-utils, + filemanip, + filepath, + containers, + mtl diff --git a/src/EVM.hs b/src/EVM.hs --- a/src/EVM.hs +++ b/src/EVM.hs @@ -1,2763 +1,2651 @@ {-# Language ImplicitParams #-} -{-# Language DataKinds #-} -{-# Language GADTs #-} -{-# Language TemplateHaskell #-} - -module EVM where - -import Prelude hiding (log, exponent, GT, LT) - -import EVM.ABI -import EVM.Concrete (createAddress, create2Address) -import EVM.Expr (readStorage, writeStorage, readByte, readWord, writeWord, - writeByte, bufLength, indexWord, litAddr, readBytes, word256At, copySlice) -import EVM.Expr qualified as Expr -import EVM.FeeSchedule (FeeSchedule (..)) -import EVM.Op -import EVM.Precompiled qualified -import EVM.Solidity -import EVM.Types hiding (IllegalOverflow, Error) -import EVM.Sign qualified - -import Control.Lens hiding (op, (:<), (|>), (.>)) -import Control.Monad.State.Strict hiding (state) -import Data.Bits (FiniteBits, countLeadingZeros, finiteBitSize) -import Data.ByteArray qualified as BA -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Lazy (fromStrict) -import Data.ByteString.Lazy qualified as LS -import Data.ByteString.Char8 qualified as Char8 -import Data.Foldable (toList) -import Data.List (find) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe, fromJust) -import Data.Set (Set, insert, member, fromList) -import Data.Sequence (Seq) -import Data.Sequence qualified as Seq -import Data.Text (unpack) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Tree -import Data.Tree.Zipper qualified as Zipper -import Data.Tuple.Curry -import Data.Vector qualified as RegularVector -import Data.Vector qualified as V -import Data.Vector.Storable (Vector) -import Data.Vector.Storable qualified as Vector -import Data.Vector.Storable.Mutable qualified as Vector -import Data.Word (Word8, Word32, Word64) -import Options.Generic as Options - -import Crypto.Hash (Digest, SHA256, RIPEMD160) -import Crypto.Hash qualified as Crypto -import Crypto.Number.ModArithmetic (expFast) -import Crypto.PubKey.ECC.ECDSA (signDigestWith, PrivateKey(..), Signature(..)) - --- * Data types - --- | EVM failure modes -data Error - = BalanceTooLow W256 W256 - | UnrecognizedOpcode Word8 - | SelfDestruction - | StackUnderrun - | BadJumpDestination - | Revert (Expr Buf) - | OutOfGas Word64 Word64 - | BadCheatCode (Maybe Word32) - | StackLimitExceeded - | IllegalOverflow - | Query Query - | Choose Choose - | StateChangeWhileStatic - | InvalidMemoryAccess - | CallDepthLimitReached - | MaxCodeSizeExceeded W256 W256 - | InvalidFormat - | PrecompileFailure - | forall a . UnexpectedSymbolicArg Int String [Expr a] - | DeadPath - | NotUnique (Expr EWord) - | SMTTimeout - | FFI [AbiValue] - | ReturnDataOutOfBounds - | NonceOverflow -deriving instance Show Error - --- | The possible result states of a VM -data VMResult - = VMFailure Error -- ^ An operation failed - | VMSuccess (Expr Buf) -- ^ Reached STOP, RETURN, or end-of-code - -deriving instance Show VMResult - --- | The state of a stepwise EVM execution -data VM = VM - { _result :: Maybe VMResult - , _state :: FrameState - , _frames :: [Frame] - , _env :: Env - , _block :: Block - , _tx :: TxState - , _logs :: [Expr Log] - , _traces :: Zipper.TreePos Zipper.Empty Trace - , _cache :: Cache - , _burned :: {-# UNPACK #-} !Word64 - , _iterations :: Map CodeLocation Int - , _constraints :: [Prop] - , _keccakEqs :: [Prop] - , _allowFFI :: Bool - , _overrideCaller :: Maybe (Expr EWord) - } - deriving (Show) - -data Trace = Trace - { _traceOpIx :: Int - , _traceContract :: Contract - , _traceData :: TraceData - } - deriving (Show) - -data TraceData - = EventTrace (Expr EWord) (Expr Buf) [Expr EWord] - | FrameTrace FrameContext - | QueryTrace Query - | ErrorTrace Error - | EntryTrace Text - | ReturnTrace (Expr Buf) FrameContext - deriving (Show) - --- | Queries halt execution until resolved through RPC calls or SMT queries -data Query where - PleaseFetchContract :: Addr -> (Contract -> EVM ()) -> Query - --PleaseMakeUnique :: SBV a -> [SBool] -> (IsUnique a -> EVM ()) -> Query - PleaseFetchSlot :: Addr -> W256 -> (W256 -> EVM ()) -> Query - PleaseAskSMT :: Expr EWord -> [Prop] -> (BranchCondition -> EVM ()) -> Query - PleaseDoFFI :: [String] -> (ByteString -> EVM ()) -> Query - -data Choose where - PleaseChoosePath :: Expr EWord -> (Bool -> EVM ()) -> Choose - -instance Show Query where - showsPrec _ = \case - PleaseFetchContract addr _ -> - (("") ++) - PleaseFetchSlot addr slot _ -> - (("") ++) - PleaseAskSMT condition constraints _ -> - (("") ++) --- PleaseMakeUnique val constraints _ -> --- (("") ++) - PleaseDoFFI cmd _ -> - ((" - ((" b = Cache - { _fetchedContracts = Map.unionWith unifyCachedContract a._fetchedContracts b._fetchedContracts - , _fetchedStorage = Map.unionWith unifyCachedStorage a._fetchedStorage b._fetchedStorage - , _path = mappend a._path b._path - } - -unifyCachedStorage :: Map W256 W256 -> Map W256 W256 -> Map W256 W256 -unifyCachedStorage _ _ = undefined - --- only intended for use in Cache merges, where we expect --- everything to be Concrete -unifyCachedContract :: Contract -> Contract -> Contract -unifyCachedContract _ _ = undefined - {- -unifyCachedContract a b = a & set storage merged - where merged = case (view storage a, view storage b) of - (ConcreteStore sa, ConcreteStore sb) -> - ConcreteStore (mappend sa sb) - _ -> - view storage a - -} - -instance Monoid Cache where - mempty = Cache { _fetchedContracts = mempty, - _fetchedStorage = mempty, - _path = mempty - } - --- * Data accessors - -currentContract :: VM -> Maybe Contract -currentContract vm = - Map.lookup vm._state._codeContract vm._env._contracts - --- * Data constructors - -makeVm :: VMOpts -> VM -makeVm o = - let txaccessList = o.vmoptTxAccessList - txorigin = o.vmoptOrigin - txtoAddr = o.vmoptAddress - initialAccessedAddrs = fromList $ [txorigin, txtoAddr] ++ [1..9] ++ (Map.keys txaccessList) - initialAccessedStorageKeys = fromList $ foldMap (uncurry (map . (,))) (Map.toList txaccessList) - touched = if o.vmoptCreate then [txorigin] else [txorigin, txtoAddr] - in - VM - { _result = Nothing - , _frames = mempty - , _tx = TxState - { _gasprice = o.vmoptGasprice - , _txgaslimit = o.vmoptGaslimit - , _txPriorityFee = o.vmoptPriorityFee - , _origin = txorigin - , _toAddr = txtoAddr - , _value = o.vmoptValue - , _substate = SubState mempty touched initialAccessedAddrs initialAccessedStorageKeys mempty - --, _accessList = txaccessList - , _isCreate = o.vmoptCreate - , _txReversion = Map.fromList - [(o.vmoptAddress , o.vmoptContract )] - } - , _logs = [] - , _traces = Zipper.fromForest [] - , _block = Block - { _coinbase = o.vmoptCoinbase - , _timestamp = o.vmoptTimestamp - , _number = o.vmoptNumber - , _prevRandao = o.vmoptPrevRandao - , _maxCodeSize = o.vmoptMaxCodeSize - , _gaslimit = o.vmoptBlockGaslimit - , _baseFee = o.vmoptBaseFee - , _schedule = o.vmoptSchedule - } - , _state = FrameState - { _pc = 0 - , _stack = mempty - , _memory = mempty - , _memorySize = 0 - , _code = o.vmoptContract._contractcode - , _contract = o.vmoptAddress - , _codeContract = o.vmoptAddress - , _calldata = fst o.vmoptCalldata - , _callvalue = o.vmoptValue - , _caller = o.vmoptCaller - , _gas = o.vmoptGas - , _returndata = mempty - , _static = False - } - , _env = Env - { _sha3Crack = mempty - , _chainId = o.vmoptChainId - , _storage = if o.vmoptStorageBase == Concrete then EmptyStore else AbstractStore - , _origStorage = mempty - , _contracts = Map.fromList - [(o.vmoptAddress, o.vmoptContract )] - --, _keccakUsed = mempty - --, _storageModel = vmoptStorageModel o - } - , _cache = Cache mempty mempty mempty - , _burned = 0 - , _constraints = snd o.vmoptCalldata - , _keccakEqs = mempty - , _iterations = mempty - , _allowFFI = o.vmoptAllowFFI - , _overrideCaller = Nothing - } - --- | Initialize empty contract with given code -initialContract :: ContractCode -> Contract -initialContract theContractCode = Contract - { _contractcode = theContractCode - , _codehash = hashcode theContractCode - , _balance = 0 - , _nonce = if creation then 1 else 0 - , _opIxMap = mkOpIxMap theContractCode - , _codeOps = mkCodeOps theContractCode - , _external = False - } where - creation = case theContractCode of - InitCode _ _ -> True - RuntimeCode _ -> False - --- * Opcode dispatch (exec1) - --- | Update program counter -next :: (?op :: Word8) => EVM () -next = modifying (state . pc) (+ (opSize ?op)) - --- | Executes the EVM one step -exec1 :: EVM () -exec1 = do - vm <- get - - let - -- Convenient aliases - mem = vm._state._memory - stk = vm._state._stack - self = vm._state._contract - this = fromMaybe (error "internal error: state contract") (Map.lookup self vm._env._contracts) - - fees@FeeSchedule {..} = vm._block._schedule - - doStop = finishFrame (FrameReturned mempty) - - if self > 0x0 && self <= 0x9 then do - -- call to precompile - let ?op = 0x00 -- dummy value - case bufLength vm._state._calldata of - (Lit calldatasize) -> do - copyBytesToMemory vm._state._calldata (Lit calldatasize) (Lit 0) (Lit 0) - executePrecompile self vm._state._gas 0 calldatasize 0 0 [] - vmx <- get - case vmx._state._stack of - (x:_) -> case x of - Lit (num -> x' :: Integer) -> case x' of - 0 -> do - fetchAccount self $ \_ -> do - touchAccount self - vmError PrecompileFailure - _ -> fetchAccount self $ \_ -> do - touchAccount self - out <- use (state . returndata) - finishFrame (FrameReturned out) - e -> vmError $ - UnexpectedSymbolicArg vmx._state._pc "precompile returned a symbolic value" [e] - _ -> - underrun - e -> vmError $ UnexpectedSymbolicArg vm._state._pc "cannot call precompiles with symbolic data" [e] - - else if vm._state._pc >= opslen vm._state._code - then doStop - - else do - let ?op = case vm._state._code of - InitCode conc _ -> BS.index conc vm._state._pc - RuntimeCode (ConcreteRuntimeCode bs) -> BS.index bs vm._state._pc - RuntimeCode (SymbolicRuntimeCode ops) -> - fromMaybe (error "could not analyze symbolic code") $ - unlitByte $ ops V.! vm._state._pc - - case getOp(?op) of - - OpPush n' -> do - let n = fromIntegral n' - !xs = case vm._state._code of - InitCode conc _ -> Lit $ word $ padRight n $ BS.take n (BS.drop (1 + vm._state._pc) conc) - RuntimeCode (ConcreteRuntimeCode bs) -> Lit $ word $ BS.take n $ BS.drop (1 + vm._state._pc) bs - RuntimeCode (SymbolicRuntimeCode ops) -> - let bytes = V.take n $ V.drop (1 + vm._state._pc) ops - in readWord (Lit 0) $ Expr.fromList $ padLeft' 32 bytes - limitStack 1 $ - burn g_verylow $ do - next - pushSym xs - - OpDup i -> - case preview (ix (fromIntegral i - 1)) stk of - Nothing -> underrun - Just y -> - limitStack 1 $ - burn g_verylow $ do - next - pushSym y - - OpSwap i -> - if length stk < (fromIntegral i) + 1 - then underrun - else - burn g_verylow $ do - next - zoom (state . stack) $ do - assign (ix 0) (stk ^?! ix (fromIntegral i)) - assign (ix (fromIntegral i)) (stk ^?! ix 0) - - OpLog n -> - notStatic $ - case stk of - (xOffset':xSize':xs) -> - if length xs < (fromIntegral n) - then underrun - else - forceConcrete2 (xOffset', xSize') "LOG" $ \(xOffset, xSize) -> do - let (topics, xs') = splitAt (fromIntegral n) xs - bytes = readMemory xOffset' xSize' vm - logs' = (LogEntry (litAddr self) bytes topics) : vm._logs - burn (g_log + g_logdata * (num xSize) + num n * g_logtopic) $ - accessMemoryRange xOffset xSize $ do - traceTopLog logs' - next - assign (state . stack) xs' - assign logs logs' - _ -> - underrun - - OpStop -> doStop - - OpAdd -> stackOp2 g_verylow (uncurry Expr.add) - OpMul -> stackOp2 g_low (uncurry Expr.mul) - OpSub -> stackOp2 g_verylow (uncurry Expr.sub) - - OpDiv -> stackOp2 g_low (uncurry Expr.div) - - OpSdiv -> stackOp2 g_low (uncurry Expr.sdiv) - - OpMod-> stackOp2 g_low (uncurry Expr.mod) - - OpSmod -> stackOp2 g_low (uncurry Expr.smod) - OpAddmod -> stackOp3 g_mid (uncurryN Expr.addmod) - OpMulmod -> stackOp3 g_mid (uncurryN Expr.mulmod) - - OpLt -> stackOp2 g_verylow (uncurry Expr.lt) - OpGt -> stackOp2 g_verylow (uncurry Expr.gt) - OpSlt -> stackOp2 g_verylow (uncurry Expr.slt) - OpSgt -> stackOp2 g_verylow (uncurry Expr.sgt) - - OpEq -> stackOp2 g_verylow (uncurry Expr.eq) - OpIszero -> stackOp1 g_verylow Expr.iszero - - OpAnd -> stackOp2 g_verylow (uncurry Expr.and) - OpOr -> stackOp2 g_verylow (uncurry Expr.or) - OpXor -> stackOp2 g_verylow (uncurry Expr.xor) - OpNot -> stackOp1 g_verylow Expr.not - - OpByte -> stackOp2 g_verylow (\(i, w) -> Expr.padByte $ Expr.indexWord i w) - - OpShl -> stackOp2 g_verylow (uncurry Expr.shl) - OpShr -> stackOp2 g_verylow (uncurry Expr.shr) - OpSar -> stackOp2 g_verylow (uncurry Expr.sar) - - -- more accurately refered to as KECCAK - OpSha3 -> - case stk of - (xOffset' : xSize' : xs) -> - forceConcrete xOffset' "sha3 offset must be concrete" $ - \xOffset -> forceConcrete xSize' "sha3 size must be concrete" $ \xSize -> - burn (g_sha3 + g_sha3word * ceilDiv (num xSize) 32) $ - accessMemoryRange xOffset xSize $ do - (hash, invMap) <- case readMemory xOffset' xSize' vm of - ConcreteBuf bs -> do - let hash' = keccak' bs - eqs <- use keccakEqs - assign keccakEqs $ PEq (Lit hash') (Keccak (ConcreteBuf bs)):eqs - pure (Lit hash', Map.singleton hash' bs) - buf -> pure (Keccak buf, mempty) - next - assign (state . stack) (hash : xs) - (env . sha3Crack) <>= invMap - _ -> underrun - - OpAddress -> - limitStack 1 $ - burn g_base (next >> push (num self)) - - OpBalance -> - case stk of - (x':xs) -> forceConcrete x' "BALANCE" $ \x -> - accessAndBurn (num x) $ - fetchAccount (num x) $ \c -> do - next - assign (state . stack) xs - push (num c._balance) - [] -> - underrun - - OpOrigin -> - limitStack 1 . burn g_base $ - next >> push (num vm._tx._origin) - - OpCaller -> - limitStack 1 . burn g_base $ - next >> pushSym vm._state._caller - - OpCallvalue -> - limitStack 1 . burn g_base $ - next >> pushSym vm._state._callvalue - - OpCalldataload -> stackOp1 g_verylow $ - \ind -> Expr.readWord ind vm._state._calldata - - OpCalldatasize -> - limitStack 1 . burn g_base $ - next >> pushSym (bufLength vm._state._calldata) - - OpCalldatacopy -> - case stk of - (xTo' : xFrom : xSize' : xs) -> - forceConcrete2 (xTo', xSize') "CALLDATACOPY" $ - \(xTo, xSize) -> - burn (g_verylow + g_copy * ceilDiv (num xSize) 32) $ - accessMemoryRange xTo xSize $ do - next - assign (state . stack) xs - copyBytesToMemory vm._state._calldata xSize' xFrom xTo' - _ -> underrun - - OpCodesize -> - limitStack 1 . burn g_base $ - next >> pushSym (codelen vm._state._code) - - OpCodecopy -> - case stk of - (memOffset' : codeOffset : n' : xs) -> - forceConcrete2 (memOffset', n') "CODECOPY" $ - \(memOffset,n) -> do - case toWord64 n of - Nothing -> vmError IllegalOverflow - Just n'' -> - if n'' <= ( (maxBound :: Word64) - g_verylow ) `div` g_copy * 32 then - burn (g_verylow + g_copy * ceilDiv (num n) 32) $ - accessMemoryRange memOffset n $ do - next - assign (state . stack) xs - copyBytesToMemory (toBuf vm._state._code) n' codeOffset memOffset' - else vmError IllegalOverflow - _ -> underrun - - OpGasprice -> - limitStack 1 . burn g_base $ - next >> push vm._tx._gasprice - - OpExtcodesize -> - case stk of - (x':xs) -> case x' of - (Lit x) -> if x == num cheatCode - then do - next - assign (state . stack) xs - pushSym (Lit 1) - else - accessAndBurn (num x) $ - fetchAccount (num x) $ \c -> do - next - assign (state . stack) xs - pushSym (bufLength (view bytecode c)) - _ -> do - assign (state . stack) xs - pushSym (CodeSize x') - next - [] -> - underrun - - OpExtcodecopy -> - case stk of - ( extAccount' - : memOffset' - : codeOffset - : codeSize' - : xs ) -> - forceConcrete3 (extAccount', memOffset', codeSize') "EXTCODECOPY" $ - \(extAccount, memOffset, codeSize) -> do - acc <- accessAccountForGas (num extAccount) - let cost = if acc then g_warm_storage_read else g_cold_account_access - burn (cost + g_copy * ceilDiv (num codeSize) 32) $ - accessMemoryRange memOffset codeSize $ - fetchAccount (num extAccount) $ \c -> do - next - assign (state . stack) xs - copyBytesToMemory (view bytecode c) codeSize' codeOffset memOffset' - _ -> underrun - - OpReturndatasize -> - limitStack 1 . burn g_base $ - next >> pushSym (bufLength vm._state._returndata) - - OpReturndatacopy -> - case stk of - (xTo' : xFrom : xSize' :xs) -> forceConcrete2 (xTo', xSize') "RETURNDATACOPY" $ - \(xTo, xSize) -> - burn (g_verylow + g_copy * ceilDiv (num xSize) 32) $ - accessMemoryRange xTo xSize $ do - next - assign (state . stack) xs - - let jump True = vmError EVM.ReturnDataOutOfBounds - jump False = copyBytesToMemory vm._state._returndata xSize' xFrom xTo' - - case (xFrom, bufLength vm._state._returndata) of - (Lit f, Lit l) -> - jump $ l < f + xSize || f + xSize < f - _ -> do - let oob = Expr.lt (bufLength vm._state._returndata) (Expr.add xFrom xSize') - overflow = Expr.lt (Expr.add xFrom xSize') (xFrom) - loc <- codeloc - branch loc (Expr.or oob overflow) jump - _ -> underrun - - OpExtcodehash -> - case stk of - (x':xs) -> forceConcrete x' "EXTCODEHASH" $ \x -> - accessAndBurn (num x) $ do - next - assign (state . stack) xs - fetchAccount (num x) $ \c -> - if accountEmpty c - then push (num (0 :: Int)) - else pushSym $ keccak (view bytecode c) - [] -> - underrun - - OpBlockhash -> do - -- We adopt the fake block hash scheme of the VMTests, - -- so that blockhash(i) is the hash of i as decimal ASCII. - stackOp1 g_blockhash $ \case - (Lit i) -> if i + 256 < vm._block._number || i >= vm._block._number - then Lit 0 - else (num i :: Integer) & show & Char8.pack & keccak' & Lit - i -> BlockHash i - - OpCoinbase -> - limitStack 1 . burn g_base $ - next >> push (num vm._block._coinbase) - - OpTimestamp -> - limitStack 1 . burn g_base $ - next >> pushSym vm._block._timestamp - - OpNumber -> - limitStack 1 . burn g_base $ - next >> push vm._block._number - - OpPrevRandao -> do - limitStack 1 . burn g_base $ - next >> push vm._block._prevRandao - - OpGaslimit -> - limitStack 1 . burn g_base $ - next >> push (num vm._block._gaslimit) - - OpChainid -> - limitStack 1 . burn g_base $ - next >> push vm._env._chainId - - OpSelfbalance -> - limitStack 1 . burn g_low $ - next >> push this._balance - - OpBaseFee -> - limitStack 1 . burn g_base $ - next >> push vm._block._baseFee - - OpPop -> - case stk of - (_:xs) -> burn g_base (next >> assign (state . stack) xs) - _ -> underrun - - OpMload -> - case stk of - (x':xs) -> forceConcrete x' "MLOAD" $ \x -> - burn g_verylow $ - accessMemoryWord x $ do - next - assign (state . stack) (readWord (Lit x) mem : xs) - _ -> underrun - - OpMstore -> - case stk of - (x':y:xs) -> forceConcrete x' "MSTORE index" $ \x -> - burn g_verylow $ - accessMemoryWord x $ do - next - assign (state . memory) (writeWord (Lit x) y mem) - assign (state . stack) xs - _ -> underrun - - OpMstore8 -> - case stk of - (x':y:xs) -> forceConcrete x' "MSTORE8" $ \x -> - burn g_verylow $ - accessMemoryRange x 1 $ do - let yByte = indexWord (Lit 31) y - next - modifying (state . memory) (writeByte (Lit x) yByte) - assign (state . stack) xs - _ -> underrun - - OpSload -> - case stk of - (x:xs) -> do - acc <- accessStorageForGas self x - let cost = if acc then g_warm_storage_read else g_cold_sload - burn cost $ - accessStorage self x $ \y -> do - next - assign (state . stack) (y:xs) - _ -> underrun - - OpSstore -> - notStatic $ - case stk of - (x:new:xs) -> - accessStorage self x $ \current -> do - availableGas <- use (state . gas) - - if num availableGas <= g_callstipend - then finishFrame (FrameErrored (OutOfGas availableGas (num g_callstipend))) - else do - let original = case readStorage (litAddr self) x (ConcreteStore vm._env._origStorage) of - Just (Lit v) -> v - _ -> 0 - let storage_cost = case (maybeLitWord current, maybeLitWord new) of - (Just current', Just new') -> - if (current' == new') then g_sload - else if (current' == original) && (original == 0) then g_sset - else if (current' == original) then g_sreset - else g_sload - - -- if any of the arguments are symbolic, - -- assume worst case scenario - _ -> g_sset - - acc <- accessStorageForGas self x - let cold_storage_cost = if acc then 0 else g_cold_sload - burn (storage_cost + cold_storage_cost) $ do - next - assign (state . stack) xs - modifying (env . storage) - (writeStorage (litAddr self) x new) - - case (maybeLitWord current, maybeLitWord new) of - (Just current', Just new') -> - unless (current' == new') $ - if current' == original - then when (original /= 0 && new' == 0) $ - refund (g_sreset + g_access_list_storage_key) - else do - when (original /= 0) $ - if new' == 0 - then refund (g_sreset + g_access_list_storage_key) - else unRefund (g_sreset + g_access_list_storage_key) - when (original == new') $ - if original == 0 - then refund (g_sset - g_sload) - else refund (g_sreset - g_sload) - -- if any of the arguments are symbolic, - -- don't change the refund counter - _ -> noop - _ -> underrun - - OpJump -> - case stk of - (x:xs) -> - burn g_mid $ forceConcrete x "JUMP: symbolic jumpdest" $ \x' -> - case toInt x' of - Nothing -> vmError EVM.BadJumpDestination - Just i -> checkJump i xs - _ -> underrun - - OpJumpi -> do - case stk of - (x:y:xs) -> forceConcrete x "JUMPI: symbolic jumpdest" $ \x' -> - burn g_high $ - let jump :: Bool -> EVM () - jump False = assign (state . stack) xs >> next - jump _ = case toInt x' of - Nothing -> vmError EVM.BadJumpDestination - Just i -> checkJump i xs - in case maybeLitWord y of - Just y' -> jump (0 /= y') - -- if the jump condition is symbolic, we explore both sides - Nothing -> do - loc <- codeloc - branch loc y jump - _ -> underrun - - OpPc -> - limitStack 1 . burn g_base $ - next >> push (num vm._state._pc) - - OpMsize -> - limitStack 1 . burn g_base $ - next >> push (num vm._state._memorySize) - - OpGas -> - limitStack 1 . burn g_base $ - next >> push (num (vm._state._gas - g_base)) - - OpJumpdest -> burn g_jumpdest next - - OpExp -> - -- NOTE: this can be done symbolically using unrolling like this: - -- https://hackage.haskell.org/package/sbv-9.0/docs/src/Data.SBV.Core.Model.html#.%5E - -- However, it requires symbolic gas, since the gas depends on the exponent - case stk of - (base:exponent':xs) -> forceConcrete exponent' "EXP: symbolic exponent" $ \exponent -> - let cost = if exponent == 0 - then g_exp - else g_exp + g_expbyte * num (ceilDiv (1 + log2 exponent) 8) - in burn cost $ do - next - state . stack .= Expr.exp base exponent' : xs - _ -> underrun - - OpSignextend -> stackOp2 g_low (uncurry Expr.sex) - - OpCreate -> - notStatic $ - case stk of - (xValue' : xOffset' : xSize' : xs) -> forceConcrete3 (xValue', xOffset', xSize') "CREATE" $ - \(xValue, xOffset, xSize) -> do - accessMemoryRange xOffset xSize $ do - availableGas <- use (state . gas) - let - newAddr = createAddress self this._nonce - (cost, gas') = costOfCreate fees availableGas 0 - _ <- accessAccountForGas newAddr - burn (cost - gas') $ do - -- unfortunately we have to apply some (pretty hacky) - -- heuristics here to parse the unstructured buffer read - -- from memory into a code and data section - let initCode = readMemory xOffset' xSize' vm - create self this (num gas') xValue xs newAddr initCode - _ -> underrun - - OpCall -> - case stk of - ( xGas' - : xTo - : xValue' - : xInOffset' - : xInSize' - : xOutOffset' - : xOutSize' - : xs - ) -> forceConcrete6 (xGas', xValue', xInOffset', xInSize', xOutOffset', xOutSize') "CALL" $ - \(xGas, xValue, xInOffset, xInSize, xOutOffset, xOutSize) -> - (if xValue > 0 then notStatic else id) $ - delegateCall this (num xGas) xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ \callee -> do - zoom state $ do - assign callvalue (Lit xValue) - assign caller $ fromMaybe (litAddr self) (vm ^. overrideCaller) - assign contract callee - assign overrideCaller Nothing - transfer self callee xValue - touchAccount self - touchAccount callee - _ -> - underrun - - OpCallcode -> - case stk of - ( xGas' - : xTo - : xValue' - : xInOffset' - : xInSize' - : xOutOffset' - : xOutSize' - : xs - ) -> forceConcrete6 (xGas', xValue', xInOffset', xInSize', xOutOffset', xOutSize') "CALLCODE" $ - \(xGas, xValue, xInOffset, xInSize, xOutOffset, xOutSize) -> - delegateCall this (num xGas) xTo (litAddr self) xValue xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do - zoom state $ do - assign callvalue (Lit xValue) - assign caller $ fromMaybe (litAddr self) (vm ^. overrideCaller) - assign overrideCaller Nothing - touchAccount self - _ -> - underrun - - OpReturn -> - case stk of - (xOffset' : xSize' :_) -> forceConcrete2 (xOffset', xSize') "RETURN" $ \(xOffset, xSize) -> - accessMemoryRange xOffset xSize $ do - let - output = readMemory xOffset' xSize' vm - codesize = fromMaybe (error "RETURN: cannot return dynamically sized abstract data") - . unlit . bufLength $ output - maxsize = vm._block._maxCodeSize - creation = case vm._frames of - [] -> vm._tx._isCreate - frame:_ -> case frame._frameContext of - CreationContext {} -> True - CallContext {} -> False - if creation - then - if codesize > maxsize - then - finishFrame (FrameErrored (MaxCodeSizeExceeded maxsize codesize)) - else do - let frameReturned = burn (g_codedeposit * num codesize) $ - finishFrame (FrameReturned output) - frameErrored = finishFrame $ FrameErrored InvalidFormat - case readByte (Lit 0) output of - LitByte 0xef -> frameErrored - LitByte _ -> frameReturned - y -> do - loc <- codeloc - branch loc (Expr.eqByte y (LitByte 0xef)) $ \case - True -> frameErrored - False -> frameReturned - else - finishFrame (FrameReturned output) - _ -> underrun - - OpDelegatecall -> - case stk of - (xGas' - :xTo - :xInOffset' - :xInSize' - :xOutOffset' - :xOutSize' - :xs) -> forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') "DELEGATECALL" $ - \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> - delegateCall this (num xGas) xTo (litAddr self) 0 xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do - touchAccount self - _ -> underrun - - OpCreate2 -> notStatic $ - case stk of - (xValue' - :xOffset' - :xSize' - :xSalt' - :xs) -> forceConcrete4 (xValue', xOffset', xSize', xSalt') "CREATE2" $ - \(xValue, xOffset, xSize, xSalt) -> - accessMemoryRange xOffset xSize $ do - availableGas <- use (state . gas) - - forceConcreteBuf (readMemory xOffset' xSize' vm) "CREATE2" $ - \initCode -> do - let - newAddr = create2Address self xSalt initCode - (cost, gas') = costOfCreate fees availableGas xSize - _ <- accessAccountForGas newAddr - burn (cost - gas') $ create self this gas' xValue xs newAddr (ConcreteBuf initCode) - _ -> underrun - - OpStaticcall -> - case stk of - (xGas' - :xTo - :xInOffset' - :xInSize' - :xOutOffset' - :xOutSize' - :xs) -> forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') "STATICCALL" $ - \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> do - delegateCall this (num xGas) xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs $ \callee -> do - zoom state $ do - assign callvalue (Lit 0) - assign caller $ fromMaybe (litAddr self) (vm ^. overrideCaller) - assign contract callee - assign static True - assign overrideCaller Nothing - touchAccount self - touchAccount callee - _ -> - underrun - - OpSelfdestruct -> - notStatic $ - case stk of - [] -> underrun - (xTo':_) -> forceConcrete xTo' "SELFDESTRUCT" $ \(num -> xTo) -> do - acc <- accessAccountForGas (num xTo) - let cost = if acc then 0 else g_cold_account_access - funds = this._balance - recipientExists = accountExists xTo vm - c_new = if not recipientExists && funds /= 0 - then g_selfdestruct_newaccount - else 0 - burn (g_selfdestruct + c_new + cost) $ do - selfdestruct self - touchAccount xTo - - if funds /= 0 - then fetchAccount xTo $ \_ -> do - env . contracts . ix xTo . balance += funds - assign (env . contracts . ix self . balance) 0 - doStop - else doStop - - OpRevert -> - case stk of - (xOffset':xSize':_) -> forceConcrete2 (xOffset', xSize') "REVERT" $ \(xOffset, xSize) -> - accessMemoryRange xOffset xSize $ do - let output = readMemory xOffset' xSize' vm - finishFrame (FrameReverted output) - _ -> underrun - - OpUnknown xxx -> - vmError (UnrecognizedOpcode xxx) - -transfer :: Addr -> Addr -> W256 -> EVM () -transfer xFrom xTo xValue = - zoom (env . contracts) $ do - ix xFrom . balance -= xValue - ix xTo . balance += xValue - --- | Checks a *CALL for failure; OOG, too many callframes, memory access etc. -callChecks - :: (?op :: Word8) - => Contract -> Word64 -> Addr -> Addr -> W256 -> W256 -> W256 -> W256 -> W256 -> [Expr EWord] - -- continuation with gas available for call - -> (Word64 -> EVM ()) - -> EVM () -callChecks this xGas xContext xTo xValue xInOffset xInSize xOutOffset xOutSize xs continue = do - vm <- get - let fees = vm._block._schedule - accessMemoryRange xInOffset xInSize $ - accessMemoryRange xOutOffset xOutSize $ do - availableGas <- use (state . gas) - let recipientExists = accountExists xContext vm - (cost, gas') <- costOfCall fees recipientExists xValue availableGas xGas xTo - burn (cost - gas') $ do - if xValue > num this._balance - then do - assign (state . stack) (Lit 0 : xs) - assign (state . returndata) mempty - pushTrace $ ErrorTrace $ BalanceTooLow xValue this._balance - next - else if length vm._frames >= 1024 - then do - assign (state . stack) (Lit 0 : xs) - assign (state . returndata) mempty - pushTrace $ ErrorTrace CallDepthLimitReached - next - else continue gas' - -precompiledContract - :: (?op :: Word8) - => Contract - -> Word64 - -> Addr - -> Addr - -> W256 - -> W256 -> W256 -> W256 -> W256 - -> [Expr EWord] - -> EVM () -precompiledContract this xGas precompileAddr recipient xValue inOffset inSize outOffset outSize xs = - callChecks this xGas recipient precompileAddr xValue inOffset inSize outOffset outSize xs $ \gas' -> - do - executePrecompile precompileAddr gas' inOffset inSize outOffset outSize xs - self <- use (state . contract) - stk <- use (state . stack) - pc' <- use (state . pc) - result' <- use result - case result' of - Nothing -> case stk of - (x:_) -> case maybeLitWord x of - Just 0 -> - return () - Just 1 -> - fetchAccount recipient $ \_ -> do - transfer self recipient xValue - touchAccount self - touchAccount recipient - _ -> vmError $ UnexpectedSymbolicArg pc' "unexpected return value from precompile" [x] - _ -> underrun - _ -> pure () - -executePrecompile - :: (?op :: Word8) - => Addr - -> Word64 -> W256 -> W256 -> W256 -> W256 -> [Expr EWord] - -> EVM () -executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = do - vm <- get - let input = readMemory (Lit inOffset) (Lit inSize) vm - fees = vm._block._schedule - cost = costOfPrecompile fees preCompileAddr input - notImplemented = error $ "precompile at address " <> show preCompileAddr <> " not yet implemented" - precompileFail = burn (gasCap - cost) $ do - assign (state . stack) (Lit 0 : xs) - pushTrace $ ErrorTrace PrecompileFailure - next - if cost > gasCap then - burn gasCap $ do - assign (state . stack) (Lit 0 : xs) - next - else - burn cost $ - case preCompileAddr of - -- ECRECOVER - 0x1 -> - -- TODO: support symbolic variant - forceConcreteBuf input "ECRECOVER" $ \input' -> do - case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of - Nothing -> do - -- return no output for invalid signature - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) mempty - next - Just output -> do - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) (ConcreteBuf output) - copyBytesToMemory (ConcreteBuf output) (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- SHA2-256 - 0x2 -> forceConcreteBuf input "SHA2-256" $ \input' -> do - let - hash = sha256Buf input' - sha256Buf x = ConcreteBuf $ BA.convert (Crypto.hash x :: Digest SHA256) - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) hash - copyBytesToMemory hash (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- RIPEMD-160 - 0x3 -> - -- TODO: support symbolic variant - forceConcreteBuf input "RIPEMD160" $ \input' -> - - let - padding = BS.pack $ replicate 12 0 - hash' = BA.convert (Crypto.hash input' :: Digest RIPEMD160) - hash = ConcreteBuf $ padding <> hash' - in do - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) hash - copyBytesToMemory hash (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- IDENTITY - 0x4 -> do - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) input - copyCallBytesToMemory input (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- MODEXP - 0x5 -> - -- TODO: support symbolic variant - forceConcreteBuf input "MODEXP" $ \input' -> - - let - (lenb, lene, lenm) = parseModexpLength input' - - output = ConcreteBuf $ - if isZero (96 + lenb + lene) lenm input' - then truncpadlit (num lenm) (asBE (0 :: Int)) - else - let - b = asInteger $ lazySlice 96 lenb input' - e = asInteger $ lazySlice (96 + lenb) lene input' - m = asInteger $ lazySlice (96 + lenb + lene) lenm input' - in - padLeft (num lenm) (asBE (expFast b e m)) - in do - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) output - copyBytesToMemory output (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- ECADD - 0x6 -> - -- TODO: support symbolic variant - forceConcreteBuf input "ECADD" $ \input' -> - case EVM.Precompiled.execute 0x6 (truncpadlit 128 input') 64 of - Nothing -> precompileFail - Just output -> do - let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- ECMUL - 0x7 -> - -- TODO: support symbolic variant - forceConcreteBuf input "ECMUL" $ \input' -> - - case EVM.Precompiled.execute 0x7 (truncpadlit 96 input') 64 of - Nothing -> precompileFail - Just output -> do - let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- ECPAIRING - 0x8 -> - -- TODO: support symbolic variant - forceConcreteBuf input "ECPAIR" $ \input' -> - - case EVM.Precompiled.execute 0x8 input' 32 of - Nothing -> precompileFail - Just output -> do - let truncpaddedOutput = ConcreteBuf $ truncpadlit 32 output - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- BLAKE2 - 0x9 -> - -- TODO: support symbolic variant - forceConcreteBuf input "BLAKE2" $ \input' -> do - - case (BS.length input', 1 >= BS.last input') of - (213, True) -> case EVM.Precompiled.execute 0x9 input' 64 of - Just output -> do - let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) - next - Nothing -> precompileFail - _ -> precompileFail - - - _ -> notImplemented - -truncpadlit :: Int -> ByteString -> ByteString -truncpadlit n xs = if m > n then BS.take n xs - else BS.append xs (BS.replicate (n - m) 0) - where m = BS.length xs - -lazySlice :: W256 -> W256 -> ByteString -> LS.ByteString -lazySlice offset size bs = - let bs' = LS.take (num size) (LS.drop (num offset) (fromStrict bs)) - in bs' <> LS.replicate ((num size) - LS.length bs') 0 - -parseModexpLength :: ByteString -> (W256, W256, W256) -parseModexpLength input = - let lenb = word $ LS.toStrict $ lazySlice 0 32 input - lene = word $ LS.toStrict $ lazySlice 32 64 input - lenm = word $ LS.toStrict $ lazySlice 64 96 input - in (lenb, lene, lenm) - ---- checks if a range of ByteString bs starting at offset and length size is all zeros. -isZero :: W256 -> W256 -> ByteString -> Bool -isZero offset size bs = - LS.all (== 0) $ - LS.take (num size) $ - LS.drop (num offset) $ - fromStrict bs - -asInteger :: LS.ByteString -> Integer -asInteger xs = if xs == mempty then 0 - else 256 * asInteger (LS.init xs) - + num (LS.last xs) - --- * Opcode helper actions - -noop :: Monad m => m () -noop = pure () - -pushTo :: MonadState s m => ASetter s s [a] [a] -> a -> m () -pushTo f x = f %= (x :) - -pushToSequence :: MonadState s m => ASetter s s (Seq a) (Seq a) -> a -> m () -pushToSequence f x = f %= (Seq.|> x) - -getCodeLocation :: VM -> CodeLocation -getCodeLocation vm = (vm._state._contract, vm._state._pc) - -branch :: CodeLocation -> Expr EWord -> (Bool -> EVM ()) -> EVM () -branch loc cond continue = do - pathconds <- use constraints - assign result . Just . VMFailure . Query $ PleaseAskSMT cond pathconds choosePath - where - choosePath (Case v) = do assign result Nothing - pushTo constraints $ if v then (cond ./= (Lit 0)) else (cond .== (Lit 0)) - iteration <- use (iterations . at loc . non 0) - assign (cache . path . at (loc, iteration)) (Just v) - assign (iterations . at loc) (Just (iteration + 1)) - continue v - -- Both paths are possible; we ask for more input - choosePath Unknown = assign result . Just . VMFailure . Choose . PleaseChoosePath cond $ choosePath . Case - -- None of the paths are possible; fail this branch - choosePath Inconsistent = vmError DeadPath - - --- | Construct RPC Query and halt execution until resolved -fetchAccount :: Addr -> (Contract -> EVM ()) -> EVM () -fetchAccount addr continue = - use (env . contracts . at addr) >>= \case - Just c -> continue c - Nothing -> - use (cache . fetchedContracts . at addr) >>= \case - Just c -> do - assign (env . contracts . at addr) (Just c) - continue c - Nothing -> do - assign result . Just . VMFailure $ Query $ - PleaseFetchContract addr - (\c -> do assign (cache . fetchedContracts . at addr) (Just c) - assign (env . contracts . at addr) (Just c) - assign result Nothing - continue c) - -accessStorage - :: Addr -- ^ Contract address - -> Expr EWord -- ^ Storage slot key - -> (Expr EWord -> EVM ()) -- ^ Continuation - -> EVM () -accessStorage addr slot continue = do - store <- use (env . storage) - use (env . contracts . at addr) >>= \case - Just c -> - case readStorage (litAddr addr) slot store of - -- Notice that if storage is symbolic, we always continue straight away - Just x -> - continue x - Nothing -> - if c._external then - forceConcrete slot "cannot read symbolic slots via RPC" $ \litSlot -> do - -- check if the slot is cached - cachedStore <- use (cache . fetchedStorage) - case Map.lookup (num addr) cachedStore >>= Map.lookup litSlot of - Nothing -> mkQuery litSlot - Just val -> continue (Lit val) - else do - modifying (env . storage) (writeStorage (litAddr addr) slot (Lit 0)) - continue $ Lit 0 - Nothing -> - fetchAccount addr $ \_ -> - accessStorage addr slot continue - where - mkQuery s = assign result . Just . VMFailure . Query $ - PleaseFetchSlot addr s - (\x -> do - modifying (cache . fetchedStorage . ix (num addr)) (Map.insert s x) - modifying (env . storage) (writeStorage (litAddr addr) slot (Lit x)) - assign result Nothing - continue (Lit x)) - -accountExists :: Addr -> VM -> Bool -accountExists addr vm = - case Map.lookup addr vm._env._contracts of - Just c -> not (accountEmpty c) - Nothing -> False - --- EIP 161 -accountEmpty :: Contract -> Bool -accountEmpty c = - case c._contractcode of - RuntimeCode (ConcreteRuntimeCode "") -> True - RuntimeCode (SymbolicRuntimeCode b) -> null b - _ -> False - && c._nonce == 0 - && c._balance == 0 - --- * How to finalize a transaction -finalize :: EVM () -finalize = do - let - revertContracts = use (tx . txReversion) >>= assign (env . contracts) - revertSubstate = assign (tx . substate) (SubState mempty mempty mempty mempty mempty) - - use result >>= \case - Nothing -> - error "Finalising an unfinished tx." - Just (VMFailure (EVM.Revert _)) -> do - revertContracts - revertSubstate - Just (VMFailure _) -> do - -- burn remaining gas - assign (state . gas) 0 - revertContracts - revertSubstate - Just (VMSuccess output) -> do - -- deposit the code from a creation tx - pc' <- use (state . pc) - creation <- use (tx . isCreate) - createe <- use (state . contract) - createeExists <- (Map.member createe) <$> use (env . contracts) - let onContractCode contractCode = - when (creation && createeExists) $ replaceCode createe contractCode - case output of - ConcreteBuf bs -> - onContractCode $ RuntimeCode (ConcreteRuntimeCode bs) - _ -> - case Expr.toList output of - Nothing -> - vmError $ UnexpectedSymbolicArg pc' "runtime code cannot have an abstract lentgh" [output] - Just ops -> - onContractCode $ RuntimeCode (SymbolicRuntimeCode ops) - - -- compute and pay the refund to the caller and the - -- corresponding payment to the miner - txOrigin <- use (tx . origin) - sumRefunds <- (sum . (snd <$>)) <$> (use (tx . substate . refunds)) - miner <- use (block . coinbase) - blockReward <- num . (.r_block) <$> (use (block . schedule)) - gasPrice <- use (tx . gasprice) - priorityFee <- use (tx . txPriorityFee) - gasLimit <- use (tx . txgaslimit) - gasRemaining <- use (state . gas) - - let - gasUsed = gasLimit - gasRemaining - cappedRefund = min (quot gasUsed 5) (num sumRefunds) - originPay = (num $ gasRemaining + cappedRefund) * gasPrice - - minerPay = priorityFee * (num gasUsed) - - modifying (env . contracts) - (Map.adjust (over balance (+ originPay)) txOrigin) - modifying (env . contracts) - (Map.adjust (over balance (+ minerPay)) miner) - touchAccount miner - - -- pay out the block reward, recreating the miner if necessary - preuse (env . contracts . ix miner) >>= \case - Nothing -> modifying (env . contracts) - (Map.insert miner (initialContract (EVM.RuntimeCode (ConcreteRuntimeCode "")))) - Just _ -> noop - modifying (env . contracts) - (Map.adjust (over balance (+ blockReward)) miner) - - -- perform state trie clearing (EIP 161), of selfdestructs - -- and touched accounts. addresses are cleared if they have - -- a) selfdestructed, or - -- b) been touched and - -- c) are empty. - -- (see Yellow Paper "Accrued Substate") - -- - -- remove any destructed addresses - destroyedAddresses <- use (tx . substate . selfdestructs) - modifying (env . contracts) - (Map.filterWithKey (\k _ -> (k `notElem` destroyedAddresses))) - -- then, clear any remaining empty and touched addresses - touchedAddresses <- use (tx . substate . touchedAccounts) - modifying (env . contracts) - (Map.filterWithKey - (\k a -> not ((k `elem` touchedAddresses) && accountEmpty a))) - --- | Loads the selected contract as the current contract to execute -loadContract :: Addr -> EVM () -loadContract target = - preuse (env . contracts . ix target . contractcode) >>= - \case - Nothing -> - error "Call target doesn't exist" - Just targetCode -> do - assign (state . contract) target - assign (state . code) targetCode - assign (state . codeContract) target - -limitStack :: Int -> EVM () -> EVM () -limitStack n continue = do - stk <- use (state . stack) - if length stk + n > 1024 - then vmError EVM.StackLimitExceeded - else continue - -notStatic :: EVM () -> EVM () -notStatic continue = do - bad <- use (state . static) - if bad - then vmError StateChangeWhileStatic - else continue - --- | Burn gas, failing if insufficient gas is available -burn :: Word64 -> EVM () -> EVM () -burn n continue = do - available <- use (state . gas) - if n <= available - then do - state . gas -= n - burned += n - continue - else - vmError (OutOfGas available n) - -forceConcrete :: Expr EWord -> String -> (W256 -> EVM ()) -> EVM () -forceConcrete n msg continue = case maybeLitWord n of - Nothing -> do - vm <- get - vmError $ UnexpectedSymbolicArg vm._state._pc msg [n] - Just c -> continue c - -forceConcrete2 :: (Expr EWord, Expr EWord) -> String -> ((W256, W256) -> EVM ()) -> EVM () -forceConcrete2 (n,m) msg continue = case (maybeLitWord n, maybeLitWord m) of - (Just c, Just d) -> continue (c, d) - _ -> do - vm <- get - vmError $ UnexpectedSymbolicArg vm._state._pc msg [n, m] - -forceConcrete3 :: (Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256) -> EVM ()) -> EVM () -forceConcrete3 (k,n,m) msg continue = case (maybeLitWord k, maybeLitWord n, maybeLitWord m) of - (Just c, Just d, Just f) -> continue (c, d, f) - _ -> do - vm <- get - vmError $ UnexpectedSymbolicArg vm._state._pc msg [k, n, m] - -forceConcrete4 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256) -> EVM ()) -> EVM () -forceConcrete4 (k,l,n,m) msg continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord n, maybeLitWord m) of - (Just b, Just c, Just d, Just f) -> continue (b, c, d, f) - _ -> do - vm <- get - vmError $ UnexpectedSymbolicArg vm._state._pc msg [k, l, n, m] - -forceConcrete5 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256, W256) -> EVM ()) -> EVM () -forceConcrete5 (k,l,m,n,o) msg continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord m, maybeLitWord n, maybeLitWord o) of - (Just a, Just b, Just c, Just d, Just e) -> continue (a, b, c, d, e) - _ -> do - vm <- get - vmError $ UnexpectedSymbolicArg vm._state._pc msg [k, l, m, n, o] - -forceConcrete6 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256, W256, W256) -> EVM ()) -> EVM () -forceConcrete6 (k,l,m,n,o,p) msg continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord m, maybeLitWord n, maybeLitWord o, maybeLitWord p) of - (Just a, Just b, Just c, Just d, Just e, Just f) -> continue (a, b, c, d, e, f) - _ -> do - vm <- get - vmError $ UnexpectedSymbolicArg vm._state._pc msg [k, l, m, n, o, p] - -forceConcreteBuf :: Expr Buf -> String -> (ByteString -> EVM ()) -> EVM () -forceConcreteBuf (ConcreteBuf b) _ continue = continue b -forceConcreteBuf b msg _ = do - vm <- get - vmError $ UnexpectedSymbolicArg vm._state._pc msg [b] - --- * Substate manipulation -refund :: Word64 -> EVM () -refund n = do - self <- use (state . contract) - pushTo (tx . substate . refunds) (self, n) - -unRefund :: Word64 -> EVM () -unRefund n = do - self <- use (state . contract) - refs <- use (tx . substate . refunds) - assign (tx . substate . refunds) - (filter (\(a,b) -> not (a == self && b == n)) refs) - -touchAccount :: Addr -> EVM() -touchAccount = pushTo ((tx . substate) . touchedAccounts) - -selfdestruct :: Addr -> EVM() -selfdestruct = pushTo ((tx . substate) . selfdestructs) - -accessAndBurn :: Addr -> EVM () -> EVM () -accessAndBurn x cont = do - FeeSchedule {..} <- use ( block . schedule ) - acc <- accessAccountForGas x - let cost = if acc then g_warm_storage_read else g_cold_account_access - burn cost cont - --- | returns a wrapped boolean- if true, this address has been touched before in the txn (warm gas cost as in EIP 2929) --- otherwise cold -accessAccountForGas :: Addr -> EVM Bool -accessAccountForGas addr = do - accessedAddrs <- use (tx . substate . accessedAddresses) - let accessed = member addr accessedAddrs - assign (tx . substate . accessedAddresses) (insert addr accessedAddrs) - return accessed - --- | returns a wrapped boolean- if true, this slot has been touched before in the txn (warm gas cost as in EIP 2929) --- otherwise cold -accessStorageForGas :: Addr -> Expr EWord -> EVM Bool -accessStorageForGas addr key = do - accessedStrkeys <- use (tx . substate . accessedStorageKeys) - case maybeLitWord key of - Just litword -> do - let accessed = member (addr, litword) accessedStrkeys - assign (tx . substate . accessedStorageKeys) (insert (addr, litword) accessedStrkeys) - return accessed - _ -> return False - --- * Cheat codes - --- The cheat code is 7109709ecfa91a80626ff3989d68f67f5b1dd12d. --- Call this address using one of the cheatActions below to do --- special things, e.g. changing the block timestamp. Beware that --- these are necessarily hevm specific. -cheatCode :: Addr -cheatCode = num (keccak' "hevm cheat code") - -cheat - :: (?op :: Word8) - => (W256, W256) -> (W256, W256) - -> EVM () -cheat (inOffset, inSize) (outOffset, outSize) = do - mem <- use (state . memory) - vm <- get - let - abi = readBytes 4 (Lit inOffset) mem - input = readMemory (Lit $ inOffset + 4) (Lit $ inSize - 4) vm - case maybeLitWord abi of - Nothing -> vmError $ UnexpectedSymbolicArg vm._state._pc "symbolic cheatcode selector" [abi] - Just (fromIntegral -> abi') -> - case Map.lookup abi' cheatActions of - Nothing -> - vmError (BadCheatCode (Just abi')) - Just action -> do - action (Lit outOffset) (Lit outSize) input - next - push 1 - -type CheatAction = Expr EWord -> Expr EWord -> Expr Buf -> EVM () - -cheatActions :: Map Word32 CheatAction -cheatActions = - Map.fromList - [ action "ffi(string[])" $ - \sig outOffset outSize input -> do - vm <- get - if vm._allowFFI then - case decodeBuf [AbiArrayDynamicType AbiStringType] input of - CAbi valsArr -> case valsArr of - [AbiArrayDynamic AbiStringType strsV] -> - let - cmd = fmap - (\case - (AbiString a) -> unpack $ decodeUtf8 a - _ -> "") - (V.toList strsV) - cont bs = do - let encoded = ConcreteBuf bs - assign (state . returndata) encoded - copyBytesToMemory encoded outSize (Lit 0) outOffset - assign result Nothing - in assign result (Just . VMFailure . Query $ (PleaseDoFFI cmd cont)) - _ -> vmError (BadCheatCode sig) - _ -> vmError (BadCheatCode sig) - else - let msg = encodeUtf8 "ffi disabled: run again with --ffi if you want to allow tests to call external scripts" - in vmError . EVM.Revert . ConcreteBuf $ - abiMethod "Error(string)" (AbiTuple . V.fromList $ [AbiString msg]), - - action "warp(uint256)" $ - \sig _ _ input -> case decodeStaticArgs 0 1 input of - [x] -> assign (block . timestamp) x - _ -> vmError (BadCheatCode sig), - - action "roll(uint256)" $ - \sig _ _ input -> case decodeStaticArgs 0 1 input of - [x] -> forceConcrete x "cannot roll to a symbolic block number" (assign (block . number)) - _ -> vmError (BadCheatCode sig), - - action "store(address,bytes32,bytes32)" $ - \sig _ _ input -> case decodeStaticArgs 0 3 input of - [a, slot, new] -> - forceConcrete a "cannot store at a symbolic address" $ \(num -> a') -> - fetchAccount a' $ \_ -> do - modifying (env . storage) (writeStorage (litAddr a') slot new) - _ -> vmError (BadCheatCode sig), - - action "load(address,bytes32)" $ - \sig outOffset _ input -> case decodeStaticArgs 0 2 input of - [a, slot] -> - forceConcrete a "cannot load from a symbolic address" $ \(num -> a') -> - accessStorage a' slot $ \res -> do - assign (state . returndata . word256At (Lit 0)) res - assign (state . memory . word256At outOffset) res - _ -> vmError (BadCheatCode sig), - - action "sign(uint256,bytes32)" $ - \sig outOffset _ input -> case decodeStaticArgs 0 2 input of - [sk, hash] -> - forceConcrete2 (sk, hash) "cannot sign symbolic data" $ \(sk', hash') -> do - let (v,r,s) = EVM.Sign.sign hash' (toInteger sk') - encoded = encodeAbiValue $ - AbiTuple (RegularVector.fromList - [ AbiUInt 8 $ num v - , AbiBytes 32 (word256Bytes r) - , AbiBytes 32 (word256Bytes s) - ]) - assign (state . returndata) (ConcreteBuf encoded) - copyBytesToMemory (ConcreteBuf encoded) (Lit . num . BS.length $ encoded) (Lit 0) outOffset - _ -> vmError (BadCheatCode sig), - - action "addr(uint256)" $ - \sig outOffset _ input -> case decodeStaticArgs 0 1 input of - [sk] -> forceConcrete sk "cannot derive address for a symbolic key" $ \sk' -> do - let a = EVM.Sign.deriveAddr $ num sk' - case a of - Nothing -> vmError (BadCheatCode sig) - Just address -> do - let expAddr = litAddr address - assign (state . returndata . word256At (Lit 0)) expAddr - assign (state . memory . word256At outOffset) expAddr - _ -> vmError (BadCheatCode sig), - - action "prank(address)" $ - \sig _ _ input -> case decodeStaticArgs 0 1 input of - [addr] -> assign overrideCaller (Just addr) - _ -> vmError (BadCheatCode sig) - - ] - where - action s f = (abiKeccak s, f (Just $ abiKeccak s)) - --- | We don't wanna introduce the machinery needed to sign with a random nonce, --- so we just use the same nonce every time (420). This is obviusly very --- insecure, but fine for testing purposes. -ethsign :: PrivateKey -> Digest Crypto.Keccak_256 -> Signature -ethsign sk digest = go 420 - where - go k = case signDigestWith k sk digest of - Nothing -> go (k + 1) - Just sig -> sig - --- * General call implementation ("delegateCall") --- note that the continuation is ignored in the precompile case -delegateCall - :: (?op :: Word8) - => Contract -> Word64 -> Expr EWord -> Expr EWord -> W256 -> W256 -> W256 -> W256 -> W256 - -> [Expr EWord] - -> (Addr -> EVM ()) - -> EVM () -delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue = - forceConcrete2 (xTo, xContext) "cannot delegateCall with symbolic target or context" $ - \((num -> xTo'), (num -> xContext')) -> - if xTo' > 0 && xTo' <= 9 - then precompiledContract this gasGiven xTo' xContext' xValue xInOffset xInSize xOutOffset xOutSize xs - else if xTo' == cheatCode then - do - assign (state . stack) xs - cheat (xInOffset, xInSize) (xOutOffset, xOutSize) - else - callChecks this gasGiven xContext' xTo' xValue xInOffset xInSize xOutOffset xOutSize xs $ - \xGas -> do - vm0 <- get - fetchAccount xTo' $ \target -> - burn xGas $ do - let newContext = CallContext - { callContextTarget = xTo' - , callContextContext = xContext' - , callContextOffset = xOutOffset - , callContextSize = xOutSize - , callContextCodehash = target._codehash - , callContextReversion = (vm0._env._contracts, vm0._env._storage) - , callContextSubState = vm0._tx._substate - , callContextAbi = - if xInSize >= 4 - then case unlit $ readBytes 4 (Lit xInOffset) vm0._state._memory - of Nothing -> Nothing - Just abi -> Just $ num abi - else Nothing - , callContextData = (readMemory (Lit xInOffset) (Lit xInSize) vm0) - } - - pushTrace (FrameTrace newContext) - next - vm1 <- get - - pushTo frames $ Frame - { _frameState = vm1._state { _stack = xs } - , _frameContext = newContext - } - - let clearInitCode = \case - (InitCode _ _) -> InitCode mempty mempty - a -> a - - zoom state $ do - assign gas (num xGas) - assign pc 0 - assign code (clearInitCode target._contractcode) - assign codeContract xTo' - assign stack mempty - assign memory mempty - assign memorySize 0 - assign returndata mempty - assign calldata (copySlice (Lit xInOffset) (Lit 0) (Lit xInSize) vm0._state._memory mempty) - - continue xTo' - --- -- * Contract creation - --- EIP 684 -collision :: Maybe Contract -> Bool -collision c' = case c' of - Just c -> c._nonce /= 0 || case c._contractcode of - RuntimeCode (ConcreteRuntimeCode "") -> False - RuntimeCode (SymbolicRuntimeCode b) -> not $ null b - _ -> True - Nothing -> False - -create :: (?op :: Word8) - => Addr -> Contract - -> Word64 -> W256 -> [Expr EWord] -> Addr -> Expr Buf -> EVM () -create self this xGas' xValue xs newAddr initCode = do - vm0 <- get - let xGas = num xGas' - if this._nonce == num (maxBound :: Word64) - then do - assign (state . stack) (Lit 0 : xs) - assign (state . returndata) mempty - pushTrace $ ErrorTrace NonceOverflow - next - else if xValue > this._balance - then do - assign (state . stack) (Lit 0 : xs) - assign (state . returndata) mempty - pushTrace $ ErrorTrace $ BalanceTooLow xValue this._balance - next - else if length vm0._frames >= 1024 - then do - assign (state . stack) (Lit 0 : xs) - assign (state . returndata) mempty - pushTrace $ ErrorTrace CallDepthLimitReached - next - else if collision $ Map.lookup newAddr vm0._env._contracts - then burn xGas $ do - assign (state . stack) (Lit 0 : xs) - assign (state . returndata) mempty - modifying (env . contracts . ix self . nonce) succ - next - else burn xGas $ do - touchAccount self - touchAccount newAddr - let - -- unfortunately we have to apply some (pretty hacky) - -- heuristics here to parse the unstructured buffer read - -- from memory into a code and data section - -- TODO: comment explaining whats going on here - let contract' = do - prefixLen <- Expr.concPrefix initCode - prefix <- Expr.toList $ Expr.take (num prefixLen) initCode - let sym = Expr.drop (num prefixLen) initCode - conc <- mapM unlitByte prefix - pure $ InitCode (BS.pack $ V.toList conc) sym - case contract' of - Nothing -> - vmError $ UnexpectedSymbolicArg vm0._state._pc "initcode must have a concrete prefix" [] - Just c -> do - let - newContract = initialContract c - newContext = - CreationContext { creationContextAddress = newAddr - , creationContextCodehash = newContract._codehash - , creationContextReversion = vm0._env._contracts - , creationContextSubstate = vm0._tx._substate - } - - zoom (env . contracts) $ do - oldAcc <- use (at newAddr) - let oldBal = maybe 0 (._balance) oldAcc - - assign (at newAddr) (Just (newContract & balance .~ oldBal)) - modifying (ix self . nonce) succ - - let resetStorage = \case - ConcreteStore s -> ConcreteStore (Map.delete (num newAddr) s) - AbstractStore -> AbstractStore - EmptyStore -> EmptyStore - SStore {} -> error "trying to reset symbolic storage with writes in create" - GVar _ -> error "unexpected global variable" - - modifying (env . storage) resetStorage - modifying (env . origStorage) (Map.delete (num newAddr)) - - transfer self newAddr xValue - - pushTrace (FrameTrace newContext) - next - vm1 <- get - pushTo frames $ Frame - { _frameContext = newContext - , _frameState = vm1._state { _stack = xs } - } - - assign state $ - blankState - & set contract newAddr - & set codeContract newAddr - & set code c - & set callvalue (Lit xValue) - & set caller (litAddr self) - & set gas xGas' - --- | Replace a contract's code, like when CREATE returns --- from the constructor code. -replaceCode :: Addr -> ContractCode -> EVM () -replaceCode target newCode = - zoom (env . contracts . at target) $ - get >>= \case - Just now -> case now._contractcode of - InitCode _ _ -> - put . Just $ - (initialContract newCode) - { _balance = now._balance - , _nonce = now._nonce - } - RuntimeCode _ -> - error ("internal error: can't replace code of deployed contract " <> show target) - Nothing -> - error "internal error: can't replace code of nonexistent contract" - -replaceCodeOfSelf :: ContractCode -> EVM () -replaceCodeOfSelf newCode = do - vm <- get - replaceCode vm._state._contract newCode - -resetState :: EVM () -resetState = do - assign result Nothing - assign frames [] - assign state blankState - - --- * VM error implementation - -vmError :: Error -> EVM () -vmError e = finishFrame (FrameErrored e) - -underrun :: EVM () -underrun = vmError EVM.StackUnderrun - --- | A stack frame can be popped in three ways. -data FrameResult - = FrameReturned (Expr Buf) -- ^ STOP, RETURN, or no more code - | FrameReverted (Expr Buf) -- ^ REVERT - | FrameErrored Error -- ^ Any other error - deriving Show - --- | This function defines how to pop the current stack frame in either of --- the ways specified by 'FrameResult'. --- --- It also handles the case when the current stack frame is the only one; --- in this case, we set the final '_result' of the VM execution. -finishFrame :: FrameResult -> EVM () -finishFrame how = do - oldVm <- get - - case oldVm._frames of - -- Is the current frame the only one? - [] -> do - case how of - FrameReturned output -> assign result . Just $ VMSuccess output - FrameReverted buffer -> assign result . Just $ VMFailure (EVM.Revert buffer) - FrameErrored e -> assign result . Just $ VMFailure e - finalize - - -- Are there some remaining frames? - nextFrame : remainingFrames -> do - - -- Insert a debug trace. - insertTrace $ - case how of - FrameErrored e -> - ErrorTrace e - FrameReverted e -> - ErrorTrace (EVM.Revert e) - FrameReturned output -> - ReturnTrace output nextFrame._frameContext - -- Pop to the previous level of the debug trace stack. - popTrace - - -- Pop the top frame. - assign frames remainingFrames - -- Install the state of the frame to which we shall return. - assign state nextFrame._frameState - - -- When entering a call, the gas allowance is counted as burned - -- in advance; this unburns the remainder and adds it to the - -- parent frame. - let remainingGas = oldVm._state._gas - reclaimRemainingGasAllowance = do - modifying burned (subtract remainingGas) - modifying (state . gas) (+ remainingGas) - - -- Now dispatch on whether we were creating or calling, - -- and whether we shall return, revert, or error (six cases). - case nextFrame._frameContext of - - -- Were we calling? - CallContext _ _ (Lit -> outOffset) (Lit -> outSize) _ _ _ reversion substate' -> do - - -- Excerpt K.1. from the yellow paper: - -- K.1. Deletion of an Account Despite Out-of-gas. - -- At block 2675119, in the transaction 0xcf416c536ec1a19ed1fb89e4ec7ffb3cf73aa413b3aa9b77d60e4fd81a4296ba, - -- an account at address 0x03 was called and an out-of-gas occurred during the call. - -- Against the equation (197), this added 0x03 in the set of touched addresses, and this transaction turned σ[0x03] into ∅. - - -- In other words, we special case address 0x03 and keep it in the set of touched accounts during revert - touched <- use (tx . substate . touchedAccounts) - - let - substate'' = over touchedAccounts (maybe id cons (find (3 ==) touched)) substate' - (contractsReversion, storageReversion) = reversion - revertContracts = assign (env . contracts) contractsReversion - revertStorage = assign (env . storage) storageReversion - revertSubstate = assign (tx . substate) substate'' - - case how of - -- Case 1: Returning from a call? - FrameReturned output -> do - assign (state . returndata) output - copyCallBytesToMemory output outSize (Lit 0) outOffset - reclaimRemainingGasAllowance - push 1 - - -- Case 2: Reverting during a call? - FrameReverted output -> do - revertContracts - revertStorage - revertSubstate - assign (state . returndata) output - copyCallBytesToMemory output outSize (Lit 0) outOffset - reclaimRemainingGasAllowance - push 0 - - -- Case 3: Error during a call? - FrameErrored _ -> do - revertContracts - revertStorage - revertSubstate - assign (state . returndata) mempty - push 0 - -- Or were we creating? - CreationContext _ _ reversion substate' -> do - creator <- use (state . contract) - let - createe = oldVm._state._contract - revertContracts = assign (env . contracts) reversion' - revertSubstate = assign (tx . substate) substate' - - -- persist the nonce through the reversion - reversion' = (Map.adjust (over nonce (+ 1)) creator) reversion - - case how of - -- Case 4: Returning during a creation? - FrameReturned output -> do - let onContractCode contractCode = do - replaceCode createe contractCode - assign (state . returndata) mempty - reclaimRemainingGasAllowance - push (num createe) - case output of - ConcreteBuf bs -> - onContractCode $ RuntimeCode (ConcreteRuntimeCode bs) - _ -> - case Expr.toList output of - Nothing -> vmError $ - UnexpectedSymbolicArg - oldVm._state._pc - "runtime code cannot have an abstract length" - [output] - Just newCode -> do - onContractCode $ RuntimeCode (SymbolicRuntimeCode newCode) - - -- Case 5: Reverting during a creation? - FrameReverted output -> do - revertContracts - revertSubstate - assign (state . returndata) output - reclaimRemainingGasAllowance - push 0 - - -- Case 6: Error during a creation? - FrameErrored _ -> do - revertContracts - revertSubstate - assign (state . returndata) mempty - push 0 - - --- * Memory helpers - -accessUnboundedMemoryRange - :: Word64 - -> Word64 - -> EVM () - -> EVM () -accessUnboundedMemoryRange _ 0 continue = continue -accessUnboundedMemoryRange f l continue = do - m0 <- num <$> use (state . memorySize) - fees <- gets (._block._schedule) - do - let m1 = 32 * ceilDiv (max m0 (f + l)) 32 - burn (memoryCost fees m1 - memoryCost fees m0) $ do - assign (state . memorySize) m1 - continue - -accessMemoryRange - :: W256 - -> W256 - -> EVM () - -> EVM () -accessMemoryRange _ 0 continue = continue -accessMemoryRange f l continue = - case (,) <$> toWord64 f <*> toWord64 l of - Nothing -> vmError IllegalOverflow - Just (f64, l64) -> - if f64 + l64 < l64 - then vmError IllegalOverflow - else accessUnboundedMemoryRange f64 l64 continue - -accessMemoryWord - :: W256 -> EVM () -> EVM () -accessMemoryWord x = accessMemoryRange x 32 - -copyBytesToMemory - :: Expr Buf -> Expr EWord -> Expr EWord -> Expr EWord -> EVM () -copyBytesToMemory bs size xOffset yOffset = - if size == (Lit 0) then noop - else do - mem <- use (state . memory) - assign (state . memory) $ - copySlice xOffset yOffset size bs mem - -copyCallBytesToMemory - :: Expr Buf -> Expr EWord -> Expr EWord -> Expr EWord -> EVM () -copyCallBytesToMemory bs size xOffset yOffset = - if size == (Lit 0) then noop - else do - mem <- use (state . memory) - assign (state . memory) $ - copySlice xOffset yOffset (Expr.min size (bufLength bs)) bs mem - -readMemory :: Expr EWord -> Expr EWord -> VM -> Expr Buf -readMemory offset size vm = copySlice offset (Lit 0) size vm._state._memory mempty - --- * Tracing - -withTraceLocation :: TraceData -> EVM Trace -withTraceLocation x = do - vm <- get - let this = fromJust $ currentContract vm - pure Trace - { _traceData = x - , _traceContract = this - , _traceOpIx = fromMaybe 0 $ this._opIxMap Vector.!? vm._state._pc - } - -pushTrace :: TraceData -> EVM () -pushTrace x = do - trace <- withTraceLocation x - modifying traces $ - \t -> Zipper.children $ Zipper.insert (Node trace []) t - -insertTrace :: TraceData -> EVM () -insertTrace x = do - trace <- withTraceLocation x - modifying traces $ - \t -> Zipper.nextSpace $ Zipper.insert (Node trace []) t - -popTrace :: EVM () -popTrace = - modifying traces $ - \t -> case Zipper.parent t of - Nothing -> error "internal error (trace root)" - Just t' -> Zipper.nextSpace t' - -zipperRootForest :: Zipper.TreePos Zipper.Empty a -> Forest a -zipperRootForest z = - case Zipper.parent z of - Nothing -> Zipper.toForest z - Just z' -> zipperRootForest (Zipper.nextSpace z') - -traceForest :: VM -> Forest Trace -traceForest vm = zipperRootForest vm._traces - -traceTopLog :: [Expr Log] -> EVM () -traceTopLog [] = noop -traceTopLog ((LogEntry addr bytes topics) : _) = do - trace <- withTraceLocation (EventTrace addr bytes topics) - modifying traces $ - \t -> Zipper.nextSpace (Zipper.insert (Node trace []) t) -traceTopLog ((GVar _) : _) = error "unexpected global variable" - --- * Stack manipulation - -push :: W256 -> EVM () -push = pushSym . Lit - -pushSym :: Expr EWord -> EVM () -pushSym x = state . stack %= (x :) - - -stackOp1 - :: (?op :: Word8) - => Word64 - -> ((Expr EWord) -> (Expr EWord)) - -> EVM () -stackOp1 cost f = - use (state . stack) >>= \case - (x:xs) -> - burn cost $ do - next - let !y = f x - state . stack .= y : xs - _ -> - underrun - -stackOp2 - :: (?op :: Word8) - => Word64 - -> (((Expr EWord), (Expr EWord)) -> (Expr EWord)) - -> EVM () -stackOp2 cost f = - use (state . stack) >>= \case - (x:y:xs) -> - burn cost $ do - next - state . stack .= f (x, y) : xs - _ -> - underrun - -stackOp3 - :: (?op :: Word8) - => Word64 - -> (((Expr EWord), (Expr EWord), (Expr EWord)) -> (Expr EWord)) - -> EVM () -stackOp3 cost f = - use (state . stack) >>= \case - (x:y:z:xs) -> - burn cost $ do - next - state . stack .= f (x, y, z) : xs - _ -> - underrun - --- * Bytecode data functions - -checkJump :: Int -> [Expr EWord] -> EVM () -checkJump x xs = do - theCode <- use (state . code) - self <- use (state . codeContract) - theCodeOps <- use (env . contracts . ix self . codeOps) - theOpIxMap <- use (env . contracts . ix self . opIxMap) - let op = case theCode of - InitCode ops _ -> BS.indexMaybe ops x - RuntimeCode (ConcreteRuntimeCode ops) -> BS.indexMaybe ops x - RuntimeCode (SymbolicRuntimeCode ops) -> ops V.!? x >>= unlitByte - case op of - Nothing -> vmError EVM.BadJumpDestination - Just b -> - if 0x5b == b && OpJumpdest == snd (theCodeOps RegularVector.! (theOpIxMap Vector.! num x)) - then do - state . stack .= xs - state . pc .= num x - else - vmError EVM.BadJumpDestination - -opSize :: Word8 -> Int -opSize x | x >= 0x60 && x <= 0x7f = num x - 0x60 + 2 -opSize _ = 1 - --- i of the resulting vector contains the operation index for --- the program counter value i. This is needed because source map --- entries are per operation, not per byte. -mkOpIxMap :: ContractCode -> Vector Int -mkOpIxMap (InitCode conc _) - = Vector.create $ Vector.new (BS.length conc) >>= \v -> - -- Loop over the byte string accumulating a vector-mutating action. - -- This is somewhat obfuscated, but should be fast. - let (_, _, _, m) = BS.foldl' (go v) (0 :: Word8, 0, 0, return ()) conc - in m >> return v - where - -- concrete case - go v (0, !i, !j, !m) x | x >= 0x60 && x <= 0x7f = - {- Start of PUSH op. -} (x - 0x60 + 1, i + 1, j, m >> Vector.write v i j) - go v (1, !i, !j, !m) _ = - {- End of PUSH op. -} (0, i + 1, j + 1, m >> Vector.write v i j) - go v (0, !i, !j, !m) _ = - {- Other op. -} (0, i + 1, j + 1, m >> Vector.write v i j) - go v (n, !i, !j, !m) _ = - {- PUSH data. -} (n - 1, i + 1, j, m >> Vector.write v i j) - -mkOpIxMap (RuntimeCode (ConcreteRuntimeCode ops)) = - mkOpIxMap (InitCode ops mempty) -- a bit hacky - -mkOpIxMap (RuntimeCode (SymbolicRuntimeCode ops)) - = Vector.create $ Vector.new (length ops) >>= \v -> - let (_, _, _, m) = foldl (go v) (0, 0, 0, return ()) (stripBytecodeMetadataSym $ V.toList ops) - in m >> return v - where - go v (0, !i, !j, !m) x = case unlitByte x of - Just x' -> if x' >= 0x60 && x' <= 0x7f - -- start of PUSH op -- - then (x' - 0x60 + 1, i + 1, j, m >> Vector.write v i j) - -- other data -- - else (0, i + 1, j + 1, m >> Vector.write v i j) - _ -> error $ "cannot analyze symbolic code:\nx: " <> show x <> " i: " <> show i <> " j: " <> show j - - go v (1, !i, !j, !m) _ = - {- End of PUSH op. -} (0, i + 1, j + 1, m >> Vector.write v i j) - go v (n, !i, !j, !m) _ = - {- PUSH data. -} (n - 1, i + 1, j, m >> Vector.write v i j) - - -vmOp :: VM -> Maybe Op -vmOp vm = - let i = vm ^. state . pc - code' = vm ^. state . code - (op, pushdata) = case code' of - InitCode xs' _ -> - (BS.index xs' i, fmap LitByte $ BS.unpack $ BS.drop i xs') - RuntimeCode (ConcreteRuntimeCode xs') -> - (BS.index xs' i, fmap LitByte $ BS.unpack $ BS.drop i xs') - RuntimeCode (SymbolicRuntimeCode xs') -> - ( fromMaybe (error "unexpected symbolic code") . unlitByte $ xs' V.! i , V.toList $ V.drop i xs') - in if (opslen code' < i) - then Nothing - else Just (readOp op pushdata) - -vmOpIx :: VM -> Maybe Int -vmOpIx vm = - do self <- currentContract vm - self._opIxMap Vector.!? vm._state._pc - -opParams :: VM -> Map String (Expr EWord) -opParams vm = - case vmOp vm of - Just OpCreate -> - params $ words "value offset size" - Just OpCall -> - params $ words "gas to value in-offset in-size out-offset out-size" - Just OpSstore -> - params $ words "index value" - Just OpCodecopy -> - params $ words "mem-offset code-offset code-size" - Just OpSha3 -> - params $ words "offset size" - Just OpCalldatacopy -> - params $ words "to from size" - Just OpExtcodecopy -> - params $ words "account mem-offset code-offset code-size" - Just OpReturn -> - params $ words "offset size" - Just OpJumpi -> - params $ words "destination condition" - _ -> mempty - where - params xs = - if length (vm ^. state . stack) >= length xs - then Map.fromList (zip xs (vm ^. state . stack)) - else mempty - --- Maps operation indicies into a pair of (bytecode index, operation) -mkCodeOps :: ContractCode -> RegularVector.Vector (Int, Op) -mkCodeOps contractCode = - let l = case contractCode of - InitCode bytes _ -> - LitByte <$> (BS.unpack bytes) - RuntimeCode (ConcreteRuntimeCode ops) -> - LitByte <$> (BS.unpack $ stripBytecodeMetadata ops) - RuntimeCode (SymbolicRuntimeCode ops) -> - stripBytecodeMetadataSym $ V.toList ops - in RegularVector.fromList . toList $ go 0 l - where - go !i !xs = - case uncons xs of - Nothing -> - mempty - Just (x, xs') -> - let x' = fromMaybe (error "unexpected symbolic code argument") $ unlitByte x - j = opSize x' - in (i, readOp x' xs') Seq.<| go (i + j) (drop j xs) - --- * Gas cost calculation helpers - --- Gas cost function for CALL, transliterated from the Yellow Paper. -costOfCall - :: FeeSchedule Word64 - -> Bool -> W256 -> Word64 -> Word64 -> Addr - -> EVM (Word64, Word64) -costOfCall (FeeSchedule {..}) recipientExists xValue availableGas xGas target = do - acc <- accessAccountForGas target - let call_base_gas = if acc then g_warm_storage_read else g_cold_account_access - c_new = if not recipientExists && xValue /= 0 - then g_newaccount - else 0 - c_xfer = if xValue /= 0 then num g_callvalue else 0 - c_extra = call_base_gas + c_xfer + c_new - c_gascap = if availableGas >= c_extra - then min xGas (allButOne64th (availableGas - c_extra)) - else xGas - c_callgas = if xValue /= 0 then c_gascap + g_callstipend else c_gascap - return (c_gascap + c_extra, c_callgas) - --- Gas cost of create, including hash cost if needed -costOfCreate - :: FeeSchedule Word64 - -> Word64 -> W256 -> (Word64, Word64) -costOfCreate (FeeSchedule {..}) availableGas hashSize = - (createCost + initGas, initGas) - where - createCost = g_create + hashCost - hashCost = g_sha3word * ceilDiv (num hashSize) 32 - initGas = allButOne64th (availableGas - createCost) - -concreteModexpGasFee :: ByteString -> Word64 -concreteModexpGasFee input = - if lenb < num (maxBound :: Word32) && - (lene < num (maxBound :: Word32) || (lenb == 0 && lenm == 0)) && - lenm < num (maxBound :: Word64) - then - max 200 ((multiplicationComplexity * iterCount) `div` 3) - else - maxBound -- TODO: this is not 100% correct, return Nothing on overflow - where (lenb, lene, lenm) = parseModexpLength input - ez = isZero (96 + lenb) lene input - e' = word $ LS.toStrict $ - lazySlice (96 + lenb) (min 32 lene) input - nwords :: Word64 - nwords = ceilDiv (num $ max lenb lenm) 8 - multiplicationComplexity = nwords * nwords - iterCount' :: Word64 - iterCount' | lene <= 32 && ez = 0 - | lene <= 32 = num (log2 e') - | e' == 0 = 8 * (num lene - 32) - | otherwise = num (log2 e') + 8 * (num lene - 32) - iterCount = max iterCount' 1 - --- Gas cost of precompiles -costOfPrecompile :: FeeSchedule Word64 -> Addr -> Expr Buf -> Word64 -costOfPrecompile (FeeSchedule {..}) precompileAddr input = - let errorDynamicSize = error "precompile input cannot have a dynamic size" - inputLen = case input of - ConcreteBuf bs -> fromIntegral $ BS.length bs - AbstractBuf _ -> errorDynamicSize - buf -> case bufLength buf of - Lit l -> num l -- TODO: overflow - _ -> errorDynamicSize - in case precompileAddr of - -- ECRECOVER - 0x1 -> 3000 - -- SHA2-256 - 0x2 -> num $ (((inputLen + 31) `div` 32) * 12) + 60 - -- RIPEMD-160 - 0x3 -> num $ (((inputLen + 31) `div` 32) * 120) + 600 - -- IDENTITY - 0x4 -> num $ (((inputLen + 31) `div` 32) * 3) + 15 - -- MODEXP - 0x5 -> case input of - ConcreteBuf i -> concreteModexpGasFee i - _ -> error "Unsupported symbolic modexp gas calc " - -- ECADD - 0x6 -> g_ecadd - -- ECMUL - 0x7 -> g_ecmul - -- ECPAIRING - 0x8 -> (inputLen `div` 192) * g_pairing_point + g_pairing_base - -- BLAKE2 - 0x9 -> case input of - ConcreteBuf i -> g_fround * (num $ asInteger $ lazySlice 0 4 i) - _ -> error "Unsupported symbolic blake2 gas calc" - _ -> error ("unimplemented precompiled contract " ++ show precompileAddr) - --- Gas cost of memory expansion -memoryCost :: FeeSchedule Word64 -> Word64 -> Word64 -memoryCost FeeSchedule{..} byteCount = - let - wordCount = ceilDiv byteCount 32 - linearCost = g_memory * wordCount - quadraticCost = div (wordCount * wordCount) 512 - in - linearCost + quadraticCost - --- * Arithmetic - -ceilDiv :: (Num a, Integral a) => a -> a -> a -ceilDiv m n = div (m + n - 1) n - -allButOne64th :: (Num a, Integral a) => a -> a -allButOne64th n = n - div n 64 - -log2 :: FiniteBits b => b -> Int -log2 x = finiteBitSize x - 1 - countLeadingZeros x - -hashcode :: ContractCode -> Expr EWord -hashcode (InitCode ops args) = keccak $ (ConcreteBuf ops) <> args -hashcode (RuntimeCode (ConcreteRuntimeCode ops)) = keccak (ConcreteBuf ops) -hashcode (RuntimeCode (SymbolicRuntimeCode ops)) = keccak . Expr.fromList $ ops - --- | The length of the code ignoring any constructor args. --- This represents the region that can contain executable opcodes -opslen :: ContractCode -> Int -opslen (InitCode ops _) = BS.length ops -opslen (RuntimeCode (ConcreteRuntimeCode ops)) = BS.length ops -opslen (RuntimeCode (SymbolicRuntimeCode ops)) = length ops - --- | The length of the code including any constructor args. --- This can return an abstract value -codelen :: ContractCode -> Expr EWord -codelen c@(InitCode {}) = bufLength $ toBuf c -codelen (RuntimeCode (ConcreteRuntimeCode ops)) = Lit . num $ BS.length ops -codelen (RuntimeCode (SymbolicRuntimeCode ops)) = Lit . num $ length ops - -toBuf :: ContractCode -> Expr Buf -toBuf (InitCode ops args) = ConcreteBuf ops <> args -toBuf (RuntimeCode (ConcreteRuntimeCode ops)) = ConcreteBuf ops -toBuf (RuntimeCode (SymbolicRuntimeCode ops)) = Expr.fromList ops - - -codeloc :: EVM CodeLocation -codeloc = do - vm <- get - let self = vm._state._contract - loc = vm._state._pc - pure (self, loc) - --- * Emacs setup - --- Local Variables: --- outline-regexp: "-- \\*+\\|data \\|newtype \\|type \\| +-- op: " --- outline-heading-alist: --- (("-- *" . 1) ("data " . 2) ("newtype " . 2) ("type " . 2)) --- compile-command: "make" --- End: +{-# Language UndecidableInstances #-} +{-# Language TemplateHaskell #-} +{-# Language ScopedTypeVariables #-} +{-# Language GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeApplications #-} + +module EVM where + +import Prelude hiding (log, exponent, GT, LT) + +import Optics.Core +import Optics.TH +import Optics.State +import Optics.State.Operators +import Optics.Zoom +import Optics.Operators.Unsafe + +import EVM.ABI +import EVM.Concrete (createAddress, create2Address) +import EVM.Expr (readStorage, writeStorage, readByte, readWord, writeWord, + writeByte, bufLength, indexWord, litAddr, readBytes, word256At, copySlice) +import EVM.Expr qualified as Expr +import EVM.FeeSchedule (FeeSchedule (..)) +import EVM.Op +import EVM.Precompiled qualified +import EVM.Solidity +import EVM.Types hiding (IllegalOverflow, Error) +import EVM.Sign qualified + +import Control.Monad.State.Strict hiding (state) +import Data.Bits (FiniteBits, countLeadingZeros, finiteBitSize) +import Data.ByteArray qualified as BA +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy (fromStrict) +import Data.ByteString.Lazy qualified as LS +import Data.ByteString.Char8 qualified as Char8 +import Data.Foldable (toList) +import Data.List (find) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, fromJust) +import Data.Set (Set, insert, member, fromList) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Text (unpack) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Tree +import Data.Tree.Zipper qualified as Zipper +import Data.Tuple.Curry +import Data.Vector qualified as RegularVector +import Data.Vector qualified as V +import Data.Vector.Storable (Vector) +import Data.Vector.Storable qualified as Vector +import Data.Vector.Storable.Mutable qualified as Vector +import Data.Word (Word8, Word32, Word64) +import Options.Generic as Options + +import Crypto.Hash (Digest, SHA256, RIPEMD160) +import Crypto.Hash qualified as Crypto +import Crypto.Number.ModArithmetic (expFast) + +-- * Data types + +-- | EVM failure modes +data Error + = BalanceTooLow W256 W256 + | UnrecognizedOpcode Word8 + | SelfDestruction + | StackUnderrun + | BadJumpDestination + | Revert (Expr Buf) + | OutOfGas Word64 Word64 + | BadCheatCode FunctionSelector + | StackLimitExceeded + | IllegalOverflow + | Query Query + | Choose Choose + | StateChangeWhileStatic + | InvalidMemoryAccess + | CallDepthLimitReached + | MaxCodeSizeExceeded W256 W256 + | InvalidFormat + | PrecompileFailure + | forall a . UnexpectedSymbolicArg Int String [Expr a] + | DeadPath + | NotUnique (Expr EWord) + | SMTTimeout + | FFI [AbiValue] + | ReturnDataOutOfBounds + | NonceOverflow +deriving instance Show Error + +-- | The possible result states of a VM +data VMResult + = VMFailure Error -- ^ An operation failed + | VMSuccess (Expr Buf) -- ^ Reached STOP, RETURN, or end-of-code + +deriving instance Show VMResult + +-- | The state of a stepwise EVM execution +data VM = VM + { result :: Maybe VMResult + , state :: FrameState + , frames :: [Frame] + , env :: Env + , block :: Block + , tx :: TxState + , logs :: [Expr Log] + , traces :: Zipper.TreePos Zipper.Empty Trace + , cache :: Cache + , burned :: {-# UNPACK #-} !Word64 + , iterations :: Map CodeLocation Int + , constraints :: [Prop] + , keccakEqs :: [Prop] + , allowFFI :: Bool + , overrideCaller :: Maybe Addr + } + deriving (Show, Generic) + +data Trace = Trace + { opIx :: Int + , contract :: Contract + , tracedata :: TraceData + } + deriving (Show, Generic) + +data TraceData + = EventTrace (Expr EWord) (Expr Buf) [Expr EWord] + | FrameTrace FrameContext + | QueryTrace Query + | ErrorTrace Error + | EntryTrace Text + | ReturnTrace (Expr Buf) FrameContext + deriving (Show, Generic) + +-- | Queries halt execution until resolved through RPC calls or SMT queries +data Query where + PleaseFetchContract :: Addr -> (Contract -> EVM ()) -> Query + PleaseFetchSlot :: Addr -> W256 -> (W256 -> EVM ()) -> Query + PleaseAskSMT :: Expr EWord -> [Prop] -> (BranchCondition -> EVM ()) -> Query + PleaseDoFFI :: [String] -> (ByteString -> EVM ()) -> Query + +data Choose where + PleaseChoosePath :: Expr EWord -> (Bool -> EVM ()) -> Choose + +instance Show Query where + showsPrec _ = \case + PleaseFetchContract addr _ -> + (("") ++) + PleaseFetchSlot addr slot _ -> + (("") ++) + PleaseAskSMT condition constraints _ -> + (("") ++) + PleaseDoFFI cmd _ -> + ((" + ((" b = Cache + { fetchedContracts = Map.unionWith unifyCachedContract a.fetchedContracts b.fetchedContracts + , fetchedStorage = Map.unionWith unifyCachedStorage a.fetchedStorage b.fetchedStorage + , path = mappend a.path b.path + } + +unifyCachedStorage :: Map W256 W256 -> Map W256 W256 -> Map W256 W256 +unifyCachedStorage _ _ = undefined + +-- only intended for use in Cache merges, where we expect +-- everything to be Concrete +unifyCachedContract :: Contract -> Contract -> Contract +unifyCachedContract _ _ = undefined + {- +unifyCachedContract a b = a & set storage merged + where merged = case (view storage a, view storage b) of + (ConcreteStore sa, ConcreteStore sb) -> + ConcreteStore (mappend sa sb) + _ -> + view storage a + -} + +instance Monoid Cache where + mempty = Cache { fetchedContracts = mempty, + fetchedStorage = mempty, + path = mempty + } + +-- * Data accessors + +currentContract :: VM -> Maybe Contract +currentContract vm = + Map.lookup vm.state.codeContract vm.env.contracts + +-- * Data constructors + +makeVm :: VMOpts -> VM +makeVm o = + let txaccessList = o.txAccessList + txorigin = o.origin + txtoAddr = o.address + initialAccessedAddrs = fromList $ [txorigin, txtoAddr] ++ [1..9] ++ (Map.keys txaccessList) + initialAccessedStorageKeys = fromList $ foldMap (uncurry (map . (,))) (Map.toList txaccessList) + touched = if o.create then [txorigin] else [txorigin, txtoAddr] + in + VM + { result = Nothing + , frames = mempty + , tx = TxState + { gasprice = o.gasprice + , gaslimit = o.gaslimit + , priorityFee = o.priorityFee + , origin = txorigin + , toAddr = txtoAddr + , value = o.value + , substate = SubState mempty touched initialAccessedAddrs initialAccessedStorageKeys mempty + --, _accessList = txaccessList + , isCreate = o.create + , txReversion = Map.fromList + [(o.address , o.contract )] + } + , logs = [] + , traces = Zipper.fromForest [] + , block = Block + { coinbase = o.coinbase + , timestamp = o.timestamp + , number = o.number + , prevRandao = o.prevRandao + , maxCodeSize = o.maxCodeSize + , gaslimit = o.blockGaslimit + , baseFee = o.baseFee + , schedule = o.schedule + } + , state = FrameState + { pc = 0 + , stack = mempty + , memory = mempty + , memorySize = 0 + , code = o.contract.contractcode + , contract = o.address + , codeContract = o.address + , calldata = fst o.calldata + , callvalue = o.value + , caller = o.caller + , gas = o.gas + , returndata = mempty + , static = False + } + , env = Env + { sha3Crack = mempty + , chainId = o.chainId + , storage = o.initialStorage + , origStorage = mempty + , contracts = Map.fromList + [(o.address, o.contract )] + } + , cache = Cache mempty mempty mempty + , burned = 0 + , constraints = snd o.calldata + , keccakEqs = mempty + , iterations = mempty + , allowFFI = o.allowFFI + , overrideCaller = Nothing + } + +-- | Initialize empty contract with given code +initialContract :: ContractCode -> Contract +initialContract contractCode = Contract + { contractcode = contractCode + , codehash = hashcode contractCode + , balance = 0 + , nonce = if creation then 1 else 0 + , opIxMap = mkOpIxMap contractCode + , codeOps = mkCodeOps contractCode + , external = False + } where + creation = case contractCode of + InitCode _ _ -> True + RuntimeCode _ -> False + +-- * Opcode dispatch (exec1) + +-- | Update program counter +next :: (?op :: Word8) => EVM () +next = modifying (#state % #pc) (+ (opSize ?op)) + +-- | Executes the EVM one step +exec1 :: EVM () +exec1 = do + vm <- get + + let + -- Convenient aliases + mem = vm.state.memory + stk = vm.state.stack + self = vm.state.contract + this = fromMaybe (error "internal error: state contract") (Map.lookup self vm.env.contracts) + + fees@FeeSchedule {..} = vm.block.schedule + + doStop = finishFrame (FrameReturned mempty) + + if self > 0x0 && self <= 0x9 then do + -- call to precompile + let ?op = 0x00 -- dummy value + case bufLength vm.state.calldata of + Lit calldatasize -> do + copyBytesToMemory vm.state.calldata (Lit calldatasize) (Lit 0) (Lit 0) + executePrecompile self vm.state.gas 0 calldatasize 0 0 [] + vmx <- get + case vmx.state.stack of + x:_ -> case x of + Lit 0 -> + fetchAccount self $ \_ -> do + touchAccount self + vmError PrecompileFailure + Lit _ -> + fetchAccount self $ \_ -> do + touchAccount self + out <- use (#state % #returndata) + finishFrame (FrameReturned out) + e -> vmError $ + UnexpectedSymbolicArg vmx.state.pc "precompile returned a symbolic value" [e] + _ -> + underrun + e -> vmError $ UnexpectedSymbolicArg vm.state.pc "cannot call precompiles with symbolic data" [e] + + else if vm.state.pc >= opslen vm.state.code + then doStop + + else do + let ?op = case vm.state.code of + InitCode conc _ -> BS.index conc vm.state.pc + RuntimeCode (ConcreteRuntimeCode bs) -> BS.index bs vm.state.pc + RuntimeCode (SymbolicRuntimeCode ops) -> + fromMaybe (error "could not analyze symbolic code") $ + unlitByte $ ops V.! vm.state.pc + + case getOp(?op) of + + OpPush n' -> do + let n = fromIntegral n' + !xs = case vm.state.code of + InitCode conc _ -> Lit $ word $ padRight n $ BS.take n (BS.drop (1 + vm.state.pc) conc) + RuntimeCode (ConcreteRuntimeCode bs) -> Lit $ word $ BS.take n $ BS.drop (1 + vm.state.pc) bs + RuntimeCode (SymbolicRuntimeCode ops) -> + let bytes = V.take n $ V.drop (1 + vm.state.pc) ops + in readWord (Lit 0) $ Expr.fromList $ padLeft' 32 bytes + limitStack 1 $ + burn g_verylow $ do + next + pushSym xs + + OpDup i -> + case preview (ix (fromIntegral i - 1)) stk of + Nothing -> underrun + Just y -> + limitStack 1 $ + burn g_verylow $ do + next + pushSym y + + OpSwap i -> + if length stk < (fromIntegral i) + 1 + then underrun + else + burn g_verylow $ do + next + zoom (#state % #stack) $ do + assign (ix 0) (stk ^?! ix (fromIntegral i)) + assign (ix (fromIntegral i)) (stk ^?! ix 0) + + OpLog n -> + notStatic $ + case stk of + (xOffset':xSize':xs) -> + if length xs < (fromIntegral n) + then underrun + else + forceConcrete2 (xOffset', xSize') "LOG" $ \(xOffset, xSize) -> do + let (topics, xs') = splitAt (fromIntegral n) xs + bytes = readMemory xOffset' xSize' vm + logs' = (LogEntry (litAddr self) bytes topics) : vm.logs + burn (g_log + g_logdata * (num xSize) + num n * g_logtopic) $ + accessMemoryRange xOffset xSize $ do + traceTopLog logs' + next + assign (#state % #stack) xs' + assign #logs logs' + _ -> + underrun + + OpStop -> doStop + + OpAdd -> stackOp2 g_verylow (uncurry Expr.add) + OpMul -> stackOp2 g_low (uncurry Expr.mul) + OpSub -> stackOp2 g_verylow (uncurry Expr.sub) + + OpDiv -> stackOp2 g_low (uncurry Expr.div) + + OpSdiv -> stackOp2 g_low (uncurry Expr.sdiv) + + OpMod -> stackOp2 g_low (uncurry Expr.mod) + + OpSmod -> stackOp2 g_low (uncurry Expr.smod) + OpAddmod -> stackOp3 g_mid (uncurryN Expr.addmod) + OpMulmod -> stackOp3 g_mid (uncurryN Expr.mulmod) + + OpLt -> stackOp2 g_verylow (uncurry Expr.lt) + OpGt -> stackOp2 g_verylow (uncurry Expr.gt) + OpSlt -> stackOp2 g_verylow (uncurry Expr.slt) + OpSgt -> stackOp2 g_verylow (uncurry Expr.sgt) + + OpEq -> stackOp2 g_verylow (uncurry Expr.eq) + OpIszero -> stackOp1 g_verylow Expr.iszero + + OpAnd -> stackOp2 g_verylow (uncurry Expr.and) + OpOr -> stackOp2 g_verylow (uncurry Expr.or) + OpXor -> stackOp2 g_verylow (uncurry Expr.xor) + OpNot -> stackOp1 g_verylow Expr.not + + OpByte -> stackOp2 g_verylow (\(i, w) -> Expr.padByte $ Expr.indexWord i w) + + OpShl -> stackOp2 g_verylow (uncurry Expr.shl) + OpShr -> stackOp2 g_verylow (uncurry Expr.shr) + OpSar -> stackOp2 g_verylow (uncurry Expr.sar) + + -- more accurately refered to as KECCAK + OpSha3 -> + case stk of + xOffset':xSize':xs -> + forceConcrete xOffset' "sha3 offset must be concrete" $ + \xOffset -> forceConcrete xSize' "sha3 size must be concrete" $ \xSize -> + burn (g_sha3 + g_sha3word * ceilDiv (num xSize) 32) $ + accessMemoryRange xOffset xSize $ do + (hash, invMap) <- case readMemory xOffset' xSize' vm of + ConcreteBuf bs -> do + let hash' = keccak' bs + eqs <- use #keccakEqs + assign #keccakEqs $ + PEq (Lit hash') (Keccak (ConcreteBuf bs)):eqs + pure (Lit hash', Map.singleton hash' bs) + buf -> pure (Keccak buf, mempty) + next + assign (#state % #stack) (hash : xs) + modifying (#env % #sha3Crack) ((<>) invMap) + _ -> underrun + + OpAddress -> + limitStack 1 $ + burn g_base (next >> push (num self)) + + OpBalance -> + case stk of + x':xs -> forceConcrete x' "BALANCE" $ \x -> + accessAndBurn (num x) $ + fetchAccount (num x) $ \c -> do + next + assign (#state % #stack) xs + push (num c.balance) + [] -> + underrun + + OpOrigin -> + limitStack 1 . burn g_base $ + next >> push (num vm.tx.origin) + + OpCaller -> + limitStack 1 . burn g_base $ + next >> pushSym vm.state.caller + + OpCallvalue -> + limitStack 1 . burn g_base $ + next >> pushSym vm.state.callvalue + + OpCalldataload -> stackOp1 g_verylow $ + \ind -> Expr.readWord ind vm.state.calldata + + OpCalldatasize -> + limitStack 1 . burn g_base $ + next >> pushSym (bufLength vm.state.calldata) + + OpCalldatacopy -> + case stk of + xTo':xFrom:xSize':xs -> + forceConcrete2 (xTo', xSize') "CALLDATACOPY" $ + \(xTo, xSize) -> + burn (g_verylow + g_copy * ceilDiv (num xSize) 32) $ + accessMemoryRange xTo xSize $ do + next + assign (#state % #stack) xs + copyBytesToMemory vm.state.calldata xSize' xFrom xTo' + _ -> underrun + + OpCodesize -> + limitStack 1 . burn g_base $ + next >> pushSym (codelen vm.state.code) + + OpCodecopy -> + case stk of + memOffset':codeOffset:n':xs -> + forceConcrete2 (memOffset', n') "CODECOPY" $ + \(memOffset,n) -> do + case toWord64 n of + Nothing -> vmError IllegalOverflow + Just n'' -> + if n'' <= ( (maxBound :: Word64) - g_verylow ) `div` g_copy * 32 then + burn (g_verylow + g_copy * ceilDiv (num n) 32) $ + accessMemoryRange memOffset n $ do + next + assign (#state % #stack) xs + copyBytesToMemory (toBuf vm.state.code) n' codeOffset memOffset' + else vmError IllegalOverflow + _ -> underrun + + OpGasprice -> + limitStack 1 . burn g_base $ + next >> push vm.tx.gasprice + + OpExtcodesize -> + case stk of + x':xs -> case x' of + Lit x -> if x == num cheatCode + then do + next + assign (#state % #stack) xs + pushSym (Lit 1) + else + accessAndBurn (num x) $ + fetchAccount (num x) $ \c -> do + next + assign (#state % #stack) xs + pushSym (bufLength (view bytecode c)) + _ -> do + assign (#state % #stack) xs + pushSym (CodeSize x') + next + [] -> + underrun + + OpExtcodecopy -> + case stk of + extAccount':memOffset':codeOffset:codeSize':xs -> + forceConcrete3 (extAccount', memOffset', codeSize') "EXTCODECOPY" $ + \(extAccount, memOffset, codeSize) -> do + acc <- accessAccountForGas (num extAccount) + let cost = if acc then g_warm_storage_read else g_cold_account_access + burn (cost + g_copy * ceilDiv (num codeSize) 32) $ + accessMemoryRange memOffset codeSize $ + fetchAccount (num extAccount) $ \c -> do + next + assign (#state % #stack) xs + copyBytesToMemory (view bytecode c) codeSize' codeOffset memOffset' + _ -> underrun + + OpReturndatasize -> + limitStack 1 . burn g_base $ + next >> pushSym (bufLength vm.state.returndata) + + OpReturndatacopy -> + case stk of + xTo':xFrom:xSize':xs -> forceConcrete2 (xTo', xSize') "RETURNDATACOPY" $ + \(xTo, xSize) -> + burn (g_verylow + g_copy * ceilDiv (num xSize) 32) $ + accessMemoryRange xTo xSize $ do + next + assign (#state % #stack) xs + + let jump True = vmError EVM.ReturnDataOutOfBounds + jump False = copyBytesToMemory vm.state.returndata xSize' xFrom xTo' + + case (xFrom, bufLength vm.state.returndata) of + (Lit f, Lit l) -> + jump $ l < f + xSize || f + xSize < f + _ -> do + let oob = Expr.lt (bufLength vm.state.returndata) (Expr.add xFrom xSize') + overflow = Expr.lt (Expr.add xFrom xSize') (xFrom) + loc <- codeloc + branch loc (Expr.or oob overflow) jump + _ -> underrun + + OpExtcodehash -> + case stk of + x':xs -> forceConcrete x' "EXTCODEHASH" $ \x -> + accessAndBurn (num x) $ do + next + assign (#state % #stack) xs + fetchAccount (num x) $ \c -> + if accountEmpty c + then push (num (0 :: Int)) + else pushSym $ keccak (view bytecode c) + [] -> + underrun + + OpBlockhash -> do + -- We adopt the fake block hash scheme of the VMTests, + -- so that blockhash(i) is the hash of i as decimal ASCII. + stackOp1 g_blockhash $ \case + Lit i -> if i + 256 < vm.block.number || i >= vm.block.number + then Lit 0 + else (num i :: Integer) & show & Char8.pack & keccak' & Lit + i -> BlockHash i + + OpCoinbase -> + limitStack 1 . burn g_base $ + next >> push (num vm.block.coinbase) + + OpTimestamp -> + limitStack 1 . burn g_base $ + next >> pushSym vm.block.timestamp + + OpNumber -> + limitStack 1 . burn g_base $ + next >> push vm.block.number + + OpPrevRandao -> do + limitStack 1 . burn g_base $ + next >> push vm.block.prevRandao + + OpGaslimit -> + limitStack 1 . burn g_base $ + next >> push (num vm.block.gaslimit) + + OpChainid -> + limitStack 1 . burn g_base $ + next >> push vm.env.chainId + + OpSelfbalance -> + limitStack 1 . burn g_low $ + next >> push this.balance + + OpBaseFee -> + limitStack 1 . burn g_base $ + next >> push vm.block.baseFee + + OpPop -> + case stk of + _:xs -> burn g_base (next >> assign (#state % #stack) xs) + _ -> underrun + + OpMload -> + case stk of + x':xs -> forceConcrete x' "MLOAD" $ \x -> + burn g_verylow $ + accessMemoryWord x $ do + next + assign (#state % #stack) (readWord (Lit x) mem : xs) + _ -> underrun + + OpMstore -> + case stk of + x':y:xs -> forceConcrete x' "MSTORE index" $ \x -> + burn g_verylow $ + accessMemoryWord x $ do + next + assign (#state % #memory) (writeWord (Lit x) y mem) + assign (#state % #stack) xs + _ -> underrun + + OpMstore8 -> + case stk of + x':y:xs -> forceConcrete x' "MSTORE8" $ \x -> + burn g_verylow $ + accessMemoryRange x 1 $ do + let yByte = indexWord (Lit 31) y + next + modifying (#state % #memory) (writeByte (Lit x) yByte) + assign (#state % #stack) xs + _ -> underrun + + OpSload -> + case stk of + x:xs -> do + acc <- accessStorageForGas self x + let cost = if acc then g_warm_storage_read else g_cold_sload + burn cost $ + accessStorage self x $ \y -> do + next + assign (#state % #stack) (y:xs) + _ -> underrun + + OpSstore -> + notStatic $ + case stk of + x:new:xs -> + accessStorage self x $ \current -> do + availableGas <- use (#state % #gas) + + if num availableGas <= g_callstipend then + finishFrame (FrameErrored (OutOfGas availableGas (num g_callstipend))) + else do + let + original = + case readStorage (litAddr self) x (ConcreteStore vm.env.origStorage) of + Just (Lit v) -> v + _ -> 0 + storage_cost = + case (maybeLitWord current, maybeLitWord new) of + (Just current', Just new') -> + if (current' == new') then g_sload + else if (current' == original) && (original == 0) then g_sset + else if (current' == original) then g_sreset + else g_sload + + -- if any of the arguments are symbolic, + -- assume worst case scenario + _ -> g_sset + + acc <- accessStorageForGas self x + let cold_storage_cost = if acc then 0 else g_cold_sload + burn (storage_cost + cold_storage_cost) $ do + next + assign (#state % #stack) xs + modifying (#env % #storage) (writeStorage (litAddr self) x new) + + case (maybeLitWord current, maybeLitWord new) of + (Just current', Just new') -> + unless (current' == new') $ + if current' == original then + when (original /= 0 && new' == 0) $ + refund (g_sreset + g_access_list_storage_key) + else do + when (original /= 0) $ + if new' == 0 + then refund (g_sreset + g_access_list_storage_key) + else unRefund (g_sreset + g_access_list_storage_key) + when (original == new') $ + if original == 0 + then refund (g_sset - g_sload) + else refund (g_sreset - g_sload) + -- if any of the arguments are symbolic, + -- don't change the refund counter + _ -> noop + _ -> underrun + + OpJump -> + case stk of + x:xs -> + burn g_mid $ forceConcrete x "JUMP: symbolic jumpdest" $ \x' -> + case toInt x' of + Nothing -> vmError EVM.BadJumpDestination + Just i -> checkJump i xs + _ -> underrun + + OpJumpi -> do + case stk of + (x:y:xs) -> forceConcrete x "JUMPI: symbolic jumpdest" $ \x' -> + burn g_high $ + let jump :: Bool -> EVM () + jump False = assign (#state % #stack) xs >> next + jump _ = case toInt x' of + Nothing -> vmError EVM.BadJumpDestination + Just i -> checkJump i xs + in case maybeLitWord y of + Just y' -> jump (0 /= y') + -- if the jump condition is symbolic, we explore both sides + Nothing -> do + loc <- codeloc + branch loc y jump + _ -> underrun + + OpPc -> + limitStack 1 . burn g_base $ + next >> push (num vm.state.pc) + + OpMsize -> + limitStack 1 . burn g_base $ + next >> push (num vm.state.memorySize) + + OpGas -> + limitStack 1 . burn g_base $ + next >> push (num (vm.state.gas - g_base)) + + OpJumpdest -> burn g_jumpdest next + + OpExp -> + -- NOTE: this can be done symbolically using unrolling like this: + -- https://hackage.haskell.org/package/sbv-9.0/docs/src/Data.SBV.Core.Model.html#.%5E + -- However, it requires symbolic gas, since the gas depends on the exponent + case stk of + base:exponent':xs -> forceConcrete exponent' "EXP: symbolic exponent" $ \exponent -> + let cost = if exponent == 0 + then g_exp + else g_exp + g_expbyte * num (ceilDiv (1 + log2 exponent) 8) + in burn cost $ do + next + (#state % #stack) .= Expr.exp base exponent' : xs + _ -> underrun + + OpSignextend -> stackOp2 g_low (uncurry Expr.sex) + + OpCreate -> + notStatic $ + case stk of + xValue':xOffset':xSize':xs -> forceConcrete3 (xValue', xOffset', xSize') "CREATE" $ + \(xValue, xOffset, xSize) -> do + accessMemoryRange xOffset xSize $ do + availableGas <- use (#state % #gas) + let + newAddr = createAddress self this.nonce + (cost, gas') = costOfCreate fees availableGas 0 + _ <- accessAccountForGas newAddr + burn (cost - gas') $ do + -- unfortunately we have to apply some (pretty hacky) + -- heuristics here to parse the unstructured buffer read + -- from memory into a code and data section + let initCode = readMemory xOffset' xSize' vm + create self this (num gas') xValue xs newAddr initCode + _ -> underrun + + OpCall -> + case stk of + xGas':xTo:xValue':xInOffset':xInSize':xOutOffset':xOutSize':xs -> + forceConcrete6 (xGas', xValue', xInOffset', xInSize', xOutOffset', xOutSize') "CALL" $ + \(xGas, xValue, xInOffset, xInSize, xOutOffset, xOutSize) -> + (if xValue > 0 then notStatic else id) $ + delegateCall this (num xGas) xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ \callee -> do + let from' = fromMaybe self vm.overrideCaller + zoom #state $ do + assign #callvalue (Lit xValue) + assign #caller (litAddr from') + assign #contract callee + assign #overrideCaller Nothing + transfer from' callee xValue + touchAccount self + touchAccount callee + _ -> + underrun + + OpCallcode -> + case stk of + xGas':xTo:xValue':xInOffset':xInSize':xOutOffset':xOutSize':xs -> + forceConcrete6 (xGas', xValue', xInOffset', xInSize', xOutOffset', xOutSize') "CALLCODE" $ + \(xGas, xValue, xInOffset, xInSize, xOutOffset, xOutSize) -> + delegateCall this (num xGas) xTo (litAddr self) xValue xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do + zoom #state $ do + assign #callvalue (Lit xValue) + assign #caller $ litAddr $ fromMaybe self vm.overrideCaller + assign #overrideCaller Nothing + touchAccount self + _ -> + underrun + + OpReturn -> + case stk of + xOffset':xSize':_ -> forceConcrete2 (xOffset', xSize') "RETURN" $ \(xOffset, xSize) -> + accessMemoryRange xOffset xSize $ do + let + output = readMemory xOffset' xSize' vm + codesize = fromMaybe (error "RETURN: cannot return dynamically sized abstract data") + . unlit . bufLength $ output + maxsize = vm.block.maxCodeSize + creation = case vm.frames of + [] -> vm.tx.isCreate + frame:_ -> case frame.context of + CreationContext {} -> True + CallContext {} -> False + if creation + then + if codesize > maxsize + then + finishFrame (FrameErrored (MaxCodeSizeExceeded maxsize codesize)) + else do + let frameReturned = burn (g_codedeposit * num codesize) $ + finishFrame (FrameReturned output) + frameErrored = finishFrame $ FrameErrored InvalidFormat + case readByte (Lit 0) output of + LitByte 0xef -> frameErrored + LitByte _ -> frameReturned + y -> do + loc <- codeloc + branch loc (Expr.eqByte y (LitByte 0xef)) $ \case + True -> frameErrored + False -> frameReturned + else + finishFrame (FrameReturned output) + _ -> underrun + + OpDelegatecall -> + case stk of + xGas':xTo:xInOffset':xInSize':xOutOffset':xOutSize':xs -> + forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') "DELEGATECALL" $ + \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> + delegateCall this (num xGas) xTo (litAddr self) 0 xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do + touchAccount self + _ -> underrun + + OpCreate2 -> notStatic $ + case stk of + xValue':xOffset':xSize':xSalt':xs -> + forceConcrete4 (xValue', xOffset', xSize', xSalt') "CREATE2" $ + \(xValue, xOffset, xSize, xSalt) -> + accessMemoryRange xOffset xSize $ do + availableGas <- use (#state % #gas) + + forceConcreteBuf (readMemory xOffset' xSize' vm) "CREATE2" $ + \initCode -> do + let + newAddr = create2Address self xSalt initCode + (cost, gas') = costOfCreate fees availableGas xSize + _ <- accessAccountForGas newAddr + burn (cost - gas') $ create self this gas' xValue xs newAddr (ConcreteBuf initCode) + _ -> underrun + + OpStaticcall -> + case stk of + xGas':xTo:xInOffset':xInSize':xOutOffset':xOutSize':xs -> + forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') "STATICCALL" $ + \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> do + delegateCall this (num xGas) xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs $ \callee -> do + zoom #state $ do + assign #callvalue (Lit 0) + assign #caller $ litAddr $ fromMaybe self (vm.overrideCaller) + assign #contract callee + assign #static True + assign #overrideCaller Nothing + touchAccount self + touchAccount callee + _ -> + underrun + + OpSelfdestruct -> + notStatic $ + case stk of + [] -> underrun + (xTo':_) -> forceConcrete xTo' "SELFDESTRUCT" $ \(num -> xTo) -> do + acc <- accessAccountForGas (num xTo) + let cost = if acc then 0 else g_cold_account_access + funds = this.balance + recipientExists = accountExists xTo vm + c_new = if not recipientExists && funds /= 0 + then g_selfdestruct_newaccount + else 0 + burn (g_selfdestruct + c_new + cost) $ do + selfdestruct self + touchAccount xTo + + if funds /= 0 + then fetchAccount xTo $ \_ -> do + #env % #contracts % ix xTo % #balance %= (+ funds) + assign (#env % #contracts % ix self % #balance) 0 + doStop + else doStop + + OpRevert -> + case stk of + xOffset':xSize':_ -> forceConcrete2 (xOffset', xSize') "REVERT" $ \(xOffset, xSize) -> + accessMemoryRange xOffset xSize $ do + let output = readMemory xOffset' xSize' vm + finishFrame (FrameReverted output) + _ -> underrun + + OpUnknown xxx -> + vmError (UnrecognizedOpcode xxx) + +transfer :: Addr -> Addr -> W256 -> EVM () +transfer xFrom xTo xValue = + zoom (#env % #contracts) $ do + (ix xFrom % #balance) %= (subtract xValue) + (ix xTo % #balance) %= (+ xValue) + +-- | Checks a *CALL for failure; OOG, too many callframes, memory access etc. +callChecks + :: (?op :: Word8) + => Contract -> Word64 -> Addr -> Addr -> W256 -> W256 -> W256 -> W256 -> W256 -> [Expr EWord] + -- continuation with gas available for call + -> (Word64 -> EVM ()) + -> EVM () +callChecks this xGas xContext xTo xValue xInOffset xInSize xOutOffset xOutSize xs continue = do + vm <- get + let fees = vm.block.schedule + accessMemoryRange xInOffset xInSize $ + accessMemoryRange xOutOffset xOutSize $ do + availableGas <- use (#state % #gas) + let recipientExists = accountExists xContext vm + (cost, gas') <- costOfCall fees recipientExists xValue availableGas xGas xTo + burn (cost - gas') $ do + if xValue > num this.balance + then do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + pushTrace $ ErrorTrace $ BalanceTooLow xValue this.balance + next + else if length vm.frames >= 1024 + then do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + pushTrace $ ErrorTrace CallDepthLimitReached + next + else continue gas' + +precompiledContract + :: (?op :: Word8) + => Contract + -> Word64 + -> Addr + -> Addr + -> W256 + -> W256 -> W256 -> W256 -> W256 + -> [Expr EWord] + -> EVM () +precompiledContract this xGas precompileAddr recipient xValue inOffset inSize outOffset outSize xs = + callChecks this xGas recipient precompileAddr xValue inOffset inSize outOffset outSize xs $ \gas' -> + do + executePrecompile precompileAddr gas' inOffset inSize outOffset outSize xs + self <- use (#state % #contract) + stk <- use (#state % #stack) + pc' <- use (#state % #pc) + result' <- use #result + case result' of + Nothing -> case stk of + x:_ -> case maybeLitWord x of + Just 0 -> + pure () + Just 1 -> + fetchAccount recipient $ \_ -> do + transfer self recipient xValue + touchAccount self + touchAccount recipient + _ -> vmError $ UnexpectedSymbolicArg pc' "unexpected return value from precompile" [x] + _ -> underrun + _ -> pure () + +executePrecompile + :: (?op :: Word8) + => Addr + -> Word64 -> W256 -> W256 -> W256 -> W256 -> [Expr EWord] + -> EVM () +executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = do + vm <- get + let input = readMemory (Lit inOffset) (Lit inSize) vm + fees = vm.block.schedule + cost = costOfPrecompile fees preCompileAddr input + notImplemented = error $ "precompile at address " <> show preCompileAddr <> " not yet implemented" + precompileFail = burn (gasCap - cost) $ do + assign (#state % #stack) (Lit 0 : xs) + pushTrace $ ErrorTrace PrecompileFailure + next + if cost > gasCap then + burn gasCap $ do + assign (#state % #stack) (Lit 0 : xs) + next + else burn cost $ + case preCompileAddr of + -- ECRECOVER + 0x1 -> + -- TODO: support symbolic variant + forceConcreteBuf input "ECRECOVER" $ \input' -> do + case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of + Nothing -> do + -- return no output for invalid signature + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) mempty + next + Just output -> do + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) (ConcreteBuf output) + copyBytesToMemory (ConcreteBuf output) (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- SHA2-256 + 0x2 -> + forceConcreteBuf input "SHA2-256" $ \input' -> do + let + hash = sha256Buf input' + sha256Buf x = ConcreteBuf $ BA.convert (Crypto.hash x :: Digest SHA256) + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) hash + copyBytesToMemory hash (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- RIPEMD-160 + 0x3 -> + -- TODO: support symbolic variant + forceConcreteBuf input "RIPEMD160" $ \input' -> do + let + padding = BS.pack $ replicate 12 0 + hash' = BA.convert (Crypto.hash input' :: Digest RIPEMD160) + hash = ConcreteBuf $ padding <> hash' + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) hash + copyBytesToMemory hash (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- IDENTITY + 0x4 -> do + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) input + copyCallBytesToMemory input (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- MODEXP + 0x5 -> + -- TODO: support symbolic variant + forceConcreteBuf input "MODEXP" $ \input' -> do + let + (lenb, lene, lenm) = parseModexpLength input' + + output = ConcreteBuf $ + if isZero (96 + lenb + lene) lenm input' + then truncpadlit (num lenm) (asBE (0 :: Int)) + else + let + b = asInteger $ lazySlice 96 lenb input' + e = asInteger $ lazySlice (96 + lenb) lene input' + m = asInteger $ lazySlice (96 + lenb + lene) lenm input' + in + padLeft (num lenm) (asBE (expFast b e m)) + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) output + copyBytesToMemory output (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- ECADD + 0x6 -> + -- TODO: support symbolic variant + forceConcreteBuf input "ECADD" $ \input' -> + case EVM.Precompiled.execute 0x6 (truncpadlit 128 input') 64 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- ECMUL + 0x7 -> + -- TODO: support symbolic variant + forceConcreteBuf input "ECMUL" $ \input' -> + case EVM.Precompiled.execute 0x7 (truncpadlit 96 input') 64 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- ECPAIRING + 0x8 -> + -- TODO: support symbolic variant + forceConcreteBuf input "ECPAIR" $ \input' -> + case EVM.Precompiled.execute 0x8 input' 32 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuf $ truncpadlit 32 output + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- BLAKE2 + 0x9 -> + -- TODO: support symbolic variant + forceConcreteBuf input "BLAKE2" $ \input' -> do + case (BS.length input', 1 >= BS.last input') of + (213, True) -> case EVM.Precompiled.execute 0x9 input' 64 of + Just output -> do + let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) + next + Nothing -> precompileFail + _ -> precompileFail + + _ -> notImplemented + +truncpadlit :: Int -> ByteString -> ByteString +truncpadlit n xs = if m > n then BS.take n xs + else BS.append xs (BS.replicate (n - m) 0) + where m = BS.length xs + +lazySlice :: W256 -> W256 -> ByteString -> LS.ByteString +lazySlice offset size bs = + let bs' = LS.take (num size) (LS.drop (num offset) (fromStrict bs)) + in bs' <> LS.replicate ((num size) - LS.length bs') 0 + +parseModexpLength :: ByteString -> (W256, W256, W256) +parseModexpLength input = + let lenb = word $ LS.toStrict $ lazySlice 0 32 input + lene = word $ LS.toStrict $ lazySlice 32 64 input + lenm = word $ LS.toStrict $ lazySlice 64 96 input + in (lenb, lene, lenm) + +--- checks if a range of ByteString bs starting at offset and length size is all zeros. +isZero :: W256 -> W256 -> ByteString -> Bool +isZero offset size bs = + LS.all (== 0) $ + LS.take (num size) $ + LS.drop (num offset) $ + fromStrict bs + +asInteger :: LS.ByteString -> Integer +asInteger xs = if xs == mempty then 0 + else 256 * asInteger (LS.init xs) + + num (LS.last xs) + +-- * Opcode helper actions + +noop :: Monad m => m () +noop = pure () + +pushTo :: MonadState s m => Lens s s [a] [a] -> a -> m () +pushTo f x = f %= (x :) + +pushToSequence :: MonadState s m => Setter s s (Seq a) (Seq a) -> a -> m () +pushToSequence f x = f %= (Seq.|> x) + +getCodeLocation :: VM -> CodeLocation +getCodeLocation vm = (vm.state.contract, vm.state.pc) + +branch :: CodeLocation -> Expr EWord -> (Bool -> EVM ()) -> EVM () +branch loc cond continue = do + pathconds <- use #constraints + assign #result . Just . VMFailure . Query $ PleaseAskSMT cond pathconds choosePath + where + choosePath (Case v) = do + assign #result Nothing + pushTo #constraints $ if v then (cond ./= Lit 0) else (cond .== Lit 0) + iteration <- use (#iterations % at loc % non 0) + assign (#cache % #path % at (loc, iteration)) (Just v) + assign (#iterations % at loc) (Just (iteration + 1)) + continue v + -- Both paths are possible; we ask for more input + choosePath Unknown = + assign #result . Just . VMFailure . Choose . PleaseChoosePath cond $ choosePath . Case + -- None of the paths are possible; fail this branch + choosePath Inconsistent = vmError DeadPath + + +-- | Construct RPC Query and halt execution until resolved +fetchAccount :: Addr -> (Contract -> EVM ()) -> EVM () +fetchAccount addr continue = + use (#env % #contracts % at addr) >>= \case + Just c -> continue c + Nothing -> + use (#cache % #fetchedContracts % at addr) >>= \case + Just c -> do + assign (#env % #contracts % at addr) (Just c) + continue c + Nothing -> do + assign (#result) . Just . VMFailure $ Query $ + PleaseFetchContract addr + (\c -> do assign (#cache % #fetchedContracts % at addr) (Just c) + assign (#env % #contracts % at addr) (Just c) + assign #result Nothing + continue c) + +accessStorage + :: Addr + -> Expr EWord + -> (Expr EWord -> EVM ()) + -> EVM () +accessStorage addr slot continue = do + store <- (.env.storage) <$> get + use (#env % #contracts % at addr) >>= \case + Just c -> + case readStorage (litAddr addr) slot store of + -- Notice that if storage is symbolic, we always continue straight away + Just x -> + continue x + Nothing -> + if c.external then + forceConcrete slot "cannot read symbolic slots via RPC" $ \litSlot -> do + -- check if the slot is cached + cachedStore <- (.cache.fetchedStorage) <$> get + case Map.lookup (num addr) cachedStore >>= Map.lookup litSlot of + Nothing -> mkQuery litSlot + Just val -> continue (Lit val) + else do + -- TODO: is this actually needed? + modifying (#env % #storage) (writeStorage (litAddr addr) slot (Lit 0)) + continue $ Lit 0 + Nothing -> + fetchAccount addr $ \_ -> + accessStorage addr slot continue + where + mkQuery s = assign #result . Just . VMFailure . Query $ + PleaseFetchSlot addr s + (\x -> do + modifying (#cache % #fetchedStorage % ix (num addr)) (Map.insert s x) + modifying (#env % #storage) (writeStorage (litAddr addr) slot (Lit x)) + assign #result Nothing + continue (Lit x)) + +accountExists :: Addr -> VM -> Bool +accountExists addr vm = + case Map.lookup addr vm.env.contracts of + Just c -> not (accountEmpty c) + Nothing -> False + +-- EIP 161 +accountEmpty :: Contract -> Bool +accountEmpty c = + case c.contractcode of + RuntimeCode (ConcreteRuntimeCode "") -> True + RuntimeCode (SymbolicRuntimeCode b) -> null b + _ -> False + && c.nonce == 0 + && c.balance == 0 + +-- * How to finalize a transaction +finalize :: EVM () +finalize = do + let + revertContracts = use (#tx % #txReversion) >>= assign (#env % #contracts) + revertSubstate = assign (#tx % #substate) (SubState mempty mempty mempty mempty mempty) + + use #result >>= \case + Nothing -> + error "Finalising an unfinished tx." + Just (VMFailure (EVM.Revert _)) -> do + revertContracts + revertSubstate + Just (VMFailure _) -> do + -- burn remaining gas + assign (#state % #gas) 0 + revertContracts + revertSubstate + Just (VMSuccess output) -> do + -- deposit the code from a creation tx + pc' <- use (#state % #pc) + creation <- use (#tx % #isCreate) + createe <- use (#state % #contract) + createeExists <- (Map.member createe) <$> use (#env % #contracts) + let onContractCode contractCode = + when (creation && createeExists) $ replaceCode createe contractCode + case output of + ConcreteBuf bs -> + onContractCode $ RuntimeCode (ConcreteRuntimeCode bs) + _ -> + case Expr.toList output of + Nothing -> + vmError $ UnexpectedSymbolicArg pc' "runtime code cannot have an abstract lentgh" [output] + Just ops -> + onContractCode $ RuntimeCode (SymbolicRuntimeCode ops) + + -- compute and pay the refund to the caller and the + -- corresponding payment to the miner + block <- use #block + tx <- use #tx + gasRemaining <- use (#state % #gas) + + let + sumRefunds = sum (snd <$> tx.substate.refunds) + blockReward = num (block.schedule.r_block) + gasUsed = tx.gaslimit - gasRemaining + cappedRefund = min (quot gasUsed 5) (num sumRefunds) + originPay = (num $ gasRemaining + cappedRefund) * tx.gasprice + minerPay = tx.priorityFee * (num gasUsed) + + modifying (#env % #contracts) + (Map.adjust (over #balance (+ originPay)) tx.origin) + modifying (#env % #contracts) + (Map.adjust (over #balance (+ minerPay)) block.coinbase) + touchAccount block.coinbase + + -- pay out the block reward, recreating the miner if necessary + preuse (#env % #contracts % ix block.coinbase) >>= \case + Nothing -> modifying (#env % #contracts) + (Map.insert block.coinbase (initialContract (EVM.RuntimeCode (ConcreteRuntimeCode "")))) + Just _ -> noop + modifying (#env % #contracts) + (Map.adjust (over #balance (+ blockReward)) block.coinbase) + + -- perform state trie clearing (EIP 161), of selfdestructs + -- and touched accounts. addresses are cleared if they have + -- a) selfdestructed, or + -- b) been touched and + -- c) are empty. + -- (see Yellow Paper "Accrued Substate") + -- + -- remove any destructed addresses + destroyedAddresses <- use (#tx % #substate % #selfdestructs) + modifying (#env % #contracts) + (Map.filterWithKey (\k _ -> (k `notElem` destroyedAddresses))) + -- then, clear any remaining empty and touched addresses + touchedAddresses <- use (#tx % #substate % #touchedAccounts) + modifying (#env % #contracts) + (Map.filterWithKey + (\k a -> not ((k `elem` touchedAddresses) && accountEmpty a))) + +-- | Loads the selected contract as the current contract to execute +loadContract :: Addr -> EVM () +loadContract target = + preuse (#env % #contracts % ix target % #contractcode) >>= + \case + Nothing -> + error "Call target doesn't exist" + Just targetCode -> do + assign (#state % #contract) target + assign (#state % #code) targetCode + assign (#state % #codeContract) target + +limitStack :: Int -> EVM () -> EVM () +limitStack n continue = do + stk <- use (#state % #stack) + if length stk + n > 1024 + then vmError EVM.StackLimitExceeded + else continue + +notStatic :: EVM () -> EVM () +notStatic continue = do + bad <- use (#state % #static) + if bad + then vmError StateChangeWhileStatic + else continue + +-- | Burn gas, failing if insufficient gas is available +burn :: Word64 -> EVM () -> EVM () +burn n continue = do + available <- use (#state % #gas) + if n <= available + then do + #state % #gas %= (subtract n) + #burned %= (+ n) + continue + else + vmError (OutOfGas available n) + +forceConcrete :: Expr EWord -> String -> (W256 -> EVM ()) -> EVM () +forceConcrete n msg continue = case maybeLitWord n of + Nothing -> do + vm <- get + vmError $ UnexpectedSymbolicArg vm.state.pc msg [n] + Just c -> continue c + +forceConcrete2 :: (Expr EWord, Expr EWord) -> String -> ((W256, W256) -> EVM ()) -> EVM () +forceConcrete2 (n,m) msg continue = case (maybeLitWord n, maybeLitWord m) of + (Just c, Just d) -> continue (c, d) + _ -> do + vm <- get + vmError $ UnexpectedSymbolicArg vm.state.pc msg [n, m] + +forceConcrete3 :: (Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256) -> EVM ()) -> EVM () +forceConcrete3 (k,n,m) msg continue = case (maybeLitWord k, maybeLitWord n, maybeLitWord m) of + (Just c, Just d, Just f) -> continue (c, d, f) + _ -> do + vm <- get + vmError $ UnexpectedSymbolicArg vm.state.pc msg [k, n, m] + +forceConcrete4 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256) -> EVM ()) -> EVM () +forceConcrete4 (k,l,n,m) msg continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord n, maybeLitWord m) of + (Just b, Just c, Just d, Just f) -> continue (b, c, d, f) + _ -> do + vm <- get + vmError $ UnexpectedSymbolicArg vm.state.pc msg [k, l, n, m] + +forceConcrete5 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256, W256) -> EVM ()) -> EVM () +forceConcrete5 (k,l,m,n,o) msg continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord m, maybeLitWord n, maybeLitWord o) of + (Just a, Just b, Just c, Just d, Just e) -> continue (a, b, c, d, e) + _ -> do + vm <- get + vmError $ UnexpectedSymbolicArg vm.state.pc msg [k, l, m, n, o] + +forceConcrete6 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256, W256, W256) -> EVM ()) -> EVM () +forceConcrete6 (k,l,m,n,o,p) msg continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord m, maybeLitWord n, maybeLitWord o, maybeLitWord p) of + (Just a, Just b, Just c, Just d, Just e, Just f) -> continue (a, b, c, d, e, f) + _ -> do + vm <- get + vmError $ UnexpectedSymbolicArg vm.state.pc msg [k, l, m, n, o, p] + +forceConcreteBuf :: Expr Buf -> String -> (ByteString -> EVM ()) -> EVM () +forceConcreteBuf (ConcreteBuf b) _ continue = continue b +forceConcreteBuf b msg _ = do + vm <- get + vmError $ UnexpectedSymbolicArg vm.state.pc msg [b] + +-- * Substate manipulation +refund :: Word64 -> EVM () +refund n = do + self <- use (#state % #contract) + pushTo (#tx % #substate % #refunds) (self, n) + +unRefund :: Word64 -> EVM () +unRefund n = do + self <- use (#state % #contract) + refs <- use (#tx % #substate % #refunds) + assign (#tx % #substate % #refunds) + (filter (\(a,b) -> not (a == self && b == n)) refs) + +touchAccount :: Addr -> EVM() +touchAccount = pushTo ((#tx % #substate) % #touchedAccounts) + +selfdestruct :: Addr -> EVM() +selfdestruct = pushTo ((#tx % #substate) % #selfdestructs) + +accessAndBurn :: Addr -> EVM () -> EVM () +accessAndBurn x cont = do + FeeSchedule {..} <- use (#block % #schedule) + acc <- accessAccountForGas x + let cost = if acc then g_warm_storage_read else g_cold_account_access + burn cost cont + +-- | returns a wrapped boolean- if true, this address has been touched before in the txn (warm gas cost as in EIP 2929) +-- otherwise cold +accessAccountForGas :: Addr -> EVM Bool +accessAccountForGas addr = do + accessedAddrs <- use (#tx % #substate % #accessedAddresses) + let accessed = member addr accessedAddrs + assign (#tx % #substate % #accessedAddresses) (insert addr accessedAddrs) + pure accessed + +-- | returns a wrapped boolean- if true, this slot has been touched before in the txn (warm gas cost as in EIP 2929) +-- otherwise cold +accessStorageForGas :: Addr -> Expr EWord -> EVM Bool +accessStorageForGas addr key = do + accessedStrkeys <- use (#tx % #substate % #accessedStorageKeys) + case maybeLitWord key of + Just litword -> do + let accessed = member (addr, litword) accessedStrkeys + assign (#tx % #substate % #accessedStorageKeys) (insert (addr, litword) accessedStrkeys) + pure accessed + _ -> return False + +-- * Cheat codes + +-- The cheat code is 7109709ecfa91a80626ff3989d68f67f5b1dd12d. +-- Call this address using one of the cheatActions below to do +-- special things, e.g. changing the block timestamp. Beware that +-- these are necessarily hevm specific. +cheatCode :: Addr +cheatCode = num (keccak' "hevm cheat code") + +cheat + :: (?op :: Word8) + => (W256, W256) -> (W256, W256) + -> EVM () +cheat (inOffset, inSize) (outOffset, outSize) = do + mem <- use (#state % #memory) + vm <- get + let + abi = readBytes 4 (Lit inOffset) mem + input = readMemory (Lit $ inOffset + 4) (Lit $ inSize - 4) vm + case maybeLitWord abi of + Nothing -> vmError $ UnexpectedSymbolicArg vm.state.pc "symbolic cheatcode selector" [abi] + Just (fromIntegral -> abi') -> + case Map.lookup abi' cheatActions of + Nothing -> + vmError (BadCheatCode abi') + Just action -> do + action (Lit outOffset) (Lit outSize) input + next + push 1 + +type CheatAction = Expr EWord -> Expr EWord -> Expr Buf -> EVM () + +cheatActions :: Map FunctionSelector CheatAction +cheatActions = + Map.fromList + [ action "ffi(string[])" $ + \sig outOffset outSize input -> do + vm <- get + if vm.allowFFI then + case decodeBuf [AbiArrayDynamicType AbiStringType] input of + CAbi valsArr -> case valsArr of + [AbiArrayDynamic AbiStringType strsV] -> + let + cmd = fmap + (\case + (AbiString a) -> unpack $ decodeUtf8 a + _ -> "") + (V.toList strsV) + cont bs = do + let encoded = ConcreteBuf bs + assign (#state % #returndata) encoded + copyBytesToMemory encoded outSize (Lit 0) outOffset + assign #result Nothing + in assign #result (Just . VMFailure . Query $ (PleaseDoFFI cmd cont)) + _ -> vmError (BadCheatCode sig) + _ -> vmError (BadCheatCode sig) + else + let msg = encodeUtf8 "ffi disabled: run again with --ffi if you want to allow tests to call external scripts" + in vmError . EVM.Revert . ConcreteBuf $ + abiMethod "Error(string)" (AbiTuple . V.fromList $ [AbiString msg]), + + action "warp(uint256)" $ + \sig _ _ input -> case decodeStaticArgs 0 1 input of + [x] -> assign (#block % #timestamp) x + _ -> vmError (BadCheatCode sig), + + action "roll(uint256)" $ + \sig _ _ input -> case decodeStaticArgs 0 1 input of + [x] -> forceConcrete x "cannot roll to a symbolic block number" (assign (#block % #number)) + _ -> vmError (BadCheatCode sig), + + action "store(address,bytes32,bytes32)" $ + \sig _ _ input -> case decodeStaticArgs 0 3 input of + [a, slot, new] -> + forceConcrete a "cannot store at a symbolic address" $ \(num -> a') -> + fetchAccount a' $ \_ -> do + modifying (#env % #storage) (writeStorage (litAddr a') slot new) + _ -> vmError (BadCheatCode sig), + + action "load(address,bytes32)" $ + \sig outOffset _ input -> case decodeStaticArgs 0 2 input of + [a, slot] -> + forceConcrete a "cannot load from a symbolic address" $ \(num -> a') -> + accessStorage a' slot $ \res -> do + assign (#state % #returndata % word256At (Lit 0)) res + assign (#state % #memory % word256At outOffset) res + _ -> vmError (BadCheatCode sig), + + action "sign(uint256,bytes32)" $ + \sig outOffset _ input -> case decodeStaticArgs 0 2 input of + [sk, hash] -> + forceConcrete2 (sk, hash) "cannot sign symbolic data" $ \(sk', hash') -> do + let (v,r,s) = EVM.Sign.sign hash' (toInteger sk') + encoded = encodeAbiValue $ + AbiTuple (RegularVector.fromList + [ AbiUInt 8 $ num v + , AbiBytes 32 (word256Bytes r) + , AbiBytes 32 (word256Bytes s) + ]) + assign (#state % #returndata) (ConcreteBuf encoded) + copyBytesToMemory (ConcreteBuf encoded) (Lit . num . BS.length $ encoded) (Lit 0) outOffset + _ -> vmError (BadCheatCode sig), + + action "addr(uint256)" $ + \sig outOffset _ input -> case decodeStaticArgs 0 1 input of + [sk] -> forceConcrete sk "cannot derive address for a symbolic key" $ \sk' -> do + let a = EVM.Sign.deriveAddr $ num sk' + case a of + Nothing -> vmError (BadCheatCode sig) + Just address -> do + let expAddr = litAddr address + assign (#state % #returndata % word256At (Lit 0)) expAddr + assign (#state % #memory % word256At outOffset) expAddr + _ -> vmError (BadCheatCode sig), + + action "prank(address)" $ + \sig _ _ input -> case decodeStaticArgs 0 1 input of + [addr] -> assign #overrideCaller (Expr.exprToAddr addr) + _ -> vmError (BadCheatCode sig) + + ] + where + action s f = (abiKeccak s, f (abiKeccak s)) + +-- * General call implementation ("delegateCall") +-- note that the continuation is ignored in the precompile case +delegateCall + :: (?op :: Word8) + => Contract -> Word64 -> Expr EWord -> Expr EWord -> W256 -> W256 -> W256 -> W256 -> W256 + -> [Expr EWord] + -> (Addr -> EVM ()) + -> EVM () +delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue = + forceConcrete2 (xTo, xContext) "cannot delegateCall with symbolic target or context" $ + \((num -> xTo'), (num -> xContext')) -> + if xTo' > 0 && xTo' <= 9 + then precompiledContract this gasGiven xTo' xContext' xValue xInOffset xInSize xOutOffset xOutSize xs + else if xTo' == cheatCode then + do + assign (#state % #stack) xs + cheat (xInOffset, xInSize) (xOutOffset, xOutSize) + else + callChecks this gasGiven xContext' xTo' xValue xInOffset xInSize xOutOffset xOutSize xs $ + \xGas -> do + vm0 <- get + fetchAccount xTo' $ \target -> + burn xGas $ do + let newContext = CallContext + { target = xTo' + , context = xContext' + , offset = xOutOffset + , size = xOutSize + , codehash = target.codehash + , callreversion = (vm0.env.contracts, vm0.env.storage) + , subState = vm0.tx.substate + , abi = + if xInSize >= 4 + then case unlit $ readBytes 4 (Lit xInOffset) vm0.state.memory + of Nothing -> Nothing + Just abi -> Just $ num abi + else Nothing + , calldata = (readMemory (Lit xInOffset) (Lit xInSize) vm0) + } + + pushTrace (FrameTrace newContext) + next + vm1 <- get + + pushTo #frames $ Frame + { state = vm1.state { stack = xs } + , context = newContext + } + + let clearInitCode = \case + (InitCode _ _) -> InitCode mempty mempty + a -> a + + zoom #state $ do + assign #gas (num xGas) + assign #pc 0 + assign #code (clearInitCode target.contractcode) + assign #codeContract xTo' + assign #stack mempty + assign #memory mempty + assign #memorySize 0 + assign #returndata mempty + assign #calldata (copySlice (Lit xInOffset) (Lit 0) (Lit xInSize) vm0.state.memory mempty) + + continue xTo' + +-- -- * Contract creation + +-- EIP 684 +collision :: Maybe Contract -> Bool +collision c' = case c' of + Just c -> c.nonce /= 0 || case c.contractcode of + RuntimeCode (ConcreteRuntimeCode "") -> False + RuntimeCode (SymbolicRuntimeCode b) -> not $ null b + _ -> True + Nothing -> False + +create :: (?op :: Word8) + => Addr -> Contract + -> Word64 -> W256 -> [Expr EWord] -> Addr -> Expr Buf -> EVM () +create self this xGas' xValue xs newAddr initCode = do + vm0 <- get + let xGas = num xGas' + if this.nonce == num (maxBound :: Word64) + then do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + pushTrace $ ErrorTrace NonceOverflow + next + else if xValue > this.balance + then do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + pushTrace $ ErrorTrace $ BalanceTooLow xValue this.balance + next + else if length vm0.frames >= 1024 + then do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + pushTrace $ ErrorTrace CallDepthLimitReached + next + else if collision $ Map.lookup newAddr vm0.env.contracts + then burn xGas $ do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + modifying (#env % #contracts % ix self % #nonce) succ + next + else burn xGas $ do + touchAccount self + touchAccount newAddr + let + -- unfortunately we have to apply some (pretty hacky) + -- heuristics here to parse the unstructured buffer read + -- from memory into a code and data section + -- TODO: comment explaining whats going on here + let contract' = do + prefixLen <- Expr.concPrefix initCode + prefix <- Expr.toList $ Expr.take (num prefixLen) initCode + let sym = Expr.drop (num prefixLen) initCode + conc <- mapM unlitByte prefix + pure $ InitCode (BS.pack $ V.toList conc) sym + case contract' of + Nothing -> + vmError $ UnexpectedSymbolicArg vm0.state.pc "initcode must have a concrete prefix" [] + Just c -> do + let + newContract = initialContract c + newContext = + CreationContext { address = newAddr + , codehash = newContract.codehash + , createreversion = vm0.env.contracts + , substate = vm0.tx.substate + } + + zoom (#env % #contracts) $ do + oldAcc <- use (at newAddr) + let oldBal = maybe 0 (.balance) oldAcc + + assign (at newAddr) (Just (newContract & #balance .~ oldBal)) + modifying (ix self % #nonce) succ + + let resetStorage = \case + ConcreteStore s -> ConcreteStore (Map.delete (num newAddr) s) + AbstractStore -> AbstractStore + EmptyStore -> EmptyStore + SStore {} -> error "trying to reset symbolic storage with writes in create" + GVar _ -> error "unexpected global variable" + + modifying (#env % #storage) resetStorage + modifying (#env % #origStorage) (Map.delete (num newAddr)) + + transfer self newAddr xValue + + pushTrace (FrameTrace newContext) + next + vm1 <- get + pushTo #frames $ Frame + { context = newContext + , state = vm1.state { stack = xs } + } + + assign #state $ + blankState + & set #contract newAddr + & set #codeContract newAddr + & set #code c + & set #callvalue (Lit xValue) + & set #caller (litAddr self) + & set #gas xGas' + +-- | Replace a contract's code, like when CREATE returns +-- from the constructor code. +replaceCode :: Addr -> ContractCode -> EVM () +replaceCode target newCode = + zoom (#env % #contracts % at target) $ + get >>= \case + Just now -> case now.contractcode of + InitCode _ _ -> + put . Just $ + (initialContract newCode) + { balance = now.balance + , nonce = now.nonce + } + RuntimeCode _ -> + error ("internal error: can't replace code of deployed contract " <> show target) + Nothing -> + error "internal error: can't replace code of nonexistent contract" + +replaceCodeOfSelf :: ContractCode -> EVM () +replaceCodeOfSelf newCode = do + vm <- get + replaceCode vm.state.contract newCode + +resetState :: EVM () +resetState = + modify' $ \vm -> vm { result = Nothing + , frames = [] + , state = blankState } + +-- * VM error implementation + +vmError :: Error -> EVM () +vmError e = finishFrame (FrameErrored e) + +underrun :: EVM () +underrun = vmError EVM.StackUnderrun + +-- | A stack frame can be popped in three ways. +data FrameResult + = FrameReturned (Expr Buf) -- ^ STOP, RETURN, or no more code + | FrameReverted (Expr Buf) -- ^ REVERT + | FrameErrored Error -- ^ Any other error + deriving Show + +-- | This function defines how to pop the current stack frame in either of +-- the ways specified by 'FrameResult'. +-- +-- It also handles the case when the current stack frame is the only one; +-- in this case, we set the final '_result' of the VM execution. +finishFrame :: FrameResult -> EVM () +finishFrame how = do + oldVm <- get + + case oldVm.frames of + -- Is the current frame the only one? + [] -> do + case how of + FrameReturned output -> assign #result . Just $ VMSuccess output + FrameReverted buffer -> assign #result . Just $ VMFailure (EVM.Revert buffer) + FrameErrored e -> assign #result . Just $ VMFailure e + finalize + + -- Are there some remaining frames? + nextFrame : remainingFrames -> do + + -- Insert a debug trace. + insertTrace $ + case how of + FrameErrored e -> + ErrorTrace e + FrameReverted e -> + ErrorTrace (EVM.Revert e) + FrameReturned output -> + ReturnTrace output nextFrame.context + -- Pop to the previous level of the debug trace stack. + popTrace + + -- Pop the top frame. + assign #frames remainingFrames + -- Install the state of the frame to which we shall return. + assign #state nextFrame.state + + -- When entering a call, the gas allowance is counted as burned + -- in advance; this unburns the remainder and adds it to the + -- parent frame. + let remainingGas = oldVm.state.gas + reclaimRemainingGasAllowance = do + modifying #burned (subtract remainingGas) + modifying (#state % #gas) (+ remainingGas) + + -- Now dispatch on whether we were creating or calling, + -- and whether we shall return, revert, or error (six cases). + case nextFrame.context of + + -- Were we calling? + CallContext _ _ (Lit -> outOffset) (Lit -> outSize) _ _ _ reversion substate' -> do + + -- Excerpt K.1. from the yellow paper: + -- K.1. Deletion of an Account Despite Out-of-gas. + -- At block 2675119, in the transaction 0xcf416c536ec1a19ed1fb89e4ec7ffb3cf73aa413b3aa9b77d60e4fd81a4296ba, + -- an account at address 0x03 was called and an out-of-gas occurred during the call. + -- Against the equation (197), this added 0x03 in the set of touched addresses, and this transaction turned σ[0x03] into ∅. + + -- In other words, we special case address 0x03 and keep it in the set of touched accounts during revert + touched <- use (#tx % #substate % #touchedAccounts) + + let + substate'' = over #touchedAccounts (maybe id cons (find (3 ==) touched)) substate' + (contractsReversion, storageReversion) = reversion + revertContracts = assign (#env % #contracts) contractsReversion + revertStorage = assign (#env % #storage) storageReversion + revertSubstate = assign (#tx % #substate) substate'' + + case how of + -- Case 1: Returning from a call? + FrameReturned output -> do + assign (#state % #returndata) output + copyCallBytesToMemory output outSize (Lit 0) outOffset + reclaimRemainingGasAllowance + push 1 + + -- Case 2: Reverting during a call? + FrameReverted output -> do + revertContracts + revertStorage + revertSubstate + assign (#state % #returndata) output + copyCallBytesToMemory output outSize (Lit 0) outOffset + reclaimRemainingGasAllowance + push 0 + + -- Case 3: Error during a call? + FrameErrored _ -> do + revertContracts + revertStorage + revertSubstate + assign (#state % #returndata) mempty + push 0 + -- Or were we creating? + CreationContext _ _ reversion substate' -> do + creator <- use (#state % #contract) + let + createe = oldVm.state.contract + revertContracts = assign (#env % #contracts) reversion' + revertSubstate = assign (#tx % #substate) substate' + + -- persist the nonce through the reversion + reversion' = (Map.adjust (over #nonce (+ 1)) creator) reversion + + case how of + -- Case 4: Returning during a creation? + FrameReturned output -> do + let onContractCode contractCode = do + replaceCode createe contractCode + assign (#state % #returndata) mempty + reclaimRemainingGasAllowance + push (num createe) + case output of + ConcreteBuf bs -> + onContractCode $ RuntimeCode (ConcreteRuntimeCode bs) + _ -> + case Expr.toList output of + Nothing -> vmError $ + UnexpectedSymbolicArg + oldVm.state.pc + "runtime code cannot have an abstract length" + [output] + Just newCode -> do + onContractCode $ RuntimeCode (SymbolicRuntimeCode newCode) + + -- Case 5: Reverting during a creation? + FrameReverted output -> do + revertContracts + revertSubstate + assign (#state % #returndata) output + reclaimRemainingGasAllowance + push 0 + + -- Case 6: Error during a creation? + FrameErrored _ -> do + revertContracts + revertSubstate + assign (#state % #returndata) mempty + push 0 + + +-- * Memory helpers + +accessUnboundedMemoryRange + :: Word64 + -> Word64 + -> EVM () + -> EVM () +accessUnboundedMemoryRange _ 0 continue = continue +accessUnboundedMemoryRange f l continue = do + m0 <- num <$> use (#state % #memorySize) + fees <- gets (.block.schedule) + let m1 = 32 * ceilDiv (max m0 (f + l)) 32 + burn (memoryCost fees m1 - memoryCost fees m0) $ do + assign (#state % #memorySize) m1 + continue + +accessMemoryRange + :: W256 + -> W256 + -> EVM () + -> EVM () +accessMemoryRange _ 0 continue = continue +accessMemoryRange f l continue = + case (,) <$> toWord64 f <*> toWord64 l of + Nothing -> vmError IllegalOverflow + Just (f64, l64) -> + if f64 + l64 < l64 + then vmError IllegalOverflow + else accessUnboundedMemoryRange f64 l64 continue + +accessMemoryWord + :: W256 -> EVM () -> EVM () +accessMemoryWord x = accessMemoryRange x 32 + +copyBytesToMemory + :: Expr Buf -> Expr EWord -> Expr EWord -> Expr EWord -> EVM () +copyBytesToMemory bs size xOffset yOffset = + if size == Lit 0 then noop + else do + mem <- use (#state % #memory) + assign (#state % #memory) $ + copySlice xOffset yOffset size bs mem + +copyCallBytesToMemory + :: Expr Buf -> Expr EWord -> Expr EWord -> Expr EWord -> EVM () +copyCallBytesToMemory bs size xOffset yOffset = + if size == Lit 0 then noop + else do + mem <- use (#state % #memory) + assign (#state % #memory) $ + copySlice xOffset yOffset (Expr.min size (bufLength bs)) bs mem + +readMemory :: Expr EWord -> Expr EWord -> VM -> Expr Buf +readMemory offset size vm = copySlice offset (Lit 0) size vm.state.memory mempty + +-- * Tracing + +withTraceLocation :: TraceData -> EVM Trace +withTraceLocation x = do + vm <- get + let this = fromJust $ currentContract vm + pure Trace + { tracedata = x + , contract = this + , opIx = fromMaybe 0 $ this.opIxMap Vector.!? vm.state.pc + } + +pushTrace :: TraceData -> EVM () +pushTrace x = do + trace <- withTraceLocation x + modifying #traces $ + \t -> Zipper.children $ Zipper.insert (Node trace []) t + +insertTrace :: TraceData -> EVM () +insertTrace x = do + trace <- withTraceLocation x + modifying #traces $ + \t -> Zipper.nextSpace $ Zipper.insert (Node trace []) t + +popTrace :: EVM () +popTrace = + modifying #traces $ + \t -> case Zipper.parent t of + Nothing -> error "internal error (trace root)" + Just t' -> Zipper.nextSpace t' + +zipperRootForest :: Zipper.TreePos Zipper.Empty a -> Forest a +zipperRootForest z = + case Zipper.parent z of + Nothing -> Zipper.toForest z + Just z' -> zipperRootForest (Zipper.nextSpace z') + +traceForest :: VM -> Forest Trace +traceForest vm = zipperRootForest vm.traces + +traceTopLog :: [Expr Log] -> EVM () +traceTopLog [] = noop +traceTopLog ((LogEntry addr bytes topics) : _) = do + trace <- withTraceLocation (EventTrace addr bytes topics) + modifying #traces $ + \t -> Zipper.nextSpace (Zipper.insert (Node trace []) t) +traceTopLog ((GVar _) : _) = error "unexpected global variable" + +-- * Stack manipulation + +push :: W256 -> EVM () +push = pushSym . Lit + +pushSym :: Expr EWord -> EVM () +pushSym x = #state % #stack %= (x :) + +stackOp1 + :: (?op :: Word8) + => Word64 + -> ((Expr EWord) -> (Expr EWord)) + -> EVM () +stackOp1 cost f = + use (#state % #stack) >>= \case + x:xs -> + burn cost $ do + next + let !y = f x + (#state % #stack) .= y : xs + _ -> + underrun + +stackOp2 + :: (?op :: Word8) + => Word64 + -> (((Expr EWord), (Expr EWord)) -> (Expr EWord)) + -> EVM () +stackOp2 cost f = + use (#state % #stack) >>= \case + x:y:xs -> + burn cost $ do + next + (#state % #stack) .= f (x, y) : xs + _ -> + underrun + +stackOp3 + :: (?op :: Word8) + => Word64 + -> (((Expr EWord), (Expr EWord), (Expr EWord)) -> (Expr EWord)) + -> EVM () +stackOp3 cost f = + use (#state % #stack) >>= \case + x:y:z:xs -> + burn cost $ do + next + (#state % #stack) .= f (x, y, z) : xs + _ -> + underrun + +-- * Bytecode data functions + +use' :: (VM -> a) -> EVM a +use' f = do + vm <- get + pure (f vm) + +checkJump :: Int -> [Expr EWord] -> EVM () +checkJump x xs = do + theCode <- use (#state % #code) + self <- use (#state % #codeContract) + codeOps <- preuse (#env % #contracts % ix self % #codeOps) + opIxMap <- preuse (#env % #contracts % ix self % #opIxMap) + case (codeOps, opIxMap) of + (Just co, Just opMap) -> do + let op = case theCode of + InitCode ops _ -> BS.indexMaybe ops x + RuntimeCode (ConcreteRuntimeCode ops) -> BS.indexMaybe ops x + RuntimeCode (SymbolicRuntimeCode ops) -> ops V.!? x >>= unlitByte + case op of + Nothing -> vmError EVM.BadJumpDestination + Just b -> + if 0x5b == b && OpJumpdest == snd (co RegularVector.! (opMap Vector.! num x)) + then do + #state % #stack .= xs + #state % #pc .= num x + else + vmError EVM.BadJumpDestination + (_, _) -> error "Internal Error: self not found in current contracts" + + +opSize :: Word8 -> Int +opSize x | x >= 0x60 && x <= 0x7f = num x - 0x60 + 2 +opSize _ = 1 + +-- i of the resulting vector contains the operation index for +-- the program counter value i. This is needed because source map +-- entries are per operation, not per byte. +mkOpIxMap :: ContractCode -> Vector Int +mkOpIxMap (InitCode conc _) + = Vector.create $ Vector.new (BS.length conc) >>= \v -> + -- Loop over the byte string accumulating a vector-mutating action. + -- This is somewhat obfuscated, but should be fast. + let (_, _, _, m) = BS.foldl' (go v) (0 :: Word8, 0, 0, pure ()) conc + in m >> pure v + where + -- concrete case + go v (0, !i, !j, !m) x | x >= 0x60 && x <= 0x7f = + {- Start of PUSH op. -} (x - 0x60 + 1, i + 1, j, m >> Vector.write v i j) + go v (1, !i, !j, !m) _ = + {- End of PUSH op. -} (0, i + 1, j + 1, m >> Vector.write v i j) + go v (0, !i, !j, !m) _ = + {- Other op. -} (0, i + 1, j + 1, m >> Vector.write v i j) + go v (n, !i, !j, !m) _ = + {- PUSH data. -} (n - 1, i + 1, j, m >> Vector.write v i j) + +mkOpIxMap (RuntimeCode (ConcreteRuntimeCode ops)) = + mkOpIxMap (InitCode ops mempty) -- a bit hacky + +mkOpIxMap (RuntimeCode (SymbolicRuntimeCode ops)) + = Vector.create $ Vector.new (length ops) >>= \v -> + let (_, _, _, m) = foldl (go v) (0, 0, 0, pure ()) (stripBytecodeMetadataSym $ V.toList ops) + in m >> pure v + where + go v (0, !i, !j, !m) x = case unlitByte x of + Just x' -> if x' >= 0x60 && x' <= 0x7f + -- start of PUSH op -- + then (x' - 0x60 + 1, i + 1, j, m >> Vector.write v i j) + -- other data -- + else (0, i + 1, j + 1, m >> Vector.write v i j) + _ -> error $ "cannot analyze symbolic code:\nx: " <> show x <> " i: " <> show i <> " j: " <> show j + + go v (1, !i, !j, !m) _ = + {- End of PUSH op. -} (0, i + 1, j + 1, m >> Vector.write v i j) + go v (n, !i, !j, !m) _ = + {- PUSH data. -} (n - 1, i + 1, j, m >> Vector.write v i j) + + +vmOp :: VM -> Maybe Op +vmOp vm = + let i = vm ^. #state % #pc + code' = vm ^. #state % #code + (op, pushdata) = case code' of + InitCode xs' _ -> + (BS.index xs' i, fmap LitByte $ BS.unpack $ BS.drop i xs') + RuntimeCode (ConcreteRuntimeCode xs') -> + (BS.index xs' i, fmap LitByte $ BS.unpack $ BS.drop i xs') + RuntimeCode (SymbolicRuntimeCode xs') -> + ( fromMaybe (error "unexpected symbolic code") . unlitByte $ xs' V.! i , V.toList $ V.drop i xs') + in if (opslen code' < i) + then Nothing + else Just (readOp op pushdata) + +vmOpIx :: VM -> Maybe Int +vmOpIx vm = + do self <- currentContract vm + self.opIxMap Vector.!? vm.state.pc + +-- Maps operation indicies into a pair of (bytecode index, operation) +mkCodeOps :: ContractCode -> RegularVector.Vector (Int, Op) +mkCodeOps contractCode = + let l = case contractCode of + InitCode bytes _ -> + LitByte <$> (BS.unpack bytes) + RuntimeCode (ConcreteRuntimeCode ops) -> + LitByte <$> (BS.unpack $ stripBytecodeMetadata ops) + RuntimeCode (SymbolicRuntimeCode ops) -> + stripBytecodeMetadataSym $ V.toList ops + in RegularVector.fromList . toList $ go 0 l + where + go !i !xs = + case uncons xs of + Nothing -> + mempty + Just (x, xs') -> + let x' = fromMaybe (error "unexpected symbolic code argument") $ unlitByte x + j = opSize x' + in (i, readOp x' xs') Seq.<| go (i + j) (drop j xs) + +-- * Gas cost calculation helpers + +-- Gas cost function for CALL, transliterated from the Yellow Paper. +costOfCall + :: FeeSchedule Word64 + -> Bool -> W256 -> Word64 -> Word64 -> Addr + -> EVM (Word64, Word64) +costOfCall (FeeSchedule {..}) recipientExists xValue availableGas xGas target = do + acc <- accessAccountForGas target + let call_base_gas = if acc then g_warm_storage_read else g_cold_account_access + c_new = if not recipientExists && xValue /= 0 + then g_newaccount + else 0 + c_xfer = if xValue /= 0 then num g_callvalue else 0 + c_extra = call_base_gas + c_xfer + c_new + c_gascap = if availableGas >= c_extra + then min xGas (allButOne64th (availableGas - c_extra)) + else xGas + c_callgas = if xValue /= 0 then c_gascap + g_callstipend else c_gascap + pure (c_gascap + c_extra, c_callgas) + +-- Gas cost of create, including hash cost if needed +costOfCreate + :: FeeSchedule Word64 + -> Word64 -> W256 -> (Word64, Word64) +costOfCreate (FeeSchedule {..}) availableGas hashSize = + (createCost + initGas, initGas) + where + createCost = g_create + hashCost + hashCost = g_sha3word * ceilDiv (num hashSize) 32 + initGas = allButOne64th (availableGas - createCost) + +concreteModexpGasFee :: ByteString -> Word64 +concreteModexpGasFee input = + if lenb < num (maxBound :: Word32) && + (lene < num (maxBound :: Word32) || (lenb == 0 && lenm == 0)) && + lenm < num (maxBound :: Word64) + then + max 200 ((multiplicationComplexity * iterCount) `div` 3) + else + maxBound -- TODO: this is not 100% correct, return Nothing on overflow + where + (lenb, lene, lenm) = parseModexpLength input + ez = isZero (96 + lenb) lene input + e' = word $ LS.toStrict $ + lazySlice (96 + lenb) (min 32 lene) input + nwords :: Word64 + nwords = ceilDiv (num $ max lenb lenm) 8 + multiplicationComplexity = nwords * nwords + iterCount' :: Word64 + iterCount' | lene <= 32 && ez = 0 + | lene <= 32 = num (log2 e') + | e' == 0 = 8 * (num lene - 32) + | otherwise = num (log2 e') + 8 * (num lene - 32) + iterCount = max iterCount' 1 + +-- Gas cost of precompiles +costOfPrecompile :: FeeSchedule Word64 -> Addr -> Expr Buf -> Word64 +costOfPrecompile (FeeSchedule {..}) precompileAddr input = + let errorDynamicSize = error "precompile input cannot have a dynamic size" + inputLen = case input of + ConcreteBuf bs -> fromIntegral $ BS.length bs + AbstractBuf _ -> errorDynamicSize + buf -> case bufLength buf of + Lit l -> num l -- TODO: overflow + _ -> errorDynamicSize + in case precompileAddr of + -- ECRECOVER + 0x1 -> 3000 + -- SHA2-256 + 0x2 -> num $ (((inputLen + 31) `div` 32) * 12) + 60 + -- RIPEMD-160 + 0x3 -> num $ (((inputLen + 31) `div` 32) * 120) + 600 + -- IDENTITY + 0x4 -> num $ (((inputLen + 31) `div` 32) * 3) + 15 + -- MODEXP + 0x5 -> case input of + ConcreteBuf i -> concreteModexpGasFee i + _ -> error "Unsupported symbolic modexp gas calc " + -- ECADD + 0x6 -> g_ecadd + -- ECMUL + 0x7 -> g_ecmul + -- ECPAIRING + 0x8 -> (inputLen `div` 192) * g_pairing_point + g_pairing_base + -- BLAKE2 + 0x9 -> case input of + ConcreteBuf i -> g_fround * (num $ asInteger $ lazySlice 0 4 i) + _ -> error "Unsupported symbolic blake2 gas calc" + _ -> error ("unimplemented precompiled contract " ++ show precompileAddr) + +-- Gas cost of memory expansion +memoryCost :: FeeSchedule Word64 -> Word64 -> Word64 +memoryCost FeeSchedule{..} byteCount = + let + wordCount = ceilDiv byteCount 32 + linearCost = g_memory * wordCount + quadraticCost = div (wordCount * wordCount) 512 + in + linearCost + quadraticCost + +hashcode :: ContractCode -> Expr EWord +hashcode (InitCode ops args) = keccak $ (ConcreteBuf ops) <> args +hashcode (RuntimeCode (ConcreteRuntimeCode ops)) = keccak (ConcreteBuf ops) +hashcode (RuntimeCode (SymbolicRuntimeCode ops)) = keccak . Expr.fromList $ ops + +-- | The length of the code ignoring any constructor args. +-- This represents the region that can contain executable opcodes +opslen :: ContractCode -> Int +opslen (InitCode ops _) = BS.length ops +opslen (RuntimeCode (ConcreteRuntimeCode ops)) = BS.length ops +opslen (RuntimeCode (SymbolicRuntimeCode ops)) = length ops + +-- | The length of the code including any constructor args. +-- This can return an abstract value +codelen :: ContractCode -> Expr EWord +codelen c@(InitCode {}) = bufLength $ toBuf c +codelen (RuntimeCode (ConcreteRuntimeCode ops)) = Lit . num $ BS.length ops +codelen (RuntimeCode (SymbolicRuntimeCode ops)) = Lit . num $ length ops + +toBuf :: ContractCode -> Expr Buf +toBuf (InitCode ops args) = ConcreteBuf ops <> args +toBuf (RuntimeCode (ConcreteRuntimeCode ops)) = ConcreteBuf ops +toBuf (RuntimeCode (SymbolicRuntimeCode ops)) = Expr.fromList ops + +codeloc :: EVM CodeLocation +codeloc = do + vm <- get + pure (vm.state.contract, vm.state.pc) + +-- * Arithmetic + +ceilDiv :: (Num a, Integral a) => a -> a -> a +ceilDiv m n = div (m + n - 1) n + +allButOne64th :: (Num a, Integral a) => a -> a +allButOne64th n = n - div n 64 + +log2 :: FiniteBits b => b -> Int +log2 x = finiteBitSize x - 1 - countLeadingZeros x diff --git a/src/EVM/ABI.hs b/src/EVM/ABI.hs --- a/src/EVM/ABI.hs +++ b/src/EVM/ABI.hs @@ -343,11 +343,12 @@ decodeAbiValue = runGet . getAbi selector :: Text -> BS.ByteString -selector s = BSLazy.toStrict . runPut $ putWord32be (abiKeccak (encodeUtf8 s)) +selector s = BSLazy.toStrict . runPut $ + putWord32be (abiKeccak (encodeUtf8 s)).unFunctionSelector abiMethod :: Text -> AbiValue -> BS.ByteString abiMethod s args = BSLazy.toStrict . runPut $ do - putWord32be (abiKeccak (encodeUtf8 s)) + putWord32be (abiKeccak (encodeUtf8 s)).unFunctionSelector putAbi args parseTypeName :: Vector AbiType -> Text -> Maybe AbiType diff --git a/src/EVM/Concrete.hs b/src/EVM/Concrete.hs --- a/src/EVM/Concrete.hs +++ b/src/EVM/Concrete.hs @@ -5,9 +5,8 @@ import EVM.RLP import EVM.Types -import Control.Lens ((^?), ix) import Data.Bits (Bits (..), shiftR) -import Data.ByteString (ByteString) +import Data.ByteString (ByteString, (!?)) import Data.Maybe (fromMaybe) import Data.Word (Word8) @@ -18,7 +17,7 @@ word (padRight 32 (BS.drop i bs)) readByteOrZero :: Int -> ByteString -> Word8 -readByteOrZero i bs = fromMaybe 0 (bs ^? ix i) +readByteOrZero i bs = fromMaybe 0 (bs !? i) byteStringSliceWithDefaultZeroes :: Int -> Int -> ByteString -> ByteString byteStringSliceWithDefaultZeroes offset size bs = diff --git a/src/EVM/Dapp.hs b/src/EVM/Dapp.hs --- a/src/EVM/Dapp.hs +++ b/src/EVM/Dapp.hs @@ -5,7 +5,7 @@ import EVM.Concrete import EVM.Debug (srcMapCodePos) import EVM.Solidity -import EVM.Types (W256, abiKeccak, keccak', Addr, regexMatches, unlit, unlitByte) +import EVM.Types (W256, abiKeccak, keccak', Addr, regexMatches, unlit, unlitByte, FunctionSelector) import Control.Arrow ((>>>)) import Data.Aeson (Value) @@ -20,7 +20,6 @@ import Data.Text (Text, isPrefixOf, pack, unpack) import Data.Text.Encoding (encodeUtf8) import Data.Vector qualified as V -import Data.Word (Word32) data DappInfo = DappInfo { root :: FilePath @@ -29,7 +28,7 @@ , solcByCode :: [(Code, SolcContract)] -- for contracts with `immutable` vars. , sources :: SourceCache , unitTests :: [(Text, [(Test, [AbiType])])] - , abiMap :: Map Word32 Method + , abiMap :: Map FunctionSelector Method , eventMap :: Map W256 Event , errorMap :: Map W256 SolError , astIdMap :: Map Int Value @@ -98,7 +97,7 @@ -- Tests beginning with "test" are interpreted as concrete tests, whereas -- tests beginning with "prove" are interpreted as symbolic tests. -unitTestMarkerAbi :: Word32 +unitTestMarkerAbi :: FunctionSelector unitTestMarkerAbi = abiKeccak (encodeUtf8 "IS_TEST()") findAllUnitTests :: [SolcContract] -> [(Text, [(Test, [AbiType])])] @@ -141,12 +140,12 @@ extractSig (InvariantTest sig) = sig traceSrcMap :: DappInfo -> Trace -> Maybe SrcMap -traceSrcMap dapp trace = srcMap dapp trace._traceContract trace._traceOpIx +traceSrcMap dapp trace = srcMap dapp trace.contract trace.opIx srcMap :: DappInfo -> Contract -> Int -> Maybe SrcMap srcMap dapp contr opIndex = do sol <- findSrc contr dapp - case contr._contractcode of + case contr.contractcode of (InitCode _ _) -> Seq.lookup opIndex sol.creationSrcmap (RuntimeCode _) -> @@ -154,10 +153,10 @@ findSrc :: Contract -> DappInfo -> Maybe SolcContract findSrc c dapp = do - hash <- unlit c._codehash + hash <- unlit c.codehash case Map.lookup hash dapp.solcByHash of Just (_, v) -> Just v - Nothing -> lookupCode c._contractcode dapp + Nothing -> lookupCode c.contractcode dapp lookupCode :: ContractCode -> DappInfo -> Maybe SolcContract diff --git a/src/EVM/Debug.hs b/src/EVM/Debug.hs --- a/src/EVM/Debug.hs +++ b/src/EVM/Debug.hs @@ -2,13 +2,13 @@ module EVM.Debug where -import EVM (Contract, nonce, balance, bytecode, codehash) -import EVM.Solidity (SrcMap, srcMapFile, srcMapOffset, srcMapLength, SourceCache(..)) +import EVM (Contract, bytecode) +import EVM.Solidity (SrcMap(..), SourceCache(..)) import EVM.Types (Addr) import EVM.Expr (bufLength) import Control.Arrow (second) -import Control.Lens +import Optics.Core import Data.ByteString (ByteString) import Data.Map (Map) import Data.Text (Text) @@ -32,9 +32,9 @@ prettyContract c = object [ (text "codesize", text . show $ (bufLength (c ^. bytecode))) - , (text "codehash", text (show (c ^. codehash))) - , (text "balance", int (fromIntegral (c ^. balance))) - , (text "nonce", int (fromIntegral (c ^. nonce))) + , (text "codehash", text (show (c ^. #codehash))) + , (text "balance", int (fromIntegral (c ^. #balance))) + , (text "nonce", int (fromIntegral (c ^. #nonce))) ] prettyContracts :: Map Addr Contract -> Doc @@ -45,12 +45,12 @@ srcMapCodePos :: SourceCache -> SrcMap -> Maybe (Text, Int) srcMapCodePos cache sm = - fmap (second f) $ cache.files ^? ix sm.srcMapFile + fmap (second f) $ cache.files ^? ix sm.file where - f v = ByteString.count 0xa (ByteString.take (sm.srcMapOffset - 1) v) + 1 + f v = ByteString.count 0xa (ByteString.take sm.offset v) + 1 srcMapCode :: SourceCache -> SrcMap -> Maybe ByteString srcMapCode cache sm = - fmap f $ cache.files ^? ix sm.srcMapFile + fmap f $ cache.files ^? ix sm.file where - f (_, v) = ByteString.take (min 80 sm.srcMapLength) (ByteString.drop sm.srcMapOffset v) + f (_, v) = ByteString.take (min 80 sm.length) (ByteString.drop sm.offset v) diff --git a/src/EVM/Demand.hs b/src/EVM/Demand.hs deleted file mode 100644 --- a/src/EVM/Demand.hs +++ /dev/null @@ -1,13 +0,0 @@ -module EVM.Demand (demand) where - -import Control.DeepSeq (NFData, force) -import Control.Exception.Base (evaluate) -import Control.Monad.IO.Class (MonadIO, liftIO) - --- | This is an easy way to force full evaluation of a value inside of --- the IO monad, being essentially just the composition of @evaluate@ --- and @force@. -demand :: (MonadIO m, NFData a) => a -> m () -demand x = do - _ <- liftIO (evaluate (force x)) - return () diff --git a/src/EVM/Dev.hs b/src/EVM/Dev.hs --- a/src/EVM/Dev.hs +++ b/src/EVM/Dev.hs @@ -365,44 +365,44 @@ where contractCode = RuntimeCode (ConcreteRuntimeCode bs) c = Contract - { _contractcode = contractCode - , _balance = 0 - , _nonce = 0 - , _codehash = keccak (ConcreteBuf bs) - , _opIxMap = mkOpIxMap contractCode - , _codeOps = mkCodeOps contractCode - , _external = False + { contractcode = contractCode + , balance = 0 + , nonce = 0 + , codehash = keccak (ConcreteBuf bs) + , opIxMap = mkOpIxMap contractCode + , codeOps = mkCodeOps contractCode + , external = False } vm = makeVm $ VMOpts - { EVM.vmoptContract = c - , EVM.vmoptCalldata = (AbstractBuf "txdata", []) - , EVM.vmoptValue = CallValue 0 - , EVM.vmoptAddress = Addr 0xffffffffffffffff - , EVM.vmoptCaller = Lit 0 - , EVM.vmoptOrigin = Addr 0xffffffffffffffff - , EVM.vmoptGas = 0xffffffffffffffff - , EVM.vmoptGaslimit = 0xffffffffffffffff - , EVM.vmoptStorageBase = Symbolic - , EVM.vmoptBaseFee = 0 - , EVM.vmoptPriorityFee = 0 - , EVM.vmoptCoinbase = 0 - , EVM.vmoptNumber = 0 - , EVM.vmoptTimestamp = Var "timestamp" - , EVM.vmoptBlockGaslimit = 0 - , EVM.vmoptGasprice = 0 - , EVM.vmoptMaxCodeSize = 0xffffffff - , EVM.vmoptPrevRandao = 420 - , EVM.vmoptSchedule = FeeSchedule.berlin - , EVM.vmoptChainId = 1 - , EVM.vmoptCreate = False - , EVM.vmoptTxAccessList = mempty - , EVM.vmoptAllowFFI = False + { contract = c + , calldata = (AbstractBuf "txdata", []) + , value = CallValue 0 + , address = Addr 0xffffffffffffffff + , caller = Lit 0 + , origin = Addr 0xffffffffffffffff + , gas = 0xffffffffffffffff + , gaslimit = 0xffffffffffffffff + , initialStorage = AbstractStore + , baseFee = 0 + , priorityFee = 0 + , coinbase = 0 + , number = 0 + , timestamp = Var "timestamp" + , blockGaslimit = 0 + , gasprice = 0 + , maxCodeSize = 0xffffffff + , prevRandao = 420 + , schedule = FeeSchedule.berlin + , chainId = 1 + , create = False + , txAccessList = mempty + , allowFFI = False } -- | Builds the Expr for the given evm bytecode object buildExpr :: SolverGroup -> ByteString -> IO (Expr End) -buildExpr solvers bs = evalStateT (interpret (Fetch.oracle solvers Nothing) Nothing Nothing runExpr) (initVm bs) +buildExpr solvers bs = interpret (Fetch.oracle solvers Nothing) Nothing Nothing (initVm bs) runExpr dai :: IO ByteString dai = do diff --git a/src/EVM/Exec.hs b/src/EVM/Exec.hs --- a/src/EVM/Exec.hs +++ b/src/EVM/Exec.hs @@ -7,7 +7,7 @@ import qualified EVM.FeeSchedule as FeeSchedule -import Control.Lens +import Optics.Core import Control.Monad.Trans.State.Strict (get, State) import Data.ByteString (ByteString) import Data.Maybe (isNothing) @@ -19,43 +19,43 @@ vmForEthrunCreation :: ByteString -> VM vmForEthrunCreation creationCode = (makeVm $ VMOpts - { vmoptContract = initialContract (InitCode creationCode mempty) - , vmoptCalldata = mempty - , vmoptValue = (Lit 0) - , vmoptStorageBase = Concrete - , vmoptAddress = createAddress ethrunAddress 1 - , vmoptCaller = litAddr ethrunAddress - , vmoptOrigin = ethrunAddress - , vmoptCoinbase = 0 - , vmoptNumber = 0 - , vmoptTimestamp = (Lit 0) - , vmoptBlockGaslimit = 0 - , vmoptGasprice = 0 - , vmoptPrevRandao = 42069 - , vmoptGas = 0xffffffffffffffff - , vmoptGaslimit = 0xffffffffffffffff - , vmoptBaseFee = 0 - , vmoptPriorityFee = 0 - , vmoptMaxCodeSize = 0xffffffff - , vmoptSchedule = FeeSchedule.berlin - , vmoptChainId = 1 - , vmoptCreate = False - , vmoptTxAccessList = mempty - , vmoptAllowFFI = False - }) & set (env . contracts . at ethrunAddress) + { contract = initialContract (InitCode creationCode mempty) + , calldata = mempty + , value = (Lit 0) + , initialStorage = EmptyStore + , address = createAddress ethrunAddress 1 + , caller = litAddr ethrunAddress + , origin = ethrunAddress + , coinbase = 0 + , number = 0 + , timestamp = (Lit 0) + , blockGaslimit = 0 + , gasprice = 0 + , prevRandao = 42069 + , gas = 0xffffffffffffffff + , gaslimit = 0xffffffffffffffff + , baseFee = 0 + , priorityFee = 0 + , maxCodeSize = 0xffffffff + , schedule = FeeSchedule.berlin + , chainId = 1 + , create = False + , txAccessList = mempty + , allowFFI = False + }) & set (#env % #contracts % at ethrunAddress) (Just (initialContract (RuntimeCode (ConcreteRuntimeCode "")))) exec :: State VM VMResult exec = do vm <- get - case vm._result of + case vm.result of Nothing -> exec1 >> exec Just r -> pure r run :: State VM VM run = do vm <- get - case vm._result of + case vm.result of Nothing -> exec1 >> run Just _ -> pure vm @@ -64,7 +64,7 @@ where go i = do vm <- get - if p vm && isNothing vm._result + if p vm && isNothing vm.result then do go $! (i + 1) else diff --git a/src/EVM/Expr.hs b/src/EVM/Expr.hs --- a/src/EVM/Expr.hs +++ b/src/EVM/Expr.hs @@ -15,7 +15,7 @@ import Data.Maybe import Data.List -import Control.Lens (lens) +import Optics.Core import EVM.Types import EVM.Traversals @@ -215,19 +215,18 @@ then val else readByte i src readByte i@(Lit x) (WriteWord (Lit idx) val src) - = if idx <= x && x <= idx + 31 + = if x - idx < 32 then case val of (Lit _) -> indexWord (Lit $ x - idx) val _ -> IndexWord (Lit $ x - idx) val else readByte i src readByte i@(Lit x) (CopySlice (Lit srcOffset) (Lit dstOffset) (Lit size) src dst) - = if dstOffset <= x && x < (dstOffset + size) + = if x - dstOffset < size then readByte (Lit $ x - (dstOffset - srcOffset)) src else readByte i dst readByte i@(Lit x) buf@(CopySlice _ (Lit dstOffset) (Lit size) _ dst) - -- the byte we are trying to read is compeletely outside of the sliced reegion - -- we check that there is no overflow and that addresses do not wrap around - = if (x < dstOffset || x >= dstOffset + size) && (dstOffset <= dstOffset + size) + -- the byte we are trying to read is compeletely outside of the sliced region + = if x - dstOffset >= size then readByte i dst else ReadByte (Lit x) buf @@ -249,7 +248,7 @@ | idx == idx' = val | otherwise = case (idx, idx') of (Lit i, Lit i') -> - if i >= i' + 32 || i + 32 <= i' + if i' - i >= 32 && i' - i <= (maxBound :: W256) - 31 -- the region we are trying to read is completely outside of the WriteWord then readWord idx buf -- the region we are trying to read partially overlaps the WriteWord @@ -259,10 +258,9 @@ _ -> readWordFromBytes idx b readWord (Lit idx) b@(CopySlice (Lit srcOff) (Lit dstOff) (Lit size) src dst) -- the region we are trying to read is enclosed in the sliced region - | idx >= dstOff && idx + 32 <= dstOff + size = readWord (Lit $ srcOff + (idx - dstOff)) src - -- the region we are trying to read is compeletely outside of the sliced reegion - -- we check that there is no overflow and that addresses do not wrap around - | (idx >= dstOff + size || idx + 32 <= dstOff) && (dstOff<= dstOff + size) = readWord (Lit idx) dst + | (idx - dstOff) < size && 32 <= size - (idx - dstOff) = readWord (Lit $ srcOff + (idx - dstOff)) src + -- the region we are trying to read is compeletely outside of the sliced region + | (idx - dstOff) >= size && (idx - dstOff) <= (maxBound :: W256) - 31 = readWord (Lit idx) dst -- the region we are trying to read partially overlaps the sliced region | otherwise = readWordFromBytes (Lit idx) b readWord i b = readWordFromBytes i b @@ -468,15 +466,11 @@ b <- Map.lookup a bufEnv go l b -word256At - :: Functor f - => Expr EWord -> (Expr EWord -> f (Expr EWord)) - -> Expr Buf -> f (Expr Buf) +word256At :: Expr EWord -> Lens (Expr Buf) (Expr Buf) (Expr EWord) (Expr EWord) word256At i = lens getter setter where getter = readWord i setter m x = writeWord i x m - -- | Returns the first n bytes of buf take :: W256 -> Expr Buf -> Expr Buf take n = slice (Lit 0) (Lit n) @@ -530,34 +524,36 @@ -- | Removes any irrelevant writes when reading from a buffer simplifyReads :: Expr a -> Expr a simplifyReads = \case - ReadWord (Lit idx) b -> readWord (Lit idx) (stripWrites idx (idx + 31) b) - ReadByte (Lit idx) b -> readByte (Lit idx) (stripWrites idx idx b) + ReadWord (Lit idx) b -> readWord (Lit idx) (stripWrites idx 32 b) + ReadByte (Lit idx) b -> readByte (Lit idx) (stripWrites idx 1 b) a -> a -- | Strips writes from the buffer that can be statically determined to be out of range -- TODO: are the bounds here correct? I think there might be some off by one mistakes... stripWrites :: W256 -> W256 -> Expr Buf -> Expr Buf -stripWrites bottom top = \case +stripWrites off size = \case AbstractBuf s -> AbstractBuf s - ConcreteBuf b -> ConcreteBuf $ BS.take (num top+1) b + ConcreteBuf b -> ConcreteBuf $ if off <= off + size + then BS.take (num $ off+size) b + else b WriteByte (Lit idx) v prev - -> if idx < bottom || idx > top - then stripWrites bottom top prev - else WriteByte (Lit idx) v (stripWrites bottom top prev) + -> if idx - off >= size + then stripWrites off size prev + else WriteByte (Lit idx) v (stripWrites off size prev) -- TODO: handle partial overlaps WriteWord (Lit idx) v prev - -> if idx + 31 < bottom || idx > top - then stripWrites bottom top prev - else WriteWord (Lit idx) v (stripWrites bottom top prev) - CopySlice (Lit srcOff) (Lit dstOff) (Lit size) src dst - -> if dstOff + size < bottom || dstOff > top - then stripWrites bottom top dst - else CopySlice (Lit srcOff) (Lit dstOff) (Lit size) - (stripWrites srcOff (srcOff + size) src) - (stripWrites bottom top dst) - WriteByte i v prev -> WriteByte i v (stripWrites bottom top prev) - WriteWord i v prev -> WriteWord i v (stripWrites bottom top prev) - CopySlice srcOff dstOff size src dst -> CopySlice srcOff dstOff size src dst + -> if idx - off >= size && idx - off <= (maxBound :: W256) - 31 + then stripWrites off size prev + else WriteWord (Lit idx) v (stripWrites off size prev) + CopySlice (Lit srcOff) (Lit dstOff) (Lit size') src dst + -> if dstOff - off >= size && dstOff - off <= (maxBound :: W256) - size' - 1 + then stripWrites off size dst + else CopySlice (Lit srcOff) (Lit dstOff) (Lit size') + (stripWrites srcOff size' src) + (stripWrites off size dst) + WriteByte i v prev -> WriteByte i v (stripWrites off size prev) + WriteWord i v prev -> WriteWord i v (stripWrites off size prev) + CopySlice srcOff dstOff size' src dst -> CopySlice srcOff dstOff size' src dst GVar _ -> error "unexpected GVar in stripWrites" @@ -792,8 +788,14 @@ -- Double NOT is a no-op, since it's a bitwise inversion go (EVM.Types.Not (EVM.Types.Not a)) = a + -- Some trivial min / max eliminations go (Max (Lit 0) a) = a go (Min (Lit 0) _) = Lit 0 + + -- If a >= b then the value of the `Max` expression can never be < b + go o@(LT (Max (Lit a) _) (Lit b)) + | a >= b = Lit 0 + | otherwise = o go a = a diff --git a/src/EVM/Facts.hs b/src/EVM/Facts.hs --- a/src/EVM/Facts.hs +++ b/src/EVM/Facts.hs @@ -33,7 +33,7 @@ ) where import EVM (VM, Contract, Cache) -import EVM (balance, nonce, storage, bytecode, env, contracts, cache, fetchedStorage, fetchedContracts) +import EVM (bytecode) import EVM.Types (Addr, W256, Expr(..), num) import EVM.Expr (writeStorage, litAddr) @@ -41,7 +41,9 @@ import Prelude hiding (Word) -import Control.Lens (view, set, at, ix, (&), over, assign) +import Optics.Core +import Optics.State + import Control.Monad.State.Strict (execState, when) import Data.ByteString (ByteString) import Data.Ord (comparing) @@ -112,15 +114,15 @@ contractFacts a x store = case view bytecode x of ConcreteBuf b -> storageFacts a store ++ - [ BalanceFact a x._balance - , NonceFact a x._nonce + [ BalanceFact a x.balance + , NonceFact a x.nonce , CodeFact a b ] _ -> -- here simply ignore storing the bytecode storageFacts a store ++ - [ BalanceFact a x._balance - , NonceFact a x._nonce + [ BalanceFact a x.balance + , NonceFact a x.nonce ] @@ -136,13 +138,13 @@ cacheFacts :: Cache -> Set Fact cacheFacts c = Set.fromList $ do - (k, v) <- Map.toList c._fetchedContracts - contractFacts k v c._fetchedStorage + (k, v) <- Map.toList c.fetchedContracts + contractFacts k v c.fetchedStorage vmFacts :: VM -> Set Fact vmFacts vm = Set.fromList $ do - (k, v) <- Map.toList vm._env._contracts - case vm._env._storage of + (k, v) <- Map.toList vm.env.contracts + case vm.env.storage of EmptyStore -> contractFacts k v Map.empty ConcreteStore s -> contractFacts k v s _ -> error "cannot serialize an abstract store" @@ -158,30 +160,30 @@ apply1 vm fact = case fact of CodeFact {..} -> flip execState vm $ do - assign (env . contracts . at addr) (Just (EVM.initialContract (EVM.RuntimeCode (EVM.ConcreteRuntimeCode blob)))) - when (vm._state._contract == addr) $ EVM.loadContract addr + assign (#env % #contracts % at addr) (Just (EVM.initialContract (EVM.RuntimeCode (EVM.ConcreteRuntimeCode blob)))) + when (vm.state.contract == addr) $ EVM.loadContract addr StorageFact {..} -> - vm & over (env . storage) (writeStorage (litAddr addr) (Lit which) (Lit what)) + vm & over (#env % #storage) (writeStorage (litAddr addr) (Lit which) (Lit what)) BalanceFact {..} -> - vm & set (env . contracts . ix addr . balance) what + vm & set (#env % #contracts % ix addr % #balance) what NonceFact {..} -> - vm & set (env . contracts . ix addr . nonce) what + vm & set (#env % #contracts % ix addr % #nonce) what apply2 :: VM -> Fact -> VM apply2 vm fact = case fact of CodeFact {..} -> flip execState vm $ do - assign (cache . fetchedContracts . at addr) (Just (EVM.initialContract (EVM.RuntimeCode (EVM.ConcreteRuntimeCode blob)))) - when (vm._state._contract == addr) $ EVM.loadContract addr + assign (#cache % #fetchedContracts % at addr) (Just (EVM.initialContract (EVM.RuntimeCode (EVM.ConcreteRuntimeCode blob)))) + when (vm.state.contract == addr) $ EVM.loadContract addr StorageFact {..} -> let - store = vm._cache._fetchedStorage + store = vm.cache.fetchedStorage ctrct = Map.findWithDefault Map.empty (num addr) store in - vm & set (cache . fetchedStorage) (Map.insert (num addr) (Map.insert which what ctrct) store) + vm & set (#cache % #fetchedStorage) (Map.insert (num addr) (Map.insert which what ctrct) store) BalanceFact {..} -> - vm & set (cache . fetchedContracts . ix addr . balance) what + vm & set (#cache % #fetchedContracts % ix addr % #balance) what NonceFact {..} -> - vm & set (cache . fetchedContracts . ix addr . nonce) what + vm & set (#cache % #fetchedContracts % ix addr % #nonce) what -- Sort facts in the right order for `apply1` to work. instance Ord Fact where diff --git a/src/EVM/Facts/Git.hs b/src/EVM/Facts/Git.hs --- a/src/EVM/Facts/Git.hs +++ b/src/EVM/Facts/Git.hs @@ -10,7 +10,7 @@ import EVM.Facts (Fact (..), File (..), Path (..), Data (..), fileToFact, factToFile) -import Control.Lens +import Optics.Core import Data.Set (Set) import Data.Maybe (catMaybes) @@ -45,5 +45,5 @@ loadFacts :: RepoAt -> IO (Set Fact) loadFacts (RepoAt src) = fmap - (prune . Set.map (fileToFact . view (from fileRepr))) + (prune . Set.map (fileToFact . review fileRepr)) (Git.load src) diff --git a/src/EVM/Fetch.hs b/src/EVM/Fetch.hs --- a/src/EVM/Fetch.hs +++ b/src/EVM/Fetch.hs @@ -9,15 +9,16 @@ import EVM.Types (Addr, W256, hexText, Expr(Lit), Expr(..), Prop(..), (.&&), (./=)) import EVM.SMT import EVM.Solvers -import EVM (EVM, Contract, Block, initialContract, nonce, balance, external) +import EVM (EVM, Contract, Block, initialContract) import qualified EVM.FeeSchedule as FeeSchedule import qualified EVM -import Control.Lens hiding ((.=)) +import Optics.Core + import Control.Monad.Trans.Maybe import Data.Aeson hiding (Error) -import Data.Aeson.Lens +import Data.Aeson.Optics import qualified Data.ByteString as BS import Data.Text (Text, unpack, pack) import Data.Maybe (fromMaybe) @@ -85,39 +86,49 @@ x <- case q of QueryCode addr -> do m <- f (rpc "eth_getCode" [toRPC addr, toRPC n]) - return $ hexText . view _String <$> m + pure $ do + t <- preview _String <$> m + hexText <$> t QueryNonce addr -> do m <- f (rpc "eth_getTransactionCount" [toRPC addr, toRPC n]) - return $ readText . view _String <$> m + pure $ do + t <- preview _String <$> m + readText <$> t QueryBlock -> do m <- f (rpc "eth_getBlockByNumber" [toRPC n, toRPC False]) return $ m >>= parseBlock QueryBalance addr -> do m <- f (rpc "eth_getBalance" [toRPC addr, toRPC n]) - return $ readText . view _String <$> m + pure $ do + t <- preview _String <$> m + readText <$> t QuerySlot addr slot -> do m <- f (rpc "eth_getStorageAt" [toRPC addr, toRPC slot, toRPC n]) - return $ readText . view _String <$> m + pure $ do + t <- preview _String <$> m + readText <$> t QueryChainId -> do m <- f (rpc "eth_chainId" [toRPC n]) - return $ readText . view _String <$> m + pure $ do + t <- preview _String <$> m + readText <$> t return x parseBlock :: (AsValue s, Show s) => s -> Maybe EVM.Block parseBlock j = do - coinbase <- readText <$> j ^? key "miner" . _String - timestamp <- Lit . readText <$> j ^? key "timestamp" . _String - number <- readText <$> j ^? key "number" . _String - gasLimit <- readText <$> j ^? key "gasLimit" . _String + coinbase <- readText <$> j ^? key "miner" % _String + timestamp <- Lit . readText <$> j ^? key "timestamp" % _String + number <- readText <$> j ^? key "number" % _String + gasLimit <- readText <$> j ^? key "gasLimit" % _String let - baseFee = readText <$> j ^? key "baseFeePerGas" . _String + baseFee = readText <$> j ^? key "baseFeePerGas" % _String -- It seems unclear as to whether this field should still be called mixHash or renamed to prevRandao -- According to https://github.com/ethereum/EIPs/blob/master/EIPS/eip-4399.md it should be renamed -- but alchemy is still returning mixHash - mixhash = readText <$> j ^? key "mixHash" . _String - prevRandao = readText <$> j ^? key "prevRandao" . _String - difficulty = readText <$> j ^? key "difficulty" . _String + mixhash = readText <$> j ^? key "mixHash" % _String + prevRandao = readText <$> j ^? key "prevRandao" % _String + difficulty = readText <$> j ^? key "difficulty" % _String prd = case (prevRandao, mixhash, difficulty) of (Just p, _, _) -> p (Nothing, Just mh, Just 0x0) -> mh @@ -129,7 +140,7 @@ fetchWithSession :: Text -> Session -> Value -> IO (Maybe Value) fetchWithSession url sess x = do r <- asValue =<< Session.post sess (unpack url) x - return (r ^? responseBody . key "result") + return (r ^? (lensVL responseBody) % key "result") fetchContractWithSession :: BlockNumber -> Text -> Addr -> Session -> IO (Maybe Contract) @@ -144,9 +155,9 @@ return $ initialContract (EVM.RuntimeCode (EVM.ConcreteRuntimeCode theCode)) - & set nonce theNonce - & set balance theBalance - & set external True + & set #nonce theNonce + & set #balance theBalance + & set #external True fetchSlotWithSession :: BlockNumber -> Text -> Session -> Addr -> W256 -> IO (Maybe W256) @@ -159,19 +170,24 @@ fetchQuery n (fetchWithSession url sess) QueryBlock fetchBlockFrom :: BlockNumber -> Text -> IO (Maybe Block) -fetchBlockFrom n url = - Session.withAPISession - (fetchBlockWithSession n url) +fetchBlockFrom n url = do + sess <- Session.newAPISession + fetchBlockWithSession n url sess fetchContractFrom :: BlockNumber -> Text -> Addr -> IO (Maybe Contract) -fetchContractFrom n url addr = - Session.withAPISession - (fetchContractWithSession n url addr) +fetchContractFrom n url addr = do + sess <- Session.newAPISession + fetchContractWithSession n url addr sess fetchSlotFrom :: BlockNumber -> Text -> Addr -> W256 -> IO (Maybe W256) -fetchSlotFrom n url addr slot = - Session.withAPISession - (\s -> fetchSlotWithSession n url s addr slot) +fetchSlotFrom n url addr slot = do + sess <- Session.newAPISession + fetchSlotWithSession n url sess addr slot + +fetchChainIdFrom :: Text -> IO (Maybe W256) +fetchChainIdFrom url = do + sess <- Session.newAPISession + fetchQuery Latest (fetchWithSession url sess) QueryChainId http :: Natural -> Maybe Natural -> BlockNumber -> Text -> Fetcher http smtjobs smttimeout n url q = diff --git a/src/EVM/Format.hs b/src/EVM/Format.hs --- a/src/EVM/Format.hs +++ b/src/EVM/Format.hs @@ -35,10 +35,10 @@ import EVM.Hexdump (prettyHex) import EVM.Solidity (SolcContract(..), Method(..), contractName, abiMap) import EVM.Types (maybeLitWord, W256(..),num, word, Expr(..), EType(..), Addr, - ByteStringS(..), Error(..)) + ByteStringS(..), Error(..), FunctionSelector) import Control.Arrow ((>>>)) -import Control.Lens (preview, ix, _2) +import Optics.Core import Data.Binary.Get (runGetOrFail) import Data.Bits (shiftR) import Data.ByteString (ByteString) @@ -48,7 +48,6 @@ import Data.Char qualified as Char import Data.DoubleWord (signedWord) import Data.Foldable (toList) -import Data.Functor ((<&>)) import Data.Map qualified as Map import Data.Maybe (catMaybes, fromMaybe, fromJust) import Data.Text (Text, pack, unpack, intercalate, dropEnd, splitOn) @@ -56,7 +55,6 @@ import Data.Text.Encoding (decodeUtf8, decodeUtf8') import Data.Tree.View (showTree) import Data.Vector (Vector) -import Data.Word (Word32) import Numeric (showHex) data Signedness = Signed | Unsigned @@ -107,9 +105,9 @@ name = case Map.lookup addr contracts of Nothing -> "" Just contract -> - let hash = maybeLitWord contract._codehash + let hash = maybeLitWord contract.codehash in case hash of - Just h -> maybeContractName' (preview (ix h . _2) dappinfo.solcByHash) + Just h -> maybeContractName' (preview (ix h % _2) dappinfo.solcByHash) Nothing -> "" in name <> "@" <> (pack $ show addr) @@ -192,14 +190,14 @@ showTrace :: DappInfo -> VM -> Trace -> Text showTrace dapp vm trace = - let ?context = DappContext { info = dapp, env = vm._env._contracts } + let ?context = DappContext { info = dapp, env = vm.env.contracts } in let pos = case showTraceLocation dapp trace of Left x -> " \x1b[1m" <> x <> "\x1b[0m" Right x -> " \x1b[1m(" <> x <> ")\x1b[0m" fullAbiMap = dapp.abiMap - in case trace._traceData of + in case trace.tracedata of EventTrace _ bytes topics -> let logn = mconcat [ "\x1b[36m" @@ -241,7 +239,7 @@ -- bytes data -- ) anonymous; let - sig = fromIntegral $ shiftR topic 224 :: Word32 + sig = fromIntegral $ shiftR topic 224 :: FunctionSelector usr = case maybeLitWord t2 of Just w -> pack $ show (fromIntegral w :: Addr) @@ -298,7 +296,7 @@ t FrameTrace (CreationContext addr (Lit hash) _ _ ) -> -- FIXME: irrefutable pattern "create " - <> maybeContractName (preview (ix hash . _2) dapp.solcByHash) + <> maybeContractName (preview (ix hash % _2) dapp.solcByHash) <> "@" <> pack (show addr) <> pos FrameTrace (CreationContext addr _ _ _ ) -> @@ -311,7 +309,7 @@ then "call " else "delegatecall " hash' = fromJust $ maybeLitWord hash - in case preview (ix hash' . _2) dapp.solcByHash of + in case preview (ix hash' % _2) dapp.solcByHash of Nothing -> calltype <> pack (show target) diff --git a/src/EVM/SMT.hs b/src/EVM/SMT.hs --- a/src/EVM/SMT.hs +++ b/src/EVM/SMT.hs @@ -48,11 +48,11 @@ -- variable names in SMT that we want to get values for data CexVars = CexVars - { calldataV :: [Text] - , buffersV :: Map Text (Expr EWord) -- buffers and guesses at their maximum size - , storeReads :: [(Expr EWord, Expr EWord)] -- a list of relevant store reads - , blockContextV :: [Text] - , txContextV :: [Text] + { calldata :: [Text] + , buffers :: Map Text (Expr EWord) -- buffers and guesses at their maximum size + , storeReads :: [(Expr EWord, Expr EWord)] -- a list of relevant store reads + , blockContext :: [Text] + , txContext :: [Text] } deriving (Eq, Show) @@ -61,11 +61,11 @@ instance Monoid CexVars where mempty = CexVars - { calldataV = mempty - , buffersV = mempty + { calldata = mempty + , buffers = mempty , storeReads = mempty - , blockContextV = mempty - , txContextV = mempty + , blockContext = mempty + , txContext = mempty } -- | A model for a buffer, either in it's compressed form (for storing parsed @@ -97,7 +97,7 @@ flattenBufs :: SMTCex -> Maybe SMTCex flattenBufs cex = do bs <- mapM collapse cex.buffers - pure $ cex { buffers = bs} + pure $ cex{ buffers = bs } -- | Attemps to collapse a compressed buffer representation down to a flattened one collapse :: BufModel -> Maybe BufModel @@ -161,7 +161,7 @@ <> readAssumes <> SMT2 [""] mempty <> SMT2 (fmap (\p -> "(assert " <> p <> ")") encs) mempty - <> SMT2 [] mempty{storeReads = storageReads} + <> SMT2 [] mempty{ storeReads = storageReads } where (ps_elim, bufs, stores) = eliminateProps ps @@ -319,8 +319,8 @@ declareBufs :: [Prop] -> BufEnv -> StoreEnv -> SMT2 declareBufs props bufEnv storeEnv = SMT2 ("; buffers" : fmap declareBuf allBufs <> ("; buffer lengths" : fmap declareLength allBufs)) cexvars where - cexvars = mempty{buffersV = discoverMaxReads props bufEnv storeEnv} - allBufs = fmap fromLazyText $ Map.keys cexvars.buffersV + cexvars = (mempty :: CexVars){ buffers = discoverMaxReads props bufEnv storeEnv } + allBufs = fmap fromLazyText $ Map.keys cexvars.buffers declareBuf n = "(declare-const " <> n <> " (Array (_ BitVec 256) (_ BitVec 8)))" declareLength n = "(declare-const " <> n <> "_length" <> " (_ BitVec 256))" @@ -329,21 +329,21 @@ declareVars names = SMT2 (["; variables"] <> fmap declare names) cexvars where declare n = "(declare-const " <> n <> " (_ BitVec 256))" - cexvars = mempty{calldataV = fmap toLazyText names} + cexvars = mempty{ calldata = fmap toLazyText names } declareFrameContext :: [Builder] -> SMT2 declareFrameContext names = SMT2 (["; frame context"] <> fmap declare names) cexvars where declare n = "(declare-const " <> n <> " (_ BitVec 256))" - cexvars = mempty{txContextV = fmap toLazyText names} + cexvars = (mempty :: CexVars){ txContext = fmap toLazyText names } declareBlockContext :: [Builder] -> SMT2 declareBlockContext names = SMT2 (["; block context"] <> fmap declare names) cexvars where declare n = "(declare-const " <> n <> " (_ BitVec 256))" - cexvars = mempty{blockContextV = fmap toLazyText names} + cexvars = (mempty :: CexVars){ blockContext = fmap toLazyText names } prelude :: SMT2 diff --git a/src/EVM/Solidity.hs b/src/EVM/Solidity.hs --- a/src/EVM/Solidity.hs +++ b/src/EVM/Solidity.hs @@ -42,12 +42,14 @@ import EVM.ABI import EVM.Types +import Optics.Core +import Optics.Operators.Unsafe + import Control.Applicative -import Control.Lens hiding (Indexed, (.=)) import Control.Monad import Data.Aeson hiding (json) import Data.Aeson.Types -import Data.Aeson.Lens +import Data.Aeson.Optics import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap import Data.Scientific @@ -73,7 +75,7 @@ import Data.Text.IO (readFile, writeFile) import Data.Vector (Vector) import Data.Vector qualified as Vector -import Data.Word (Word8, Word32) +import Data.Word (Word8) import GHC.Generics (Generic) import Prelude hiding (readFile, writeFile) import System.IO hiding (readFile, writeFile) @@ -125,7 +127,7 @@ , creationCode :: ByteString , contractName :: Text , constructorInputs :: [(Text, AbiType)] - , abiMap :: Map Word32 Method + , abiMap :: Map FunctionSelector Method , eventMap :: Map W256 Event , errorMap :: Map W256 SolError , immutableReferences :: Map W256 [Reference] @@ -177,11 +179,11 @@ deriving (Show, Eq, Ord, Generic) data SrcMap = SM { - srcMapOffset :: {-# UNPACK #-} !Int, - srcMapLength :: {-# UNPACK #-} !Int, - srcMapFile :: {-# UNPACK #-} !Int, - srcMapJump :: JumpType, - srcMapModifierDepth :: {-# UNPACK #-} !Int + offset :: {-# UNPACK #-} !Int, + length :: {-# UNPACK #-} !Int, + file :: {-# UNPACK #-} !Int, + jump :: JumpType, + modifierDepth :: {-# UNPACK #-} !Int } deriving (Show, Eq, Ord, Generic) data SrcMapParseState @@ -281,7 +283,7 @@ (json, path) <- yul' src let f = (json ^?! key "contracts") ^?! key (Key.fromText path) c = f ^?! key (Key.fromText $ if Text.null contract then "object" else contract) - bytecode = c ^?! key "evm" ^?! key "bytecode" ^?! key "object" . _String + bytecode = c ^?! key "evm" ^?! key "bytecode" ^?! key "object" % _String pure $ toCode <$> (Just bytecode) yulRuntime :: Text -> Text -> IO (Maybe ByteString) @@ -289,7 +291,7 @@ (json, path) <- yul' src let f = (json ^?! key "contracts") ^?! key (Key.fromText path) c = f ^?! key (Key.fromText $ if Text.null contract then "object" else contract) - bytecode = c ^?! key "evm" ^?! key "deployedBytecode" ^?! key "object" . _String + bytecode = c ^?! key "evm" ^?! key "deployedBytecode" ^?! key "object" % _String pure $ toCode <$> (Just bytecode) solidity :: Text -> Text -> IO (Maybe ByteString) @@ -323,26 +325,26 @@ -- deprecate me soon readCombinedJSON :: Text -> Maybe (Map Text SolcContract, Map Text Value, [(Text, Maybe ByteString)]) readCombinedJSON json = do - contracts <- f . KeyMap.toHashMapText <$> (json ^? key "contracts" . _Object) - sources <- toList . fmap (view _String) <$> json ^? key "sourceList" . _Array - return (contracts, Map.fromList (HMap.toList asts), [ (x, Nothing) | x <- sources]) + contracts <- f . KeyMap.toHashMapText <$> (json ^? key "contracts" % _Object) + sources <- toList . fmap (preview _String) <$> json ^? key "sourceList" % _Array + return (contracts, Map.fromList (HMap.toList asts), [ (x, Nothing) | Just x <- sources]) where - asts = KeyMap.toHashMapText $ fromMaybe (error "JSON lacks abstract syntax trees.") (json ^? key "sources" . _Object) + asts = KeyMap.toHashMapText $ fromMaybe (error "JSON lacks abstract syntax trees.") (json ^? key "sources" % _Object) f x = Map.fromList . HMap.toList $ HMap.mapWithKey g x g s x = let - theRuntimeCode = toCode (x ^?! key "bin-runtime" . _String) - theCreationCode = toCode (x ^?! key "bin" . _String) + theRuntimeCode = toCode (x ^?! key "bin-runtime" % _String) + theCreationCode = toCode (x ^?! key "bin" % _String) abis = toList $ case (x ^?! key "abi") ^? _Array of Just v -> v -- solc >= 0.8 - Nothing -> (x ^?! key "abi" . _String) ^?! _Array -- solc < 0.8 + Nothing -> (x ^?! key "abi" % _String) ^?! _Array -- solc < 0.8 in SolcContract { runtimeCode = theRuntimeCode, creationCode = theCreationCode, runtimeCodehash = keccak' (stripBytecodeMetadata theRuntimeCode), creationCodehash = keccak' (stripBytecodeMetadata theCreationCode), - runtimeSrcmap = force "internal error: srcmap-runtime" (makeSrcMaps (x ^?! key "srcmap-runtime" . _String)), - creationSrcmap = force "internal error: srcmap" (makeSrcMaps (x ^?! key "srcmap" . _String)), + runtimeSrcmap = force "internal error: srcmap-runtime" (makeSrcMaps (x ^?! key "srcmap-runtime" % _String)), + creationSrcmap = force "internal error: srcmap" (makeSrcMaps (x ^?! key "srcmap" % _String)), contractName = s, constructorInputs = mkConstructor abis, abiMap = mkAbiMap abis, @@ -354,9 +356,9 @@ readStdJSON :: Text -> Maybe (Map Text SolcContract, Map Text Value, [(Text, Maybe ByteString)]) readStdJSON json = do - contracts <- KeyMap.toHashMapText <$> json ^? key "contracts" . _Object + contracts <- KeyMap.toHashMapText <$> json ^? key "contracts" % _Object -- TODO: support the general case of "urls" and "content" in the standard json - sources <- KeyMap.toHashMapText <$> json ^? key "sources" . _Object + sources <- KeyMap.toHashMapText <$> json ^? key "sources" % _Object let asts = force "JSON lacks abstract syntax trees." . preview (key "ast") <$> sources contractMap = f contracts contents src = (src, encodeUtf8 <$> HMap.lookup src (mconcat $ Map.elems $ snd <$> contractMap)) @@ -364,28 +366,30 @@ where f :: (AsValue s) => HMap.HashMap Text s -> (Map Text (SolcContract, (HMap.HashMap Text Text))) f x = Map.fromList . (concatMap g) . HMap.toList $ x - g (s, x) = h s <$> HMap.toList (KeyMap.toHashMapText (view _Object x)) + g (s, x) = h s <$> HMap.toList (KeyMap.toHashMapText (fromMaybe (error "Could not parse json object") (preview _Object x))) h :: Text -> (Text, Value) -> (Text, (SolcContract, HMap.HashMap Text Text)) h s (c, x) = let evmstuff = x ^?! key "evm" runtime = evmstuff ^?! key "deployedBytecode" creation = evmstuff ^?! key "bytecode" - theRuntimeCode = toCode $ fromMaybe "" $ runtime ^? key "object" . _String - theCreationCode = toCode $ fromMaybe "" $ creation ^? key "object" . _String + theRuntimeCode = toCode $ fromMaybe "" $ runtime ^? key "object" % _String + theCreationCode = toCode $ fromMaybe "" $ creation ^? key "object" % _String srcContents :: Maybe (HMap.HashMap Text Text) - srcContents = do metadata <- x ^? key "metadata" . _String - srcs <- KeyMap.toHashMapText <$> metadata ^? key "sources" . _Object - return $ (view (key "content" . _String)) <$> (HMap.filter (isJust . preview (key "content")) srcs) + srcContents = do metadata <- x ^? key "metadata" % _String + srcs <- KeyMap.toHashMapText <$> metadata ^? key "sources" % _Object + return $ fmap + (fromMaybe (error "Internal Error: could not parse contents field into a string") . preview (key "content" % _String)) + (HMap.filter (isJust . preview (key "content")) srcs) abis = force ("abi key not found in " <> show x) $ - toList <$> x ^? key "abi" . _Array + toList <$> x ^? key "abi" % _Array in (s <> ":" <> c, (SolcContract { runtimeCode = theRuntimeCode, creationCode = theCreationCode, runtimeCodehash = keccak' (stripBytecodeMetadata theRuntimeCode), creationCodehash = keccak' (stripBytecodeMetadata theCreationCode), - runtimeSrcmap = force "internal error: srcmap-runtime" (makeSrcMaps (runtime ^?! key "sourceMap" . _String)), - creationSrcmap = force "internal error: srcmap" (makeSrcMaps (creation ^?! key "sourceMap" . _String)), + runtimeSrcmap = force "internal error: srcmap-runtime" (makeSrcMaps (runtime ^?! key "sourceMap" % _String)), + creationSrcmap = force "internal error: srcmap" (makeSrcMaps (creation ^?! key "sourceMap" % _String)), contractName = s <> ":" <> c, constructorInputs = mkConstructor abis, abiMap = mkAbiMap abis, @@ -399,55 +403,55 @@ _ -> Nothing }, fromMaybe mempty srcContents)) -mkAbiMap :: [Value] -> Map Word32 Method +mkAbiMap :: [Value] -> Map FunctionSelector Method mkAbiMap abis = Map.fromList $ let - relevant = filter (\y -> "function" == y ^?! key "type" . _String) abis + relevant = filter (\y -> "function" == y ^?! key "type" % _String) abis f abi = (abiKeccak (encodeUtf8 (signature abi)), - Method { name = abi ^?! key "name" . _String + Method { name = abi ^?! key "name" % _String , methodSignature = signature abi , inputs = map parseMethodInput - (toList (abi ^?! key "inputs" . _Array)) + (toList (abi ^?! key "inputs" % _Array)) , output = map parseMethodInput - (toList (abi ^?! key "outputs" . _Array)) + (toList (abi ^?! key "outputs" % _Array)) , mutability = parseMutability - (abi ^?! key "stateMutability" . _String) + (abi ^?! key "stateMutability" % _String) }) in f <$> relevant mkEventMap :: [Value] -> Map W256 Event mkEventMap abis = Map.fromList $ let - relevant = filter (\y -> "event" == y ^?! key "type" . _String) abis + relevant = filter (\y -> "event" == y ^?! key "type" % _String) abis f abi = ( keccak' (encodeUtf8 (signature abi)) , Event - (abi ^?! key "name" . _String) - (case abi ^?! key "anonymous" . _Bool of + (abi ^?! key "name" % _String) + (case abi ^?! key "anonymous" % _Bool of True -> Anonymous False -> NotAnonymous) (map (\y -> - ( y ^?! key "name" . _String + ( y ^?! key "name" % _String , force "internal error: type" (parseTypeName' y) - , if y ^?! key "indexed" . _Bool + , if y ^?! key "indexed" % _Bool then Indexed else NotIndexed )) - (toList $ abi ^?! key "inputs" . _Array)) + (toList $ abi ^?! key "inputs" % _Array)) ) in f <$> relevant mkErrorMap :: [Value] -> Map W256 SolError mkErrorMap abis = Map.fromList $ let - relevant = filter (\y -> "error" == y ^?! key "type" . _String) abis + relevant = filter (\y -> "error" == y ^?! key "type" % _String) abis f abi = ( stripKeccak $ keccak' (encodeUtf8 (signature abi)) , SolError - (abi ^?! key "name" . _String) + (abi ^?! key "name" % _String) (map (force "internal error: type" . parseTypeName') - (toList $ abi ^?! key "inputs" . _Array)) + (toList $ abi ^?! key "inputs" % _Array)) ) in f <$> relevant where @@ -458,24 +462,24 @@ mkConstructor abis = let isConstructor y = - "constructor" == y ^?! key "type" . _String + "constructor" == y ^?! key "type" % _String in case filter isConstructor abis of - [abi] -> map parseMethodInput (toList (abi ^?! key "inputs" . _Array)) + [abi] -> map parseMethodInput (toList (abi ^?! key "inputs" % _Array)) [] -> [] -- default constructor has zero inputs _ -> error "strange: contract has multiple constructors" mkStorageLayout :: Maybe Value -> Maybe (Map Text StorageItem) mkStorageLayout Nothing = Nothing mkStorageLayout (Just json) = do - items <- json ^? key "storage" . _Array + items <- json ^? key "storage" % _Array types <- json ^? key "types" fmap Map.fromList (forM (Vector.toList items) $ \item -> - do name <- item ^? key "label" . _String - offset <- item ^? key "offset" . _Number >>= toBoundedInteger - slot <- item ^? key "slot" . _String - typ <- Key.fromText <$> item ^? key "type" . _String - slotType <- types ^?! key typ ^? key "label" . _String + do name <- item ^? key "label" % _String + offset <- item ^? key "offset" % _Number >>= toBoundedInteger + slot <- item ^? key "slot" % _String + typ <- Key.fromText <$> item ^? key "type" % _String + slotType <- types ^?! key typ ^? key "label" % _String return (name, StorageItem (read $ Text.unpack slotType) offset (read $ Text.unpack slot))) signature :: AsValue s => s -> Text @@ -484,10 +488,10 @@ "fallback" -> "" _ -> fold [ - fromMaybe "" (abi ^? key "name" . _String), "(", + fromMaybe "" (abi ^? key "name" % _String), "(", intercalate "," - (map (\x -> x ^?! key "type" . _String) - (toList $ abi ^?! key "inputs" . _Array)), + (map (\x -> x ^?! key "type" % _String) + (toList $ abi ^?! key "inputs" % _Array)), ")" ] @@ -495,8 +499,8 @@ parseTypeName' :: AsValue s => s -> Maybe AbiType parseTypeName' x = parseTypeName - (fromMaybe mempty $ x ^? key "components" . _Array . to parseComponents) - (x ^?! key "type" . _String) + (fromMaybe mempty $ x ^? key "components" % _Array % to parseComponents) + (x ^?! key "type" % _String) where parseComponents = fmap $ snd . parseMethodInput parseMutability :: Text -> Mutability @@ -509,7 +513,7 @@ -- This actually can also parse a method output! :O parseMethodInput :: AsValue s => s -> (Text, AbiType) parseMethodInput x = - ( x ^?! key "name" . _String + ( x ^?! key "name" % _String , force "internal error: method type" (parseTypeName' x) ) @@ -707,7 +711,7 @@ Map.fromList . mapMaybe (\v -> do - src <- preview (key "src" . _String) v + src <- preview (key "src" % _String) v [i, n, f] <- mapM (readMaybe . Text.unpack) (Text.split (== ':') src) return ((i, n, f), v) ) diff --git a/src/EVM/Solvers.hs b/src/EVM/Solvers.hs --- a/src/EVM/Solvers.hs +++ b/src/EVM/Solvers.hs @@ -18,8 +18,8 @@ import Control.Concurrent (forkIO, killThread) import Control.Monad.State.Strict import Data.Char (isSpace) - import Data.Maybe (fromMaybe) + import Data.Text.Lazy (Text) import Data.Map (Map) import qualified Data.Map as Map @@ -48,11 +48,11 @@ -- | A running solver instance data SolverInstance = SolverInstance - { _type :: Solver - , _stdin :: Handle - , _stdout :: Handle - , _stderr :: Handle - , _process :: ProcessHandle + { solvertype :: Solver + , stdin :: Handle + , stdout :: Handle + , stderr :: Handle + , process :: ProcessHandle } -- | A channel representing a group of solvers @@ -145,7 +145,7 @@ -- get an initial version of the model from the solver initialModel <- getRaw -- get concrete values for each buffers max read index - hints <- capHints <$> queryMaxReads (getValue inst) cexvars.buffersV + hints <- capHints <$> queryMaxReads (getValue inst) cexvars.buffers -- check the sizes of buffer models and shrink if needed if bufsUsable initialModel then do @@ -154,11 +154,11 @@ where getRaw :: IO SMTCex getRaw = do - vars <- getVars parseVar (getValue inst) (fmap T.toStrict cexvars.calldataV) - buffers <- getBufs (getValue inst) (Map.keys cexvars.buffersV) + vars <- getVars parseVar (getValue inst) (fmap T.toStrict cexvars.calldata) + buffers <- getBufs (getValue inst) (Map.keys cexvars.buffers) storage <- getStore (getValue inst) cexvars.storeReads - blockctx <- getVars parseBlockCtx (getValue inst) (fmap T.toStrict cexvars.blockContextV) - txctx <- getVars parseFrameCtx (getValue inst) (fmap T.toStrict cexvars.txContextV) + blockctx <- getVars parseBlockCtx (getValue inst) (fmap T.toStrict cexvars.blockContext) + txctx <- getVars parseFrameCtx (getValue inst) (fmap T.toStrict cexvars.txContext) pure $ SMTCex vars buffers storage blockctx txctx -- sometimes the solver might give us back a model for the max read index @@ -218,9 +218,13 @@ -- TODO: do I need to check the write idx here? (Write _ idx next) -> idx <= 1024 && go (Comp next) +mkTimeout :: Maybe Natural -> Text +mkTimeout t = T.pack $ show $ (1000 *)$ case t of + Nothing -> 300 :: Natural + Just t' -> t' -- | Arguments used when spawing a solver instance -solverArgs :: Solver -> Maybe (Natural) -> [Text] +solverArgs :: Solver -> Maybe Natural -> [Text] solverArgs solver timeout = case solver of Bitwuzla -> error "TODO: Bitwuzla args" Z3 -> @@ -229,7 +233,7 @@ [ "--lang=smt" , "--no-interactive" , "--produce-models" - , "--tlimit-per=" <> T.pack (show (1000 * fromMaybe 10 timeout)) + , "--tlimit-per=" <> mkTimeout timeout ] Custom _ -> [] @@ -240,13 +244,11 @@ (Just stdin, Just stdout, Just stderr, process) <- createProcess cmd hSetBuffering stdin (BlockBuffering (Just 1000000)) let solverInstance = SolverInstance solver stdin stdout stderr process - case timeout of - Nothing -> pure solverInstance - Just t -> case solver of - CVC5 -> pure solverInstance - _ -> do - _ <- sendLine' solverInstance $ "(set-option :timeout " <> T.pack (show t) <> ")" - pure solverInstance + case solver of + CVC5 -> pure solverInstance + _ -> do + _ <- sendLine' solverInstance $ "(set-option :timeout " <> mkTimeout timeout <> ")" + pure solverInstance -- | Cleanly shutdown a running solver instnace stopSolver :: SolverInstance -> IO () diff --git a/src/EVM/Stepper.hs b/src/EVM/Stepper.hs --- a/src/EVM/Stepper.hs +++ b/src/EVM/Stepper.hs @@ -1,4 +1,3 @@ -{-# Language GADTs #-} {-# Language DataKinds #-} module EVM.Stepper @@ -24,28 +23,24 @@ -- The implementation uses the operational monad pattern -- as the framework for monadic interpretation. -import Prelude hiding (fail) - -import Control.Monad.Operational (Program, singleton, view, ProgramViewT(..), ProgramView) -import Control.Monad.State.Strict (runState, liftIO, StateT) -import qualified Control.Monad.State.Class as State -import qualified EVM.Exec +import Control.Monad.Operational (Program, ProgramViewT(..), ProgramView, singleton, view) +import Control.Monad.State.Strict (StateT, execState, runState, runStateT) import Data.Text (Text) -import EVM.Types (Expr, EType(..)) import EVM (EVM, VM, VMResult (VMFailure, VMSuccess), Error (Query, Choose), Query, Choose) -import qualified EVM - -import qualified EVM.Fetch as Fetch +import EVM qualified +import EVM.Exec qualified +import EVM.Fetch qualified as Fetch +import EVM.Types (Expr, EType(..)) -- | The instruction type of the operational monad data Action a where -- | Keep executing until an intermediate result is reached - Exec :: Action VMResult + Exec :: Action VMResult -- | Keep executing until an intermediate state is reached - Run :: Action VM + Run :: Action VM -- | Wait for a query to be resolved Wait :: Query -> Action () @@ -99,7 +94,7 @@ runFully :: Stepper EVM.VM runFully = do vm <- run - case vm._result of + case vm.result of Nothing -> error "should not occur" Just (VMFailure (Query q)) -> wait q >> runFully @@ -118,31 +113,28 @@ enter :: Text -> Stepper () enter t = evm (EVM.pushTrace (EVM.EntryTrace t)) -interpret :: Fetch.Fetcher -> Stepper a -> StateT VM IO a -interpret fetcher = - eval . view - +interpret :: Fetch.Fetcher -> VM -> Stepper a -> IO a +interpret fetcher vm = eval . view where - eval - :: ProgramView Action a - -> StateT VM IO a - - eval (Return x) = - pure x - - eval (action :>>= k) = - case action of - Exec -> - (State.state . runState) EVM.Exec.exec >>= interpret fetcher . k - Run -> - (State.state . runState) EVM.Exec.run >>= interpret fetcher . k - Wait q -> - do m <- liftIO (fetcher q) - State.state (runState m) >> interpret fetcher (k ()) - Ask _ -> - error "cannot make choices with this interpreter" - IOAct m -> - do m >>= interpret fetcher . k - EVM m -> do - r <- State.state (runState m) - interpret fetcher (k r) + eval :: ProgramView Action a -> IO a + eval (Return x) = pure x + eval (action :>>= k) = + case action of + Exec -> + let (r, vm') = runState EVM.Exec.exec vm + in interpret fetcher vm' (k r) + Run -> + let vm' = execState EVM.Exec.run vm + in interpret fetcher vm' (k vm') + Wait q -> do + m <- fetcher q + let vm' = execState m vm + interpret fetcher vm' (k ()) + Ask _ -> + error "cannot make choices with this interpreter" + IOAct m -> do + (r, vm') <- runStateT m vm + interpret fetcher vm' (k r) + EVM m -> + let (r, vm') = runState m vm + in interpret fetcher vm' (k r) diff --git a/src/EVM/StorageLayout.hs b/src/EVM/StorageLayout.hs --- a/src/EVM/StorageLayout.hs +++ b/src/EVM/StorageLayout.hs @@ -6,9 +6,9 @@ import EVM.Solidity (SolcContract, creationSrcmap, SlotType(..)) import EVM.ABI (AbiType (..), parseTypeName) -import Control.Lens +import Optics.Core import Data.Aeson (Value (..)) -import Data.Aeson.Lens +import Data.Aeson.Optics import Data.Foldable (toList) import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map @@ -44,8 +44,8 @@ (findContractDefinition dapp solc) in case preview ( key "attributes" - . key "linearizedBaseContracts" - . _Array + % key "linearizedBaseContracts" + % _Array ) root of Nothing -> [] @@ -60,15 +60,15 @@ storageVariablesForContract :: Value -> Maybe [Text] storageVariablesForContract node = do - name <- preview (ix "attributes" . key "name" . _String) node + name <- preview (ix "attributes" % key "name" % _String) node vars <- fmap (filter isStorageVariableDeclaration . toList) - (preview (ix "children" . _Array) node) + (preview (ix "children" % _Array) node) pure . flip map vars $ \x -> - case preview (key "attributes" . key "name" . _String) x of + case preview (key "attributes" % key "name" % _String) x of Just variableName -> mconcat [ variableName @@ -85,16 +85,16 @@ isSourceNode = isJust (preview (key "src") x) hasRightName = - Just t == preview (key "name" . _String) x + Just t == preview (key "name" % _String) x isStorageVariableDeclaration :: Value -> Bool isStorageVariableDeclaration x = nodeIs "VariableDeclaration" x - && preview (key "attributes" . key "constant" . _Bool) x /= Just True + && preview (key "attributes" % key "constant" % _Bool) x /= Just True slotTypeForDeclaration :: Value -> SlotType slotTypeForDeclaration node = - case toList <$> preview (key "children" . _Array) node of + case toList <$> preview (key "children" % _Array) node of Just (x:_) -> grokDeclarationType x _ -> @@ -102,9 +102,9 @@ grokDeclarationType :: Value -> SlotType grokDeclarationType x = - case preview (key "name" . _String) x of + case preview (key "name" % _String) x of Just "Mapping" -> - case preview (key "children" . _Array) x of + case preview (key "children" % _Array) x of Just (toList -> xs) -> grokMappingType xs _ -> @@ -128,9 +128,9 @@ grokValueType :: Value -> AbiType grokValueType x = - case ( preview (key "name" . _String) x - , preview (key "children" . _Array) x - , preview (key "attributes" . key "type" . _String) x + case ( preview (key "name" % _String) x + , preview (key "children" % _Array) x + , preview (key "attributes" % key "type" % _String) x ) of (Just "ElementaryTypeName", _, Just typeName) -> fromMaybe (error ("ungrokked value type: " ++ show typeName)) @@ -140,8 +140,8 @@ (Just "ArrayTypeName", fmap toList -> Just [t], _)-> AbiArrayDynamicType (grokValueType t) (Just "ArrayTypeName", fmap toList -> Just [t, n], _)-> - case ( preview (key "name" . _String) n - , preview (key "attributes" . key "value" . _String) n + case ( preview (key "name" % _String) n + , preview (key "attributes" % key "value" % _String) n ) of (Just "Literal", Just ((read . unpack) -> i)) -> AbiArrayType i (grokValueType t) diff --git a/src/EVM/SymExec.hs b/src/EVM/SymExec.hs --- a/src/EVM/SymExec.hs +++ b/src/EVM/SymExec.hs @@ -1,51 +1,47 @@ -{-# Language TupleSections #-} {-# Language DataKinds #-} module EVM.SymExec where -import Prelude hiding (Word) - +import Control.Concurrent.Async (concurrently, mapConcurrently) +import Control.Concurrent.Spawn (parMapIO, pool) +import Control.Concurrent.STM (atomically, TVar, readTVarIO, readTVar, newTVarIO, writeTVar) +import Control.Monad.Operational qualified as Operational +import Control.Monad.State.Strict +import Data.Bifunctor (second) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.DoubleWord (Word256) +import Data.List (foldl', sortBy) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe +import Data.Set (Set, isSubsetOf, size) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.IO qualified as TL import Data.Tuple (swap) -import Control.Lens hiding (pre) -import EVM hiding (Query, Revert, push, bytecode, cache) -import qualified EVM -import EVM.Exec -import qualified EVM.Fetch as Fetch +import GHC.Conc (getNumProcessors) +import Optics.Core + +import EVM hiding (Query, Revert, bytecode) +import EVM qualified import EVM.ABI +import EVM.Concrete (createAddress) +import EVM.Exec +import EVM.Expr qualified as Expr +import EVM.FeeSchedule qualified as FeeSchedule +import EVM.Fetch qualified as Fetch +import EVM.Format (formatExpr, indent, formatBinary) import EVM.SMT (SMTCex(..), SMT2(..), assertProps, formatSMT2) -import qualified EVM.SMT as SMT +import EVM.SMT qualified as SMT import EVM.Solvers -import EVM.Traversals -import qualified EVM.Expr as Expr import EVM.Stepper (Stepper) -import qualified EVM.Stepper as Stepper -import qualified Control.Monad.Operational as Operational -import Control.Monad.State.Strict hiding (state) +import EVM.Stepper qualified as Stepper +import EVM.Traversals import EVM.Types -import EVM.Concrete (createAddress) -import qualified EVM.FeeSchedule as FeeSchedule -import Data.DoubleWord (Word256) -import Control.Concurrent.Async -import Data.Maybe -import Data.List (foldl', sortBy) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Control.Monad.State.Class as State -import Data.Bifunctor (first, second) -import Data.Text (Text) -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TL -import EVM.Format (formatExpr) -import Data.Set (Set, isSubsetOf, size) -import qualified Data.Set as Set -import Control.Concurrent.STM (atomically, TVar, readTVarIO, readTVar, newTVarIO, writeTVar) -import Control.Concurrent.Spawn -import GHC.Conc (getNumProcessors) -import EVM.Format (indent, formatBinary) -- | A method name, and the (ordered) types of it's arguments data Sig = Sig Text [AbiType] @@ -115,11 +111,12 @@ else error "bad type" AbiBoolType -> let v = Var name in St [bool v] v AbiAddressType -> let v = Var name in St [inRange 160 v] v - AbiBytesType n - -> if n > 0 && n <= 32 - then let v = Var name in St [inRange (n * 8) v] v - else error "bad type" - AbiArrayType sz tp -> Comp $ fmap (\n -> symAbiArg (name <> n) tp) [T.pack (show n) | n <- [0..sz-1]] + AbiBytesType n -> + if n > 0 && n <= 32 + then let v = Var name in St [inRange (n * 8) v] v + else error "bad type" + AbiArrayType sz tp -> + Comp $ fmap (\n -> symAbiArg (name <> n) tp) [T.pack (show n) | n <- [0..sz-1]] t -> error $ "TODO: symbolic abi encoding for " <> show t data CalldataFragment @@ -134,22 +131,23 @@ -- kept symbolic. symCalldata :: Text -> [AbiType] -> [String] -> Expr Buf -> (Expr Buf, [Prop]) symCalldata sig typesignature concreteArgs base = - let args = concreteArgs <> replicate (length typesignature - length concreteArgs) "" - mkArg :: AbiType -> String -> Int -> CalldataFragment - mkArg typ "" n = symAbiArg (T.pack $ "arg" <> show n) typ - mkArg typ arg _ = let v = makeAbiValue typ arg - in case v of - AbiUInt _ w -> St [] . Lit . num $ w - AbiInt _ w -> St [] . Lit . num $ w - AbiAddress w -> St [] . Lit . num $ w - AbiBool w -> St [] . Lit $ if w then 1 else 0 - _ -> error "TODO" - calldatas = zipWith3 mkArg typesignature args [1..] - (cdBuf, props) = combineFragments calldatas base - withSelector = writeSelector cdBuf sig - sizeConstraints - = (Expr.bufLength withSelector .>= cdLen calldatas) - .&& (Expr.bufLength withSelector .< (Lit (2 ^ (64 :: Integer)))) + let + args = concreteArgs <> replicate (length typesignature - length concreteArgs) "" + mkArg :: AbiType -> String -> Int -> CalldataFragment + mkArg typ "" n = symAbiArg (T.pack $ "arg" <> show n) typ + mkArg typ arg _ = + case makeAbiValue typ arg of + AbiUInt _ w -> St [] . Lit . num $ w + AbiInt _ w -> St [] . Lit . num $ w + AbiAddress w -> St [] . Lit . num $ w + AbiBool w -> St [] . Lit $ if w then 1 else 0 + _ -> error "TODO" + calldatas = zipWith3 mkArg typesignature args [1..] + (cdBuf, props) = combineFragments calldatas base + withSelector = writeSelector cdBuf sig + sizeConstraints + = (Expr.bufLength withSelector .>= cdLen calldatas) + .&& (Expr.bufLength withSelector .< (Lit (2 ^ (64 :: Integer)))) in (withSelector, sizeConstraints : props) cdLen :: [CalldataFragment] -> Expr EWord @@ -162,7 +160,8 @@ _ -> error "unsupported" writeSelector :: Expr Buf -> Text -> Expr Buf -writeSelector buf sig = writeSel (Lit 0) $ writeSel (Lit 1) $ writeSel (Lit 2) $ writeSel (Lit 3) buf +writeSelector buf sig = + writeSel (Lit 0) $ writeSel (Lit 1) $ writeSel (Lit 2) $ writeSel (Lit 3) buf where sel = ConcreteBuf $ selector sig writeSel idx = Expr.writeByte idx (Expr.readByte idx sel) @@ -172,127 +171,141 @@ where go :: Expr EWord -> [CalldataFragment] -> (Expr Buf, [Prop]) -> (Expr Buf, [Prop]) go _ [] acc = acc - go idx (f:rest) (buf, ps) = case f of - St p w -> go (Expr.add idx (Lit 32)) rest (Expr.writeWord idx w buf, p <> ps) - s -> error $ "unsupported cd fragment: " <> show s + go idx (f:rest) (buf, ps) = + case f of + St p w -> go (Expr.add idx (Lit 32)) rest (Expr.writeWord idx w buf, p <> ps) + s -> error $ "unsupported cd fragment: " <> show s -abstractVM :: (Expr Buf, [Prop]) -> ByteString -> Maybe Precondition -> StorageModel -> VM -abstractVM (cd, calldataProps) contractCode maybepre storagemodel = finalVm +abstractVM + :: (Expr Buf, [Prop]) + -> ByteString + -> Maybe Precondition + -> Expr Storage + -> VM +abstractVM cd contractCode maybepre store = finalVm where - store = case storagemodel of - SymbolicS -> AbstractStore - InitialS -> EmptyStore - ConcreteS -> ConcreteStore mempty caller' = Caller 0 value' = CallValue 0 code' = RuntimeCode (ConcreteRuntimeCode contractCode) - vm' = loadSymVM code' store caller' value' cd calldataProps + vm' = loadSymVM code' store caller' value' cd precond = case maybepre of Nothing -> [] Just p -> [p vm'] - finalVm = vm' & over constraints (<> precond) + finalVm = vm' & over #constraints (<> precond) -loadSymVM :: ContractCode -> Expr Storage -> Expr EWord -> Expr EWord -> Expr Buf -> [Prop] -> VM -loadSymVM x initStore addr callvalue' calldata' calldataProps = +loadSymVM + :: ContractCode + -> Expr Storage + -> Expr EWord + -> Expr EWord + -> (Expr Buf, [Prop]) + -> VM +loadSymVM x initStore addr callvalue' cd = (makeVm $ VMOpts - { vmoptContract = initialContract x - , vmoptCalldata = (calldata', calldataProps) - , vmoptValue = callvalue' - , vmoptStorageBase = Symbolic - , vmoptAddress = createAddress ethrunAddress 1 - , vmoptCaller = addr - , vmoptOrigin = ethrunAddress --todo: generalize - , vmoptCoinbase = 0 - , vmoptNumber = 0 - , vmoptTimestamp = (Lit 0) - , vmoptBlockGaslimit = 0 - , vmoptGasprice = 0 - , vmoptPrevRandao = 42069 - , vmoptGas = 0xffffffffffffffff - , vmoptGaslimit = 0xffffffffffffffff - , vmoptBaseFee = 0 - , vmoptPriorityFee = 0 - , vmoptMaxCodeSize = 0xffffffff - , vmoptSchedule = FeeSchedule.berlin - , vmoptChainId = 1 - , vmoptCreate = False - , vmoptTxAccessList = mempty - , vmoptAllowFFI = False - }) & set (env . contracts . at (createAddress ethrunAddress 1)) + { contract = initialContract x + , calldata = cd + , value = callvalue' + , initialStorage = initStore + , address = createAddress ethrunAddress 1 + , caller = addr + , origin = ethrunAddress --todo: generalize + , coinbase = 0 + , number = 0 + , timestamp = Lit 0 + , blockGaslimit = 0 + , gasprice = 0 + , prevRandao = 42069 + , gas = 0xffffffffffffffff + , gaslimit = 0xffffffffffffffff + , baseFee = 0 + , priorityFee = 0 + , maxCodeSize = 0xffffffff + , schedule = FeeSchedule.berlin + , chainId = 1 + , create = False + , txAccessList = mempty + , allowFFI = False + }) & set (#env % #contracts % at (createAddress ethrunAddress 1)) (Just (initialContract x)) - & set (env . EVM.storage) initStore - --- | Interpreter which explores all paths at branching points. --- returns an Expr representing the possible executions +-- | Interpreter which explores all paths at branching points. Returns an +-- 'Expr End' representing the possible executions. interpret :: Fetch.Fetcher -> Maybe Integer -- max iterations -> Maybe Integer -- ask smt iterations + -> VM -> Stepper (Expr End) - -> StateT VM IO (Expr End) -interpret fetcher maxIter askSmtIters = + -> IO (Expr End) +interpret fetcher maxIter askSmtIters vm = eval . Operational.view - where - eval - :: Operational.ProgramView Stepper.Action (Expr End) - -> StateT VM IO (Expr End) + eval + :: Operational.ProgramView Stepper.Action (Expr End) + -> IO (Expr End) - eval (Operational.Return x) = pure x + eval (Operational.Return x) = pure x - eval (action Operational.:>>= k) = - case action of - Stepper.Exec -> - (State.state . runState) exec >>= interpret fetcher maxIter askSmtIters . k - Stepper.Run -> - (State.state . runState) run >>= interpret fetcher maxIter askSmtIters . k - Stepper.IOAct q -> - mapStateT liftIO q >>= interpret fetcher maxIter askSmtIters . k - Stepper.Ask (EVM.PleaseChoosePath cond continue) -> do - assign result Nothing - vm <- get - case maxIterationsReached vm maxIter of - -- TODO: parallelise - Nothing -> do - a <- interpret fetcher maxIter askSmtIters (Stepper.evm (continue True) >>= k) - put vm - b <- interpret fetcher maxIter askSmtIters (Stepper.evm (continue False) >>= k) - return $ ITE cond a b - Just n -> - -- Let's escape the loop. We give no guarantees at this point - interpret fetcher maxIter askSmtIters (Stepper.evm (continue (not n)) >>= k) - Stepper.Wait q -> do - let performQuery = do - m <- liftIO (fetcher q) - interpret fetcher maxIter askSmtIters (Stepper.evm m >>= k) + eval (action Operational.:>>= k) = + case action of + Stepper.Exec -> do + let (r, vm') = runState exec vm + interpret fetcher maxIter askSmtIters vm' (k r) + Stepper.Run -> do + let vm' = execState exec vm + interpret fetcher maxIter askSmtIters vm' (k vm') + Stepper.IOAct q -> do + (r, vm') <- runStateT q vm + interpret fetcher maxIter askSmtIters vm' (k r) + Stepper.Ask (EVM.PleaseChoosePath cond continue) -> + case maxIterationsReached vm maxIter of + Nothing -> do + (a, b) <- concurrently + (let (ra, vma) = runState (continue True) vm { result = Nothing } + in interpret fetcher maxIter askSmtIters vma (k ra)) + (let (rb, vmb) = runState (continue False) vm { result = Nothing } + in interpret fetcher maxIter askSmtIters vmb (k rb)) - case q of - PleaseAskSMT _ _ continue -> do - codelocation <- getCodeLocation <$> get - iteration <- num . fromMaybe 0 <$> use (iterations . at codelocation) + pure $ ITE cond a b + Just n -> do + -- Let's escape the loop. We give no guarantees at this point + let (r, vm') = runState (continue (not n)) vm { result = Nothing } + interpret fetcher maxIter askSmtIters vm' (k r) + Stepper.Wait q -> do + let performQuery = do + m <- liftIO (fetcher q) + let (r, vm') = runState m vm + interpret fetcher maxIter askSmtIters vm' (k r) - -- if this is the first time we are branching at this point, - -- explore both branches without consulting SMT. - -- Exploring too many branches is a lot cheaper than - -- consulting our SMT solver. - if iteration < (fromMaybe 5 askSmtIters) - then interpret fetcher maxIter askSmtIters (Stepper.evm (continue EVM.Unknown) >>= k) - else performQuery + case q of + PleaseAskSMT _ _ continue -> do + let + codelocation = getCodeLocation vm + iteration = num . fromMaybe 0 $ Map.lookup codelocation vm.iterations - _ -> performQuery + -- if this is the first time we are branching at this point, + -- explore both branches without consulting SMT. + -- Exploring too many branches is a lot cheaper than + -- consulting our SMT solver. + if iteration < fromMaybe 5 askSmtIters then do + let (r, vm') = runState (continue EVM.Unknown) vm + interpret fetcher maxIter askSmtIters vm' (k r) + else performQuery - Stepper.EVM m -> - State.state (runState m) >>= interpret fetcher maxIter askSmtIters . k + _ -> performQuery + Stepper.EVM m -> do + let (r, vm') = runState m vm + interpret fetcher maxIter askSmtIters vm' (k r) + maxIterationsReached :: VM -> Maybe Integer -> Maybe Bool maxIterationsReached _ Nothing = Nothing maxIterationsReached vm (Just maxIter) = let codelocation = getCodeLocation vm - iters = view (at codelocation . non 0) vm._iterations + iters = view (at codelocation % non 0) vm.iterations in if num maxIter <= iters - then Map.lookup (codelocation, iters - 1) vm._cache._path + then Map.lookup (codelocation, iters - 1) vm.cache.path else Nothing @@ -300,10 +313,18 @@ type Postcondition = VM -> Expr End -> Prop -checkAssert :: SolverGroup -> [Word256] -> ByteString -> Maybe Sig -> [String] -> VeriOpts -> IO (Expr End, [VerifyResult]) -checkAssert solvers errs c signature' concreteArgs opts = verifyContract solvers c signature' concreteArgs opts SymbolicS Nothing (Just $ checkAssertions errs) +checkAssert + :: SolverGroup + -> [Word256] + -> ByteString + -> Maybe Sig + -> [String] + -> VeriOpts + -> IO (Expr End, [VerifyResult]) +checkAssert solvers errs c signature' concreteArgs opts = + verifyContract solvers c signature' concreteArgs opts AbstractStore Nothing (Just $ checkAssertions errs) -{- |Checks if an assertion violation has been encountered +{- | Checks if an assertion violation has been encountered hevm recognises the following as an assertion violation: @@ -328,37 +349,48 @@ Revert _ b -> foldl' PAnd (PBool True) (fmap (PNeg . PEq b . ConcreteBuf . panicMsg) errs) _ -> PBool True --- |By default hevm checks for all assertions except those which result from arithmetic overflow +-- | By default hevm only checks for user-defined assertions defaultPanicCodes :: [Word256] -defaultPanicCodes = [ 0x00, 0x01, 0x12, 0x21, 0x22, 0x31, 0x32, 0x41, 0x51 ] +defaultPanicCodes = [0x01] allPanicCodes :: [Word256] -allPanicCodes = [ 0x00, 0x01, 0x11, 0x12, 0x21, 0x22, 0x31, 0x32, 0x41, 0x51 ] +allPanicCodes = [0x00, 0x01, 0x11, 0x12, 0x21, 0x22, 0x31, 0x32, 0x41, 0x51] --- |Produces the revert message for solc >=0.8 assertion violations +-- | Produces the revert message for solc >=0.8 assertion violations panicMsg :: Word256 -> ByteString -panicMsg err = (selector "Panic(uint256)") <> (encodeAbiValue $ AbiUInt 256 err) +panicMsg err = selector "Panic(uint256)" <> encodeAbiValue (AbiUInt 256 err) --- | Builds a buffer representing calldata from the provided method description and concrete arguments +-- | Builds a buffer representing calldata from the provided method description +-- and concrete arguments mkCalldata :: Maybe Sig -> [String] -> (Expr Buf, [Prop]) mkCalldata Nothing _ = - ( AbstractBuf "txdata" - -- assert that the length of the calldata is never more than 2^64 - -- this is way larger than would ever be allowed by the gas limit - -- and avoids spurious counterexamples during abi decoding - -- TODO: can we encode calldata as an array with a smaller length? - , [Expr.bufLength (AbstractBuf "txdata") .< (Lit (2 ^ (64 :: Integer)))] - ) -mkCalldata (Just (Sig name types)) args = symCalldata name types args (AbstractBuf "txdata") + ( AbstractBuf "txdata" + -- assert that the length of the calldata is never more than 2^64 + -- this is way larger than would ever be allowed by the gas limit + -- and avoids spurious counterexamples during abi decoding + -- TODO: can we encode calldata as an array with a smaller length? + , [Expr.bufLength (AbstractBuf "txdata") .< (Lit (2 ^ (64 :: Integer)))] + ) +mkCalldata (Just (Sig name types)) args = + symCalldata name types args (AbstractBuf "txdata") -verifyContract :: SolverGroup -> ByteString -> Maybe Sig -> [String] -> VeriOpts -> StorageModel -> Maybe Precondition -> Maybe Postcondition -> IO (Expr End, [VerifyResult]) -verifyContract solvers theCode signature concreteArgs opts storagemodel maybepre maybepost = do - let preState = abstractVM (mkCalldata signature concreteArgs) theCode maybepre storagemodel - verify solvers opts preState maybepost +verifyContract + :: SolverGroup + -> ByteString + -> Maybe Sig + -> [String] + -> VeriOpts + -> Expr Storage + -> Maybe Precondition + -> Maybe Postcondition + -> IO (Expr End, [VerifyResult]) +verifyContract solvers theCode signature' concreteArgs opts initStore maybepre maybepost = + let preState = abstractVM (mkCalldata signature' concreteArgs) theCode maybepre initStore + in verify solvers opts preState maybepost pruneDeadPaths :: [VM] -> [VM] pruneDeadPaths = - filter $ \vm -> case vm._result of + filter $ \vm -> case vm.result of Just (VMFailure DeadPath) -> False _ -> True @@ -366,10 +398,10 @@ runExpr :: Stepper.Stepper (Expr End) runExpr = do vm <- Stepper.runFully - let asserts = vm._keccakEqs - pure $ case vm._result of + let asserts = vm.keccakEqs + pure $ case vm.result of Nothing -> error "Internal Error: vm in intermediate state after call to runFully" - Just (VMSuccess buf) -> Return asserts buf vm._env._storage + Just (VMSuccess buf) -> Return asserts buf vm.env.storage Just (VMFailure e) -> case e of UnrecognizedOpcode _ -> Failure asserts Invalid SelfDestruction -> Failure asserts SelfDestruct @@ -381,18 +413,19 @@ EVM.StackUnderrun -> Failure asserts EVM.Types.StackUnderrun e' -> Failure asserts $ EVM.Types.TmpErr (show e') --- | Converts a given top level expr into a list of final states and the associated path conditions for each state -flattenExpr :: Expr End -> [([Prop], Expr End)] +-- | Converts a given top level expr into a list of final states and the +-- associated path conditions for each state. +flattenExpr :: Expr End -> [Expr End] flattenExpr = go [] where - go :: [Prop] -> Expr End -> [([Prop], Expr End)] - go pcs = \case - ITE c t f -> go (PNeg ((PEq c (Lit 0))) : pcs) t <> go (PEq c (Lit 0) : pcs) f - e@(Revert _ _) -> [(pcs, e)] - e@(Return _ _ _) -> [(pcs, e)] - Failure _ (TmpErr s) -> error s - e@(Failure _ _) -> [(pcs, e)] - GVar _ -> error "cannot flatten an Expr containing a GVar" + go :: [Prop] -> Expr End -> [Expr End] + go pcs = \case + ITE c t f -> go (PNeg ((PEq c (Lit 0))) : pcs) t <> go (PEq c (Lit 0) : pcs) f + Failure _ (TmpErr s) -> error s + GVar _ -> error "cannot flatten an Expr containing a GVar" + Revert ps msg -> [Revert (ps <> pcs) msg] + Return ps msg store -> [Return (ps <> pcs) msg store] + Failure ps e -> [Failure (ps <> pcs) e] -- | Strips unreachable branches from a given expr -- Returns a list of executed SMT queries alongside the reduced expression for debugging purposes @@ -405,8 +438,8 @@ -- TODO: handle errors properly reachable :: SolverGroup -> Expr End -> IO ([SMT2], Expr End) reachable solvers e = do - res <- go [] e - pure $ second (fromMaybe (error "Internal Error: no reachable paths found")) res + res <- go [] e + pure $ second (fromMaybe (error "Internal Error: no reachable paths found")) res where {- Walk down the tree and collect pcs. @@ -468,7 +501,7 @@ o -> o --- | Extract contraints stored in Expr End nodes +-- | Extract contraints stored in Expr End nodes extractProps :: Expr End -> [Prop] extractProps = \case ITE _ _ _ -> [] @@ -478,12 +511,18 @@ GVar _ -> error "cannot extract props from a GVar" --- | Symbolically execute the VM and check all endstates against the postcondition, if available. -verify :: SolverGroup -> VeriOpts -> VM -> Maybe Postcondition -> IO (Expr End, [VerifyResult]) +-- | Symbolically execute the VM and check all endstates against the +-- postcondition, if available. +verify + :: SolverGroup + -> VeriOpts + -> VM + -> Maybe Postcondition + -> IO (Expr End, [VerifyResult]) verify solvers opts preState maybepost = do putStrLn "Exploring contract" - exprInter <- evalStateT (interpret (Fetch.oracle solvers opts.rpcInfo) opts.maxIter opts.askSmtIters runExpr) preState + exprInter <- interpret (Fetch.oracle solvers opts.rpcInfo) opts.maxIter opts.askSmtIters preState runExpr when opts.debug $ T.writeFile "unsimplified.expr" (formatExpr exprInter) putStrLn "Simplifying expression" @@ -498,12 +537,15 @@ let -- Filter out any leaves that can be statically shown to be safe canViolate = flip filter (flattenExpr expr) $ - \(_, leaf) -> case evalProp (post preState leaf) of + \leaf -> case evalProp (post preState leaf) of PBool True -> False _ -> True - assumes = preState._constraints - withQueries = fmap (\(pcs, leaf) -> (assertProps (PNeg (post preState leaf) : assumes <> extractProps leaf <> pcs), leaf)) canViolate - putStrLn $ "Checking for reachability of " <> show (length withQueries) <> " potential property violation(s)" + assumes = preState.constraints + withQueries = canViolate <&> \leaf -> + (assertProps (PNeg (post preState leaf) : assumes <> extractProps leaf), leaf) + putStrLn $ "Checking for reachability of " + <> show (length withQueries) + <> " potential property violation(s)" when opts.debug $ forM_ (zip [(1 :: Int)..] withQueries) $ \(idx, (q, leaf)) -> do TL.writeFile @@ -526,12 +568,17 @@ type UnsatCache = TVar [Set Prop] --- | Compares two contract runtimes for trace equivalence by running two VMs and comparing the end states. +-- | Compares two contract runtimes for trace equivalence by running two VMs +-- and comparing the end states. -- --- We do this by asking the solver to find a common input for each pair of endstates that satisfies the path --- conditions for both sides and produces a differing output. If we can find such an input, then we have a clear --- equivalence break, and since we run this check for every pair of end states, the check is exhaustive. -equivalenceCheck :: SolverGroup -> ByteString -> ByteString -> VeriOpts -> (Expr Buf, [Prop]) -> IO [EquivResult] +-- We do this by asking the solver to find a common input for each pair of +-- endstates that satisfies the path conditions for both sides and produces a +-- differing output. If we can find such an input, then we have a clear +-- equivalence break, and since we run this check for every pair of end states, +-- the check is exhaustive. +equivalenceCheck + :: SolverGroup -> ByteString -> ByteString -> VeriOpts -> (Expr Buf, [Prop]) + -> IO [EquivResult] equivalenceCheck solvers bytecodeA bytecodeB opts calldata' = do case bytecodeA == bytecodeB of True -> do @@ -541,11 +588,11 @@ branchesA <- getBranches bytecodeA branchesB <- getBranches bytecodeB let allPairs = [(a,b) | a <- branchesA, b <- branchesB] - putStrLn $ "Found " <> (show $ length allPairs) <> " total pairs of endstates" + putStrLn $ "Found " <> show (length allPairs) <> " total pairs of endstates" - when opts.debug $ putStrLn - $ "endstates in bytecodeA: " <> (show $ length branchesA) - <> "\nendstates in bytecodeB: " <> (show $ length branchesB) + when opts.debug $ + putStrLn $ "endstates in bytecodeA: " <> show (length branchesA) + <> "\nendstates in bytecodeB: " <> show (length branchesB) let differingEndStates = sortBySize (mapMaybe (uncurry distinct) allPairs) putStrLn $ "Asking the SMT solver for " <> (show $ length differingEndStates) <> " pairs" @@ -572,12 +619,12 @@ subsetAny a b = foldr (\bp acc -> acc || isSubsetOf a bp) False b -- decompiles the given bytecode into a list of branches - getBranches :: ByteString -> IO [([Prop], Expr End)] + getBranches :: ByteString -> IO [Expr End] getBranches bs = do let bytecode = if BS.null bs then BS.pack [0] else bs - prestate = abstractVM calldata' bytecode Nothing SymbolicS - expr <- evalStateT (interpret (Fetch.oracle solvers Nothing) opts.maxIter opts.askSmtIters runExpr) prestate + prestate = abstractVM calldata' bytecode Nothing AbstractStore + expr <- interpret (Fetch.oracle solvers Nothing) opts.maxIter opts.askSmtIters prestate runExpr let simpl = if opts.simp then (Expr.simplify expr) else expr pure $ flattenExpr simpl @@ -594,13 +641,14 @@ else (fmap ((False),) (checkSat solvers smt)) case res of (_, Sat x) -> pure (Cex x, False) - (quick, Unsat) -> case quick of - True -> pure (Qed (), quick) - False -> do - -- nb: we might end up with duplicates here due to a - -- potential race, but it doesn't matter for correctness - atomically $ readTVar knownUnsat >>= writeTVar knownUnsat . (props :) - pure (Qed (), False) + (quick, Unsat) -> + case quick of + True -> pure (Qed (), quick) + False -> do + -- nb: we might end up with duplicates here due to a + -- potential race, but it doesn't matter for correctness + atomically $ readTVar knownUnsat >>= writeTVar knownUnsat . (props :) + pure (Qed (), False) (_, EVM.Solvers.Unknown) -> pure (Timeout (), False) (_, Error txt) -> error $ "Error while running solver: `" <> T.unpack txt -- <> "` SMT file was: `" <> filename <> "`" @@ -618,8 +666,8 @@ -- for a given pair of branches, equivalence is violated if there exists an -- input that satisfies the branch conditions from both sides and produces -- a differing result in each branch - distinct :: ([Prop], Expr End) -> ([Prop], Expr End) -> Maybe (Set Prop) - distinct (aProps, aEnd) (bProps, bEnd) = + distinct :: Expr End -> Expr End -> Maybe (Set Prop) + distinct aEnd bEnd = let differingResults = case (aEnd, bEnd) of (Return _ aOut aStore, Return _ bOut bStore) -> @@ -646,11 +694,11 @@ -- if we can statically determine that the end states differ, then we -- ask the solver to find us inputs that satisfy both sets of branch -- conditions - PBool True -> Just . Set.fromList $ aProps <> bProps + PBool True -> Just . Set.fromList $ extractProps aEnd <> extractProps bEnd -- if we cannot statically determine whether or not the end states -- differ, then we ask the solver if the end states can differ if both -- sets of path conditions are satisfiable - _ -> Just . Set.fromList $ differingResults : aProps <> bProps + _ -> Just . Set.fromList $ differingResults : extractProps aEnd <> extractProps bEnd both' :: (a -> b) -> (a, a) -> (b, b) both' f (x, y) = (f x, f y) @@ -658,7 +706,7 @@ produceModels :: SolverGroup -> Expr End -> IO [(Expr End, CheckSatResult)] produceModels solvers expr = do let flattened = flattenExpr expr - withQueries = fmap (first assertProps) flattened + withQueries = fmap (\e -> (assertProps . extractProps $ e, e)) flattened results <- flip mapConcurrently withQueries $ \(query, leaf) -> do res <- checkSat solvers query pure (res, leaf) @@ -713,7 +761,10 @@ | Map.null store = [] | otherwise = [ "Storage:" - , indent 2 $ T.unlines $ Map.foldrWithKey (\key val acc -> ("Addr " <> (T.pack $ show key) <> ": " <> (T.pack $ show (Map.toList val))) : acc) mempty store + , indent 2 $ T.unlines $ Map.foldrWithKey (\key val acc -> + ("Addr " <> (T.pack . show . Addr . num $ key) + <> ": " <> (T.pack $ show (Map.toList val))) : acc + ) mempty store , "" ] @@ -722,7 +773,9 @@ | Map.null txContext = [] | otherwise = [ "Transaction Context:" - , indent 2 $ T.unlines $ Map.foldrWithKey (\key val acc -> (showTxCtx key <> ": " <> (T.pack $ show val)) : acc) mempty (filterSubCtx txContext) + , indent 2 $ T.unlines $ Map.foldrWithKey (\key val acc -> + (showTxCtx key <> ": " <> (T.pack $ show val)) : acc + ) mempty (filterSubCtx txContext) , "" ] @@ -751,7 +804,9 @@ | Map.null blockContext = [] | otherwise = [ "Block Context:" - , indent 2 $ T.unlines $ Map.foldrWithKey (\key val acc -> (T.pack $ show key <> ": " <> show val) : acc) mempty txContext + , indent 2 $ T.unlines $ Map.foldrWithKey (\key val acc -> + (T.pack $ show key <> ": " <> show val) : acc + ) mempty txContext , "" ] @@ -760,12 +815,17 @@ prettyBuf (ConcreteBuf bs) = formatBinary bs prettyBuf _ = "Any" --- | Takes a buffer and a Cex and replaces all abstract values in the buf with concrete ones from the Cex +-- | Takes a buffer and a Cex and replaces all abstract values in the buf with +-- concrete ones from the Cex. subModel :: SMTCex -> Expr a -> Expr a -subModel c expr = subBufs (fmap forceFlattened c.buffers) . subVars c.vars . subStore c.store . subVars c.blockContext . subVars c.txContext $ expr +subModel c expr = + subBufs (fmap forceFlattened c.buffers) . subVars c.vars . subStore c.store + . subVars c.blockContext . subVars c.txContext $ expr where forceFlattened (SMT.Flat bs) = bs - forceFlattened b@(SMT.Comp _) = forceFlattened $ fromMaybe (error $ "Internal Error: cannot flatten buffer: " <> show b) (SMT.collapse b) + forceFlattened b@(SMT.Comp _) = forceFlattened $ + fromMaybe (error $ "Internal Error: cannot flatten buffer: " <> show b) + (SMT.collapse b) subVars model b = Map.foldlWithKey subVar b model subVar :: Expr a -> Expr EWord -> W256 -> Expr a diff --git a/src/EVM/TTY.hs b/src/EVM/TTY.hs --- a/src/EVM/TTY.hs +++ b/src/EVM/TTY.hs @@ -1,4 +1,5 @@ {-# Language TemplateHaskell #-} +{-# Language UndecidableInstances #-} {-# Language ImplicitParams #-} {-# Language DataKinds #-} @@ -32,10 +33,13 @@ import EVM.StorageLayout import EVM.TTYCenteredList qualified as Centered -import Control.Lens hiding (List) +import Optics.Core +import Optics.State +import Optics.TH + import Control.Monad.Operational qualified as Operational import Control.Monad.State.Strict hiding (state) -import Data.Aeson.Lens +import Data.Aeson.Optics import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.List (sort, find) @@ -68,23 +72,23 @@ type UiWidget = Widget Name data UiVmState = UiVmState - { _uiVm :: VM - , _uiStep :: Int - , _uiSnapshots :: Map Int (VM, Stepper ()) - , _uiStepper :: Stepper () - , _uiShowMemory :: Bool - , _uiTestOpts :: UnitTestOptions + { vm :: VM + , step :: Int + , snapshots :: Map Int (VM, Stepper ()) + , stepper :: Stepper () + , showMemory :: Bool + , testOpts :: UnitTestOptions } data UiTestPickerState = UiTestPickerState - { _testPickerList :: List Name (Text, Text) - , _testPickerDapp :: DappInfo - , _testOpts :: UnitTestOptions + { tests :: List Name (Text, Text) + , dapp :: DappInfo + , opts :: UnitTestOptions } data UiBrowserState = UiBrowserState - { _browserContractList :: List Name (Addr, Contract) - , _browserVm :: UiVmState + { contracts :: List Name (Addr, Contract) + , vm :: UiVmState } data UiState @@ -93,9 +97,9 @@ | ViewPicker UiTestPickerState | ViewHelp UiVmState -makeLenses ''UiVmState -makeLenses ''UiTestPickerState -makeLenses ''UiBrowserState +makeFieldLabelsNoPrefix ''UiVmState +makeFieldLabelsNoPrefix ''UiTestPickerState +makeFieldLabelsNoPrefix ''UiBrowserState makePrisms ''UiState -- caching VM states lets us backstep efficiently @@ -142,10 +146,10 @@ Stepper.Run -> do -- Have we reached the final result of this action? - use (uiVm . result) >>= \case + use (#vm % #result) >>= \case Just _ -> do -- Yes, proceed with the next action. - vm <- use uiVm + vm <- use #vm interpret mode (k vm) Nothing -> do -- No, keep performing the current action @@ -154,7 +158,7 @@ -- Stepper wants to keep executing? Stepper.Exec -> do -- Have we reached the final result of this action? - use (uiVm . result) >>= \case + use (#vm % #result) >>= \case Just r -> -- Yes, proceed with the next action. interpret mode (k r) @@ -165,7 +169,7 @@ -- Stepper is waiting for user input from a query Stepper.Ask (PleaseChoosePath _ cont) -> do -- ensure we aren't stepping past max iterations - vm <- use uiVm + vm <- use #vm case maxIterationsReached vm ?maxIter of Nothing -> pure $ Continue (k ()) Just n -> interpret mode (Stepper.evm (cont (not n)) >>= k) @@ -177,13 +181,13 @@ -- Stepper wants to make a query and wait for the results? Stepper.IOAct q -> do - Brick.zoom uiVm (StateT (runStateT q)) >>= interpret mode . k + Brick.zoom (toLensVL #vm) (StateT (runStateT q)) >>= interpret mode . k -- Stepper wants to modify the VM. Stepper.EVM m -> do - vm <- use uiVm + vm <- use #vm let (r, vm1) = runState m vm - assign uiVm vm1 + assign #vm vm1 interpret mode (Stepper.exec >> (k r)) keepExecuting :: (?fetcher :: Fetcher @@ -204,7 +208,7 @@ interpret (Step (i - 1)) restart StepUntil p -> do - vm <- use uiVm + vm <- use #vm if p vm then interpret (Step 0) restart @@ -251,19 +255,19 @@ v <- mkVty ui2 <- customMain v mkVty Nothing (app opts) (ViewVm ui0) case ui2 of - ViewVm ui -> return ui._uiVm + ViewVm ui -> return ui.vm _ -> error "internal error: customMain returned prematurely" initUiVmState :: VM -> UnitTestOptions -> Stepper () -> UiVmState initUiVmState vm0 opts script = UiVmState - { _uiVm = vm0 - , _uiStepper = script - , _uiStep = 0 - , _uiSnapshots = singleton 0 (vm0, script) - , _uiShowMemory = False - , _uiTestOpts = opts + { vm = vm0 + , stepper = script + , step = 0 + , snapshots = singleton 0 (vm0, script) + , showMemory = False + , testOpts = opts } @@ -290,7 +294,7 @@ let dapp = dappInfo root contractMap sourceCache ui = ViewPicker $ UiTestPickerState - { _testPickerList = + { tests = list TestPickerPane (Vec.fromList @@ -298,8 +302,8 @@ (debuggableTests opts) dapp.unitTests)) 1 - , _testPickerDapp = dapp - , _testOpts = opts + , dapp = dapp + , opts = opts } v <- mkVty _ <- customMain v mkVty Nothing (app opts) (ui :: UiState) @@ -316,9 +320,9 @@ (Stopped (), _) -> pure () (Continue steps, ui') -> - put (ViewVm (ui' & set uiStepper steps)) + put (ViewVm (ui' & set #stepper steps)) where - m = interpret mode ui._uiStepper + m = interpret mode ui.stepper nxt = runStateT m ui backstepUntil @@ -327,32 +331,32 @@ => (UiVmState -> Pred VM) -> EventM n UiState () backstepUntil p = get >>= \case ViewVm s -> - case s._uiStep of + case s.step of 0 -> pure () n -> do s1 <- liftIO $ backstep s let -- find a previous vm that satisfies the predicate - snapshots' = Data.Map.filter (p s1 . fst) s1._uiSnapshots + snapshots' = Data.Map.filter (p s1 . fst) s1.snapshots case lookupLT n snapshots' of -- If no such vm exists, go to the beginning Nothing -> let - (step', (vm', stepper')) = fromJust $ lookupLT (n - 1) s._uiSnapshots + (step', (vm', stepper')) = fromJust $ lookupLT (n - 1) s.snapshots s2 = s1 - & set uiVm vm' - & set (uiVm . cache) s1._uiVm._cache - & set uiStep step' - & set uiStepper stepper' + & set #vm vm' + & set (#vm % #cache) s1.vm.cache + & set #step step' + & set #stepper stepper' in takeStep s2 (Step 0) -- step until the predicate doesn't hold Just (step', (vm', stepper')) -> let s2 = s1 - & set uiVm vm' - & set (uiVm . cache) s1._uiVm._cache - & set uiStep step' - & set uiStepper stepper' + & set #vm vm' + & set (#vm % #cache) s1.vm.cache + & set #step step' + & set #stepper stepper' in takeStep s2 (StepUntil (not . p s1)) _ -> pure () @@ -361,7 +365,7 @@ ,?maxIter :: Maybe Integer) => UiVmState -> IO UiVmState backstep s = - case s._uiStep of + case s.step of -- We're already at the first step; ignore command. 0 -> pure s -- To step backwards, we revert to the previous snapshot @@ -371,17 +375,17 @@ -- any blocking queries, and also the memory view. n -> let - (step, (vm, stepper)) = fromJust $ lookupLT n s._uiSnapshots + (step, (vm, stepper)) = fromJust $ lookupLT n s.snapshots s1 = s - & set uiVm vm - & set (uiVm . cache) s._uiVm._cache - & set uiStep step - & set uiStepper stepper + & set #vm vm + & set (#vm % #cache) s.vm.cache + & set #step step + & set #stepper stepper stepsToTake = n - step - 1 in runStateT (interpret (Step stepsToTake) stepper) s1 >>= \case - (Continue steps, ui') -> pure $ ui' & set uiStepper steps + (Continue steps, ui') -> pure $ ui' & set #stepper steps _ -> error "unexpected end" appEvent @@ -393,7 +397,7 @@ appEvent (VtyEvent e@(V.EvKey V.KDown [])) = get >>= \case ViewContracts _s -> do Brick.zoom - (_ViewContracts . browserContractList) + (traverseOf $ _ViewContracts % #contracts) (handleListEvent e) pure () _ -> pure () @@ -403,7 +407,7 @@ appEvent (VtyEvent e@(V.EvKey V.KUp [])) = get >>= \case ViewContracts _s -> do Brick.zoom - (_ViewContracts . browserContractList) + (traverseOf $ _ViewContracts % #contracts) (handleListEvent e) _ -> pure () @@ -411,19 +415,19 @@ -- Any: Esc - return to Vm Overview or Exit appEvent (VtyEvent (V.EvKey V.KEsc [])) = get >>= \case ViewVm s -> do - let opts = s ^. uiTestOpts + let opts = s ^. #testOpts dapp = opts.dapp tests = concatMap (debuggableTests opts) dapp.unitTests case tests of [] -> halt ts -> put $ ViewPicker $ UiTestPickerState - { _testPickerList = list TestPickerPane (Vec.fromList ts) 1 - , _testPickerDapp = dapp - , _testOpts = opts + { tests = list TestPickerPane (Vec.fromList ts) 1 + , dapp = dapp + , opts = opts } ViewHelp s -> put (ViewVm s) - ViewContracts s -> put (ViewVm $ s ^. browserVm) + ViewContracts s -> put (ViewVm $ s ^. #vm) _ -> halt -- Vm Overview: Enter - open contracts view @@ -431,24 +435,24 @@ appEvent (VtyEvent (V.EvKey V.KEnter [])) = get >>= \case ViewVm s -> put . ViewContracts $ UiBrowserState - { _browserContractList = + { contracts = list BrowserPane - (Vec.fromList (Map.toList s._uiVm._env._contracts)) + (Vec.fromList (Map.toList s.vm.env.contracts)) 2 - , _browserVm = s + , vm = s } ViewPicker s -> - case listSelectedElement s._testPickerList of + case listSelectedElement s.tests of Nothing -> error "nothing selected" Just (_, x) -> do - let initVm = initialUiVmStateForTest s._testOpts x + let initVm = initialUiVmStateForTest s.opts x put (ViewVm initVm) _ -> pure () -- Vm Overview: m - toggle memory pane appEvent (VtyEvent (V.EvKey (V.KChar 'm') [])) = get >>= \case - ViewVm s -> put (ViewVm $ over uiShowMemory not s) + ViewVm s -> put (ViewVm $ over #showMemory not s) _ -> pure () -- Vm Overview: h - open help view @@ -476,28 +480,28 @@ -- Vm Overview: n - step appEvent (VtyEvent (V.EvKey (V.KChar 'n') [])) = get >>= \case ViewVm s -> - when (isNothing (s ^. uiVm . result)) $ + when (isNothing (s ^. #vm % #result)) $ takeStep s (Step 1) _ -> pure () -- Vm Overview: N - step appEvent (VtyEvent (V.EvKey (V.KChar 'N') [])) = get >>= \case ViewVm s -> - when (isNothing (s ^. uiVm . result)) $ + when (isNothing (s ^. #vm % #result)) $ takeStep s (StepUntil (isNextSourcePosition s)) _ -> pure () -- Vm Overview: C-n - step appEvent (VtyEvent (V.EvKey (V.KChar 'n') [V.MCtrl])) = get >>= \case ViewVm s -> - when (isNothing (s ^. uiVm . result)) $ + when (isNothing (s ^. #vm % #result)) $ takeStep s (StepUntil (isNextSourcePositionWithoutEntering s)) _ -> pure () -- Vm Overview: e - step appEvent (VtyEvent (V.EvKey (V.KChar 'e') [])) = get >>= \case ViewVm s -> - when (isNothing (s ^. uiVm . result)) $ + when (isNothing (s ^. #vm % #result)) $ takeStep s (StepUntil (isExecutionHalted s)) _ -> pure () @@ -507,12 +511,12 @@ -- We keep the current cache so we don't have to redo -- any blocking queries. let - (vm, stepper) = fromJust (Map.lookup 0 s._uiSnapshots) + (vm, stepper) = fromJust (Map.lookup 0 s.snapshots) s' = s - & set uiVm vm - & set (uiVm . cache) s._uiVm._cache - & set uiStep 0 - & set uiStepper stepper + & set #vm vm + & set (#vm % #cache) s.vm.cache + & set #step 0 + & set #stepper stepper in takeStep s' (Step 0) _ -> pure () @@ -520,7 +524,7 @@ -- Vm Overview: p - backstep appEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) = get >>= \case ViewVm s -> - case s._uiStep of + case s.step of 0 -> -- We're already at the first step; ignore command. pure () @@ -531,12 +535,12 @@ -- We keep the current cache so we don't have to redo -- any blocking queries, and also the memory view. let - (step, (vm, stepper)) = fromJust $ lookupLT n s._uiSnapshots + (step, (vm, stepper)) = fromJust $ lookupLT n s.snapshots s1 = s - & set uiVm vm -- set the vm to the one from the snapshot - & set (uiVm . cache) s._uiVm._cache -- persist the cache - & set uiStep step - & set uiStepper stepper + & set #vm vm -- set the vm to the one from the snapshot + & set (#vm % #cache) s.vm.cache -- persist the cache + & set #step step + & set #stepper stepper stepsToTake = n - step - 1 takeStep s1 (Step stepsToTake) @@ -553,9 +557,9 @@ -- Vm Overview: 0 - choose no jump appEvent (VtyEvent (V.EvKey (V.KChar '0') [])) = get >>= \case ViewVm s -> - case view (uiVm . result) s of + case view (#vm % #result) s of Just (VMFailure (Choose (PleaseChoosePath _ contin))) -> - takeStep (s & set uiStepper (Stepper.evm (contin True) >> s._uiStepper)) + takeStep (s & set #stepper (Stepper.evm (contin True) >> s.stepper)) (Step 1) _ -> pure () _ -> pure () @@ -563,9 +567,9 @@ -- Vm Overview: 1 - choose jump appEvent (VtyEvent (V.EvKey (V.KChar '1') [])) = get >>= \case ViewVm s -> - case s._uiVm._result of + case s.vm.result of Just (VMFailure (Choose (PleaseChoosePath _ contin))) -> - takeStep (s & set uiStepper (Stepper.evm (contin False) >> s._uiStepper)) + takeStep (s & set #stepper (Stepper.evm (contin False) >> s.stepper)) (Step 1) _ -> pure () _ -> pure () @@ -580,8 +584,7 @@ -- UnitTest Picker: (main) - render list appEvent (VtyEvent e) = do - Brick.zoom - (_ViewPicker . testPickerList) + Brick.zoom (traverseOf (_ViewPicker % #tests)) (handleListEvent e) -- Default @@ -690,7 +693,7 @@ withHighlight selected $ txt " Debug " <+> txt (contractNamePart x) <+> txt "::" <+> txt y) True - ui._testPickerList + ui.tests ] drawVmBrowser :: UiBrowserState -> [UiWidget] @@ -707,14 +710,14 @@ , " ", pack (show k) ]) True - ui._browserContractList + ui.contracts , case snd <$> Map.lookup (maybeHash c) dapp.solcByHash of Nothing -> hBox [ borderWithLabel (txt "Contract information") . padBottom Max . padRight Max $ vBox - [ txt ("Codehash: " <> pack (show c._codehash)) - , txt ("Nonce: " <> showWordExact c._nonce) - , txt ("Balance: " <> showWordExact c._balance) + [ txt ("Codehash: " <> pack (show c.codehash)) + , txt ("Nonce: " <> showWordExact c.nonce) + , txt ("Balance: " <> showWordExact c.balance) --, txt ("Storage: " <> storageDisplay (view storage c)) -- TODO: fix this ] ] @@ -738,10 +741,10 @@ ] ] where - dapp = ui._browserVm._uiTestOpts.dapp - (_, (_, c)) = fromJust $ listSelectedElement ui._browserContractList + dapp = ui.vm.testOpts.dapp + (_, (_, c)) = fromJust $ listSelectedElement ui.contracts -- currentContract = view (dappSolcByHash . ix ) dapp - maybeHash ch = fromJust (error "Internal error: cannot find concrete codehash for partially symbolic code") (maybeLitWord ch._codehash) + maybeHash ch = fromJust (error "Internal error: cannot find concrete codehash for partially symbolic code") (maybeLitWord ch.codehash) drawVm :: UiVmState -> [UiWidget] drawVm ui = @@ -794,36 +797,36 @@ stepOneOpcode :: Stepper a -> StateT UiVmState IO () stepOneOpcode restart = do - n <- use uiStep + n <- use #step when (n > 0 && n `mod` snapshotInterval == 0) $ do - vm <- use uiVm - modifying uiSnapshots (insert n (vm, void restart)) - modifying uiVm (execState exec1) - modifying uiStep (+ 1) + vm <- use #vm + modifying #snapshots (insert n (vm, void restart)) + modifying #vm (execState exec1) + modifying #step (+ 1) isNewTraceAdded :: UiVmState -> Pred VM isNewTraceAdded ui vm = let - currentTraceTree = length <$> traceForest ui._uiVm + currentTraceTree = length <$> traceForest ui.vm newTraceTree = length <$> traceForest vm in currentTraceTree /= newTraceTree isNextSourcePosition :: UiVmState -> Pred VM isNextSourcePosition ui vm = - let dapp = ui._uiTestOpts.dapp - initialPosition = currentSrcMap dapp ui._uiVm + let dapp = ui.testOpts.dapp + initialPosition = currentSrcMap dapp ui.vm in currentSrcMap dapp vm /= initialPosition isNextSourcePositionWithoutEntering :: UiVmState -> Pred VM isNextSourcePositionWithoutEntering ui vm = let - dapp = ui._uiTestOpts.dapp - vm0 = ui._uiVm + dapp = ui.testOpts.dapp + vm0 = ui.vm initialPosition = currentSrcMap dapp vm0 - initialHeight = length vm0._frames + initialHeight = length vm0.frames in case currentSrcMap dapp vm of Nothing -> @@ -831,7 +834,7 @@ Just here -> let moved = Just here /= initialPosition - deeper = length vm._frames > initialHeight + deeper = length vm.frames > initialHeight boring = case srcMapCode dapp.sources here of Just bs -> @@ -842,20 +845,20 @@ moved && not deeper && not boring isExecutionHalted :: UiVmState -> Pred VM -isExecutionHalted _ vm = isJust vm._result +isExecutionHalted _ vm = isJust vm.result currentSrcMap :: DappInfo -> VM -> Maybe SrcMap currentSrcMap dapp vm = do this <- currentContract vm - i <- this._opIxMap SVec.!? vm._state._pc + i <- this.opIxMap SVec.!? vm.state.pc srcMap dapp this i drawStackPane :: UiVmState -> UiWidget drawStackPane ui = let - gasText = showWordExact (num ui._uiVm._state._gas) + gasText = showWordExact (num ui.vm.state.gas) labelText = txt ("Gas available: " <> gasText <> "; stack:") - stackList = list StackPane (Vec.fromList $ zip [(1 :: Int)..] (simplify <$> ui._uiVm._state._stack)) 2 + stackList = list StackPane (Vec.fromList $ zip [(1 :: Int)..] (simplify <$> ui.vm.state.stack)) 2 in hBorderWithLabel labelText <=> renderList (\_ (i, w) -> @@ -864,14 +867,14 @@ <+> ourWrap (Text.unpack $ prettyIfConcreteWord w) , dim (txt (" " <> case unlit w of Nothing -> "" - Just u -> showWordExplanation u ui._uiTestOpts.dapp)) + Just u -> showWordExplanation u ui.testOpts.dapp)) ]) False stackList message :: VM -> String message vm = - case vm._result of + case vm.result of Just (VMSuccess (ConcreteBuf msg)) -> "VMSuccess: " <> (show $ ByteStringS msg) Just (VMSuccess (msg)) -> @@ -881,13 +884,13 @@ Just (VMFailure err) -> "VMFailure: " <> show err Nothing -> - "Executing EVM code in " <> show vm._state._contract + "Executing EVM code in " <> show vm.state.contract drawBytecodePane :: UiVmState -> UiWidget drawBytecodePane ui = let - vm = ui._uiVm + vm = ui.vm move = maybe id listMoveTo $ vmOpIx vm in hBorderWithLabel (str $ message vm) <=> @@ -897,7 +900,7 @@ else withDefAttr boldAttr (opWidget x)) False (move $ list BytecodePane - (maybe mempty (._codeOps) (currentContract vm)) + (maybe mempty (.codeOps) (currentContract vm)) 1) @@ -914,8 +917,8 @@ drawTracePane :: UiVmState -> UiWidget drawTracePane s = - let vm = s._uiVm - dapp = s._uiTestOpts.dapp + let vm = s.vm + dapp = s.testOpts.dapp traceList = list TracePane @@ -925,20 +928,20 @@ $ vm) 1 - in case s._uiShowMemory of + in case s.showMemory of True -> viewport TracePane Vertical $ hBorderWithLabel (txt "Calldata") - <=> ourWrap (prettyIfConcrete vm._state._calldata) + <=> ourWrap (prettyIfConcrete vm.state.calldata) <=> hBorderWithLabel (txt "Returndata") - <=> ourWrap (prettyIfConcrete vm._state._returndata) + <=> ourWrap (prettyIfConcrete vm.state.returndata) <=> hBorderWithLabel (txt "Output") - <=> ourWrap (maybe "" show vm._result) + <=> ourWrap (maybe "" show vm.result) <=> hBorderWithLabel (txt "Cache") - <=> ourWrap (show vm._cache._path) + <=> ourWrap (show vm.cache.path) <=> hBorderWithLabel (txt "Path Conditions") - <=> (ourWrap $ show $ vm._constraints) + <=> (ourWrap $ show $ vm.constraints) <=> hBorderWithLabel (txt "Memory") - <=> (ourWrap (prettyIfConcrete vm._state._memory)) + <=> (ourWrap (prettyIfConcrete vm.state.memory)) False -> hBorderWithLabel (txt "Trace") <=> renderList @@ -962,25 +965,27 @@ (case currentSrcMap dapp vm of Nothing -> mempty Just x -> - view ( - ix x.srcMapFile - . to (Vec.imap (,))) - dapp.sources.lines) + fromMaybe + (error "Internal Error: unable to find line for source map") + (preview ( + ix x.file + % to (Vec.imap (,))) + dapp.sources.lines)) 1 drawSolidityPane :: UiVmState -> UiWidget drawSolidityPane ui = - let dapp = ui._uiTestOpts.dapp + let dapp = ui.testOpts.dapp dappSrcs = dapp.sources - vm = ui._uiVm + vm = ui.vm in case currentSrcMap dapp vm of Nothing -> padBottom Max (hBorderWithLabel (txt "")) Just sm -> let - rows = dappSrcs.lines !! sm.srcMapFile - subrange = lineSubrange rows (sm.srcMapOffset, sm.srcMapLength) + rows = dappSrcs.lines !! sm.file + subrange = lineSubrange rows (sm.offset, sm.length) fileName :: Maybe Text - fileName = preview (ix sm.srcMapFile . _1) dapp.sources.files + fileName = preview (ix sm.file % _1) dapp.sources.files lineNo :: Maybe Int lineNo = ((\a -> Just (a - 1)) . snd) =<< srcMapCodePos dapp.sources sm in vBox @@ -991,7 +996,7 @@ -- Show the AST node type if present <+> txt (" (" <> fromMaybe "?" (dapp.astSrcMap sm - >>= preview (key "name" . _String)) <> ")") + >>= preview (key "name" % _String)) <> ")") , Centered.renderList (\_ (i, line) -> let s = case decodeUtf8 line of "" -> " "; y -> y @@ -1015,7 +1020,7 @@ ifTallEnough need w1 w2 = Widget Greedy Greedy $ do c <- getContext - if view availHeightL c > need + if view (lensVL availHeightL) c > need then render w1 else render w2 diff --git a/src/EVM/TTYCenteredList.hs b/src/EVM/TTYCenteredList.hs --- a/src/EVM/TTYCenteredList.hs +++ b/src/EVM/TTYCenteredList.hs @@ -2,7 +2,7 @@ -- Hard fork of brick's List that centers the currently highlighted line. -import Control.Lens +import Optics.Core import Data.Maybe (fromMaybe) import Brick.Types @@ -31,15 +31,15 @@ Widget Greedy Greedy $ do c <- getContext - let es = V.slice start num (l^.listElementsL) - idx = fromMaybe 0 (l^.listSelectedL) + let es = V.slice start num (l ^. (lensVL listElementsL)) + idx = fromMaybe 0 (l ^. (lensVL listSelectedL)) start = max 0 $ idx - (initialNumPerHeight `div` 2) - num = min (numPerHeight * 2) (V.length (l^.listElementsL) - start) + num = min (numPerHeight * 2) (V.length (l ^. (lensVL listElementsL)) - start) -- The number of items to show is the available height divided by -- the item height... - initialNumPerHeight = (c^.availHeightL) `div` (l^.listItemHeightL) + initialNumPerHeight = (c ^. (lensVL availHeightL)) `div` (l ^. (lensVL listItemHeightL)) -- ... but if the available height leaves a remainder of -- an item height then we need to ensure that we render an -- extra item to show a partial item at the top or bottom to @@ -49,7 +49,7 @@ -- rendered with only its top 2 or bottom 2 rows visible, -- depending on how the viewport state changes.) numPerHeight = initialNumPerHeight + - if initialNumPerHeight * (l^.listItemHeightL) == c^.availHeightL + if initialNumPerHeight * (l ^. (lensVL listItemHeightL)) == c ^. (lensVL availHeightL) then 0 else 1 @@ -66,6 +66,6 @@ else id in makeVisible elemWidget - render $ viewport (l^.listNameL) Vertical $ + render $ viewport (l ^. (lensVL listNameL)) Vertical $ -- translateBy (Location (0, off)) $ vBox $ V.toList drawnElements diff --git a/src/EVM/Transaction.hs b/src/EVM/Transaction.hs --- a/src/EVM/Transaction.hs +++ b/src/EVM/Transaction.hs @@ -3,15 +3,16 @@ import Prelude hiding (Word) import qualified EVM -import EVM (balance, initialContract) +import EVM (initialContract) import EVM.FeeSchedule import EVM.RLP import EVM.Types import EVM.Expr (litAddr) -import Control.Lens import EVM.Sign -import Data.ByteString (ByteString) +import Optics.Core hiding (cons) + +import Data.ByteString (ByteString, cons) import Data.Map (Map) import Data.Maybe (fromMaybe, isNothing, fromJust) import GHC.Generics (Generic) @@ -25,8 +26,8 @@ import Numeric (showHex) data AccessListEntry = AccessListEntry { - accessAddress :: Addr, - accessStorageKeys :: [W256] + address :: Addr, + storageKeys :: [W256] } deriving (Show, Generic) instance JSON.ToJSON AccessListEntry @@ -44,130 +45,130 @@ data Transaction = Transaction { - txData :: ByteString, - txGasLimit :: Word64, - txGasPrice :: Maybe W256, - txNonce :: W256, - txR :: W256, - txS :: W256, - txToAddr :: Maybe Addr, - txV :: W256, - txValue :: W256, - txType :: TxType, - txAccessList :: [AccessListEntry], - txMaxPriorityFeeGas :: Maybe W256, - txMaxFeePerGas :: Maybe W256, - txChainId :: W256 + txdata :: ByteString, + gasLimit :: Word64, + gasPrice :: Maybe W256, + nonce :: W256, + r :: W256, + s :: W256, + toAddr :: Maybe Addr, + v :: W256, + value :: W256, + txtype :: TxType, + accessList :: [AccessListEntry], + maxPriorityFeeGas :: Maybe W256, + maxFeePerGas :: Maybe W256, + chainId :: W256 } deriving (Show, Generic) instance JSON.ToJSON Transaction where - toJSON t = JSON.object [ ("input", (JSON.toJSON (ByteStringS t.txData))) - , ("gas", (JSON.toJSON $ "0x" ++ showHex (toInteger $ t.txGasLimit) "")) - , ("gasPrice", (JSON.toJSON $ show $ fromJust $ t.txGasPrice)) - , ("v", (JSON.toJSON $ show $ (t.txV)-27)) - , ("r", (JSON.toJSON $ show $ t.txR)) - , ("s", (JSON.toJSON $ show $ t.txS)) - , ("to", (JSON.toJSON $ t.txToAddr)) - , ("nonce", (JSON.toJSON $ show $ t.txNonce)) - , ("value", (JSON.toJSON $ show $ t.txValue)) - , ("type", (JSON.toJSON $ t.txType)) - , ("accessList", (JSON.toJSON $ t.txAccessList)) - , ("maxPriorityFeePerGas", (JSON.toJSON $ show $ fromJust $ t.txMaxPriorityFeeGas)) - , ("maxFeePerGas", (JSON.toJSON $ show $ fromJust $ t.txMaxFeePerGas)) - , ("chainId", (JSON.toJSON $ show t.txChainId)) + toJSON t = JSON.object [ ("input", (JSON.toJSON (ByteStringS t.txdata))) + , ("gas", (JSON.toJSON $ "0x" ++ showHex (toInteger $ t.gasLimit) "")) + , ("gasPrice", (JSON.toJSON $ show $ fromJust $ t.gasPrice)) + , ("v", (JSON.toJSON $ show $ (t.v)-27)) + , ("r", (JSON.toJSON $ show $ t.r)) + , ("s", (JSON.toJSON $ show $ t.s)) + , ("to", (JSON.toJSON $ t.toAddr)) + , ("nonce", (JSON.toJSON $ show $ t.nonce)) + , ("value", (JSON.toJSON $ show $ t.value)) + , ("type", (JSON.toJSON $ t.txtype)) + , ("accessList", (JSON.toJSON $ t.accessList)) + , ("maxPriorityFeePerGas", (JSON.toJSON $ show $ fromJust $ t.maxPriorityFeeGas)) + , ("maxFeePerGas", (JSON.toJSON $ show $ fromJust $ t.maxFeePerGas)) + , ("chainId", (JSON.toJSON $ show t.chainId)) ] emptyTransaction :: Transaction -emptyTransaction = Transaction { txData = mempty - , txGasLimit = 0 - , txGasPrice = Nothing - , txNonce = 0 - , txR = 0 - , txS = 0 - , txToAddr = Nothing - , txV = 0 - , txValue = 0 - , txType = EIP1559Transaction - , txAccessList = [] - , txMaxPriorityFeeGas = Nothing - , txMaxFeePerGas = Nothing - , txChainId = 1 +emptyTransaction = Transaction { txdata = mempty + , gasLimit = 0 + , gasPrice = Nothing + , nonce = 0 + , r = 0 + , s = 0 + , toAddr = Nothing + , v = 0 + , value = 0 + , txtype = EIP1559Transaction + , accessList = [] + , maxPriorityFeeGas = Nothing + , maxFeePerGas = Nothing + , chainId = 1 } -- | utility function for getting a more useful representation of accesslistentries -- duplicates only matter for gas computation txAccessMap :: Transaction -> Map Addr [W256] -txAccessMap tx = ((Map.fromListWith (++)) . makeTups) tx.txAccessList - where makeTups = map (\ale -> (ale.accessAddress , ale.accessStorageKeys )) +txAccessMap tx = ((Map.fromListWith (++)) . makeTups) tx.accessList + where makeTups = map (\ale -> (ale.address , ale.storageKeys )) -- Given Transaction, it recovers the address that sent it sender :: Transaction -> Maybe Addr -sender tx = ecrec v' tx.txR tx.txS hash +sender tx = ecrec v' tx.r tx.s hash where hash = keccak' (signingData tx) - v = tx.txV + v = tx.v v' = if v == 27 || v == 28 then v else 27 + v sign :: Integer -> Transaction -> Transaction -sign sk tx = tx { txV = num v, txR = r, txS = s} +sign sk tx = tx { v = num v, r = r, s = s} where hash = keccak' $ signingData tx (v, r, s) = EVM.Sign.sign hash sk signingData :: Transaction -> ByteString signingData tx = - case tx.txType of - LegacyTransaction -> if v == (tx.txChainId * 2 + 35) || v == (tx.txChainId * 2 + 36) + case tx.txtype of + LegacyTransaction -> if v == (tx.chainId * 2 + 35) || v == (tx.chainId * 2 + 36) then eip155Data else normalData AccessListTransaction -> eip2930Data EIP1559Transaction -> eip1559Data - where v = fromIntegral tx.txV - to' = case tx.txToAddr of + where v = fromIntegral tx.v + to' = case tx.toAddr of Just a -> BS $ word160Bytes a Nothing -> BS mempty - maxFee = fromJust tx.txMaxFeePerGas - maxPrio = fromJust tx.txMaxPriorityFeeGas - gasPrice = fromJust tx.txGasPrice - accessList = tx.txAccessList + maxFee = fromJust tx.maxFeePerGas + maxPrio = fromJust tx.maxPriorityFeeGas + gasPrice = fromJust tx.gasPrice + accessList = tx.accessList rlpAccessList = EVM.RLP.List $ map (\accessEntry -> - EVM.RLP.List [BS $ word160Bytes accessEntry.accessAddress, - EVM.RLP.List $ map rlpWordFull accessEntry.accessStorageKeys] + EVM.RLP.List [BS $ word160Bytes accessEntry.address, + EVM.RLP.List $ map rlpWordFull accessEntry.storageKeys] ) accessList - normalData = rlpList [rlpWord256 tx.txNonce, + normalData = rlpList [rlpWord256 tx.nonce, rlpWord256 gasPrice, - rlpWord256 (num tx.txGasLimit), + rlpWord256 (num tx.gasLimit), to', - rlpWord256 tx.txValue, - BS tx.txData] - eip155Data = rlpList [rlpWord256 tx.txNonce, + rlpWord256 tx.value, + BS tx.txdata] + eip155Data = rlpList [rlpWord256 tx.nonce, rlpWord256 gasPrice, - rlpWord256 (num tx.txGasLimit), + rlpWord256 (num tx.gasLimit), to', - rlpWord256 tx.txValue, - BS tx.txData, - rlpWord256 tx.txChainId, + rlpWord256 tx.value, + BS tx.txdata, + rlpWord256 tx.chainId, rlpWord256 0x0, rlpWord256 0x0] eip1559Data = cons 0x02 $ rlpList [ - rlpWord256 tx.txChainId, - rlpWord256 tx.txNonce, + rlpWord256 tx.chainId, + rlpWord256 tx.nonce, rlpWord256 maxPrio, rlpWord256 maxFee, - rlpWord256 (num tx.txGasLimit), + rlpWord256 (num tx.gasLimit), to', - rlpWord256 tx.txValue, - BS tx.txData, + rlpWord256 tx.value, + BS tx.txdata, rlpAccessList] eip2930Data = cons 0x01 $ rlpList [ - rlpWord256 tx.txChainId, - rlpWord256 tx.txNonce, + rlpWord256 tx.chainId, + rlpWord256 tx.nonce, rlpWord256 gasPrice, - rlpWord256 (num tx.txGasLimit), + rlpWord256 (num tx.gasLimit), to', - rlpWord256 tx.txValue, - BS tx.txData, + rlpWord256 tx.value, + BS tx.txdata, rlpAccessList] accessListPrice :: FeeSchedule Word64 -> [AccessListEntry] -> Word64 @@ -175,17 +176,17 @@ sum (map (\ale -> fs.g_access_list_address + - (fs.g_access_list_storage_key * (fromIntegral . length) ale.accessStorageKeys)) + (fs.g_access_list_storage_key * (fromIntegral . length) ale.storageKeys)) al) txGasCost :: FeeSchedule Word64 -> Transaction -> Word64 txGasCost fs tx = - let calldata = tx.txData + let calldata = tx.txdata zeroBytes = BS.count 0 calldata nonZeroBytes = BS.length calldata - zeroBytes baseCost = fs.g_transaction - + (if isNothing tx.txToAddr then fs.g_txcreate else 0) - + (accessListPrice fs tx.txAccessList ) + + (if isNothing tx.toAddr then fs.g_txcreate else 0) + + (accessListPrice fs tx.accessList ) zeroCost = fs.g_txdatazero nonZeroCost = fs.g_txdatanonzero in baseCost + zeroCost * (fromIntegral zeroBytes) + nonZeroCost * (fromIntegral nonZeroBytes) @@ -226,7 +227,7 @@ JSON.typeMismatch "Transaction" invalid accountAt :: Addr -> Getter (Map Addr EVM.Contract) EVM.Contract -accountAt a = (at a) . (to $ fromMaybe newAccount) +accountAt a = (at a) % (to $ fromMaybe newAccount) touchAccount :: Addr -> Map Addr EVM.Contract -> Map Addr EVM.Contract touchAccount a = Map.insertWith (flip const) a newAccount @@ -238,8 +239,8 @@ setupTx :: Addr -> Addr -> W256 -> Word64 -> Map Addr EVM.Contract -> Map Addr EVM.Contract setupTx origin coinbase gasPrice gasLimit prestate = let gasCost = gasPrice * (num gasLimit) - in (Map.adjust ((over EVM.nonce (+ 1)) - . (over balance (subtract gasCost))) origin) + in (Map.adjust ((over #nonce (+ 1)) + . (over #balance (subtract gasCost))) origin) . touchAccount origin . touchAccount coinbase $ prestate @@ -248,22 +249,22 @@ -- and pay receiving address initTx :: EVM.VM -> EVM.VM initTx vm = let - toAddr = vm._state._contract - origin = vm._tx._origin - gasPrice = vm._tx._gasprice - gasLimit = vm._tx._txgaslimit - coinbase = vm._block._coinbase - value = vm._state._callvalue - toContract = initialContract vm._state._code - preState = setupTx origin coinbase gasPrice gasLimit vm._env._contracts - oldBalance = view (accountAt toAddr . balance) preState - creation = vm._tx._isCreate + toAddr = vm.state.contract + origin = vm.tx.origin + gasPrice = vm.tx.gasprice + gasLimit = vm.tx.gaslimit + coinbase = vm.block.coinbase + value = vm.state.callvalue + toContract = initialContract vm.state.code + preState = setupTx origin coinbase gasPrice gasLimit vm.env.contracts + oldBalance = view (accountAt toAddr % #balance) preState + creation = vm.tx.isCreate initState = (case unlit value of - Just v -> ((Map.adjust (over balance (subtract v))) origin) - . (Map.adjust (over balance (+ v))) toAddr + Just v -> ((Map.adjust (over #balance (subtract v))) origin) + . (Map.adjust (over #balance (+ v))) toAddr Nothing -> id) . (if creation - then Map.insert toAddr (toContract & balance .~ oldBalance) + then Map.insert toAddr (toContract & #balance .~ oldBalance) else touchAccount toAddr) $ preState @@ -274,7 +275,7 @@ resetStore (SStore {}) = error "cannot reset storage if it contains symbolic addresses" resetStore s = s in - vm & EVM.env . EVM.contracts .~ initState - & EVM.tx . EVM.txReversion .~ preState - & EVM.env . EVM.storage %~ resetStore - & EVM.env . EVM.origStorage %~ resetConcreteStore + vm & #env % #contracts .~ initState + & #tx % #txReversion .~ preState + & #env % #storage %~ resetStore + & #env % #origStorage %~ resetConcreteStore diff --git a/src/EVM/Types.hs b/src/EVM/Types.hs --- a/src/EVM/Types.hs +++ b/src/EVM/Types.hs @@ -55,8 +55,8 @@ newtype W256 = W256 Word256 deriving - ( Num, Integral, Real, Ord, Generic - , Bits , FiniteBits, Enum, Eq , Bounded + ( Num, Integral, Real, Ord, Bits + , Generic, FiniteBits, Enum, Eq , Bounded ) {- | @@ -141,7 +141,6 @@ deriving instance Ord (GVar a) --- add type level list of constraints data Expr (a :: EType) where -- identifiers @@ -453,6 +452,10 @@ PImpl a b <= PImpl c d = a <= c && b <= d _ <= _ = False +-- | https://docs.soliditylang.org/en/v0.8.19/abi-spec.html#function-selector +newtype FunctionSelector = FunctionSelector { unFunctionSelector :: Word32 } + deriving (Num, Eq, Ord, Real, Enum, Integral) +instance Show FunctionSelector where show s = "0x" <> showHex s "" unlit :: Expr EWord -> Maybe W256 unlit (Lit x) = Just x @@ -743,12 +746,13 @@ keccak' :: ByteString -> W256 keccak' = keccakBytes >>> BS.take 32 >>> word -abiKeccak :: ByteString -> Word32 +abiKeccak :: ByteString -> FunctionSelector abiKeccak = keccakBytes >>> BS.take 4 >>> BS.unpack >>> word32 + >>> FunctionSelector -- Utils diff --git a/src/EVM/UnitTest.hs b/src/EVM/UnitTest.hs --- a/src/EVM/UnitTest.hs +++ b/src/EVM/UnitTest.hs @@ -30,7 +30,10 @@ import EVM.Stepper qualified as Stepper import Control.Monad.Operational qualified as Operational -import Control.Lens hiding (Indexed, elements, List, passing) +import Optics.Core hiding (elements) +import Optics.State +import Optics.State.Operators +import Optics.Zoom import Control.Monad.Par.Class (spawn_) import Control.Monad.Par.Class qualified as Par import Control.Monad.Par.IO (runParIO) @@ -83,22 +86,22 @@ } data TestVMParams = TestVMParams - { testAddress :: Addr - , testCaller :: Addr - , testOrigin :: Addr - , testGasCreate :: Word64 - , testGasCall :: Word64 - , testBaseFee :: W256 - , testPriorityFee :: W256 - , testBalanceCreate :: W256 - , testCoinbase :: Addr - , testNumber :: W256 - , testTimestamp :: W256 - , testGaslimit :: Word64 - , testGasprice :: W256 - , testMaxCodeSize :: W256 - , testPrevrandao :: W256 - , testChainId :: W256 + { address :: Addr + , caller :: Addr + , origin :: Addr + , gasCreate :: Word64 + , gasCall :: Word64 + , baseFee :: W256 + , priorityFee :: W256 + , balanceCreate :: W256 + , coinbase :: Addr + , number :: W256 + , timestamp :: W256 + , gaslimit :: Word64 + , gasprice :: W256 + , maxCodeSize :: W256 + , prevrandao :: W256 + , chainId :: W256 } defaultGasForCreating :: Word64 @@ -140,7 +143,7 @@ Just path -> -- merge all of the post-vm caches and save into the state let - evmcache = mconcat [vm._cache | vm <- vms] + evmcache = mconcat [vm.cache | vm <- vms] in liftIO $ Git.saveFacts (Git.RepoAt path) (Facts.cacheFacts evmcache) @@ -152,13 +155,13 @@ -- | Assuming a constructor is loaded, this stepper will run the constructor -- to create the test contract, give it an initial balance, and run `setUp()'. initializeUnitTest :: UnitTestOptions -> SolcContract -> Stepper () -initializeUnitTest UnitTestOptions { .. } theContract = do +initializeUnitTest opts theContract = do - let addr = testParams.testAddress + let addr = opts.testParams.address Stepper.evm $ do -- Maybe modify the initial VM, e.g. to load library code - modify vmModifier + modify opts.vmModifier -- Make a trace entry for running the constructor pushTrace (EntryTrace "constructor") @@ -167,14 +170,14 @@ Stepper.evm $ do -- Give a balance to the test target - env . contracts . ix addr . balance += testParams.testBalanceCreate + #env % #contracts % ix addr % #balance %= (+ opts.testParams.balanceCreate) -- call setUp(), if it exists, to initialize the test contract let theAbi = theContract.abiMap setUp = abiKeccak (encodeUtf8 "setUp()") when (isJust (Map.lookup setUp theAbi)) $ do - abiCall testParams (Left ("setUp()", emptyAbi)) + abiCall opts.testParams (Left ("setUp()", emptyAbi)) popTrace pushTrace (EntryTrace "setUp()") @@ -206,13 +209,13 @@ exploreStep :: UnitTestOptions -> ByteString -> Stepper Bool exploreStep UnitTestOptions{..} bs = do Stepper.evm $ do - cs <- use (env . contracts) + cs <- use (#env % #contracts) abiCall testParams (Right bs) let (Method _ inputs sig _ _) = fromMaybe (error "unknown abi call") $ Map.lookup (num $ word $ BS.take 4 bs) dapp.abiMap types = snd <$> inputs let ?context = DappContext dapp cs - this <- fromMaybe (error "unknown target") <$> (use (env . contracts . at testParams.testAddress)) - let name = maybe "" (contractNamePart . (.contractName)) $ lookupCode this._contractcode dapp + this <- fromMaybe (error "unknown target") <$> (use (#env % #contracts % at testParams.address)) + let name = maybe "" (contractNamePart . (.contractName)) $ lookupCode this.contractcode dapp pushTrace (EntryTrace (name <> "." <> sig <> "(" <> intercalate "," ((pack . show) <$> types) <> ")" <> showCall types (ConcreteBuf bs))) -- Try running the test method Stepper.execFully >>= \case @@ -244,7 +247,7 @@ fuzzTest :: UnitTestOptions -> Text -> [AbiType] -> VM -> Property fuzzTest opts@UnitTestOptions{..} sig types vm = forAllShow (genAbiValue (AbiTupleType $ Vector.fromList types)) (show . ByteStringS . encodeAbiValue) $ \args -> ioProperty $ - fst <$> runStateT (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) (runUnitTest opts sig args)) vm + EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) vm (runUnitTest opts sig args) tick :: Text -> IO () tick x = Text.putStr x >> hFlush stdout @@ -256,10 +259,10 @@ } deriving (Show) instance Eq OpLocation where - (==) (OpLocation a b) (OpLocation a' b') = b == b' && a._contractcode == a'._contractcode + (==) (OpLocation a b) (OpLocation a' b') = b == b' && a.contractcode == a'.contractcode instance Ord OpLocation where - compare (OpLocation a b) (OpLocation a' b') = compare (a._contractcode, b) (a'._contractcode, b') + compare (OpLocation a b) (OpLocation a' b') = compare (a.contractcode, b) (a'.contractcode, b') srcMapForOpLocation :: DappInfo -> OpLocation -> Maybe SrcMap srcMapForOpLocation dapp (OpLocation contr opIx) = srcMap dapp contr opIx @@ -278,14 +281,14 @@ execWithCoverage :: StateT CoverageState IO VMResult execWithCoverage = do _ <- runWithCoverage - fromJust <$> use (_1 . result) + fromJust <$> use (_1 % #result) runWithCoverage :: StateT CoverageState IO VM runWithCoverage = do -- This is just like `exec` except for every instruction evaluated, -- we also increment a counter indexed by the current code location. vm0 <- use _1 - case vm0._result of + case vm0.result of Nothing -> do vm1 <- zoom _1 (State.state (runState exec1) >> get) zoom _2 (modify (MultiSet.insert (currentOpLocation vm1))) @@ -430,13 +433,12 @@ Just theContract -> do -- Construct the initial VM and begin the contract's constructor let vm0 = initialUnitTestVm opts theContract - vm1 <- - liftIO $ execStateT - (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) - (Stepper.enter name >> initializeUnitTest opts theContract)) - vm0 + vm1 <- liftIO $ EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) vm0 $ do + Stepper.enter name + initializeUnitTest opts theContract + Stepper.evm get - case vm1._result of + case vm1.result of Nothing -> error "internal error: setUp() did not end with a result" Just (VMFailure _) -> liftIO $ do Text.putStrLn "\x1b[31m[BAIL]\x1b[0m setUp() " @@ -451,7 +453,7 @@ runCache (results, vm) (test, types) = do (t, r, vm') <- runTest opts vm (test, types) liftIO $ Text.putStrLn t - let vmCached = vm { _cache = vm'._cache } + let vmCached = vm { cache = vm'.cache } pure (((r, vm'): results), vmCached) -- Run all the test cases and print their status updates, @@ -517,8 +519,8 @@ Nothing -> Stepper.evmIO $ do vm <- get - let cs = vm._env._contracts - noCode c = case c._contractcode of + let cs = vm.env.contracts + noCode c = case c.contractcode of RuntimeCode (ConcreteRuntimeCode "") -> True RuntimeCode (SymbolicRuntimeCode c') -> null c' _ -> False @@ -532,11 +534,11 @@ -- exclude testing abis Map.filter (isNothing . preview (ix unitTestMarkerAbi) . (.abiMap)) $ -- pick all contracts with known compiler artifacts - fmap fromJust (Map.filter isJust $ Map.fromList [(addr, lookupCode c._contractcode dapp) | (addr, c) <- Map.toList cs]) + fmap fromJust (Map.filter isJust $ Map.fromList [(addr, lookupCode c.contractcode dapp) | (addr, c) <- Map.toList cs]) selected = [(addr, fromMaybe (error ("no src found for: " <> show addr)) $ lookupCode (fromMaybe (error $ "contract not found: " <> show addr) $ - Map.lookup addr cs)._contractcode dapp) + Map.lookup addr cs).contractcode dapp) | addr <- targets] -- go to IO and generate a random valid call to any known contract liftIO $ do @@ -559,17 +561,17 @@ let cd = abiMethod (sig <> "(" <> intercalate "," ((pack . show) <$> types) <> ")") args -- increment timestamp with random amount timepassed <- num <$> generate (arbitrarySizedNatural :: Gen Word32) - let ts = fromMaybe (error "symbolic timestamp not supported here") $ maybeLitWord vm._block._timestamp + let ts = fromMaybe (error "symbolic timestamp not supported here") $ maybeLitWord vm.block.timestamp return (caller', target, cd, num ts + timepassed) - let opts' = opts { testParams = testParams {testAddress = target, testCaller = caller', testTimestamp = timestamp'}} + let opts' = opts { testParams = testParams {address = target, caller = caller', timestamp = timestamp'}} thisCallRLP = List [BS $ word160Bytes caller', BS $ word160Bytes target, BS cd, BS $ word256Bytes timestamp'] -- set the timestamp - Stepper.evm $ assign (block . timestamp) (Lit timestamp') + Stepper.evm $ assign (#block % #timestamp) (Lit timestamp') -- perform the call bailed <- exploreStep opts' cd Stepper.evm popTrace let newHistory = if bailed then List history else List (thisCallRLP:history) - opts'' = opts {testParams = testParams {testTimestamp = timestamp'}} + opts'' = opts {testParams = testParams {timestamp = timestamp'}} carryOn = explorationStepper opts'' testName replayData targets newHistory (i - 1) -- if we didn't revert, run the test function if bailed @@ -585,7 +587,7 @@ getTargetContracts UnitTestOptions{..} = do vm <- Stepper.evm get let contract' = fromJust $ currentContract vm - theAbi = (fromJust $ lookupCode contract'._contractcode dapp).abiMap + theAbi = (fromJust $ lookupCode contract'.contractcode dapp).abiMap setUp = abiKeccak (encodeUtf8 "targetContracts()") case Map.lookup setUp theAbi of Nothing -> return [] @@ -609,18 +611,21 @@ exploreRun :: UnitTestOptions -> VM -> ABIMethod -> [ExploreTx] -> IO (Text, Either Text Text, VM) exploreRun opts@UnitTestOptions{..} initialVm testName replayTxs = do let oracle = Fetch.oracle solvers rpcInfo - (targets, _) <- runStateT (EVM.Stepper.interpret oracle (getTargetContracts opts)) initialVm + targets <- EVM.Stepper.interpret oracle initialVm (getTargetContracts opts) let depth = fromMaybe 20 maxDepth ((x, counterex), vm') <- - if null replayTxs - then - foldM (\a@((success, _), _) _ -> - if success - then runStateT (EVM.Stepper.interpret oracle (initialExplorationStepper opts testName [] targets depth)) initialVm - else pure a) - ((True, (List [])), initialVm) -- no canonical "post vm" - [0..fuzzRuns] - else runStateT (EVM.Stepper.interpret oracle (initialExplorationStepper opts testName replayTxs targets (length replayTxs))) initialVm + if null replayTxs then + foldM (\a@((success, _),_) _ -> + if success then + EVM.Stepper.interpret oracle initialVm $ + (,) <$> initialExplorationStepper opts testName [] targets depth + <*> Stepper.evm get + else pure a) + ((True, (List [])), initialVm) -- no canonical "post vm" + [0..fuzzRuns] + else EVM.Stepper.interpret oracle initialVm $ + (,) <$> initialExplorationStepper opts testName replayTxs targets (length replayTxs) + <*> Stepper.evm get if x then return ("\x1b[32m[PASS]\x1b[0m " <> testName <> " (runs: " <> (pack $ show fuzzRuns) <>", depth: " <> pack (show depth) <> ")", Right (passOutput vm' opts testName), vm') -- no canonical "post vm" @@ -631,21 +636,21 @@ execTest :: UnitTestOptions -> VM -> ABIMethod -> AbiValue -> IO (Bool, VM) execTest opts@UnitTestOptions{..} vm testName args = - runStateT - (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) (execTestStepper opts testName args)) - vm + EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) vm $ do + (,) <$> execTestStepper opts testName args + <*> Stepper.evm get -- | Define the thread spawner for normal test cases runOne :: UnitTestOptions -> VM -> ABIMethod -> AbiValue -> IO (Text, Either Text Text, VM) runOne opts@UnitTestOptions{..} vm testName args = do let argInfo = pack (if args == emptyAbi then "" else " with arguments: " <> show args) (bailed, vm') <- execTest opts vm testName args - (success, vm'') <- - runStateT - (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) (checkFailures opts testName bailed)) vm' + (success, vm'') <- EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) vm' $ do + (,) <$> (checkFailures opts testName bailed) + <*> Stepper.evm get if success then - let gasSpent = num testParams.testGasCall - vm'._state._gas + let gasSpent = num testParams.gasCall - vm'.state.gas gasText = pack $ show (fromIntegral gasSpent :: Integer) in pure @@ -693,7 +698,8 @@ ppOutput = pack $ show abiValue in do -- Run the failing test again to get a proper trace - vm' <- execStateT (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) (runUnitTest opts testName abiValue)) vm + vm' <- EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) vm $ + runUnitTest opts testName abiValue >> Stepper.evm get pure ("\x1b[31m[FAIL]\x1b[0m " <> testName <> ". Counterexample: " <> ppOutput <> "\nRun:\n dapp test --replay '(\"" <> testName <> "\",\"" @@ -713,7 +719,7 @@ symRun opts@UnitTestOptions{..} vm testName types = do let cd = symCalldata testName types [] (AbstractBuf "txdata") shouldFail = "proveFail" `isPrefixOf` testName - testContract = vm._state._contract + testContract = vm.state.contract -- define postcondition depending on `shouldFail` -- We directly encode the failure conditions from failed() in ds-test since this is easier to encode than a call into failed() @@ -729,11 +735,11 @@ Return _ _ store -> PNeg (failed store) _ -> PBool False - (_, vm') <- runStateT - (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) (Stepper.evm $ do - popTrace - makeTxCall testParams cd - )) vm + vm' <- EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) vm $ + Stepper.evm $ do + popTrace + makeTxCall testParams cd + get -- check postconditions against vm (_, results) <- verify solvers (makeVeriOpts opts) vm' (Just postcondition) @@ -827,7 +833,7 @@ passOutput :: VM -> UnitTestOptions -> Text -> Text passOutput vm UnitTestOptions { .. } testName = - let ?context = DappContext { info = dapp, env = vm._env._contracts } + let ?context = DappContext { info = dapp, env = vm.env.contracts } in let v = fromMaybe 0 verbose in if (v > 1) then mconcat @@ -835,7 +841,7 @@ , fromMaybe "" (stripSuffix "()" testName) , "\n" , if (v > 2) then indentLines 2 (showTraceTree dapp vm) else "" - , indentLines 2 (formatTestLogs dapp.eventMap vm._logs) + , indentLines 2 (formatTestLogs dapp.eventMap vm.logs) , "\n" ] else "" @@ -843,7 +849,7 @@ -- TODO failOutput :: VM -> UnitTestOptions -> Text -> Text failOutput vm UnitTestOptions { .. } testName = - let ?context = DappContext { info = dapp, env = vm._env._contracts} + let ?context = DappContext { info = dapp, env = vm.env.contracts } in mconcat [ "Failure: " , fromMaybe "" (stripSuffix "()" testName) @@ -851,7 +857,7 @@ , case verbose of Just _ -> indentLines 2 (showTraceTree dapp vm) _ -> "" - , indentLines 2 (formatTestLogs dapp.eventMap vm._logs) + , indentLines 2 (formatTestLogs dapp.eventMap vm.logs) , "\n" ] @@ -934,55 +940,54 @@ in makeTxCall params (ConcreteBuf cd, []) makeTxCall :: TestVMParams -> (Expr Buf, [Prop]) -> EVM () -makeTxCall TestVMParams{..} (cd, cdProps) = do +makeTxCall params (cd, cdProps) = do resetState - assign (tx . isCreate) False - loadContract testAddress - assign (state . EVM.calldata) cd - constraints %= (<> cdProps) - assign (state . caller) (litAddr testCaller) - assign (state . gas) testGasCall - origin' <- fromMaybe (initialContract (RuntimeCode (ConcreteRuntimeCode ""))) <$> use (env . contracts . at testOrigin) - let originBal = origin'._balance - when (originBal < testGasprice * (num testGasCall)) $ error "insufficient balance for gas cost" + assign (#tx % #isCreate) False + loadContract params.address + assign (#state % #calldata) cd + #constraints %= (<> cdProps) + assign (#state % #caller) (litAddr params.caller) + assign (#state % #gas) params.gasCall + origin' <- fromMaybe (initialContract (RuntimeCode (ConcreteRuntimeCode ""))) <$> use (#env % #contracts % at params.origin) + let originBal = origin'.balance + when (originBal < params.gasprice * (num params.gasCall)) $ error "insufficient balance for gas cost" vm <- get put $ initTx vm initialUnitTestVm :: UnitTestOptions -> SolcContract -> VM initialUnitTestVm (UnitTestOptions {..}) theContract = let - TestVMParams {..} = testParams vm = makeVm $ VMOpts - { vmoptContract = initialContract (InitCode theContract.creationCode mempty) - , vmoptCalldata = mempty - , vmoptValue = Lit 0 - , vmoptAddress = testAddress - , vmoptCaller = litAddr testCaller - , vmoptOrigin = testOrigin - , vmoptGas = testGasCreate - , vmoptGaslimit = testGasCreate - , vmoptCoinbase = testCoinbase - , vmoptNumber = testNumber - , vmoptTimestamp = Lit testTimestamp - , vmoptBlockGaslimit = testGaslimit - , vmoptGasprice = testGasprice - , vmoptBaseFee = testBaseFee - , vmoptPriorityFee = testPriorityFee - , vmoptMaxCodeSize = testMaxCodeSize - , vmoptPrevRandao = testPrevrandao - , vmoptSchedule = FeeSchedule.berlin - , vmoptChainId = testChainId - , vmoptCreate = True - , vmoptStorageBase = Concrete - , vmoptTxAccessList = mempty -- TODO: support unit test access lists??? - , vmoptAllowFFI = ffiAllowed + { contract = initialContract (InitCode theContract.creationCode mempty) + , calldata = mempty + , value = Lit 0 + , address = testParams.address + , caller = litAddr testParams.caller + , origin = testParams.origin + , gas = testParams.gasCreate + , gaslimit = testParams.gasCreate + , coinbase = testParams.coinbase + , number = testParams.number + , timestamp = Lit testParams.timestamp + , blockGaslimit = testParams.gaslimit + , gasprice = testParams.gasprice + , baseFee = testParams.baseFee + , priorityFee = testParams.priorityFee + , maxCodeSize = testParams.maxCodeSize + , prevRandao = testParams.prevrandao + , schedule = FeeSchedule.berlin + , chainId = testParams.chainId + , create = True + , initialStorage = EmptyStore + , txAccessList = mempty -- TODO: support unit test access lists??? + , allowFFI = ffiAllowed } creator = initialContract (RuntimeCode (ConcreteRuntimeCode "")) - & set nonce 1 - & set balance testBalanceCreate + & set #nonce 1 + & set #balance testParams.balanceCreate in vm - & set (env . contracts . at ethrunAddress) (Just creator) + & set (#env % #contracts % at ethrunAddress) (Just creator) getParametersFromEnvironmentVariables :: Maybe Text -> IO TestVMParams @@ -994,12 +999,12 @@ Nothing -> return (0,Lit 0,0,0,0,0) Just url -> Fetch.fetchBlockFrom block' url >>= \case Nothing -> error "Could not fetch block" - Just EVM.Block{..} -> return ( _coinbase - , _timestamp - , _number - , _prevRandao - , _gaslimit - , _baseFee + Just EVM.Block{..} -> return ( coinbase + , timestamp + , number + , prevRandao + , gaslimit + , baseFee ) let getWord s def = maybe def read <$> lookupEnv s diff --git a/test/BlockchainTests.hs b/test/BlockchainTests.hs --- a/test/BlockchainTests.hs +++ b/test/BlockchainTests.hs @@ -1,457 +1,9 @@ -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE TupleSections #-} - module Main where -import Prelude hiding (Word) - -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 (litAddr) -import EVM.FeeSchedule qualified -import EVM.Fetch qualified -import EVM.Stepper qualified -import EVM.Solvers (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 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 qualified as BS -import Data.ByteString.Lazy qualified as Lazy -import Data.ByteString.Lazy qualified as LazyByteString -import Data.List (isInfixOf) -import Data.Map (Map) -import Data.Map qualified as Map -import Data.Maybe (fromJust, fromMaybe, isNothing, isJust) -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 EVM.Test.BlockchainTests import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit -type Storage = Map W256 W256 - -data Which = Pre | Post - -data Block = Block - { blockCoinbase :: Addr - , blockDifficulty :: W256 - , blockGasLimit :: Word64 - , blockBaseFee :: W256 - , blockNumber :: W256 - , blockTimestamp :: W256 - , blockTxs :: [Transaction] - } deriving Show - -data Case = Case - { testVmOpts :: EVM.VMOpts - , checkContracts :: Map Addr (EVM.Contract, Storage) - , testExpectation :: Map Addr (EVM.Contract, Storage) - } deriving Show - -data BlockchainCase = BlockchainCase - { blockchainBlocks :: [Block] - , blockchainPre :: Map Addr (EVM.Contract, Storage) - , blockchainPost :: Map Addr (EVM.Contract, Storage) - , 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 = [] - -commonProblematicTests :: Map String (TestTree -> TestTree) -commonProblematicTests = Map.fromList - [ ("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 = case filter (\(name, _) -> name == test) $ Map.toList allTests of - [(_, x')] -> x' - _ -> error "test not found" - 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) -> 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 -> - acc ++ show k ++ " : " - ++ (show . toInteger $ (view nonce c)) ++ " " - ++ (show . toInteger $ (view balance c)) ++ " " - ++ (printStorage s) - ++ "\n") "" cs - - reason = map fst (filter (not . snd) - [ ("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 = x.checkContracts - expected = x.testExpectation - actual = Map.map (,mempty) $ view (EVM.env . EVM.contracts) vm -- . to (fmap (clearZeroStorage.clearOrigStorage))) vm - printStorage = show -- TODO: fixme - - when diff $ do - putStr (unwords reason) - putStrLn "\nPre balance/state: " - printContracts check - putStrLn "\nExpected balance/state: " - printContracts expected - putStrLn "\nActual balance/state: " - printContracts actual - pure (unwords reason) - -checkExpectation :: Bool -> Case -> EVM.VM -> IO (Maybe String) -checkExpectation diff x vm = do - let expectation = x.testExpectation - (okState, b2, b3, b4, b5) = checkExpectedContracts vm expectation - 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 -(~=) cs1 cs2 = - let nullAccount = EVM.initialContract (EVM.RuntimeCode (EVM.ConcreteRuntimeCode "")) - padNewAccounts cs ks = Map.union cs $ Map.fromList [(k, (nullAccount, mempty)) | k <- ks] - padded_cs1 = padNewAccounts cs1 (Map.keys cs2) - padded_cs2 = padNewAccounts cs2 (Map.keys cs1) - in and $ zipWith (===) (Map.elems padded_cs1) (Map.elems padded_cs2) - -(===) :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) -> Bool -(c1, s1) === (c2, s2) = - codeEqual && storageEqual && (c1 ^. balance == c2 ^. balance) && (c1 ^. nonce == c2 ^. nonce) - where - storageEqual = s1 == s2 - codeEqual = case (c1 ^. contractcode, c2 ^. contractcode) of - (EVM.RuntimeCode a', EVM.RuntimeCode b') -> a' == b' - _ -> error "unexpected code" - -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 - in ( (expectedCs ~= cs) - , (clearBalance <$> expectedCs) ~= (clearBalance <$> cs) - , (clearNonce <$> expectedCs) ~= (clearNonce <$> cs) - , (clearStorage <$> expectedCs) ~= (clearStorage <$> cs) - , (clearCode <$> expectedCs) ~= (clearCode <$> cs) - ) - where - zipWithStorages = Map.mapWithKey (\addr c -> (c, lookupStorage addr)) - lookupStorage _ = - case vm ^. EVM.env . EVM.storage of - ConcreteStore _ -> mempty -- clearZeroStorage $ fromMaybe mempty $ Map.lookup (num addr) s - EmptyStore -> mempty - AbstractStore -> mempty -- error "AbstractStore, should this be handled?" - SStore {} -> mempty -- error "SStore, should this be handled?" - GVar _ -> error "unexpected global variable" - -clearStorage :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) -clearStorage (c, _) = (c, mempty) - -clearBalance :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) -clearBalance (c, s) = (set balance 0 c, s) - -clearNonce :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) -clearNonce (c, s) = (set nonce 0 c, s) - -clearCode :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) -clearCode (c, s) = (set contractcode (EVM.RuntimeCode (EVM.ConcreteRuntimeCode "")) c, s) - -newtype ContractWithStorage = ContractWithStorage (EVM.Contract, Storage) - -instance FromJSON ContractWithStorage where - parseJSON (JSON.Object v) = do - code <- (EVM.RuntimeCode . EVM.ConcreteRuntimeCode <$> (hexText <$> v .: "code")) - storage' <- v .: "storage" - balance' <- v .: "balance" - nonce' <- v .: "nonce" - let c = EVM.initialContract code - & balance .~ balance' - & nonce .~ nonce' - return $ ContractWithStorage (c, storage') - - parseJSON invalid = - JSON.typeMismatch "Contract" invalid - -instance FromJSON BlockchainCase where - parseJSON (JSON.Object v) = BlockchainCase - <$> v .: "blocks" - <*> parseContracts Pre v - <*> parseContracts Post v - <*> v .: "network" - parseJSON invalid = - JSON.typeMismatch "GeneralState test case" invalid - -instance FromJSON Block where - parseJSON (JSON.Object v) = do - v' <- v .: "blockHeader" - txs <- v .: "transactions" - coinbase <- addrField v' "coinbase" - difficulty <- wordField v' "difficulty" - gasLimit <- word64Field v' "gasLimit" - number <- wordField v' "number" - baseFee <- fmap read <$> v' .:? "baseFeePerGas" - timestamp <- wordField v' "timestamp" - return $ Block coinbase difficulty gasLimit (fromMaybe 0 baseFee) number timestamp txs - parseJSON invalid = - JSON.typeMismatch "Block" invalid - -parseContracts :: - Which -> JSON.Object -> JSON.Parser (Map Addr (EVM.Contract, Storage)) -parseContracts w v = - (Map.map unwrap) <$> (v .: which >>= parseJSON) - where which = case w of - Pre -> "pre" - Post -> "postState" - unwrap (ContractWithStorage x) = x - -parseBCSuite :: - Lazy.ByteString -> Either String (Map String Case) -parseBCSuite x = case (JSON.eitherDecode' x) :: Either String (Map String BlockchainCase) of - Left e -> Left e - Right bcCases -> let allCases = fromBlockchainCase <$> bcCases - keepError (Left e) = errorFatal e - keepError _ = True - filteredCases = Map.filter keepError allCases - (erroredCases, parsedCases) = splitEithers filteredCases - in if Map.size erroredCases > 0 - then Left ("errored case: " ++ (show erroredCases)) - else if Map.size parsedCases == 0 - then Left "No cases to check." - else Right parsedCases - - -data BlockchainError - = TooManyBlocks - | TooManyTxs - | NoTxs - | SignatureUnverified - | InvalidTx - | OldNetwork - | FailedCreate - deriving Show - -errorFatal :: BlockchainError -> Bool -errorFatal TooManyBlocks = True -errorFatal TooManyTxs = True -errorFatal SignatureUnverified = True -errorFatal InvalidTx = True -errorFatal _ = False - -fromBlockchainCase :: BlockchainCase -> Either BlockchainError Case -fromBlockchainCase (BlockchainCase blocks preState postState network) = - case (blocks, network) of - ([block], "London") -> case block.blockTxs of - [tx] -> fromBlockchainCase' block tx preState postState - [] -> Left NoTxs - _ -> Left TooManyTxs - ([_], _) -> Left OldNetwork - (_, _) -> Left TooManyBlocks - -fromBlockchainCase' :: Block -> Transaction - -> Map Addr (EVM.Contract, Storage) -> Map Addr (EVM.Contract, Storage) - -> Either BlockchainError Case -fromBlockchainCase' block tx preState postState = - let isCreate = isNothing tx.txToAddr in - case (sender tx, checkTx tx block preState) of - (Nothing, _) -> Left SignatureUnverified - (_, Nothing) -> Left (if isCreate then FailedCreate else InvalidTx) - (Just origin, Just checkState) -> Right $ Case - (EVM.VMOpts - { vmoptContract = EVM.initialContract theCode - , vmoptCalldata = (cd, []) - , vmoptValue = Lit tx.txValue - , vmoptAddress = toAddr - , vmoptCaller = litAddr origin - , vmoptStorageBase = Concrete - , vmoptOrigin = origin - , vmoptGas = tx.txGasLimit - fromIntegral (txGasCost feeSchedule tx) - , vmoptBaseFee = block.blockBaseFee - , vmoptPriorityFee = priorityFee tx block.blockBaseFee - , vmoptGaslimit = tx.txGasLimit - , vmoptNumber = block.blockNumber - , vmoptTimestamp = Lit block.blockTimestamp - , vmoptCoinbase = block.blockCoinbase - , vmoptPrevRandao = block.blockDifficulty - , vmoptMaxCodeSize = 24576 - , vmoptBlockGaslimit = block.blockGasLimit - , vmoptGasprice = effectiveGasPrice - , vmoptSchedule = feeSchedule - , vmoptChainId = 1 - , vmoptCreate = isCreate - , vmoptTxAccessList = txAccessMap tx - , vmoptAllowFFI = False - }) - checkState - postState - where - toAddr = fromMaybe (EVM.createAddress origin senderNonce) tx.txToAddr - senderNonce = view (accountAt origin . nonce) (Map.map fst preState) - feeSchedule = EVM.FeeSchedule.berlin - toCode = Map.lookup toAddr preState - theCode = if isCreate - then EVM.InitCode tx.txData mempty - else maybe (EVM.RuntimeCode (EVM.ConcreteRuntimeCode "")) (view contractcode . fst) toCode - effectiveGasPrice = effectiveprice tx block.blockBaseFee - cd = if isCreate - then mempty - else ConcreteBuf tx.txData - -effectiveprice :: Transaction -> W256 -> W256 -effectiveprice tx baseFee = priorityFee tx baseFee + baseFee - -priorityFee :: Transaction -> W256 -> W256 -priorityFee tx baseFee = let - (txPrioMax, txMaxFee) = case tx.txType of - EIP1559Transaction -> - let maxPrio = fromJust tx.txMaxPriorityFeeGas - maxFee = fromJust tx.txMaxFeePerGas - in (maxPrio, maxFee) - _ -> - let gasPrice = fromJust tx.txGasPrice - in (gasPrice, gasPrice) - in min txPrioMax (txMaxFee - baseFee) - -maxBaseFee :: Transaction -> W256 -maxBaseFee tx = - case tx.txType of - EIP1559Transaction -> fromJust tx.txMaxFeePerGas - _ -> fromJust tx.txGasPrice - -validateTx :: Transaction -> Block -> Map Addr (EVM.Contract, Storage) -> Maybe () -validateTx tx block cs = do - let cs' = Map.map fst cs - origin <- sender tx - originBalance <- (view balance) <$> view (at origin) cs' - originNonce <- (view nonce) <$> view (at origin) cs' - let gasDeposit = (effectiveprice tx block.blockBaseFee) * (num tx.txGasLimit) - if gasDeposit + tx.txValue <= originBalance - && tx.txNonce == originNonce && block.blockBaseFee <= maxBaseFee tx - then Just () - else Nothing - -checkTx :: Transaction -> Block -> Map Addr (EVM.Contract, Storage) -> Maybe (Map Addr (EVM.Contract, Storage)) -checkTx tx block prestate = do - origin <- sender tx - validateTx tx block prestate - let isCreate = isNothing tx.txToAddr - senderNonce = view (accountAt origin . nonce) (Map.map fst prestate) - toAddr = fromMaybe (EVM.createAddress origin senderNonce) tx.txToAddr - prevCode = view (accountAt toAddr . contractcode) (Map.map fst prestate) - prevNonce = view (accountAt toAddr . nonce) (Map.map fst prestate) - if isCreate && ((case prevCode of {EVM.RuntimeCode (EVM.ConcreteRuntimeCode b) -> not (BS.null b); _ -> True}) || (prevNonce /= 0)) - then mzero - else - return prestate - -vmForCase :: Case -> EVM.VM -vmForCase x = - let - a = x.checkContracts - cs = Map.map fst a - st = Map.mapKeys num $ Map.map snd a - vm = EVM.makeVm x.testVmOpts - & set (EVM.env . EVM.contracts) cs - & set (EVM.env . EVM.storage) (ConcreteStore st) - & set (EVM.env . EVM.origStorage) st - in - initTx vm diff --git a/test/EVM/Test/BlockchainTests.hs b/test/EVM/Test/BlockchainTests.hs new file mode 100644 --- /dev/null +++ b/test/EVM/Test/BlockchainTests.hs @@ -0,0 +1,448 @@ +module EVM.Test.BlockchainTests where + +import Prelude hiding (Word) + +import EVM qualified +import EVM (initialContract) +import EVM.Concrete qualified as EVM +import EVM.Dapp (emptyDapp) +import EVM.Expr (litAddr) +import EVM.FeeSchedule qualified +import EVM.Fetch qualified +import EVM.Stepper qualified +import EVM.Solvers (withSolvers, Solver(Z3)) +import EVM.Transaction +import EVM.TTY qualified as TTY +import EVM.Types + +import Control.Arrow ((***), (&&&)) +import Optics.Core +import Control.Monad +import Data.Aeson ((.:), (.:?), FromJSON (..)) +import Data.Aeson qualified as JSON +import Data.Aeson.Types qualified as JSON +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as Lazy +import Data.ByteString.Lazy qualified as LazyByteString +import Data.List (isInfixOf) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (fromJust, fromMaybe, isNothing, isJust) +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 + +data Which = Pre | Post + +data Block = Block + { coinbase :: Addr + , difficulty :: W256 + , gasLimit :: Word64 + , baseFee :: W256 + , number :: W256 + , timestamp :: W256 + , txs :: [Transaction] + } deriving Show + +data Case = Case + { vmOpts :: EVM.VMOpts + , checkContracts :: Map Addr (EVM.Contract, Storage) + , testExpectation :: Map Addr (EVM.Contract, Storage) + } deriving Show + +data BlockchainCase = BlockchainCase + { blocks :: [Block] + , pre :: Map Addr (EVM.Contract, Storage) + , post :: Map Addr (EVM.Contract, Storage) + , network :: 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 = [] + +commonProblematicTests :: Map String (TestTree -> TestTree) +commonProblematicTests = Map.fromList + [ ("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 <- EVM.Stepper.interpret (EVM.Fetch.zero 0 (Just 0)) vm0 EVM.Stepper.runFully + maybeReason <- checkExpectation diffmode x result + forM_ maybeReason assertFailure + +-- | 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 = case filter (\(name, _) -> name == test) $ Map.toList allTests of + [(_, x')] -> x' + _ -> error "test not found" + 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) -> 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 -> + acc ++ show k ++ " : " + ++ (show . toInteger $ (view #nonce c)) ++ " " + ++ (show . toInteger $ (view #balance c)) ++ " " + ++ (printStorage s) + ++ "\n") "" cs + + reason = map fst (filter (not . snd) + [ ("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 = x.checkContracts + expected = x.testExpectation + actual = Map.map (,mempty) $ view (#env % #contracts) vm -- . to (fmap (clearZeroStorage.clearOrigStorage))) vm + printStorage = show -- TODO: fixme + + when diff $ do + putStr (unwords reason) + putStrLn "\nPre balance/state: " + printContracts check + putStrLn "\nExpected balance/state: " + printContracts expected + putStrLn "\nActual balance/state: " + printContracts actual + pure (unwords reason) + +checkExpectation :: Bool -> Case -> EVM.VM -> IO (Maybe String) +checkExpectation diff x vm = do + let expectation = x.testExpectation + (okState, b2, b3, b4, b5) = checkExpectedContracts vm expectation + 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 +(~=) cs1 cs2 = + let nullAccount = EVM.initialContract (EVM.RuntimeCode (EVM.ConcreteRuntimeCode "")) + padNewAccounts cs ks = Map.union cs $ Map.fromList [(k, (nullAccount, mempty)) | k <- ks] + padded_cs1 = padNewAccounts cs1 (Map.keys cs2) + padded_cs2 = padNewAccounts cs2 (Map.keys cs1) + in and $ zipWith (===) (Map.elems padded_cs1) (Map.elems padded_cs2) + +(===) :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) -> Bool +(c1, s1) === (c2, s2) = + codeEqual && storageEqual && (c1 ^. #balance == c2 ^. #balance) && (c1 ^. #nonce == c2 ^. #nonce) + where + storageEqual = s1 == s2 + codeEqual = case (c1 ^. #contractcode, c2 ^. #contractcode) of + (EVM.RuntimeCode a', EVM.RuntimeCode b') -> a' == b' + _ -> error "unexpected code" + +checkExpectedContracts :: EVM.VM -> Map Addr (EVM.Contract, Storage) -> (Bool, Bool, Bool, Bool, Bool) +checkExpectedContracts vm expected = + let cs = zipWithStorages $ vm ^. #env % #contracts -- . to (fmap (clearZeroStorage.clearOrigStorage)) + expectedCs = clearStorage <$> expected + in ( (expectedCs ~= cs) + , (clearBalance <$> expectedCs) ~= (clearBalance <$> cs) + , (clearNonce <$> expectedCs) ~= (clearNonce <$> cs) + , (clearStorage <$> expectedCs) ~= (clearStorage <$> cs) + , (clearCode <$> expectedCs) ~= (clearCode <$> cs) + ) + where + zipWithStorages = Map.mapWithKey (\addr c -> (c, lookupStorage addr)) + lookupStorage _ = + case vm ^. #env % #storage of + ConcreteStore _ -> mempty -- clearZeroStorage $ fromMaybe mempty $ Map.lookup (num addr) s + EmptyStore -> mempty + AbstractStore -> mempty -- error "AbstractStore, should this be handled?" + SStore {} -> mempty -- error "SStore, should this be handled?" + GVar _ -> error "unexpected global variable" + +clearStorage :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) +clearStorage (c, _) = (c, mempty) + +clearBalance :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) +clearBalance (c, s) = (set #balance 0 c, s) + +clearNonce :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) +clearNonce (c, s) = (set #nonce 0 c, s) + +clearCode :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) +clearCode (c, s) = (set #contractcode (EVM.RuntimeCode (EVM.ConcreteRuntimeCode "")) c, s) + +newtype ContractWithStorage = ContractWithStorage (EVM.Contract, Storage) + +instance FromJSON ContractWithStorage where + parseJSON (JSON.Object v) = do + code <- (EVM.RuntimeCode . EVM.ConcreteRuntimeCode <$> (hexText <$> v .: "code")) + storage' <- v .: "storage" + balance' <- v .: "balance" + nonce' <- v .: "nonce" + let c = EVM.initialContract code + & #balance .~ balance' + & #nonce .~ nonce' + return $ ContractWithStorage (c, storage') + + parseJSON invalid = + JSON.typeMismatch "Contract" invalid + +instance FromJSON BlockchainCase where + parseJSON (JSON.Object v) = BlockchainCase + <$> v .: "blocks" + <*> parseContracts Pre v + <*> parseContracts Post v + <*> v .: "network" + parseJSON invalid = + JSON.typeMismatch "GeneralState test case" invalid + +instance FromJSON Block where + parseJSON (JSON.Object v) = do + v' <- v .: "blockHeader" + txs <- v .: "transactions" + coinbase <- addrField v' "coinbase" + difficulty <- wordField v' "difficulty" + gasLimit <- word64Field v' "gasLimit" + number <- wordField v' "number" + baseFee <- fmap read <$> v' .:? "baseFeePerGas" + timestamp <- wordField v' "timestamp" + return $ Block coinbase difficulty gasLimit (fromMaybe 0 baseFee) number timestamp txs + parseJSON invalid = + JSON.typeMismatch "Block" invalid + +parseContracts :: Which -> JSON.Object -> JSON.Parser (Map Addr (EVM.Contract, Storage)) +parseContracts w v = + (Map.map unwrap) <$> (v .: which >>= parseJSON) + where which = case w of + Pre -> "pre" + Post -> "postState" + unwrap (ContractWithStorage x) = x + +parseBCSuite :: Lazy.ByteString -> Either String (Map String Case) +parseBCSuite x = case (JSON.eitherDecode' x) :: Either String (Map String BlockchainCase) of + Left e -> Left e + Right bcCases -> let allCases = fromBlockchainCase <$> bcCases + keepError (Left e) = errorFatal e + keepError _ = True + filteredCases = Map.filter keepError allCases + (erroredCases, parsedCases) = splitEithers filteredCases + in if Map.size erroredCases > 0 + then Left ("errored case: " ++ (show erroredCases)) + else if Map.size parsedCases == 0 + then Left "No cases to check." + else Right parsedCases + + +data BlockchainError + = TooManyBlocks + | TooManyTxs + | NoTxs + | SignatureUnverified + | InvalidTx + | OldNetwork + | FailedCreate + deriving Show + +errorFatal :: BlockchainError -> Bool +errorFatal TooManyBlocks = True +errorFatal TooManyTxs = True +errorFatal SignatureUnverified = True +errorFatal InvalidTx = True +errorFatal _ = False + +fromBlockchainCase :: BlockchainCase -> Either BlockchainError Case +fromBlockchainCase (BlockchainCase blocks preState postState network) = + case (blocks, network) of + ([block], "London") -> case block.txs of + [tx] -> fromBlockchainCase' block tx preState postState + [] -> Left NoTxs + _ -> Left TooManyTxs + ([_], _) -> Left OldNetwork + (_, _) -> Left TooManyBlocks + +fromBlockchainCase' :: Block -> Transaction + -> Map Addr (EVM.Contract, Storage) -> Map Addr (EVM.Contract, Storage) + -> Either BlockchainError Case +fromBlockchainCase' block tx preState postState = + let isCreate = isNothing tx.toAddr in + case (sender tx, checkTx tx block preState) of + (Nothing, _) -> Left SignatureUnverified + (_, Nothing) -> Left (if isCreate then FailedCreate else InvalidTx) + (Just origin, Just checkState) -> Right $ Case + (EVM.VMOpts + { contract = EVM.initialContract theCode + , calldata = (cd, []) + , value = Lit tx.value + , address = toAddr + , caller = litAddr origin + , initialStorage = EmptyStore + , origin = origin + , gas = tx.gasLimit - fromIntegral (txGasCost feeSchedule tx) + , baseFee = block.baseFee + , priorityFee = priorityFee tx block.baseFee + , gaslimit = tx.gasLimit + , number = block.number + , timestamp = Lit block.timestamp + , coinbase = block.coinbase + , prevRandao = block.difficulty + , maxCodeSize = 24576 + , blockGaslimit = block.gasLimit + , gasprice = effectiveGasPrice + , schedule = feeSchedule + , chainId = 1 + , create = isCreate + , txAccessList = txAccessMap tx + , allowFFI = False + }) + checkState + postState + where + toAddr = fromMaybe (EVM.createAddress origin senderNonce) tx.toAddr + senderNonce = view (accountAt origin % #nonce) (Map.map fst preState) + feeSchedule = EVM.FeeSchedule.berlin + toCode = Map.lookup toAddr preState + theCode = if isCreate + then EVM.InitCode tx.txdata mempty + else maybe (EVM.RuntimeCode (EVM.ConcreteRuntimeCode "")) (view #contractcode . fst) toCode + effectiveGasPrice = effectiveprice tx block.baseFee + cd = if isCreate + then mempty + else ConcreteBuf tx.txdata + +effectiveprice :: Transaction -> W256 -> W256 +effectiveprice tx baseFee = priorityFee tx baseFee + baseFee + +priorityFee :: Transaction -> W256 -> W256 +priorityFee tx baseFee = let + (txPrioMax, txMaxFee) = case tx.txtype of + EIP1559Transaction -> + let maxPrio = fromJust tx.maxPriorityFeeGas + maxFee = fromJust tx.maxFeePerGas + in (maxPrio, maxFee) + _ -> + let gasPrice = fromJust tx.gasPrice + in (gasPrice, gasPrice) + in min txPrioMax (txMaxFee - baseFee) + +maxBaseFee :: Transaction -> W256 +maxBaseFee tx = + case tx.txtype of + EIP1559Transaction -> fromJust tx.maxFeePerGas + _ -> fromJust tx.gasPrice + +validateTx :: Transaction -> Block -> Map Addr (EVM.Contract, Storage) -> Maybe () +validateTx tx block cs = do + let cs' = Map.map fst cs + origin <- sender tx + originBalance <- (view #balance) <$> view (at origin) cs' + originNonce <- (view #nonce) <$> view (at origin) cs' + let gasDeposit = (effectiveprice tx block.baseFee) * (num tx.gasLimit) + if gasDeposit + tx.value <= originBalance + && tx.nonce == originNonce && block.baseFee <= maxBaseFee tx + then Just () + else Nothing + +checkTx :: Transaction -> Block -> Map Addr (EVM.Contract, Storage) -> Maybe (Map Addr (EVM.Contract, Storage)) +checkTx tx block prestate = do + origin <- sender tx + validateTx tx block prestate + let isCreate = isNothing tx.toAddr + senderNonce = view (accountAt origin % #nonce) (Map.map fst prestate) + toAddr = fromMaybe (EVM.createAddress origin senderNonce) tx.toAddr + prevCode = view (accountAt toAddr % #contractcode) (Map.map fst prestate) + prevNonce = view (accountAt toAddr % #nonce) (Map.map fst prestate) + if isCreate && ((case prevCode of {EVM.RuntimeCode (EVM.ConcreteRuntimeCode b) -> not (BS.null b); _ -> True}) || (prevNonce /= 0)) + then mzero + else + return prestate + +vmForCase :: Case -> EVM.VM +vmForCase x = + let + a = x.checkContracts + cs = Map.map fst a + st = Map.mapKeys num $ Map.map snd a + vm = EVM.makeVm x.vmOpts + & set (#env % #contracts) cs + & set (#env % #storage) (ConcreteStore st) + & set (#env % #origStorage) st + in + initTx vm diff --git a/test/EVM/Test/Tracing.hs b/test/EVM/Test/Tracing.hs new file mode 100644 --- /dev/null +++ b/test/EVM/Test/Tracing.hs @@ -0,0 +1,868 @@ +{-| +Module : Tracing +Description : Tests to fuzz concrete tracing, and symbolic execution + +Functions here are used to generate traces for the concrete +execution of HEVM and check that against evmtool from go-ehereum. Re-using some +of this code, we also generate a symbolic expression then evaluate it +concretely through Expr.simplify, then check that against evmtool's output. +-} + +{-# Language DataKinds #-} +{-# Language DuplicateRecordFields #-} +{-# LANGUAGE DeriveGeneric #-} + +module EVM.Test.Tracing where + +import Data.ByteString (ByteString) +import System.Directory +import System.IO +import qualified Data.Word +import GHC.Generics +import Numeric (showHex) +import qualified Paths_hevm as Paths + +import Prelude hiding (fail, LT, GT) + +import qualified Data.ByteString as BS +import Data.Maybe +import Data.List qualified (length) +import Test.Tasty +import Test.Tasty.QuickCheck hiding (Failure) +import Test.QuickCheck.Instances.Text() +import Test.QuickCheck.Instances.Natural() +import Test.QuickCheck.Instances.ByteString() +import Test.QuickCheck (elements) +import Test.Tasty.HUnit +import qualified Data.Aeson as JSON +import Data.Aeson ((.:), (.:?)) +import Data.ByteString.Char8 qualified as Char8 + +import qualified Control.Monad (when) +import qualified Control.Monad.Operational as Operational (view, ProgramViewT(..), ProgramView) +import Control.Monad.State.Strict hiding (state) +import Control.Monad.State.Strict qualified as State +import Optics.Core hiding (pre) +import Optics.State +import Optics.Zoom + +import qualified Data.Vector as Vector +import qualified Data.Map.Strict as Map + +import EVM +import EVM.SymExec +import EVM.Assembler +import EVM.Op hiding (getOp) +import EVM.Exec +import EVM.Types +import EVM.Traversals +import EVM.Concrete (createAddress) +import qualified EVM.FeeSchedule as FeeSchedule +import EVM.Solvers +import qualified EVM.Expr as Expr +import qualified Data.Text.IO as T +import qualified EVM.Stepper as Stepper +import qualified EVM.Fetch as Fetch +import System.Process +import qualified EVM.Transaction +import EVM.Format (formatBinary) +import EVM.Sign (deriveAddr) +import GHC.IO.Exception (ExitCode(ExitSuccess)) + +data VMTraceResult = + VMTraceResult + { out :: ByteStringS + , gasUsed :: Data.Word.Word64 + } deriving (Generic, Show) + +instance JSON.ToJSON VMTraceResult where + toEncoding = JSON.genericToEncoding JSON.defaultOptions + +data EVMToolTrace = + EVMToolTrace + { pc :: Int + , op :: Int + , gas :: W256 + , memSize :: Integer + , depth :: Int + , refund :: Int + , opName :: String + , stack :: [W256] + , error :: Maybe String + } deriving (Generic, Show) + +instance JSON.FromJSON EVMToolTrace where + parseJSON = JSON.withObject "EVMToolTrace" $ \v -> EVMToolTrace + <$> v .: "pc" + <*> v .: "op" + <*> v .: "gas" + <*> v .: "memSize" + <*> v .: "depth" + <*> v .: "refund" + <*> v .: "opName" + <*> v .: "stack" + <*> v .:? "error" + +mkBlockHash:: Int -> Expr 'EWord +mkBlockHash x = (num x :: Integer) & show & Char8.pack & EVM.Types.keccak' & Lit + +blockHashesDefault :: Map.Map Int W256 +blockHashesDefault = Map.fromList [(x, forceLit $ mkBlockHash x) | x<- [1..256]] + +data EVMToolOutput = + EVMToolOutput + { output :: ByteStringS + , gasUsed :: W256 + , time :: Integer + } deriving (Generic, Show) + +instance JSON.FromJSON EVMToolOutput + +data EVMToolTraceOutput = + EVMToolTraceOutput + { trace :: [EVMToolTrace] + , output :: EVMToolOutput + } deriving (Generic, Show) + +instance JSON.FromJSON EVMToolTraceOutput + +data EVMToolEnv = EVMToolEnv + { coinbase :: Addr + , timestamp :: Expr EWord + , number :: W256 + , prevRandao :: W256 + , gasLimit :: Data.Word.Word64 + , baseFee :: W256 + , maxCodeSize :: W256 + , schedule :: FeeSchedule.FeeSchedule Data.Word.Word64 + , blockHashes :: Map.Map Int W256 + } deriving (Show, Generic) + +instance JSON.ToJSON EVMToolEnv where + toJSON b = JSON.object [ ("currentCoinBase" , (JSON.toJSON $ b.coinbase)) + , ("currentDifficulty", (JSON.toJSON $ b.prevRandao)) + , ("currentGasLimit" , (JSON.toJSON ("0x" ++ showHex (toInteger $ b.gasLimit) ""))) + , ("currentNumber" , (JSON.toJSON $ b.number)) + , ("currentTimestamp" , (JSON.toJSON tstamp)) + , ("currentBaseFee" , (JSON.toJSON $ b.baseFee)) + , ("blockHashes" , (JSON.toJSON $ b.blockHashes)) + ] + where + tstamp :: W256 + tstamp = case (b.timestamp) of + Lit a -> a + _ -> error "Timestamp needs to be a Lit" + +emptyEvmToolEnv :: EVMToolEnv +emptyEvmToolEnv = EVMToolEnv { coinbase = 0 + , timestamp = Lit 0 + , number = 0 + , prevRandao = 42069 + , gasLimit = 0xffffffffffffffff + , baseFee = 0 + , maxCodeSize= 0xffffffff + , schedule = FeeSchedule.berlin + , blockHashes = mempty + } + +data EVMToolReceipt = + EVMToolReceipt + { _type :: String + , root :: String + , status :: String + , cumulativeGasUsed :: String + , logsBloom :: String + , logs :: Maybe String + , transactionHash :: String + , contractAddress :: String + , gasUsed :: String + , blockHash :: String + , transactionIndex :: String + } deriving (Generic, Show) + +instance JSON.FromJSON EVMToolReceipt where + parseJSON = JSON.withObject "EVMReceipt" $ \v -> EVMToolReceipt + <$> v .: "type" + <*> v .: "root" + <*> v .: "status" + <*> v .: "cumulativeGasUsed" + <*> v .: "logsBloom" + <*> v .: "logs" + <*> v .: "transactionHash" + <*> v .: "contractAddress" + <*> v .: "gasUsed" + <*> v .: "blockHash" + <*> v .: "transactionIndex" + +data EVMToolResult = + EVMToolResult + { stateRoot :: String + , txRoot :: String + , receiptsRoot :: String + , logsHash :: String + , logsBloom :: String + , receipts :: [EVMToolReceipt] + , currentDifficulty :: String + , gasUsed :: String + , rejected :: Maybe [EVMRejected] + } deriving (Generic, Show) + +instance JSON.FromJSON EVMToolResult + +data EVMRejected = + EVMRejected + { index :: Int + , err :: String + } deriving (Generic, Show) + +instance JSON.FromJSON EVMRejected where + parseJSON = JSON.withObject "EVMRejected" $ \v -> EVMRejected + <$> v .: "index" + <*> v .: "error" + +data EVMToolAlloc = + EVMToolAlloc + { balance :: W256 + , code :: ByteString + , nonce :: W64 + } deriving (Generic) + +instance JSON.ToJSON EVMToolAlloc where + toJSON b = JSON.object [ ("balance" , (JSON.toJSON $ show b.balance)) + , ("code", (JSON.toJSON $ ByteStringS b.code)) + , ("nonce", (JSON.toJSON $ b.nonce)) + ] + +emptyEVMToolAlloc :: EVMToolAlloc +emptyEVMToolAlloc = EVMToolAlloc { balance = 0 + , code = mempty + , nonce = 0 + } +-- Sets up common parts such as TX, origin contract, and environment that can +-- later be used to create & execute either an evmtool (from go-ethereum) or an +-- HEVM transaction. Some elements here are hard-coded such as the secret key, +-- which are currently not being fuzzed. +evmSetup :: OpContract -> ByteString -> Int -> (EVM.Transaction.Transaction, EVMToolEnv, EVMToolAlloc, Addr, Addr, Integer) +evmSetup contr txData gaslimitExec = (txn, evmEnv, contrAlloc, fromAddress, toAddress, sk) + where + contrLits = assemble $ getOpData contr + toW8fromLitB :: Expr 'Byte -> Data.Word.Word8 + toW8fromLitB (LitByte a) = a + toW8fromLitB _ = error "Cannot convert non-litB" + + bitcode = BS.pack . Vector.toList $ toW8fromLitB <$> contrLits + contrAlloc = EVMToolAlloc{ balance = 0xa493d65e20984bc + , code = bitcode + , nonce = 0x48 + } + txn = EVM.Transaction.Transaction + { txdata = txData + , gasLimit = fromIntegral gaslimitExec + , gasPrice = Just 1 + , nonce = 172 + , toAddr = Just 0x8A8eAFb1cf62BfBeb1741769DAE1a9dd47996192 + , r = 0 -- will be fixed when we sign + , s = 0 -- will be fixed when we sign + , v = 0 -- will be fixed when we sign + , value = 0 -- setting this > 0 fails because HEVM doesn't handle value sent in toplevel transaction + , txtype = EVM.Transaction.EIP1559Transaction + , accessList = [] + , maxPriorityFeeGas = Just 1 + , maxFeePerGas = Just 1 + , chainId = 1 + } + evmEnv = EVMToolEnv { coinbase = 0xff + , timestamp = Lit 0x3e8 + , number = 0x0 + , prevRandao = 0x0 + , gasLimit = fromIntegral gaslimitExec + , baseFee = 0x0 + , maxCodeSize = 0xfffff + , schedule = FeeSchedule.berlin + , blockHashes = blockHashesDefault + } + sk = 0xDC38EE117CAE37750EB1ECC5CFD3DE8E85963B481B93E732C5D0CB66EE6B0C9D + fromAddress :: Addr + fromAddress = fromJust $ deriveAddr sk + toAddress :: Addr + toAddress = 0x8A8eAFb1cf62BfBeb1741769DAE1a9dd47996192 + +getHEVMRet :: OpContract -> ByteString -> Int -> IO (Either (EVM.Error, [VMTrace]) (Expr 'End, [VMTrace], VMTraceResult)) +getHEVMRet contr txData gaslimitExec = do + let (txn, evmEnv, contrAlloc, fromAddress, toAddress, _) = evmSetup contr txData gaslimitExec + hevmRun <- runCodeWithTrace Nothing evmEnv contrAlloc txn (fromAddress, toAddress) + return hevmRun + +getEVMToolRet :: OpContract -> ByteString -> Int -> IO (Maybe EVMToolResult) +getEVMToolRet contr txData gaslimitExec = do + let (txn, evmEnv, contrAlloc, fromAddress, toAddress, sk) = evmSetup contr txData gaslimitExec + txs = [EVM.Transaction.sign sk txn] + walletAlloc = EVMToolAlloc{ balance = 0x5ffd4878be161d74 + , code = BS.empty + , nonce = 0xac + } + alloc :: Map.Map Addr EVMToolAlloc + alloc = Map.fromList ([ (fromAddress, walletAlloc), (toAddress, contrAlloc)]) + JSON.encodeFile "txs.json" txs + JSON.encodeFile "alloc.json" alloc + JSON.encodeFile "env.json" evmEnv + (exitCode, evmtoolStdout, evmtoolStderr) <- readProcessWithExitCode "evm" [ "transition" + ,"--input.alloc" , "alloc.json" + , "--input.env" , "env.json" + , "--input.txs" , "txs.json" + , "--output.alloc" , "alloc-out.json" + , "--trace.returndata=true" + , "--trace" , "trace.json" + , "--output.result", "result.json" + ] "" + Control.Monad.when (exitCode /= ExitSuccess) $ do + putStrLn $ "evmtool exited with code " <> show exitCode + putStrLn $ "evmtool stderr output:" <> show evmtoolStderr + putStrLn $ "evmtool stdout output:" <> show evmtoolStdout + evmtoolResult <- JSON.decodeFileStrict "result.json" :: IO (Maybe EVMToolResult) + return evmtoolResult + +-- Compares traces of evmtool (from go-ethereum) and HEVM +compareTraces :: [VMTrace] -> [EVMToolTrace] -> IO (Bool) +compareTraces hevmTrace evmTrace = go hevmTrace evmTrace + where + go :: [VMTrace] -> [EVMToolTrace] -> IO (Bool) + go [] [] = pure True + go (a:ax) (b:bx) = do + let aOp = a.traceOp + bOp = b.op + aPc = a.tracePc + bPc = b.pc + aStack = a.traceStack + bStack = b.stack + aGas = fromIntegral a.traceGas + bGas = b.gas + if aGas /= bGas then do + putStrLn "GAS doesn't match:" + putStrLn $ "HEVM's gas : " <> (show aGas) + putStrLn $ "evmtool's gas: " <> (show bGas) + else + -- putStrLn $ "Gas match : " <> (show aGas) + return () + if aOp /= bOp || aPc /= bPc then + putStrLn $ "HEVM: " <> (intToOpName aOp) <> " (pc " <> (show aPc) <> ") --- evmtool " <> (intToOpName bOp) <> " (pc " <> (show bPc) <> ")" + else + -- putStrLn $ "trace element match. " <> (intToOpName aOp) <> " pc: " <> (show aPc) + return () + + Control.Monad.when (isJust b.error) $ do + putStrLn $ "Error by evmtool: " <> (show b.error) + putStrLn $ "Error by HEVM : " <> (show a.traceError) + + Control.Monad.when (aStack /= bStack) $ do + putStrLn "stacks don't match:" + putStrLn $ "HEVM's stack : " <> (show aStack) + putStrLn $ "evmtool's stack: " <> (show bStack) + if aOp == bOp && aStack == bStack && aPc == bPc && aGas == bGas then go ax bx + else pure False + + + go a@(_:_) [] = do + putStrLn $ "Traces don't match. HEVM's trace is longer by:" <> (show a) + pure False + go [] [b] = do + -- evmtool produces ONE more trace element of the error + -- hevm on the other hand stops and doens't produce one more + if isJust b.error then pure True + else do + putStrLn $ "Traces don't match. HEVM's trace is longer by:" <> (show b) + pure False + go [] b@(_:_) = do + putStrLn $ "Traces don't match. evmtool's trace is longer by:" <> (show b) + pure False + +getTraceFileName :: EVMToolResult -> String +getTraceFileName evmtoolResult = traceFileName + where + txName = ((evmtoolResult.receipts) !! 0).transactionHash + traceFileName = "trace-0-" ++ txName ++ ".jsonl" + +getTraceOutput :: Maybe EVMToolResult -> IO (Maybe EVMToolTraceOutput) +getTraceOutput evmtoolResult = + case evmtoolResult of + Nothing -> pure Nothing + Just res -> do + let traceFileName = getTraceFileName res + convertPath <- Paths.getDataFileName "test/scripts/convert_trace_to_json.sh" + (exitcode, _, _) <- readProcessWithExitCode "bash" [convertPath, getTraceFileName res] "" + case exitcode of + ExitSuccess -> JSON.decodeFileStrict (traceFileName ++ ".json") :: IO (Maybe EVMToolTraceOutput) + _ -> pure Nothing + +deleteTraceOutputFiles :: Maybe EVMToolResult -> IO () +deleteTraceOutputFiles evmtoolResult = + case evmtoolResult of + Nothing -> return () + Just res -> do + let traceFileName = getTraceFileName res + System.Directory.removeFile traceFileName + System.Directory.removeFile (traceFileName ++ ".json") + +-- Create symbolic VM from concrete VM +symbolify :: VM -> VM +symbolify vm = vm { state = vm.state { calldata = AbstractBuf "calldata" } } + +-- | Takes a runtime code and calls it with the provided calldata +-- Uses evmtool's alloc and transaction to set up the VM correctly +runCodeWithTrace :: Fetch.RpcInfo -> EVMToolEnv -> EVMToolAlloc -> EVM.Transaction.Transaction -> (Addr, Addr) -> IO (Either (EVM.Error, [VMTrace]) ((Expr 'End, [VMTrace], VMTraceResult))) +runCodeWithTrace rpcinfo evmEnv alloc txn (fromAddr, toAddress) = withSolvers Z3 0 Nothing $ \solvers -> do + let origVM = vmForRuntimeCode code' calldata' evmEnv alloc txn (fromAddr, toAddress) + calldata' = ConcreteBuf txn.txdata + code' = alloc.code + buildExpr :: SolverGroup -> VM -> IO (Expr End) + buildExpr s vm = interpret (Fetch.oracle s Nothing) Nothing Nothing vm runExpr + + expr <- buildExpr solvers $ symbolify origVM + (res, (vm, trace)) <- runStateT (interpretWithTrace (Fetch.oracle solvers rpcinfo) Stepper.execFully) (origVM, []) + case res of + Left x -> pure $ Left (x, trace) + Right _ -> pure $ Right (expr, trace, vmres vm) + +vmForRuntimeCode :: ByteString -> Expr Buf -> EVMToolEnv -> EVMToolAlloc -> EVM.Transaction.Transaction -> (Addr, Addr) -> VM +vmForRuntimeCode runtimecode calldata' evmToolEnv alloc txn (fromAddr, toAddress) = + let contr = initialContract (RuntimeCode (ConcreteRuntimeCode runtimecode)) + contrWithBal = (contr :: Contract) { balance = alloc.balance } + in + (makeVm $ VMOpts + { contract = contrWithBal + , calldata = (calldata', []) + , value = Lit txn.value + , initialStorage = EmptyStore + , address = toAddress + , caller = Expr.litAddr fromAddr + , origin = fromAddr + , coinbase = evmToolEnv.coinbase + , number = evmToolEnv.number + , timestamp = evmToolEnv.timestamp + , gasprice = fromJust txn.gasPrice + , gas = txn.gasLimit - fromIntegral (EVM.Transaction.txGasCost evmToolEnv.schedule txn) + , gaslimit = txn.gasLimit + , blockGaslimit = evmToolEnv.gasLimit + , prevRandao = evmToolEnv.prevRandao + , baseFee = evmToolEnv.baseFee + , priorityFee = fromJust txn.maxPriorityFeeGas + , maxCodeSize = evmToolEnv.maxCodeSize + , schedule = evmToolEnv.schedule + , chainId = txn.chainId + , create = False + , txAccessList = mempty + , allowFFI = False + }) & set (#env % #contracts % at ethrunAddress) + (Just (initialContract (RuntimeCode (ConcreteRuntimeCode BS.empty)))) + & set (#state % #calldata) calldata' + +runCode :: Fetch.RpcInfo -> ByteString -> Expr Buf -> IO (Maybe (Expr Buf)) +runCode rpcinfo code' calldata' = withSolvers Z3 0 Nothing $ \solvers -> do + let origVM = vmForRuntimeCode code' calldata' emptyEvmToolEnv emptyEVMToolAlloc EVM.Transaction.emptyTransaction (ethrunAddress, createAddress ethrunAddress 1) + res <- Stepper.interpret (Fetch.oracle solvers rpcinfo) origVM Stepper.execFully + pure $ case res of + Left _ -> Nothing + Right b -> Just b + +vmtrace :: VM -> VMTrace +vmtrace vm = + let + memsize = vm.state.memorySize + in VMTrace { tracePc = vm.state.pc + , traceOp = num $ getOp vm + , traceGas = vm.state.gas + , traceMemSize = memsize + -- increment to match geth format + , traceDepth = 1 + length (vm.frames) + -- reverse to match geth format + , traceStack = reverse $ forceLit <$> vm.state.stack + , traceError = readoutError vm.result + } + where + readoutError :: Maybe VMResult -> Maybe String + readoutError Nothing = Nothing + readoutError (Just (VMSuccess _)) = Nothing + readoutError (Just (VMFailure e)) = case e of + -- NOTE: error text made to closely match go-ethereum's errors.go file + OutOfGas {} -> Just "out of gas" + -- TODO "contract creation code storage out of gas" not handled + CallDepthLimitReached -> Just "max call depth exceeded" + BalanceTooLow {} -> Just "insufficient balance for transfer" + -- TODO "contract address collision" not handled + EVM.Revert {} -> Just "execution reverted" + -- TODO "max initcode size exceeded" not handled + MaxCodeSizeExceeded {} -> Just "max code size exceeded" + EVM.BadJumpDestination -> Just "invalid jump destination" + StateChangeWhileStatic -> Just "write protection" + ReturnDataOutOfBounds -> Just "return data out of bounds" + EVM.IllegalOverflow -> Just "gas uint64 overflow" + UnrecognizedOpcode op -> Just $ "invalid opcode: " <> show op + EVM.NonceOverflow -> Just "nonce uint64 overflow" + EVM.StackUnderrun -> Just "stack underflow" + EVM.StackLimitExceeded -> Just "stack limit reached" + EVM.InvalidMemoryAccess -> Just "write protection" + err -> Just $ "HEVM error: " <> show err + +vmres :: VM -> VMTraceResult +vmres vm = + let + gasUsed' = vm.tx.gaslimit - vm.state.gas + res = case vm.result of + Just (VMSuccess (ConcreteBuf b)) -> (ByteStringS b) + Just (VMSuccess x) -> error $ "unhandled: " <> (show x) + Just (VMFailure (EVM.Revert (ConcreteBuf b))) -> (ByteStringS b) + Just (VMFailure _) -> ByteStringS mempty + _ -> ByteStringS mempty + in VMTraceResult + { out = res + , gasUsed = gasUsed' + } + +type TraceState = (VM, [VMTrace]) + +execWithTrace :: StateT TraceState IO VMResult +execWithTrace = do + _ <- runWithTrace + fromJust <$> use (_1 % #result) + +runWithTrace :: StateT TraceState IO VM +runWithTrace = do + -- This is just like `exec` except for every instruction evaluated, + -- we also increment a counter indexed by the current code location. + vm0 <- use _1 + case vm0.result of + Nothing -> do + State.modify (\(a, b) -> (a, b ++ [vmtrace vm0])) + zoom _1 (State.state (runState exec1)) + runWithTrace + Just (VMSuccess _) -> pure vm0 + Just (VMFailure _) -> do + -- Update error text for last trace element + (a, b) <- State.get + let updatedElem = (last b) {traceError = (vmtrace vm0).traceError} + updatedTraces = take ((Data.List.length b)-1) b ++ [updatedElem] + State.put (a, updatedTraces) + pure vm0 + +interpretWithTrace + :: Fetch.Fetcher + -> Stepper.Stepper a + -> StateT TraceState IO a +interpretWithTrace fetcher = + eval . Operational.view + + where + eval + :: Operational.ProgramView Stepper.Action a + -> StateT TraceState IO a + + eval (Operational.Return x) = + pure x + + eval (action Operational.:>>= k) = + case action of + Stepper.Exec -> + execWithTrace >>= interpretWithTrace fetcher . k + Stepper.Run -> + runWithTrace >>= interpretWithTrace fetcher . k + Stepper.Wait q -> + do m <- liftIO (fetcher q) + zoom _1 (State.state (runState m)) >> interpretWithTrace fetcher (k ()) + Stepper.Ask _ -> + error "cannot make choice in this interpreter" + Stepper.IOAct q -> + zoom _1 (StateT (runStateT q)) >>= interpretWithTrace fetcher . k + Stepper.EVM m -> + zoom _1 (State.state (runState m)) >>= interpretWithTrace fetcher . k + +data OpContract = OpContract [Op] +instance Show OpContract where + show (OpContract a) = "OpContract " ++ (show a) + +getOpData :: OpContract-> [Op] +getOpData (OpContract x) = x + +instance Arbitrary OpContract where + arbitrary = fmap OpContract (sized genContract) + +removeExtcalls :: OpContract -> OpContract +removeExtcalls (OpContract ops) = OpContract (filter (noStorageNoExtcalls) ops) + where + noStorageNoExtcalls :: Op -> Bool + noStorageNoExtcalls o = case o of + -- Extrenal info functions + OpExtcodecopy -> False + OpExtcodehash -> False + OpExtcodesize -> False + OpAddress -> False + OpOrigin -> False + OpCaller -> False + OpCoinbase -> False + OpCreate -> False + OpCreate2 -> False + -- External call functions + OpDelegatecall -> False + OpStaticcall -> False + OpCall -> False + OpCallcode -> False + -- Not interesting + OpBalance -> False + OpSelfdestruct -> False + _ -> True + +getJumpDests :: [Op] -> [Int] +getJumpDests ops = go ops 0 [] + where + go :: [Op] -> Int -> [Int] -> [Int] + go [] _ dests = dests + go (a:ax) pos dests = case a of + OpJumpdest -> go ax (pos+1) (pos:dests) + OpPush _ -> go ax (pos+33) dests + -- We'll fix these up later to add a Push in between, hence they are 34 bytes + OpJump -> go ax (pos+34) dests + OpJumpi -> go ax (pos+34) dests + -- everything else is 1 byte + _ -> go ax (pos+1) dests + +fixContractJumps :: OpContract -> IO OpContract +fixContractJumps (OpContract ops) = do + let + addedOps = ops++[OpJumpdest] + jumpDests = getJumpDests addedOps + -- always end on an OpJumpdest so we don't have an issue with a "later" position + ops2 = fixup addedOps 0 [] + -- original set of operations, the set of jumpDests NOW valid, current position, return value + fixup :: [Op] -> Int -> [Op] -> IO [Op] + fixup [] _ ret = pure ret + fixup (a:ax) pos ret = case a of + OpJumpi -> do + let filtDests = (filter (> pos) jumpDests) + rndPos <- randItem filtDests + fixup ax (pos+34) (ret++[(OpPush (Lit (fromInteger (fromIntegral rndPos)))), (OpJumpi)]) + OpJump -> do + let filtDests = (filter (> pos) jumpDests) + rndPos <- randItem filtDests + fixup ax (pos+34) (ret++[(OpPush (Lit (fromInteger (fromIntegral rndPos)))), (OpJump)]) + myop@(OpPush _) -> fixup ax (pos+33) (ret++[myop]) + myop -> fixup ax (pos+1) (ret++[myop]) + fmap OpContract ops2 + +genPush :: Int -> Gen [Op] +genPush n = vectorOf n onePush + where + onePush :: Gen Op + onePush = do + p <- chooseInt (1, 10) + pure $ OpPush (Lit (fromIntegral p)) + +genContract :: Int -> Gen [Op] +genContract n = do + y <- chooseInt (3, 6) + pushes <- genPush y + normalOps <- vectorOf (3*n+40) genOne + addReturn <- chooseInt (0, 10) + let contr = pushes ++ normalOps + if addReturn < 10 then pure $ contr++[OpPush (Lit 0x40), OpPush (Lit 0x0), OpReturn] + else pure contr + where + genOne :: Gen Op + genOne = frequency [ + -- math ops + (200, frequency [ + (1, pure OpAdd) + , (1, pure OpMul) + , (1, pure OpSub) + , (1, pure OpDiv) + , (1, pure OpSdiv) + , (1, pure OpMod) + , (1, pure OpSmod) + , (1, pure OpAddmod) + , (1, pure OpMulmod) + , (1, pure OpExp) + , (1, pure OpSignextend) + , (1, pure OpLt) + , (1, pure OpGt) + , (1, pure OpSlt) + , (1, pure OpSgt) + , (1, pure OpSha3) + ]) + -- Comparison & binary ops + , (200, frequency [ + (1, pure OpEq) + , (1, pure OpIszero) + , (1, pure OpAnd) + , (1, pure OpOr) + , (1, pure OpXor) + , (1, pure OpNot) + , (1, pure OpByte) + , (1, pure OpShl) + , (1, pure OpShr) + , (1, pure OpSar) + ]) + -- calldata + , (800, pure OpCalldataload) + , (200, pure OpCalldatacopy) + -- Get some info + , (100, frequency [ + (10, pure OpAddress) + , (10, pure OpBalance) + , (10, pure OpOrigin) + , (10, pure OpCaller) + , (10, pure OpCallvalue) + , (10, pure OpCalldatasize) + , (10, pure OpCodesize) + , (10, pure OpGasprice) + , (10, pure OpReturndatasize) + , (10, pure OpReturndatacopy) + , (10, pure OpExtcodehash) + , (10, pure OpBlockhash) + , (10, pure OpCoinbase) + , (10, pure OpTimestamp) + , (10, pure OpNumber) + , (10, pure OpPrevRandao) + , (10, pure OpGaslimit) + , (10, pure OpChainid) + , (10, pure OpSelfbalance) + , (10, pure OpBaseFee) + , (10, pure OpPc) + , (10, pure OpMsize) + , (10, pure OpGas) + , (10, pure OpExtcodesize) + , (10, pure OpCodecopy) + , (10, pure OpExtcodecopy) + ]) + -- memory manip + , (1200, frequency [ + (50, pure OpMload) + , (50, pure OpMstore) + , (1, pure OpMstore8) + ]) + -- storage manip + , (100, frequency [ + (1, pure OpSload) + , (1, pure OpSstore) + ]) + -- Jumping around + , (20, frequency [ + (1, pure OpJump) + , (10, pure OpJumpi) + ]) + -- calling out + , (1, frequency [ + (1, pure OpStaticcall) + , (1, pure OpCall) + , (1, pure OpCallcode) + , (1, pure OpDelegatecall) + , (1, pure OpCreate) + , (1, pure OpCreate2) + , (1, pure OpSelfdestruct) + ]) + -- manipulate stack + , (13000, frequency [ + (1, pure OpPop) + , (400, do + -- x <- arbitrary + large <- chooseInt (0, 100) + x <- if large == 0 then chooseBoundedIntegral (0::W256, (2::W256)^(256::W256)-1) + else chooseBoundedIntegral (0, 10) + pure $ OpPush (Lit (fromIntegral x))) + , (10, do + x <- chooseInt (1, 10) + pure $ OpDup (fromIntegral x)) + , (10, do + x <- chooseInt (1, 10) + pure $ OpSwap (fromIntegral x)) + ])] + -- End states + -- , (1, frequency [ + -- (1, pure OpStop) + -- , (10, pure OpReturn) + -- , (10, pure OpRevert) + -- ]) + +forceLit :: Expr EWord -> W256 +forceLit (Lit x) = x +forceLit _ = undefined + +randItem :: [a] -> IO a +randItem = generate . Test.QuickCheck.elements + +getOp :: VM -> Data.Word.Word8 +getOp vm = + let pcpos = vm ^. #state % #pc + code' = vm ^. #state % #code + xs = case code' of + InitCode _ _ -> error "InitCode instead of RuntimeCode" + RuntimeCode (ConcreteRuntimeCode xs') -> BS.drop pcpos xs' + RuntimeCode (SymbolicRuntimeCode _) -> error "RuntimeCode is symbolic" + in if xs == BS.empty then 0 + else BS.head xs + +tests :: TestTree +tests = testGroup "contract-quickcheck-run" + [ testProperty "random-contract-concrete-call" $ \(contr :: OpContract) -> ioProperty $ do + txDataRaw <- generate $ sized $ \n -> vectorOf (10*n+5) $ chooseInt (0,255) + gaslimitExec <- generate $ chooseInt (40000, 0xffff) + let txData = BS.pack $ toEnum <$> txDataRaw + -- TODO: By removing external calls, we fuzz less + -- It should work also when we external calls. Removing for now. + contrFixed <- fixContractJumps $ removeExtcalls contr + evmtoolResult <- getEVMToolRet contrFixed txData gaslimitExec + hevmRun <- getHEVMRet contrFixed txData gaslimitExec + (Just evmtoolTraceOutput) <- getTraceOutput evmtoolResult + case hevmRun of + (Right (expr, hevmTrace, hevmTraceResult)) -> do + let + concretize :: Expr a -> Expr Buf -> Expr a + concretize a c = mapExpr go a + where + go :: Expr a -> Expr a + go = \case + AbstractBuf "calldata" -> c + y -> y + concretizedExpr = concretize expr (ConcreteBuf txData) + simplConcExpr = Expr.simplify concretizedExpr + getReturnVal :: Expr End -> Maybe ByteString + getReturnVal (Return _ (ConcreteBuf bs) _) = Just bs + getReturnVal _ = Nothing + simplConcrExprRetval = getReturnVal simplConcExpr + traceOK <- compareTraces hevmTrace (evmtoolTraceOutput.trace) + -- putStrLn $ "HEVM trace : " <> show hevmTrace + -- putStrLn $ "evmtool trace: " <> show (evmtoolTraceOutput.toTrace) + assertEqual "Traces and gas must match" traceOK True + let resultOK = evmtoolTraceOutput.output.output == hevmTraceResult.out + if resultOK then do + putStrLn $ "HEVM & evmtool's outputs match: '" <> (bsToHex $ bssToBs evmtoolTraceOutput.output.output) <> "'" + if isNothing simplConcrExprRetval || (fromJust simplConcrExprRetval) == (bssToBs hevmTraceResult.out) + then do + putStr "OK, symbolic interpretation -> concrete calldata -> Expr.simplify gives the same answer." + if isNothing simplConcrExprRetval then putStrLn ", but it was a Nothing, so not strong equivalence" + else putStrLn "" + else do + putStrLn $ "concretized expr : " <> (show concretizedExpr) + putStrLn $ "simplified concretized expr: " <> (show simplConcExpr) + putStrLn $ "return value computed : " <> (show simplConcrExprRetval) + putStrLn $ "evmtool's return value : " <> (show hevmTraceResult.out) + assertEqual "Simplified, concretized expression must match evmtool's output." True False + else do + putStrLn $ "Name of trace file: " <> (getTraceFileName $ fromJust evmtoolResult) + putStrLn $ "HEVM result :" <> (show hevmTraceResult) + T.putStrLn $ "HEVM result: " <> (formatBinary $ bssToBs hevmTraceResult.out) + T.putStrLn $ "evm result : " <> (formatBinary $ bssToBs evmtoolTraceOutput.output.output) + putStrLn $ "HEVM result len: " <> (show (BS.length $ bssToBs hevmTraceResult.out)) + putStrLn $ "evm result len: " <> (show (BS.length $ bssToBs evmtoolTraceOutput.output.output)) + assertEqual "Contract exec successful. HEVM & evmtool's outputs must match" resultOK True + Left (evmerr, hevmTrace) -> do + putStrLn $ "HEVM contract exec issue: " <> (show evmerr) + -- putStrLn $ "evmtool result was: " <> show (fromJust evmtoolResult) + -- putStrLn $ "output by evmtool is: '" <> bsToHex evmtoolTraceOutput.toOutput.output <> "'" + traceOK <- compareTraces hevmTrace (evmtoolTraceOutput.trace) + assertEqual "Traces and gas must match" traceOK True + System.Directory.removeFile "txs.json" + System.Directory.removeFile "alloc-out.json" + System.Directory.removeFile "alloc.json" + System.Directory.removeFile "result.json" + System.Directory.removeFile "env.json" + deleteTraceOutputFiles evmtoolResult + ] + diff --git a/test/EVM/Test/Utils.hs b/test/EVM/Test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/EVM/Test/Utils.hs @@ -0,0 +1,136 @@ +{-# Language QuasiQuotes #-} + +module EVM.Test.Utils where + +import Data.Text +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Paths_hevm as Paths +import Data.String.Here +import System.Directory +import System.IO.Temp +import GHC.IO.Handle (hClose) +import System.Process (readProcess) + +import EVM.Solidity +import EVM.Solvers +import EVM.Dapp +import EVM.UnitTest +import EVM.Fetch (RpcInfo) +import qualified EVM.TTY as TTY + +runDappTestCustom :: FilePath -> Text -> Maybe Integer -> Bool -> RpcInfo -> IO Bool +runDappTestCustom testFile match maxIter ffiAllowed rpcinfo = do + root <- Paths.getDataDir + (json, _) <- compileWithDSTest testFile + --T.writeFile "output.json" json + withCurrentDirectory root $ do + withSystemTempFile "output.json" $ \file handle -> do + hClose handle + T.writeFile file json + withSolvers Z3 1 Nothing $ \solvers -> do + opts <- testOpts solvers root json match maxIter ffiAllowed rpcinfo + dappTest opts file Nothing + +runDappTest :: FilePath -> Text -> IO Bool +runDappTest testFile match = runDappTestCustom testFile match Nothing True Nothing + +debugDappTest :: FilePath -> RpcInfo -> IO () +debugDappTest testFile rpcinfo = do + root <- Paths.getDataDir + (json, _) <- compileWithDSTest testFile + --TIO.writeFile "output.json" json + withCurrentDirectory root $ do + withSystemTempFile "output.json" $ \file handle -> do + hClose handle + T.writeFile file json + withSolvers Z3 1 Nothing $ \solvers -> do + opts <- testOpts solvers root json ".*" Nothing True rpcinfo + TTY.main opts root file + +testOpts :: SolverGroup -> FilePath -> Text -> Text -> Maybe Integer -> Bool -> RpcInfo -> IO UnitTestOptions +testOpts solvers root solcJson match maxIter allowFFI rpcinfo = do + srcInfo <- case readJSON solcJson of + Nothing -> error "Could not read solc json" + Just (contractMap, asts, sources) -> do + sourceCache <- makeSourceCache sources asts + pure $ dappInfo root contractMap sourceCache + + params <- getParametersFromEnvironmentVariables Nothing + + pure UnitTestOptions + { solvers = solvers + , rpcInfo = rpcinfo + , maxIter = maxIter + , askSmtIters = Nothing + , smtDebug = False + , smtTimeout = Nothing + , solver = Nothing + , covMatch = Nothing + , verbose = Just 1 + , match = match + , maxDepth = Nothing + , fuzzRuns = 100 + , replay = Nothing + , vmModifier = id + , testParams = params + , dapp = srcInfo + , ffiAllowed = allowFFI + } + +compileWithDSTest :: FilePath -> IO (Text, Text) +compileWithDSTest src = + withSystemTempFile "input.json" $ \file handle -> do + hClose handle + dsTest <- readFile =<< Paths.getDataFileName "test/contracts/lib/test.sol" + erc20 <- readFile =<< Paths.getDataFileName "test/contracts/lib/erc20.sol" + testFilePath <- Paths.getDataFileName src + testFile <- readFile testFilePath + T.writeFile file + [i| + { + "language": "Solidity", + "sources": { + "ds-test/test.sol": { + "content": ${dsTest} + }, + "lib/erc20.sol": { + "content": ${erc20} + }, + "test.sol": { + "content": ${testFile} + } + }, + "settings": { + "metadata": { + "useLiteralContent": true + }, + "outputSelection": { + "*": { + "*": [ + "metadata", + "evm.bytecode", + "evm.deployedBytecode", + "abi", + "storageLayout", + "evm.bytecode.sourceMap", + "evm.bytecode.linkReferences", + "evm.bytecode.generatedSources", + "evm.deployedBytecode.sourceMap", + "evm.deployedBytecode.linkReferences", + "evm.deployedBytecode.generatedSources" + ], + "": [ + "ast" + ] + } + } + } + } + |] + x <- T.pack <$> + readProcess + "solc" + ["--allow-paths", file, "--standard-json", file] + "" + return (x, T.pack testFilePath) diff --git a/test/EVM/TestUtils.hs b/test/EVM/TestUtils.hs deleted file mode 100644 --- a/test/EVM/TestUtils.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# Language QuasiQuotes #-} - -module EVM.TestUtils where - -import Data.Text -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Paths_hevm as Paths -import Data.String.Here -import System.Directory -import System.IO.Temp -import GHC.IO.Handle (hClose) -import System.Process (readProcess) - -import EVM.Solidity -import EVM.Solvers -import EVM.Dapp -import EVM.UnitTest -import EVM.Fetch (RpcInfo) -import qualified EVM.TTY as TTY - -runDappTestCustom :: FilePath -> Text -> Maybe Integer -> Bool -> RpcInfo -> IO Bool -runDappTestCustom testFile match maxIter ffiAllowed rpcinfo = do - root <- Paths.getDataDir - (json, _) <- compileWithDSTest testFile - --T.writeFile "output.json" json - withCurrentDirectory root $ do - withSystemTempFile "output.json" $ \file handle -> do - hClose handle - T.writeFile file json - withSolvers Z3 1 Nothing $ \solvers -> do - opts <- testOpts solvers root json match maxIter ffiAllowed rpcinfo - dappTest opts file Nothing - -runDappTest :: FilePath -> Text -> IO Bool -runDappTest testFile match = runDappTestCustom testFile match Nothing True Nothing - -debugDappTest :: FilePath -> RpcInfo -> IO () -debugDappTest testFile rpcinfo = do - root <- Paths.getDataDir - (json, _) <- compileWithDSTest testFile - --TIO.writeFile "output.json" json - withCurrentDirectory root $ do - withSystemTempFile "output.json" $ \file handle -> do - hClose handle - T.writeFile file json - withSolvers Z3 1 Nothing $ \solvers -> do - opts <- testOpts solvers root json ".*" Nothing True rpcinfo - TTY.main opts root file - -testOpts :: SolverGroup -> FilePath -> Text -> Text -> Maybe Integer -> Bool -> RpcInfo -> IO UnitTestOptions -testOpts solvers root solcJson match maxIter allowFFI rpcinfo = do - srcInfo <- case readJSON solcJson of - Nothing -> error "Could not read solc json" - Just (contractMap, asts, sources) -> do - sourceCache <- makeSourceCache sources asts - pure $ dappInfo root contractMap sourceCache - - params <- getParametersFromEnvironmentVariables Nothing - - pure UnitTestOptions - { solvers = solvers - , rpcInfo = rpcinfo - , maxIter = maxIter - , askSmtIters = Nothing - , smtDebug = False - , smtTimeout = Nothing - , solver = Nothing - , covMatch = Nothing - , verbose = Just 1 - , match = match - , maxDepth = Nothing - , fuzzRuns = 100 - , replay = Nothing - , vmModifier = id - , testParams = params - , dapp = srcInfo - , ffiAllowed = allowFFI - } - -compileWithDSTest :: FilePath -> IO (Text, Text) -compileWithDSTest src = - withSystemTempFile "input.json" $ \file handle -> do - hClose handle - dsTest <- readFile =<< Paths.getDataFileName "test/contracts/lib/test.sol" - erc20 <- readFile =<< Paths.getDataFileName "test/contracts/lib/erc20.sol" - testFilePath <- Paths.getDataFileName src - testFile <- readFile testFilePath - T.writeFile file - [i| - { - "language": "Solidity", - "sources": { - "ds-test/test.sol": { - "content": ${dsTest} - }, - "lib/erc20.sol": { - "content": ${erc20} - }, - "test.sol": { - "content": ${testFile} - } - }, - "settings": { - "metadata": { - "useLiteralContent": true - }, - "outputSelection": { - "*": { - "*": [ - "metadata", - "evm.bytecode", - "evm.deployedBytecode", - "abi", - "storageLayout", - "evm.bytecode.sourceMap", - "evm.bytecode.linkReferences", - "evm.bytecode.generatedSources", - "evm.deployedBytecode.sourceMap", - "evm.deployedBytecode.linkReferences", - "evm.deployedBytecode.generatedSources" - ], - "": [ - "ast" - ] - } - } - } - } - |] - x <- T.pack <$> - readProcess - "solc" - ["--allow-paths", file, "--standard-json", file] - "" - return (x, T.pack testFilePath) diff --git a/test/EVM/Tracing.hs b/test/EVM/Tracing.hs deleted file mode 100644 --- a/test/EVM/Tracing.hs +++ /dev/null @@ -1,870 +0,0 @@ -{-| -Module : Tracing -Description : Tests to fuzz concrete tracing, and symbolic execution - -Functions here are used to generate traces for the concrete -execution of HEVM and check that against evmtool from go-ehereum. Re-using some -of this code, we also generate a symbolic expression then evaluate it -concretely through Expr.simplify, then check that against evmtool's output. --} - -{-# Language DataKinds #-} -{-# Language DuplicateRecordFields #-} -{-# LANGUAGE DeriveGeneric #-} - -module EVM.Tracing where - -import Data.ByteString (ByteString) -import System.Directory -import System.IO -import qualified Data.Word -import GHC.Generics -import Numeric (showHex) -import qualified Paths_hevm as Paths - -import Prelude hiding (fail, LT, GT) - -import qualified Data.ByteString as BS -import Data.Maybe -import Data.List qualified (length) -import Test.Tasty -import Test.Tasty.QuickCheck hiding (Failure) -import Test.QuickCheck.Instances.Text() -import Test.QuickCheck.Instances.Natural() -import Test.QuickCheck.Instances.ByteString() -import Test.QuickCheck (elements) -import Test.Tasty.HUnit -import qualified Data.Aeson as JSON -import Data.Aeson ((.:), (.:?)) -import Data.ByteString.Char8 qualified as Char8 - -import qualified Control.Monad (when) -import qualified Control.Monad.Operational as Operational (view, ProgramViewT(..), ProgramView) -import Control.Monad.State.Strict hiding (state) -import Control.Monad.State.Strict qualified as State -import Control.Lens hiding (List, pre, (.>), re, op) - -import qualified Data.Vector as Vector -import qualified Data.Map.Strict as Map - -import EVM hiding (allowFFI) -import EVM.SymExec -import EVM.Assembler -import EVM.Op hiding (getOp) -import EVM.Exec -import EVM.Types -import EVM.Traversals -import EVM.Concrete (createAddress) -import qualified EVM.FeeSchedule as FeeSchedule -import EVM.Solvers -import qualified EVM.Expr as Expr -import qualified Data.Text.IO as T -import qualified EVM.Stepper as Stepper -import qualified EVM.Fetch as Fetch -import System.Process -import qualified EVM.Transaction -import EVM.Format (formatBinary) -import EVM.Sign (deriveAddr) -import GHC.IO.Exception (ExitCode(ExitSuccess)) - -data VMTraceResult = - VMTraceResult - { out :: ByteStringS - , gasUsed :: Data.Word.Word64 - } deriving (Generic, Show) - -instance JSON.ToJSON VMTraceResult where - toEncoding = JSON.genericToEncoding JSON.defaultOptions - -data EVMToolTrace = - EVMToolTrace - { pc :: Int - , op :: Int - , gas :: W256 - , memSize :: Integer - , depth :: Int - , refund :: Int - , opName :: String - , stack :: [W256] - , error :: Maybe String - } deriving (Generic, Show) - -instance JSON.FromJSON EVMToolTrace where - parseJSON = JSON.withObject "EVMToolTrace" $ \v -> EVMToolTrace - <$> v .: "pc" - <*> v .: "op" - <*> v .: "gas" - <*> v .: "memSize" - <*> v .: "depth" - <*> v .: "refund" - <*> v .: "opName" - <*> v .: "stack" - <*> v .:? "error" - -mkBlockHash:: Int -> Expr 'EWord -mkBlockHash x = (num x :: Integer) & show & Char8.pack & EVM.Types.keccak' & Lit - -blockHashesDefault :: Map.Map Int W256 -blockHashesDefault = Map.fromList [(x, forceLit $ mkBlockHash x) | x<- [1..256]] - -data EVMToolOutput = - EVMToolOutput - { output :: ByteStringS - , gasUsed :: W256 - , time :: Integer - } deriving (Generic, Show) - -instance JSON.FromJSON EVMToolOutput - -data EVMToolTraceOutput = - EVMToolTraceOutput - { trace :: [EVMToolTrace] - , output :: EVMToolOutput - } deriving (Generic, Show) - -instance JSON.FromJSON EVMToolTraceOutput - -data EVMToolEnv = EVMToolEnv - { coinbase :: Addr - , timestamp :: Expr EWord - , number :: W256 - , prevRandao :: W256 - , gasLimit :: Data.Word.Word64 - , baseFee :: W256 - , maxCodeSize :: W256 - , schedule :: FeeSchedule.FeeSchedule Data.Word.Word64 - , blockHashes :: Map.Map Int W256 - } deriving (Show, Generic) - -instance JSON.ToJSON EVMToolEnv where - toJSON b = JSON.object [ ("currentCoinBase" , (JSON.toJSON $ b.coinbase)) - , ("currentDifficulty", (JSON.toJSON $ b.prevRandao)) - , ("currentGasLimit" , (JSON.toJSON ("0x" ++ showHex (toInteger $ b.gasLimit) ""))) - , ("currentNumber" , (JSON.toJSON $ b.number)) - , ("currentTimestamp" , (JSON.toJSON tstamp)) - , ("currentBaseFee" , (JSON.toJSON $ b.baseFee)) - , ("blockHashes" , (JSON.toJSON $ b.blockHashes)) - ] - where - tstamp :: W256 - tstamp = case (b.timestamp) of - Lit a -> a - _ -> error "Timestamp needs to be a Lit" - -emptyEvmToolEnv :: EVMToolEnv -emptyEvmToolEnv = EVMToolEnv { coinbase = 0 - , timestamp = Lit 0 - , number = 0 - , prevRandao = 42069 - , gasLimit = 0xffffffffffffffff - , baseFee = 0 - , maxCodeSize= 0xffffffff - , schedule = FeeSchedule.berlin - , blockHashes = mempty - } - -data EVMToolReceipt = - EVMToolReceipt - { _type :: String - , root :: String - , status :: String - , cumulativeGasUsed :: String - , logsBloom :: String - , logs :: Maybe String - , transactionHash :: String - , contractAddress :: String - , gasUsed :: String - , blockHash :: String - , transactionIndex :: String - } deriving (Generic, Show) - -instance JSON.FromJSON EVMToolReceipt where - parseJSON = JSON.withObject "EVMReceipt" $ \v -> EVMToolReceipt - <$> v .: "type" - <*> v .: "root" - <*> v .: "status" - <*> v .: "cumulativeGasUsed" - <*> v .: "logsBloom" - <*> v .: "logs" - <*> v .: "transactionHash" - <*> v .: "contractAddress" - <*> v .: "gasUsed" - <*> v .: "blockHash" - <*> v .: "transactionIndex" - -data EVMToolResult = - EVMToolResult - { stateRoot :: String - , txRoot :: String - , receiptsRoot :: String - , logsHash :: String - , logsBloom :: String - , receipts :: [EVMToolReceipt] - , currentDifficulty :: String - , gasUsed :: String - , rejected :: Maybe [EVMRejected] - } deriving (Generic, Show) - -instance JSON.FromJSON EVMToolResult - -data EVMRejected = - EVMRejected - { index :: Int - , err :: String - } deriving (Generic, Show) - -instance JSON.FromJSON EVMRejected where - parseJSON = JSON.withObject "EVMRejected" $ \v -> EVMRejected - <$> v .: "index" - <*> v .: "error" - -data EVMToolAlloc = - EVMToolAlloc - { balance :: W256 - , code :: ByteString - , nonce :: W64 - } deriving (Generic) - -instance JSON.ToJSON EVMToolAlloc where - toJSON b = JSON.object [ ("balance" , (JSON.toJSON $ show b.balance)) - , ("code", (JSON.toJSON $ ByteStringS b.code)) - , ("nonce", (JSON.toJSON $ b.nonce)) - ] - -emptyEVMToolAlloc :: EVMToolAlloc -emptyEVMToolAlloc = EVMToolAlloc { balance = 0 - , code = mempty - , nonce = 0 - } --- Sets up common parts such as TX, origin contract, and environment that can --- later be used to create & execute either an evmtool (from go-ethereum) or an --- HEVM transaction. Some elements here are hard-coded such as the secret key, --- which are currently not being fuzzed. -evmSetup :: OpContract -> ByteString -> Int -> (EVM.Transaction.Transaction, EVMToolEnv, EVMToolAlloc, Addr, Addr, Integer) -evmSetup contr txData gaslimitExec = (txn, evmEnv, contrAlloc, fromAddress, toAddress, sk) - where - contrLits = assemble $ getOpData contr - toW8fromLitB :: Expr 'Byte -> Data.Word.Word8 - toW8fromLitB (LitByte a) = a - toW8fromLitB _ = error "Cannot convert non-litB" - - bitcode = BS.pack . Vector.toList $ toW8fromLitB <$> contrLits - contrAlloc = EVMToolAlloc{ balance = 0xa493d65e20984bc - , code = bitcode - , nonce = 0x48 - } - txn = EVM.Transaction.Transaction - { txData = txData - , txGasLimit = fromIntegral gaslimitExec - , txGasPrice = Just 1 - , txNonce = 172 - , txToAddr = Just 0x8A8eAFb1cf62BfBeb1741769DAE1a9dd47996192 - , txR = 0 -- will be fixed when we sign - , txS = 0 -- will be fixed when we sign - , txV = 0 -- will be fixed when we sign - , txValue = 0 -- setting this > 0 fails because HEVM doesn't handle value sent in toplevel transaction - , txType = EVM.Transaction.EIP1559Transaction - , txAccessList = [] - , txMaxPriorityFeeGas = Just 1 - , txMaxFeePerGas = Just 1 - , txChainId = 1 - } - evmEnv = EVMToolEnv { coinbase = 0xff - , timestamp = Lit 0x3e8 - , number = 0x0 - , prevRandao = 0x0 - , gasLimit = fromIntegral gaslimitExec - , baseFee = 0x0 - , maxCodeSize = 0xfffff - , schedule = FeeSchedule.berlin - , blockHashes = blockHashesDefault - } - sk = 0xDC38EE117CAE37750EB1ECC5CFD3DE8E85963B481B93E732C5D0CB66EE6B0C9D - fromAddress :: Addr - fromAddress = fromJust $ deriveAddr sk - toAddress :: Addr - toAddress = 0x8A8eAFb1cf62BfBeb1741769DAE1a9dd47996192 - -getHEVMRet :: OpContract -> ByteString -> Int -> IO (Either (EVM.Error, [VMTrace]) (Expr 'End, [VMTrace], VMTraceResult)) -getHEVMRet contr txData gaslimitExec = do - let (txn, evmEnv, contrAlloc, fromAddress, toAddress, _) = evmSetup contr txData gaslimitExec - hevmRun <- runCodeWithTrace Nothing evmEnv contrAlloc txn (fromAddress, toAddress) - return hevmRun - -getEVMToolRet :: OpContract -> ByteString -> Int -> IO (Maybe EVMToolResult) -getEVMToolRet contr txData gaslimitExec = do - let (txn, evmEnv, contrAlloc, fromAddress, toAddress, sk) = evmSetup contr txData gaslimitExec - txs = [EVM.Transaction.sign sk txn] - walletAlloc = EVMToolAlloc{ balance = 0x5ffd4878be161d74 - , code = BS.empty - , nonce = 0xac - } - alloc :: Map.Map Addr EVMToolAlloc - alloc = Map.fromList ([ (fromAddress, walletAlloc), (toAddress, contrAlloc)]) - JSON.encodeFile "txs.json" txs - JSON.encodeFile "alloc.json" alloc - JSON.encodeFile "env.json" evmEnv - (exitCode, evmtoolStdout, evmtoolStderr) <- readProcessWithExitCode "evm" [ "transition" - ,"--input.alloc" , "alloc.json" - , "--input.env" , "env.json" - , "--input.txs" , "txs.json" - , "--output.alloc" , "alloc-out.json" - , "--trace.returndata=true" - , "--trace" , "trace.json" - , "--output.result", "result.json" - ] "" - Control.Monad.when (exitCode /= ExitSuccess) $ do - putStrLn $ "evmtool exited with code " <> show exitCode - putStrLn $ "evmtool stderr output:" <> show evmtoolStderr - putStrLn $ "evmtool stdout output:" <> show evmtoolStdout - evmtoolResult <- JSON.decodeFileStrict "result.json" :: IO (Maybe EVMToolResult) - return evmtoolResult - --- Compares traces of evmtool (from go-ethereum) and HEVM -compareTraces :: [VMTrace] -> [EVMToolTrace] -> IO (Bool) -compareTraces hevmTrace evmTrace = go hevmTrace evmTrace - where - go :: [VMTrace] -> [EVMToolTrace] -> IO (Bool) - go [] [] = pure True - go (a:ax) (b:bx) = do - let aOp = a.traceOp - bOp = b.op - aPc = a.tracePc - bPc = b.pc - aStack = a.traceStack - bStack = b.stack - aGas = fromIntegral a.traceGas - bGas = b.gas - if aGas /= bGas then do - putStrLn "GAS doesn't match:" - putStrLn $ "HEVM's gas : " <> (show aGas) - putStrLn $ "evmtool's gas: " <> (show bGas) - else - -- putStrLn $ "Gas match : " <> (show aGas) - return () - if aOp /= bOp || aPc /= bPc then - putStrLn $ "HEVM: " <> (intToOpName aOp) <> " (pc " <> (show aPc) <> ") --- evmtool " <> (intToOpName bOp) <> " (pc " <> (show bPc) <> ")" - else - -- putStrLn $ "trace element match. " <> (intToOpName aOp) <> " pc: " <> (show aPc) - return () - - Control.Monad.when (isJust b.error) $ do - putStrLn $ "Error by evmtool: " <> (show b.error) - putStrLn $ "Error by HEVM : " <> (show a.traceError) - - Control.Monad.when (aStack /= bStack) $ do - putStrLn "stacks don't match:" - putStrLn $ "HEVM's stack : " <> (show aStack) - putStrLn $ "evmtool's stack: " <> (show bStack) - if aOp == bOp && aStack == bStack && aPc == bPc && aGas == bGas then go ax bx - else pure False - - - go a@(_:_) [] = do - putStrLn $ "Traces don't match. HEVM's trace is longer by:" <> (show a) - pure False - go [] [b] = do - -- evmtool produces ONE more trace element of the error - -- hevm on the other hand stops and doens't produce one more - if isJust b.error then pure True - else do - putStrLn $ "Traces don't match. HEVM's trace is longer by:" <> (show b) - pure False - go [] b@(_:_) = do - putStrLn $ "Traces don't match. evmtool's trace is longer by:" <> (show b) - pure False - -getTraceFileName :: EVMToolResult -> String -getTraceFileName evmtoolResult = traceFileName - where - txName = ((evmtoolResult.receipts) !! 0).transactionHash - traceFileName = "trace-0-" ++ txName ++ ".jsonl" - -getTraceOutput :: Maybe EVMToolResult -> IO (Maybe EVMToolTraceOutput) -getTraceOutput evmtoolResult = - case evmtoolResult of - Nothing -> pure Nothing - Just res -> do - let traceFileName = getTraceFileName res - convertPath <- Paths.getDataFileName "test/scripts/convert_trace_to_json.sh" - (exitcode, _, _) <- readProcessWithExitCode "bash" [convertPath, getTraceFileName res] "" - case exitcode of - ExitSuccess -> JSON.decodeFileStrict (traceFileName ++ ".json") :: IO (Maybe EVMToolTraceOutput) - _ -> pure Nothing - -deleteTraceOutputFiles :: Maybe EVMToolResult -> IO () -deleteTraceOutputFiles evmtoolResult = - case evmtoolResult of - Nothing -> return () - Just res -> do - let traceFileName = getTraceFileName res - System.Directory.removeFile traceFileName - System.Directory.removeFile (traceFileName ++ ".json") - --- Create symbolic VM from concrete VM -symbolify :: VM -> VM -symbolify vm = vm { _state = vm._state { _calldata = AbstractBuf "calldata" } } - --- | Takes a runtime code and calls it with the provided calldata --- Uses evmtool's alloc and transaction to set up the VM correctly -runCodeWithTrace :: Fetch.RpcInfo -> EVMToolEnv -> EVMToolAlloc -> EVM.Transaction.Transaction -> (Addr, Addr) -> IO (Either (EVM.Error, [VMTrace]) ((Expr 'End, [VMTrace], VMTraceResult))) -runCodeWithTrace rpcinfo evmEnv alloc txn (fromAddr, toAddress) = withSolvers Z3 0 Nothing $ \solvers -> do - let origVM = vmForRuntimeCode code' calldata' evmEnv alloc txn (fromAddr, toAddress) - calldata' = ConcreteBuf txn.txData - code' = alloc.code - buildExpr :: SolverGroup -> VM -> IO (Expr End) - buildExpr s vm = evalStateT (interpret (Fetch.oracle s Nothing) Nothing Nothing runExpr) vm - - expr <- buildExpr solvers $ symbolify origVM - (res, (vm, trace)) <- runStateT (interpretWithTrace (Fetch.oracle solvers rpcinfo) Stepper.execFully) (origVM, []) - case res of - Left x -> pure $ Left (x, trace) - Right _ -> pure $ Right (expr, trace, vmres vm) - -vmForRuntimeCode :: ByteString -> Expr Buf -> EVMToolEnv -> EVMToolAlloc -> EVM.Transaction.Transaction -> (Addr, Addr) -> VM -vmForRuntimeCode runtimecode calldata' evmToolEnv alloc txn (fromAddr, toAddress) = - let contr = initialContract (RuntimeCode (ConcreteRuntimeCode runtimecode)) - contrWithBal = contr { _balance = alloc.balance } - in - (makeVm $ VMOpts - { vmoptContract = contrWithBal - , vmoptCalldata = (calldata', []) - , vmoptValue = Lit txn.txValue - , vmoptStorageBase = Concrete - , vmoptAddress = toAddress - , vmoptCaller = Expr.litAddr fromAddr - , vmoptOrigin = fromAddr - , vmoptCoinbase = evmToolEnv.coinbase - , vmoptNumber = evmToolEnv.number - , vmoptTimestamp = evmToolEnv.timestamp - , vmoptGasprice = fromJust txn.txGasPrice - , vmoptGas = txn.txGasLimit - fromIntegral (EVM.Transaction.txGasCost evmToolEnv.schedule txn) - , vmoptGaslimit = txn.txGasLimit - , vmoptBlockGaslimit = evmToolEnv.gasLimit - , vmoptPrevRandao = evmToolEnv.prevRandao - , vmoptBaseFee = evmToolEnv.baseFee - , vmoptPriorityFee = fromJust txn.txMaxPriorityFeeGas - , vmoptMaxCodeSize = evmToolEnv.maxCodeSize - , vmoptSchedule = evmToolEnv.schedule - , vmoptChainId = txn.txChainId - , vmoptCreate = False - , vmoptTxAccessList = mempty - , vmoptAllowFFI = False - }) & set (EVM.env . contracts . at ethrunAddress) - (Just (initialContract (RuntimeCode (ConcreteRuntimeCode BS.empty)))) - & set (state . calldata) calldata' - -runCode :: Fetch.RpcInfo -> ByteString -> Expr Buf -> IO (Maybe (Expr Buf)) -runCode rpcinfo code' calldata' = withSolvers Z3 0 Nothing $ \solvers -> do - let origVM = vmForRuntimeCode code' calldata' emptyEvmToolEnv emptyEVMToolAlloc EVM.Transaction.emptyTransaction (ethrunAddress, createAddress ethrunAddress 1) - res <- evalStateT (Stepper.interpret (Fetch.oracle solvers rpcinfo) Stepper.execFully) origVM - pure $ case res of - Left _ -> Nothing - Right b -> Just b - -vmtrace :: VM -> VMTrace -vmtrace vm = - let - -- Convenience function to access parts of the current VM state. - -- Arcane type signature needed to avoid monomorphism restriction. - the :: (b -> VM -> Const a VM) -> ((a -> Const a a) -> b) -> a - the f g = Control.Lens.view (f . g) vm - memsize = the state memorySize - in VMTrace { tracePc = the state EVM.pc - , traceOp = num $ getOp vm - , traceGas = the state EVM.gas - , traceMemSize = memsize - -- increment to match geth format - , traceDepth = 1 + length (Control.Lens.view frames vm) - -- reverse to match geth format - , traceStack = reverse $ forceLit <$> the state EVM.stack - , traceError = readoutError vm._result - } - where - readoutError :: Maybe VMResult -> Maybe String - readoutError Nothing = Nothing - readoutError (Just (VMSuccess _)) = Nothing - readoutError (Just (VMFailure e)) = case e of - -- NOTE: error text made to closely match go-ethereum's errors.go file - OutOfGas {} -> Just "out of gas" - -- TODO "contract creation code storage out of gas" not handled - CallDepthLimitReached -> Just "max call depth exceeded" - BalanceTooLow {} -> Just "insufficient balance for transfer" - -- TODO "contract address collision" not handled - EVM.Revert {} -> Just "execution reverted" - -- TODO "max initcode size exceeded" not handled - MaxCodeSizeExceeded {} -> Just "max code size exceeded" - EVM.BadJumpDestination -> Just "invalid jump destination" - StateChangeWhileStatic -> Just "write protection" - ReturnDataOutOfBounds -> Just "return data out of bounds" - EVM.IllegalOverflow -> Just "gas uint64 overflow" - UnrecognizedOpcode op -> Just $ "invalid opcode: " <> show op - EVM.NonceOverflow -> Just "nonce uint64 overflow" - EVM.StackUnderrun -> Just "stack underflow" - EVM.StackLimitExceeded -> Just "stack limit reached" - EVM.InvalidMemoryAccess -> Just "write protection" - err -> Just $ "HEVM error: " <> show err - -vmres :: VM -> VMTraceResult -vmres vm = - let - gasUsed' = Control.Lens.view (tx . txgaslimit) vm - Control.Lens.view (state . EVM.gas) vm - res = case Control.Lens.view result vm of - Just (VMSuccess (ConcreteBuf b)) -> (ByteStringS b) - Just (VMSuccess x) -> error $ "unhandled: " <> (show x) - Just (VMFailure (EVM.Revert (ConcreteBuf b))) -> (ByteStringS b) - Just (VMFailure _) -> ByteStringS mempty - _ -> ByteStringS mempty - in VMTraceResult - { out = res - , gasUsed = gasUsed' - } - -type TraceState = (VM, [VMTrace]) - -execWithTrace :: StateT TraceState IO VMResult -execWithTrace = do - _ <- runWithTrace - fromJust <$> use (_1 . result) - -runWithTrace :: StateT TraceState IO VM -runWithTrace = do - -- This is just like `exec` except for every instruction evaluated, - -- we also increment a counter indexed by the current code location. - vm0 <- use _1 - case vm0._result of - Nothing -> do - State.modify (\(a, b) -> (a, b ++ [vmtrace vm0])) - zoom _1 (State.state (runState exec1)) - runWithTrace - Just (VMSuccess _) -> pure vm0 - Just (VMFailure _) -> do - -- Update error text for last trace element - (a, b) <- State.get - let updatedElem = (last b) {traceError = (vmtrace vm0).traceError} - updatedTraces = take ((Data.List.length b)-1) b ++ [updatedElem] - State.put (a, updatedTraces) - pure vm0 - -interpretWithTrace - :: Fetch.Fetcher - -> Stepper.Stepper a - -> StateT TraceState IO a -interpretWithTrace fetcher = - eval . Operational.view - - where - eval - :: Operational.ProgramView Stepper.Action a - -> StateT TraceState IO a - - eval (Operational.Return x) = - pure x - - eval (action Operational.:>>= k) = - case action of - Stepper.Exec -> - execWithTrace >>= interpretWithTrace fetcher . k - Stepper.Run -> - runWithTrace >>= interpretWithTrace fetcher . k - Stepper.Wait q -> - do m <- liftIO (fetcher q) - zoom _1 (State.state (runState m)) >> interpretWithTrace fetcher (k ()) - Stepper.Ask _ -> - error "cannot make choice in this interpreter" - Stepper.IOAct q -> - zoom _1 (StateT (runStateT q)) >>= interpretWithTrace fetcher . k - Stepper.EVM m -> - zoom _1 (State.state (runState m)) >>= interpretWithTrace fetcher . k - -data OpContract = OpContract [Op] -instance Show OpContract where - show (OpContract a) = "OpContract " ++ (show a) - -getOpData :: OpContract-> [Op] -getOpData (OpContract x) = x - -instance Arbitrary OpContract where - arbitrary = fmap OpContract (sized genContract) - -removeExtcalls :: OpContract -> OpContract -removeExtcalls (OpContract ops) = OpContract (filter (noStorageNoExtcalls) ops) - where - noStorageNoExtcalls :: Op -> Bool - noStorageNoExtcalls o = case o of - -- Extrenal info functions - OpExtcodecopy -> False - OpExtcodehash -> False - OpExtcodesize -> False - OpAddress -> False - OpOrigin -> False - OpCaller -> False - OpCoinbase -> False - OpCreate -> False - OpCreate2 -> False - -- External call functions - OpDelegatecall -> False - OpStaticcall -> False - OpCall -> False - OpCallcode -> False - -- Not interesting - OpBalance -> False - OpSelfdestruct -> False - _ -> True - -getJumpDests :: [Op] -> [Int] -getJumpDests ops = go ops 0 [] - where - go :: [Op] -> Int -> [Int] -> [Int] - go [] _ dests = dests - go (a:ax) pos dests = case a of - OpJumpdest -> go ax (pos+1) (pos:dests) - OpPush _ -> go ax (pos+33) dests - -- We'll fix these up later to add a Push in between, hence they are 34 bytes - OpJump -> go ax (pos+34) dests - OpJumpi -> go ax (pos+34) dests - -- everything else is 1 byte - _ -> go ax (pos+1) dests - -fixContractJumps :: OpContract -> IO OpContract -fixContractJumps (OpContract ops) = do - let - addedOps = ops++[OpJumpdest] - jumpDests = getJumpDests addedOps - -- always end on an OpJumpdest so we don't have an issue with a "later" position - ops2 = fixup addedOps 0 [] - -- original set of operations, the set of jumpDests NOW valid, current position, return value - fixup :: [Op] -> Int -> [Op] -> IO [Op] - fixup [] _ ret = pure ret - fixup (a:ax) pos ret = case a of - OpJumpi -> do - let filtDests = (filter (> pos) jumpDests) - rndPos <- randItem filtDests - fixup ax (pos+34) (ret++[(OpPush (Lit (fromInteger (fromIntegral rndPos)))), (OpJumpi)]) - OpJump -> do - let filtDests = (filter (> pos) jumpDests) - rndPos <- randItem filtDests - fixup ax (pos+34) (ret++[(OpPush (Lit (fromInteger (fromIntegral rndPos)))), (OpJump)]) - myop@(OpPush _) -> fixup ax (pos+33) (ret++[myop]) - myop -> fixup ax (pos+1) (ret++[myop]) - fmap OpContract ops2 - -genPush :: Int -> Gen [Op] -genPush n = vectorOf n onePush - where - onePush :: Gen Op - onePush = do - p <- chooseInt (1, 10) - pure $ OpPush (Lit (fromIntegral p)) - -genContract :: Int -> Gen [Op] -genContract n = do - y <- chooseInt (3, 6) - pushes <- genPush y - normalOps <- vectorOf (3*n+40) genOne - addReturn <- chooseInt (0, 10) - let contr = pushes ++ normalOps - if addReturn < 10 then pure $ contr++[OpPush (Lit 0x40), OpPush (Lit 0x0), OpReturn] - else pure contr - where - genOne :: Gen Op - genOne = frequency [ - -- math ops - (200, frequency [ - (1, pure OpAdd) - , (1, pure OpMul) - , (1, pure OpSub) - , (1, pure OpDiv) - , (1, pure OpSdiv) - , (1, pure OpMod) - , (1, pure OpSmod) - , (1, pure OpAddmod) - , (1, pure OpMulmod) - , (1, pure OpExp) - , (1, pure OpSignextend) - , (1, pure OpLt) - , (1, pure OpGt) - , (1, pure OpSlt) - , (1, pure OpSgt) - , (1, pure OpSha3) - ]) - -- Comparison & binary ops - , (200, frequency [ - (1, pure OpEq) - , (1, pure OpIszero) - , (1, pure OpAnd) - , (1, pure OpOr) - , (1, pure OpXor) - , (1, pure OpNot) - , (1, pure OpByte) - , (1, pure OpShl) - , (1, pure OpShr) - , (1, pure OpSar) - ]) - -- calldata - , (800, pure OpCalldataload) - , (200, pure OpCalldatacopy) - -- Get some info - , (100, frequency [ - (10, pure OpAddress) - , (10, pure OpBalance) - , (10, pure OpOrigin) - , (10, pure OpCaller) - , (10, pure OpCallvalue) - , (10, pure OpCalldatasize) - , (10, pure OpCodesize) - , (10, pure OpGasprice) - , (10, pure OpReturndatasize) - , (10, pure OpReturndatacopy) - , (10, pure OpExtcodehash) - , (10, pure OpBlockhash) - , (10, pure OpCoinbase) - , (10, pure OpTimestamp) - , (10, pure OpNumber) - , (10, pure OpPrevRandao) - , (10, pure OpGaslimit) - , (10, pure OpChainid) - , (10, pure OpSelfbalance) - , (10, pure OpBaseFee) - , (10, pure OpPc) - , (10, pure OpMsize) - , (10, pure OpGas) - , (10, pure OpExtcodesize) - , (10, pure OpCodecopy) - , (10, pure OpExtcodecopy) - ]) - -- memory manip - , (1200, frequency [ - (50, pure OpMload) - , (50, pure OpMstore) - , (1, pure OpMstore8) - ]) - -- storage manip - , (100, frequency [ - (1, pure OpSload) - , (1, pure OpSstore) - ]) - -- Jumping around - , (20, frequency [ - (1, pure OpJump) - , (10, pure OpJumpi) - ]) - -- calling out - , (1, frequency [ - (1, pure OpStaticcall) - , (1, pure OpCall) - , (1, pure OpCallcode) - , (1, pure OpDelegatecall) - , (1, pure OpCreate) - , (1, pure OpCreate2) - , (1, pure OpSelfdestruct) - ]) - -- manipulate stack - , (13000, frequency [ - (1, pure OpPop) - , (400, do - -- x <- arbitrary - large <- chooseInt (0, 100) - x <- if large == 0 then chooseBoundedIntegral (0::W256, (2::W256)^(256::W256)-1) - else chooseBoundedIntegral (0, 10) - pure $ OpPush (Lit (fromIntegral x))) - , (10, do - x <- chooseInt (1, 10) - pure $ OpDup (fromIntegral x)) - , (10, do - x <- chooseInt (1, 10) - pure $ OpSwap (fromIntegral x)) - ])] - -- End states - -- , (1, frequency [ - -- (1, pure OpStop) - -- , (10, pure OpReturn) - -- , (10, pure OpRevert) - -- ]) - -forceLit :: Expr EWord -> W256 -forceLit (Lit x) = x -forceLit _ = undefined - -randItem :: [a] -> IO a -randItem = generate . Test.QuickCheck.elements - -getOp :: VM -> Data.Word.Word8 -getOp vm = - let pcpos = vm ^. state . EVM.pc - code' = vm ^. state . EVM.code - xs = case code' of - InitCode _ _ -> error "InitCode instead of RuntimeCode" - RuntimeCode (ConcreteRuntimeCode xs') -> BS.drop pcpos xs' - RuntimeCode (SymbolicRuntimeCode _) -> error "RuntimeCode is symbolic" - in if xs == BS.empty then 0 - else BS.head xs - -tests :: TestTree -tests = testGroup "contract-quickcheck-run" - [ testProperty "random-contract-concrete-call" $ \(contr :: OpContract) -> ioProperty $ do - txDataRaw <- generate $ sized $ \n -> vectorOf (10*n+5) $ chooseInt (0,255) - gaslimitExec <- generate $ chooseInt (40000, 0xffff) - let txData = BS.pack $ toEnum <$> txDataRaw - -- TODO: By removing external calls, we fuzz less - -- It should work also when we external calls. Removing for now. - contrFixed <- fixContractJumps $ removeExtcalls contr - evmtoolResult <- getEVMToolRet contrFixed txData gaslimitExec - hevmRun <- getHEVMRet contrFixed txData gaslimitExec - (Just evmtoolTraceOutput) <- getTraceOutput evmtoolResult - case hevmRun of - (Right (expr, hevmTrace, hevmTraceResult)) -> do - let - concretize :: Expr a -> Expr Buf -> Expr a - concretize a c = mapExpr go a - where - go :: Expr a -> Expr a - go = \case - AbstractBuf "calldata" -> c - y -> y - concretizedExpr = concretize expr (ConcreteBuf txData) - simplConcExpr = Expr.simplify concretizedExpr - getReturnVal :: Expr End -> Maybe ByteString - getReturnVal (Return _ (ConcreteBuf bs) _) = Just bs - getReturnVal _ = Nothing - simplConcrExprRetval = getReturnVal simplConcExpr - traceOK <- compareTraces hevmTrace (evmtoolTraceOutput.trace) - -- putStrLn $ "HEVM trace : " <> show hevmTrace - -- putStrLn $ "evmtool trace: " <> show (evmtoolTraceOutput.toTrace) - assertEqual "Traces and gas must match" traceOK True - let resultOK = evmtoolTraceOutput.output.output == hevmTraceResult.out - if resultOK then do - putStrLn $ "HEVM & evmtool's outputs match: '" <> (bsToHex $ bssToBs evmtoolTraceOutput.output.output) <> "'" - if isNothing simplConcrExprRetval || (fromJust simplConcrExprRetval) == (bssToBs hevmTraceResult.out) - then do - putStr "OK, symbolic interpretation -> concrete calldata -> Expr.simplify gives the same answer." - if isNothing simplConcrExprRetval then putStrLn ", but it was a Nothing, so not strong equivalence" - else putStrLn "" - else do - putStrLn $ "concretized expr : " <> (show concretizedExpr) - putStrLn $ "simplified concretized expr: " <> (show simplConcExpr) - putStrLn $ "return value computed : " <> (show simplConcrExprRetval) - putStrLn $ "evmtool's return value : " <> (show hevmTraceResult.out) - assertEqual "Simplified, concretized expression must match evmtool's output." True False - else do - putStrLn $ "Name of trace file: " <> (getTraceFileName $ fromJust evmtoolResult) - putStrLn $ "HEVM result :" <> (show hevmTraceResult) - T.putStrLn $ "HEVM result: " <> (formatBinary $ bssToBs hevmTraceResult.out) - T.putStrLn $ "evm result : " <> (formatBinary $ bssToBs evmtoolTraceOutput.output.output) - putStrLn $ "HEVM result len: " <> (show (BS.length $ bssToBs hevmTraceResult.out)) - putStrLn $ "evm result len: " <> (show (BS.length $ bssToBs evmtoolTraceOutput.output.output)) - assertEqual "Contract exec successful. HEVM & evmtool's outputs must match" resultOK True - Left (evmerr, hevmTrace) -> do - putStrLn $ "HEVM contract exec issue: " <> (show evmerr) - -- putStrLn $ "evmtool result was: " <> show (fromJust evmtoolResult) - -- putStrLn $ "output by evmtool is: '" <> bsToHex evmtoolTraceOutput.toOutput.output <> "'" - traceOK <- compareTraces hevmTrace (evmtoolTraceOutput.trace) - assertEqual "Traces and gas must match" traceOK True - System.Directory.removeFile "txs.json" - System.Directory.removeFile "alloc-out.json" - System.Directory.removeFile "alloc.json" - System.Directory.removeFile "result.json" - System.Directory.removeFile "env.json" - deleteTraceOutputFiles evmtoolResult - ] - diff --git a/test/contracts/pass/cheatCodes.sol b/test/contracts/pass/cheatCodes.sol --- a/test/contracts/pass/cheatCodes.sol +++ b/test/contracts/pass/cheatCodes.sol @@ -23,6 +23,10 @@ } } +contract Payable { + function hi() public payable {} +} + contract CheatCodes is DSTest { address store = address(new HasStorage()); Hevm hevm = Hevm(HEVM_ADDRESS); @@ -100,5 +104,22 @@ hevm.prank(address(0xdeadbeef)); assertEq(prankster.prankme(), address(0xdeadbeef)); assertEq(prankster.prankme(), address(this)); + } + + function test_prank_val() public { + address from = address(0x1312); + uint amt = 10; + + Payable target = new Payable(); + from.call{value: amt}(""); + + uint preBal = from.balance; + + hevm.prank(from); + target.hi{value : amt}(); + + uint postBal = from.balance; + + assertEq(preBal - postBal, amt); } } diff --git a/test/rpc.hs b/test/rpc.hs --- a/test/rpc.hs +++ b/test/rpc.hs @@ -1,27 +1,23 @@ -{-# Language GADTs #-} {-# Language DataKinds #-} module Main where -import Control.Lens import Test.Tasty import Test.Tasty.HUnit -import Data.Text (Text) -import Control.Monad.State.Strict (execStateT) -import Data.Functor + import Data.Maybe -import qualified Data.Map as Map -import qualified Data.Vector as V +import Data.Map qualified as Map +import Data.Text (Text) +import Data.Vector qualified as V import EVM import EVM.ABI +import EVM.Fetch import EVM.SMT import EVM.Solvers -import EVM.Fetch +import EVM.Stepper qualified as Stepper import EVM.SymExec -import EVM.TestUtils -import qualified EVM.Stepper as Stepper -import qualified EVM.Fetch as Fetch +import EVM.Test.Utils import EVM.Types hiding (BlockNumber) main :: IO () @@ -31,31 +27,31 @@ tests = testGroup "rpc" [ testGroup "Block Parsing Tests" [ testCase "pre-merge-block" $ do - let block' = BlockNumber 15537392 - (cb, numb, basefee, prevRan) <- fetchBlockFrom block' testRpc >>= \case + let block = BlockNumber 15537392 + (cb, numb, basefee, prevRan) <- fetchBlockFrom block testRpc >>= \case Nothing -> error "Could not fetch block" - Just EVM.Block{..} -> return (_coinbase - , _number - , _baseFee - , _prevRandao + Just EVM.Block{..} -> return ( coinbase + , number + , baseFee + , prevRandao ) assertEqual "coinbase" (Addr 0xea674fdde714fd979de3edf0f56aa9716b898ec8) cb - assertEqual "number" (BlockNumber numb) block' + assertEqual "number" (BlockNumber numb) block assertEqual "basefee" 38572377838 basefee assertEqual "prevRan" 11049842297455506 prevRan , testCase "post-merge-block" $ do - let block' = BlockNumber 16184420 - (cb, numb, basefee, prevRan) <- fetchBlockFrom block' testRpc >>= \case + let block = BlockNumber 16184420 + (cb, numb, basefee, prevRan) <- fetchBlockFrom block testRpc >>= \case Nothing -> error "Could not fetch block" - Just EVM.Block{..} -> return (_coinbase - , _number - , _baseFee - , _prevRandao + Just EVM.Block{..} -> return ( coinbase + , number + , baseFee + , prevRandao ) assertEqual "coinbase" (Addr 0x690b9a9e9aa1c9db991c7721a92d351db4fac990) cb - assertEqual "number" (BlockNumber numb) block' + assertEqual "number" (BlockNumber numb) block assertEqual "basefee" 22163046690 basefee assertEqual "prevRan" 0x2267531ab030ed32fd5f2ef51f81427332d0becbd74fe7f4cd5684ddf4b287e0 prevRan ] @@ -74,14 +70,14 @@ calldata' = ConcreteBuf $ abiMethod "transfer(address,uint256)" (AbiTuple (V.fromList [AbiAddress (Addr 0xdead), AbiUInt 256 wad])) vm <- weth9VM blockNum (calldata', []) postVm <- withSolvers Z3 1 Nothing $ \solvers -> - execStateT (Stepper.interpret (Fetch.oracle solvers (Just (BlockNumber blockNum, testRpc))) . void $ Stepper.execFully) vm + Stepper.interpret (oracle solvers (Just (BlockNumber blockNum, testRpc))) vm Stepper.runFully let - postStore = case view (env . storage) postVm of + postStore = case postVm.env.storage of ConcreteStore s -> s _ -> error "ConcreteStore expected" wethStore = fromJust $ Map.lookup 0xC02aaA39b223FE8D0A0e5C4F27eAD9083C756Cc2 postStore receiverBal = fromJust $ Map.lookup (keccak' (word256Bytes 0xdead <> word256Bytes 0x3)) wethStore - msg = case view result postVm of + msg = case postVm.result of Just (VMSuccess m) -> m _ -> error "VMSuccess expected" assertEqual "should succeed" msg (ConcreteBuf $ word256Bytes 0x1) @@ -122,29 +118,29 @@ Just b -> pure b pure $ EVM.makeVm $ EVM.VMOpts - { EVM.vmoptContract = ctrct - , EVM.vmoptCalldata = calldata' - , EVM.vmoptValue = callvalue' - , EVM.vmoptAddress = address' - , EVM.vmoptCaller = caller' - , EVM.vmoptOrigin = 0xacab - , EVM.vmoptGas = 0xffffffffffffffff - , EVM.vmoptGaslimit = 0xffffffffffffffff - , EVM.vmoptBaseFee = view baseFee blk - , EVM.vmoptPriorityFee = 0 - , EVM.vmoptCoinbase = view coinbase blk - , EVM.vmoptNumber = view number blk - , EVM.vmoptTimestamp = view timestamp blk - , EVM.vmoptBlockGaslimit = view gaslimit blk - , EVM.vmoptGasprice = 0 - , EVM.vmoptMaxCodeSize = view maxCodeSize blk - , EVM.vmoptPrevRandao = view prevRandao blk - , EVM.vmoptSchedule = view schedule blk - , EVM.vmoptChainId = 1 - , EVM.vmoptCreate = False - , EVM.vmoptStorageBase = EVM.Concrete - , EVM.vmoptTxAccessList = mempty - , EVM.vmoptAllowFFI = False + { EVM.contract = ctrct + , EVM.calldata = calldata' + , EVM.value = callvalue' + , EVM.address = address' + , EVM.caller = caller' + , EVM.origin = 0xacab + , EVM.gas = 0xffffffffffffffff + , EVM.gaslimit = 0xffffffffffffffff + , EVM.baseFee = blk.baseFee + , EVM.priorityFee = 0 + , EVM.coinbase = blk.coinbase + , EVM.number = blk.number + , EVM.timestamp = blk.timestamp + , EVM.blockGaslimit = blk.gaslimit + , EVM.gasprice = 0 + , EVM.maxCodeSize = blk.maxCodeSize + , EVM.prevRandao = blk.prevRandao + , EVM.schedule = blk.schedule + , EVM.chainId = 1 + , EVM.create = False + , EVM.initialStorage = EmptyStore + , EVM.txAccessList = mempty + , EVM.allowFFI = False } testRpc :: Text diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -32,10 +32,12 @@ import Test.Tasty.HUnit import Test.Tasty.Runners hiding (Failure) import Test.Tasty.ExpectedFailure -import EVM.Tracing qualified +import EVM.Test.Tracing qualified as Tracing import Control.Monad.State.Strict hiding (state) -import Control.Lens hiding (List, pre, (.>), re, op) +import Optics.Core hiding (pre, re) +import Optics.State +import Optics.Operators.Unsafe import qualified Data.Vector as Vector import Data.String.Here @@ -44,7 +46,7 @@ import Data.Binary.Put (runPut) import Data.Binary.Get (runGetOrFail) -import EVM hiding (allowFFI) +import EVM import EVM.SymExec import EVM.ABI import EVM.Exec @@ -60,7 +62,7 @@ import qualified EVM.Expr as Expr import qualified Data.Text as T import Data.List (isSubsequenceOf) -import EVM.TestUtils +import EVM.Test.Utils import GHC.Conc (getNumProcessors) main :: IO () @@ -73,8 +75,7 @@ tests :: TestTree tests = testGroup "hevm" - [ - EVM.Tracing.tests + [ Tracing.tests , testGroup "StorageTests" [ testCase "read-from-sstore" $ assertEqual "" (Lit 0xab) @@ -97,17 +98,17 @@ , testCase "accessStorage uses fetchedStorage" $ do let dummyContract = (initialContract (RuntimeCode (ConcreteRuntimeCode mempty))) - { _external = True } + { external = True } vm = vmForEthrunCreation "" -- perform the initial access vm1 = execState (EVM.accessStorage 0 (Lit 0) (pure . pure ())) vm -- it should fetch the contract first - vm2 = case vm1._result of + vm2 = case vm1.result of Just (VMFailure (Query (PleaseFetchContract _addr continue))) -> execState (continue dummyContract) vm1 _ -> error "unexpected result" -- then it should fetch the slow - vm3 = case vm2._result of + vm3 = case vm2.result of Just (VMFailure (Query (PleaseFetchSlot _addr _slot continue))) -> execState (continue 1337) vm2 _ -> error "unexpected result" @@ -115,8 +116,19 @@ vm4 = execState (EVM.accessStorage 0 (Lit 0) (pure . pure ())) vm3 -- there won't be query now as accessStorage uses fetch cache - assertBool (show vm4._result) (isNothing vm4._result) + assertBool (show vm4.result) (isNothing vm4.result) ] + , testGroup "SimplifierUnitTests" + -- common overflow cases that the simplifier was getting wrong + [ testCase "writeWord-overflow" $ do + let e = ReadByte (Lit 0x0) (WriteWord (Lit 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffd) (Lit 0x0) (ConcreteBuf "\255\255\255\255")) + b <- checkEquiv e (Expr.simplify e) + assertBool "Simplifier failed" b + , testCase "CopySlice-overflow" $ do + let e = ReadWord (Lit 0x0) (CopySlice (Lit 0x0) (Lit 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc) (Lit 0x6) (ConcreteBuf "\255\255\255\255\255\255") (ConcreteBuf "")) + b <- checkEquiv e (Expr.simplify e) + assertBool "Simplifier failed" b + ] -- These tests fuzz the simplifier by generating a random expression, -- applying some simplification rules, and then using the smt encoding to -- check that the simplified version is semantically equivalent to the @@ -1131,7 +1143,7 @@ _ -> error "expected 2 args" in (x .<= Expr.add x y) -- TODO check if it's needed - .&& view (state . callvalue) preVM .== Lit 0 + .&& preVM.state.callvalue .== Lit 0 post prestate leaf = let (x, y) = case getStaticAbiArgs 2 prestate of [x', y'] -> (x', y') @@ -1139,7 +1151,7 @@ in case leaf of EVM.Types.Return _ b _ -> (ReadWord (Lit 0) b) .== (Add x y) _ -> PBool True - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s safeAdd (Just (Sig "add(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts SymbolicS (Just pre) (Just post) + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s safeAdd (Just (Sig "add(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts AbstractStore (Just pre) (Just post) putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" , @@ -1157,7 +1169,7 @@ _ -> error "expected 2 args" in (x .<= Expr.add x y) .&& (x .== y) - .&& Control.Lens.view (state . callvalue) preVM .== Lit 0 + .&& preVM.state.callvalue .== Lit 0 post prestate leaf = let (_, y) = case getStaticAbiArgs 2 prestate of [x', y'] -> (x', y') @@ -1166,7 +1178,7 @@ EVM.Types.Return _ b _ -> (ReadWord (Lit 0) b) .== (Mul (Lit 2) y) _ -> PBool True (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> - verifyContract s safeAdd (Just (Sig "add(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts SymbolicS (Just pre) (Just post) + verifyContract s safeAdd (Just (Sig "add(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts AbstractStore (Just pre) (Just post) putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" , testCase "summary storage writes" $ do @@ -1182,17 +1194,17 @@ } } |] - let pre vm = Lit 0 .== Control.Lens.view (state . callvalue) vm + let pre vm = Lit 0 .== vm.state.callvalue post prestate leaf = let y = case getStaticAbiArgs 1 prestate of [y'] -> y' _ -> error "expected 1 arg" - this = Expr.litAddr $ Control.Lens.view (state . codeContract) prestate - prex = Expr.readStorage' this (Lit 0) (Control.Lens.view (EVM.env . EVM.storage) prestate) + this = Expr.litAddr $ prestate.state.codeContract + prex = Expr.readStorage' this (Lit 0) prestate.env.storage in case leaf of EVM.Types.Return _ _ postStore -> Expr.add prex (Expr.mul (Lit 2) y) .== (Expr.readStorage' this (Lit 0) postStore) _ -> PBool True - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts SymbolicS (Just pre) (Just post) + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts AbstractStore (Just pre) (Just post) putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" , -- tests how whiffValue handles Neg via application of the triple IsZero simplification rule @@ -1236,13 +1248,13 @@ } } |] - let pre vm = (Lit 0) .== Control.Lens.view (state . callvalue) vm + let pre vm = (Lit 0) .== vm.state.callvalue post prestate poststate = let (x,y) = case getStaticAbiArgs 2 prestate of [x',y'] -> (x',y') _ -> error "expected 2 args" - this = Expr.litAddr $ Control.Lens.view (state . codeContract) prestate - prestore = Control.Lens.view (EVM.env . EVM.storage) prestate + this = Expr.litAddr $ prestate.state.codeContract + prestore = prestate.env.storage prex = Expr.readStorage' this x prestore prey = Expr.readStorage' this y prestore in case poststate of @@ -1251,7 +1263,7 @@ posty = Expr.readStorage' this y poststore in Expr.add prex prey .== Expr.add postx posty _ -> PBool True - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts SymbolicS (Just pre) (Just post) + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts AbstractStore (Just pre) (Just post) putStrLn "Correct, this can never fail" , -- Inspired by these `msg.sender == to` token bugs @@ -1270,13 +1282,13 @@ } } |] - let pre vm = (Lit 0) .== Control.Lens.view (state . callvalue) vm + let pre vm = (Lit 0) .== vm.state.callvalue post prestate poststate = let (x,y) = case getStaticAbiArgs 2 prestate of [x',y'] -> (x',y') _ -> error "expected 2 args" - this = Expr.litAddr $ Control.Lens.view (state . codeContract) prestate - prestore = Control.Lens.view (EVM.env . EVM.storage) prestate + this = Expr.litAddr $ prestate.state.codeContract + prestore = prestate.env.storage prex = Expr.readStorage' this x prestore prey = Expr.readStorage' this y prestore in case poststate of @@ -1285,7 +1297,7 @@ posty = Expr.readStorage' this y poststore in Expr.add prex prey .== Expr.add postx posty _ -> PBool True - (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts SymbolicS (Just pre) (Just post) + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts AbstractStore (Just pre) (Just post) let x = getVar ctr "arg1" let y = getVar ctr "arg2" putStrLn $ "y:" <> show y @@ -1293,7 +1305,7 @@ assertEqual "Catch storage collisions" x y putStrLn "expected counterexample found" , - testCase "Simple Assert" $ do + testCase "simple-assert" $ do Just c <- solcRuntime "C" [i| contract C { @@ -1302,8 +1314,8 @@ } } |] - (_, [Cex (l, _)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo()" [])) [] defaultVeriOpts - assertEqual "incorrect revert msg" l (EVM.Types.Revert [] (ConcreteBuf $ panicMsg 0x01)) + (_, [Cex (EVM.Types.Revert _ msg, _)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo()" [])) [] defaultVeriOpts + assertEqual "incorrect revert msg" msg (ConcreteBuf $ panicMsg 0x01) , testCase "simple-assert-2" $ do Just c <- solcRuntime "C" @@ -1750,10 +1762,10 @@ Just c <- solcRuntime "C" code' Just a <- solcRuntime "A" code' (_, [Cex (_, cex)]) <- withSolvers Z3 1 Nothing $ \s -> do - let vm0 = abstractVM (mkCalldata (Just (Sig "call_A()" [])) []) c Nothing SymbolicS + let vm0 = abstractVM (mkCalldata (Just (Sig "call_A()" [])) []) c Nothing AbstractStore let vm = vm0 - & set (state . callvalue) (Lit 0) - & over (EVM.env . contracts) + & set (#state % #callvalue) (Lit 0) + & over (#env % #contracts) (Map.insert aAddr (initialContract (RuntimeCode (ConcreteRuntimeCode a)))) verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) @@ -1818,7 +1830,7 @@ , ignoreTest $ testCase "safemath distributivity (yul)" $ do let yulsafeDistributivity = hex "6355a79a6260003560e01c14156016576015601f565b5b60006000fd60a1565b603d602d604435600435607c565b6039602435600435607c565b605d565b6052604b604435602435605d565b600435607c565b141515605a57fe5b5b565b6000828201821115151560705760006000fd5b82820190505b92915050565b6000818384048302146000841417151560955760006000fd5b82820290505b92915050565b" - let vm = abstractVM (mkCalldata (Just (Sig "distributivity(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) []) yulsafeDistributivity Nothing SymbolicS + let vm = abstractVM (mkCalldata (Just (Sig "distributivity(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) []) yulsafeDistributivity Nothing AbstractStore (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) putStrLn "Proven" , @@ -1844,7 +1856,7 @@ } |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "distributivity(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + (_, [Qed _]) <- withSolvers Z3 1 (Just 99999999) $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "distributivity(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts putStrLn "Proven" , testCase "storage-cex-1" $ do @@ -1905,7 +1917,7 @@ } } |] - (_, [Cex (_, cex)]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts ConcreteS Nothing (Just $ checkAssertions [0x01]) + (_, [Cex (_, cex)]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts EmptyStore Nothing (Just $ checkAssertions [0x01]) let testCex = Map.null cex.store assertBool "Did not find expected storage cex" testCex putStrLn "Expected counterexample found" @@ -2292,7 +2304,7 @@ runSimpleVM x ins = case loadVM x of Nothing -> Nothing Just vm -> let calldata' = (ConcreteBuf ins) - in case runState (assign (state . calldata) calldata' >> exec) vm of + in case runState (assign (#state % #calldata) calldata' >> exec) vm of (VMSuccess (ConcreteBuf bs), _) -> Just bs _ -> Nothing @@ -2301,11 +2313,11 @@ loadVM x = case runState exec (vmForEthrunCreation x) of (VMSuccess (ConcreteBuf targetCode), vm1) -> do - let target = Control.Lens.view (state . contract) vm1 + let target = vm1.state.contract vm2 = execState (replaceCodeOfSelf (RuntimeCode (ConcreteRuntimeCode targetCode))) vm1 return $ snd $ flip runState vm2 (do resetState - assign (state . EVM.gas) 0xffffffffffffffff -- kludge + assign (#state % #gas) 0xffffffffffffffff -- kludge loadContract target) _ -> Nothing @@ -2360,7 +2372,7 @@ getStaticAbiArgs :: Int -> VM -> [Expr EWord] getStaticAbiArgs n vm = - let cd = Control.Lens.view (state . calldata) vm + let cd = vm.state.calldata in decodeStaticArgs 4 n cd -- includes shaving off 4 byte function sig