diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,145 @@ 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). +## Added +- When a staticcall is made to a contract that does not exist, we overapproximate + and return symbolic values +- More simplification rules for Props +- JoinBytes simplification rule +- New simplification rule to help deal with abi.encodeWithSelector +- More simplification rules for Props +- Using the SMT solver to get a single concrete value for a symbolic expression + and continue running, whenever possible +- STATICCALL abstraction is now performed in case of symbolic arguments +- Better error messages for JSON parsing +- Multiple solutions are allowed for a single symbolic expression, and they are + generated via iterative calls to the SMT solver for quicker solving +- Aliasing works much better for symbolic and concrete addresses +- Constant propagation for symbolic values +- Allow reading bytecode via --code-file or --code-a-file/--code-b-file. Strips + `\n`, spaces, and ignores leading `0x` to make it easier to use via e.g. + `jq '.deplayedBytecode.object file.json > file.txt'` to parse Forge JSON output + This alleviates the issue when the contract is large and does not fit the command line + limit of 8192 characters +- Two more simplification rules: `ReadByte` & `ReadWord` when the `CopySlice` + it is reading from is writing after the position being read, so the + `CopySlice` can be ignored +- More simplification rules that help avoid symbolic copyslice in case of + STATICCALL overapproximation +- Test to make sure we don't accidentally overapproximate a working, good STATICCALL +- Allow EXTCODESIZE/HASH, BALANCE to be abstracted to a symbolic value. +- Allow CALL to be extracted in case `--promise-no-reent` is given, promising + no reentrancy of contracts. This may skip over reentrancy vulnerabilities + but allows much more thorough exploration of the contract +- Allow controlling the max buffer sizes via --max-buf-size to something smaller than 2**64 + so we don't get too large buffers as counterexamples +- More symbolic overapproximation for Balance and ExtCodeHash opcodes, fixing + CodeHash SMT representation +- Add deployment code flag to the `equivalenceCheck` function +- PNeg + PGT/PGEq/PLeq/PLT simplification rules +- We no longer dispatch Props to SMT that can be solved by a simplification +- Allow user to change the verbosity level via `--verb`. For the moment, this is only to + print some warnings related to zero-address dereference and to print `hemv test`'s + output in case of failure +- Simple test cases for the CLI +- Allow limiting the branch depth and width limitation via --max-depth and --max-width +- When there are zero solutions to a multi-solution query it means that the + currently executed branch is in fact impossible. In these cases, unwind all + frames and return a Revert with empty returndata. +- More rewrite rules for PEq, PNeg, missing eqByte call, and distributivity for And +- Allow changing of the prefix from "prove" via --prefix in `test` mode +- More complete simplification during interpretation +- SMT-based resolving of addresses now works for delegatecall and staticcall + opcodes as well +- UNSAT cache is now in `Solvers.hs` and is therefore shared across all threads. + Hence, it is now active even during branch queries. +- Rewrite rule to deal with some forms of argument packing by Solidity + via masking +- More rewrite rules for (PLT (Lit 0) _) and (PEq (Lit 1) _) +- Simplification can now be turned off from the cli via --no-simplify +- When doing Keccak concretization, and simplification is enabled, + we do both until fixedpoint +- When gathering Keccak axioms, we simplify the bytestring that + the keccak is applied to +- More rewrite rules for MulMod, AddMod, SHL, SHR, SLT, and SignExtend +- PLEq is now concretized in case it can be computed +- More SignExtend test cases +- Rewrite rules to deal with specific exponentiation patterns +- Added missing simplification and concretization of the SAR instruction + +## Fixed +- We now try to simplify expressions fully before trying to cast them to a concrete value + This should improve issues when "Unexpected Symbolic Arguments to Opcode" was + unnecessarily output +- Not all testcases ran due to incorrect filtering, fixed +- Removed dead code related to IOAct in the now deprecated and removed debugger +- Base case of exponentiation to 0 was not handled, leading to infinite loop +- Better exponential simplification +- Dumping of END states (.prop) files is now default for `--debug` +- When cheatcode is missing, we produce a partial execution warning +- Size of calldata can be up to 2**64, not 256. This is now reflected in the documentation +- We now have less noise during test runs, and assert more about symbolic copyslice tests +- CopySlice rewrite rule is now less strict while still being sound +- Assumptions about reading from buffer after its size are now the same in all cases. + Previously, they were too weak in case of reading 32 bytes. +- The equivalence checker now is able to prove that an empty store is + equivalent to a store with all slots initialized to 0. +- Equivalence checking was incorrectly assuming that overapproximated values + were sequentially equivalent. We now distinguish these symbolic values with + `A-` and `B-` +- Buffer of all zeroes was interpreted as an empty buffer during parsing SMT model. + The length of the buffer is now properly taken into account. +- It was possible to enter an infinite recursion when trying to shrink a buffer found by + the SMT solver. We now properly detect that it is not possible to shrink the buffer. +- Pretty printing of buffers is now more robust. Instead of throwing an `internal error`, + we now try best to print everything we can, and print an appropriate error message + instead of crashing. +- We no longer produce duplicate SMT assertions regarding concrete keccak values. +- Ord is now correctly implemented for Prop. +- Signed and unsigned integers have more refined ranges. +- Symbolic interpretation of assertGe/Gt/Le/Lt over signed integers now works correctly. +- SignExtend is now correctly being constant-folded +- Some of our property-based testing was ineffective because of inadvertent + simplification happening before calling the SMT solver. This has now been fixed. +- When pranking an address, we used the non-pranked address' nonce + to calculate the new address. This was incorrect, and lead to address clash, + as the nonce was never incremented. +- We only report FAIL in `test` mode for assertion failures that match the + string prefix "assertion failed", or match function selector Panic(uint256) + with a parameter 0x1. Previously, `require(a==b, "reason")` was a cause for + FAIL in case a!=b was possible. This has now been fixed. +- Out of bounds reads could occur in Haskell when trying to determine + valid jump destinations. This has now been fixed. + +## Changed +- Warnings now lead printing FAIL. This way, users don't accidentally think that + their contract is correct when there were cases/branches that hevm could not + fully explore. Printing of issues is also now much more organized +- Expressions that are commutative are now canonicalized to have the smaller + value on the LHS. This can significantly help with simplifications, automatically + determining when (Eq a b) is true when a==b modulo commutativity +- `hevm test`'s flag ` --verbose` is now `--verb`, which also increases verbosity + for other elements of the system +- Add `--arrays-exp` to cvc5 options. +- We now use Options.Applicative and a rather different way of parsing CLI options. + This should give us much better control over the CLI options and their parsing. +- block.number can now be symbolic. This only affects library use of hevm +- Removed `--smtoutput` since it was never used +- We now build with -DCMAKE_POLICY_VERSION_MINIMUM=3.5 libff, as cmake deprecated 3.5 +- CheckSatResult has now been unified with ProofResult via SMTResult +- If counterexample would require a buffer that's larger than 1GB, we abandon + shrinking it. +- If solver is not able to solve a query while attempting to shrink the model, we + abandon the attempt gracefully instead of crashing with internal error. +- Buffers are now handled more lazily when inspecting a model, which avoids some + unnecesary internal errors. +- EVM memory is now grown on demand using a 2x factor, to avoid repeated smaller + increases which hurt concrete execution performance due to their linear cost. +- The concrete MCOPY implementation has been optimized to avoid freezing the whole + EVM memory. +- We no longer accept `check` as a prefix for test cases by default. +- The way we print warnings for `symbolic` mode now matches that of `test` mode. + ## [0.54.2] - 2024-12-12 ## Fixed diff --git a/bench/bench-perf.hs b/bench/bench-perf.hs new file mode 100644 --- /dev/null +++ b/bench/bench-perf.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import Control.Monad.State.Strict (liftIO) +import Data.ByteString.UTF8 as BSU +import Data.Either +import Data.Function +import Data.Maybe +import Data.String.Here +import EVM +import EVM.ABI +import EVM.Effects (App, runApp) +import EVM.Fetch qualified as Fetch +import EVM.Solidity +import EVM.Stepper qualified as Stepper +import EVM.Transaction qualified +import EVM.Types +import EVM.UnitTest +import Test.Tasty.Bench +import Control.Monad.ST +import EVM.FeeSchedule (feeSchedule) + +-- benchmark hevm using tasty-bench + +vmFromRawByteString :: App m => ByteString -> m (VM Concrete RealWorld) +vmFromRawByteString bs = liftIO $ + bs + & ConcreteRuntimeCode + & RuntimeCode + & initialContract + & vm0 + & stToIO + & fmap EVM.Transaction.initTx + +vm0 :: Contract -> ST s (VM Concrete s) +vm0 c = makeVm $ vm0Opts c + +vm0Opts :: Contract -> VMOpts Concrete +vm0Opts c = + VMOpts + { contract = c, + calldata = (ConcreteBuf "", []), + value = Lit 0xfffffffffffff, -- balance + baseState = EmptyBase, + address = LitAddr 0xacab, + caller = LitAddr 0, + origin = LitAddr 0, + gas = 0xffffffffffffffff, + baseFee = 0, + priorityFee = 0, + gaslimit = 0xffffffffffffffff, + coinbase = LitAddr 0, + number = Lit 0, + timestamp = Lit 0, + blockGaslimit = 0xffffffffffffffff, + gasprice = 0, + maxCodeSize = 0xffffffff, + prevRandao = 0, + schedule = feeSchedule, + chainId = 1, + create = False, + txAccessList = mempty, -- TODO: support me soon + allowFFI = False, + otherContracts = [], + freshAddresses = 0, + beaconRoot = 0 + } + +vmOptsToTestVMParams :: VMOpts Concrete -> TestVMParams +vmOptsToTestVMParams v = + TestVMParams + { address = v.address, + caller = v.caller, + origin = v.origin, + gasCreate = v.gas, + gasCall = v.gas, + baseFee = v.baseFee, + priorityFee = v.priorityFee, + balanceCreate = case v.value of + Lit x -> x + _ -> 0, + coinbase = v.coinbase, + number = case v.number of + Lit x -> x + _ -> 0, + timestamp = case v.timestamp of + Lit x -> x + _ -> 0, + gaslimit = v.gaslimit, + gasprice = v.gasprice, + maxCodeSize = v.maxCodeSize, + prevrandao = v.prevRandao, + chainId = v.chainId + } + +callMainForBytecode :: App m => ByteString -> m (Either EvmError (Expr 'Buf)) +callMainForBytecode bs = do + vm <- vmFromRawByteString bs + Stepper.interpret (Fetch.zero 0 Nothing) vm (Stepper.evm (abiCall (vmOptsToTestVMParams (vm0Opts (initialContract (RuntimeCode (ConcreteRuntimeCode bs))))) (Left ("main()", emptyAbi))) >> Stepper.execFully) + +benchMain :: (String, ByteString) -> Benchmark +benchMain (name, bs) = bench name $ nfIO $ runApp $ (\x -> if isRight x then () else internalError "failed") <$> callMainForBytecode bs + +mkBench :: (Int -> IO a) -> [Int] -> IO [(String, a)] +mkBench f l = mapM (\n -> (show n,) <$> f n) l + +main :: IO () +main = do + let f (name, prog, limit) = do + ll <- mkBench prog [2 ^ n | n :: Int <- [1 .. fromMaybe 14 limit]] + pure $ bgroup name (benchMain <$> ll) + let benchmarks = [ + ("loop", simpleLoop, Nothing) + , ("primes", primes, Nothing) + , ("hashes", hashes, Nothing) + , ("hashmem", hashmem, Nothing) + , ("balanceTransfer", balanceTransfer, Nothing) + , ("funcCall", funcCall, Nothing) + , ("contractCreation", contractCreation, Nothing) + , ("contractCreationMem", contractCreationMem, Nothing) + , ("arrayCreationMem", arrayCreationMem, Just 9) + , ("mapStorage", mapStorage, Nothing) + , ("swapOperations", swapOperations, Nothing) + ] + defaultMain =<< mapM f benchmarks + + +-- Loop that adds up n numbers +simpleLoop :: Int -> IO ByteString +simpleLoop n = do + let src = + [i| + contract A { + function main() public { + uint256 acc = 0; + for (uint i = 0; i < ${n}; i++) { + acc += i; + } + } + } + |] + fmap fromJust (runApp $ solcRuntime "A" src) + +-- Computes prime numbers and stores them up to n +primes :: Int -> IO ByteString +primes n = do + let src = + [i| + contract A { + mapping (uint => uint) public primes; + function isPrime (uint n) public returns (bool) { + if (n == 2) { + return true; + } + if (n % 2 == 0) { + return false; + } + for (uint i = 3; i * i < n; i += 2) { + if (n % i == 0) { + return false; + } + } + return true; + } + + function main() public { + uint n = 0; + for (uint i = 0; i < ${n}; i++) { + if (isPrime(i)) { + primes[n++] = i; + } + } + } + } + |] + fmap fromJust (runApp $ solcRuntime "A" src) + +-- Program that repeatedly hashes a value +hashes :: Int -> IO ByteString +hashes n = do + let src = + [i| + contract A { + function main() public { + bytes32 h = 0; + for (uint i = 0; i < ${n}; i++) { + h = keccak256(abi.encode(h)); + } + } + } + |] + fmap fromJust (runApp $ solcRuntime "A" src) + +-- Program that repeatedly hashes a value and stores it in a map +hashmem :: Int -> IO ByteString +hashmem n = do + let src = + [i| + contract A { + mapping (uint256 => uint256) public map; + function main() public { + uint256 h = 0; + for (uint i = 0; i < ${n}; i++) { + uint256 x = h; + h = uint256(keccak256(abi.encode(h))); + map[x] = h; + } + } + } + |] + fmap fromJust (runApp $ solcRuntime "A" src) + +-- Transfer ETH to an address n times +balanceTransfer :: Int -> IO ByteString +balanceTransfer n = do + let src = + [i| + contract A { + function main() public { + address payable to = payable(address(0x8A8eAFb1cf62BfBeb1741769DAE1a9dd47996192)); + for (uint i = 0; i < ${n}; i++) { + to.transfer(1); + } + } + } + |] + fmap fromJust (runApp $ solcRuntime "A" src) + +-- Call a public function n times +funcCall :: Int -> IO ByteString +funcCall n = do + let src = + [i| + contract A { + uint256 public acc; + function f(uint256 x) public { + acc += x; + } + function main() public { + for (uint i = 0; i < ${n}; i++) { + f(i); + } + } + } + |] + fmap fromJust (runApp $ solcRuntime "A" src) + +-- Creates n contracts +contractCreation :: Int -> IO ByteString +contractCreation n = do + let src = + [i| + contract B { } + contract A { + B public b; + function main() public { + for (uint i = 0; i < ${n}; i++) { + b = new B(); + } + } + } + |] + fmap fromJust (runApp $ solcRuntime "A" src) + +-- Create n contracts with a string in them +contractCreationMem :: Int -> IO ByteString +contractCreationMem n = do + let src = + [i| + contract B { string m = "the quick brown fox jumps over the lazy dog"; } + contract A { + B public b; + function main() public { + for (uint i = 0; i < ${n}; i++) { + b = new B(); + } + } + } + |] + fmap fromJust (runApp $ solcRuntime "A" src) + +-- Create large array in memory +arrayCreationMem :: Int -> IO ByteString +arrayCreationMem n = do + let src = + [i| + struct C { int24 a; int24 b; uint256 c; uint128 d; } + contract A { + function work() public returns (C[] memory ret) { + ret = new C[](${n}); + for(uint a = 0; a < ${n}; a++) { + ret[a] = C({a:1, b:1, c:0xffffffffffffff, d:5}); + } + return ret; + } + function main() public { + for (uint i = 0; i < ${n}; i++) { + C[] memory ret = work(); + } + } + } + |] + fmap fromJust (runApp $ solcRuntime "A" src) + +-- Create large map in storage +mapStorage :: Int -> IO ByteString +mapStorage n = do + let src = + [i| + struct C { uint256 a; uint256 b; } + contract A { + mapping(uint256 => mapping(uint256 => C)) m; + function main() public { + for (uint i = 0; i < ${n}; i++) { + m[i][${n}-i] = C(i, ${n}); + } + } + } + |] + fmap fromJust (runApp $ solcRuntime "A" src) + +-- Do many swaps +swapOperations :: Int -> IO ByteString +swapOperations n = do + let src = + [i| + contract A { + function main() public pure { + (uint a0, uint a1, uint a2, uint a3, uint a4, uint a5, uint a6, uint a7, uint a8, uint a9, uint a10, uint a11, uint a12, uint a13, uint a14, uint a15) = (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16); + for (uint i = 0; i < ${n}; i++) { + (a0, a15) = (a15, a0); + (a1, a14) = (a14, a1); + (a2, a13) = (a13, a2); + (a3, a12) = (a12, a3); + (a4, a11) = (a11, a4); + (a5, a10) = (a10, a5); + (a6, a9) = (a9, a6); + (a7, a8) = (a8, a7); + } + } + } + |] + fmap fromJust (runApp $ solcRuntime' "A" src True) diff --git a/bench/bench.hs b/bench/bench.hs --- a/bench/bench.hs +++ b/bench/bench.hs @@ -92,10 +92,7 @@ findPanics :: App m => Solver -> Natural -> Integer -> ByteString -> m () findPanics solver count iters c = do _ <- withSolvers solver count 1 Nothing $ \s -> do - let opts = defaultVeriOpts - { maxIter = Just iters - , askSmtIters = iters + 1 - } + let opts = defaultVeriOpts { iterConf = defaultIterConf {maxIter = Just iters, askSmtIters = iters + 1 }} checkAssert s allPanicCodes c Nothing [] opts liftIO $ putStrLn "done" diff --git a/cli/cli.hs b/cli/cli.hs --- a/cli/cli.hs +++ b/cli/cli.hs @@ -3,16 +3,20 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} module Main where import Control.Monad (when, forM_, unless) import Control.Monad.ST (RealWorld, stToIO) import Control.Monad.IO.Unlift +import Control.Exception (try, IOException) import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Char8 as BC import Data.DoubleWord (Word256) -import Data.List (intersperse) -import Data.Maybe (fromMaybe, mapMaybe, fromJust, isNothing) +import Data.List (intersperse, intercalate) +import Data.Maybe (fromMaybe, mapMaybe, fromJust, isNothing, isJust) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Version (showVersion) @@ -21,12 +25,14 @@ import Numeric.Natural (Natural) import Optics.Core ((&), set) import Witch (unsafeInto) -import Options.Generic as Options +import Options.Generic as OptionsGeneric +import Options.Applicative as Options import Paths_hevm qualified as Paths import System.Directory (withCurrentDirectory, getCurrentDirectory, doesDirectoryExist, makeAbsolute) import System.FilePath (()) import System.Exit (exitFailure, exitWith, ExitCode(..)) -import Main.Utf8 (withUtf8) +import Data.List.Split (splitOn) +import Text.Read (readMaybe) import EVM (initialContract, abstractContract, makeVm) import EVM.ABI (Sig(..)) @@ -46,155 +52,243 @@ import EVM.Types qualified import EVM.UnitTest import EVM.Effects +import EVM.Expr (maybeLitWordSimp, maybeLitAddrSimp) data AssertionType = DSTest | Forge - deriving (Eq, Show, Read, ParseField) + deriving (Eq, Show, Read) --- This record defines the program's command-line options --- automatically via the `optparse-generic` package. -data Command w - = Symbolic -- Symbolically explore an abstract program, or specialized with specified env & calldata - -- vm opts - { code :: w ::: Maybe ByteString "Program bytecode" - , calldata :: w ::: Maybe ByteString "Tx: calldata" - , address :: w ::: Maybe Addr "Tx: address" - , caller :: w ::: Maybe Addr "Tx: caller" - , origin :: w ::: Maybe Addr "Tx: origin" - , coinbase :: w ::: Maybe Addr "Block: coinbase" - , value :: w ::: Maybe W256 "Tx: Eth amount" - , nonce :: w ::: Maybe Word64 "Nonce of origin" - , gas :: w ::: Maybe Word64 "Tx: gas amount" - , number :: w ::: Maybe W256 "Block: number" - , timestamp :: w ::: Maybe W256 "Block: timestamp" - , basefee :: w ::: Maybe W256 "Block: base fee" - , priorityFee :: w ::: Maybe W256 "Tx: priority fee" - , gaslimit :: w ::: Maybe Word64 "Tx: gas limit" - , gasprice :: w ::: Maybe W256 "Tx: gas price" - , create :: w ::: Bool "Tx: creation" - , maxcodesize :: w ::: Maybe W256 "Block: max code size" - , prevRandao :: w ::: Maybe W256 "Block: prevRandao" - , chainid :: w ::: Maybe W256 "Env: chainId" - -- remote state opts - , rpc :: w ::: Maybe URL "Fetch state from a remote node" - , block :: w ::: Maybe W256 "Block state is be fetched from" +projectTypeParser :: Parser ProjectType +projectTypeParser = option auto (long "project-type" <> showDefault <> value Foundry <> help "Is this a CombinedJSON or Foundry project") - -- symbolic execution opts - , root :: w ::: Maybe String "Path to project root directory (default: . )" - , projectType :: w ::: Maybe ProjectType "Is this a CombinedJSON or Foundry project (default: Foundry)" - , assertionType :: w ::: Maybe AssertionType "Assertions as per Forge or DSTest (default: Forge)" - , initialStorage :: w ::: Maybe (InitialStorage) "Starting state for storage: Empty, Abstract (default Abstract)" - , sig :: w ::: Maybe Text "Signature of types to decode / encode" - , arg :: w ::: [String] "Values to encode" - , 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 seconds (default: 300)" - , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point. For no bound, set -1 (default: 5)" - , solver :: w ::: Maybe Text "Used SMT solver: z3 (default), cvc5, or bitwuzla" - , smtdebug :: w ::: Bool "Print smt queries sent to the solver" - , debug :: w ::: Bool "Debug printing of internal behaviour, and dump internal expressions" - , trace :: w ::: Bool "Dump trace" - , assertions :: w ::: Maybe [Word256] "Comma separated list of solc panic codes to check for (default: user defined assertion violations only)" - , askSmtIterations :: w ::: Integer "1" "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 1)" - , numCexFuzz :: w ::: Integer "3" "Number of fuzzing tries to do to generate a counterexample (default: 3)" - , numSolvers :: w ::: Maybe Natural "Number of solver instances to use (default: number of cpu cores)" - , solverThreads :: w ::: Maybe Natural "Number of threads for each solver instance. Only respected for Z3 (default: 1)" - , loopDetectionHeuristic :: w ::: LoopHeuristic "StackBased" "Which heuristic should be used to determine if we are in a loop: StackBased (default) or Naive" - , noDecompose :: w ::: Bool "Don't decompose storage slots into separate arrays" - } - | Equivalence -- prove equivalence between two programs - { codeA :: w ::: ByteString "Bytecode of the first program" - , codeB :: w ::: ByteString "Bytecode of the second program" - , 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 seconds (default: 300)" - , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point. For no bound, set -1 (default: 5)" - , solver :: w ::: Maybe Text "Used SMT solver: z3 (default), cvc5, or bitwuzla" - , smtoutput :: w ::: Bool "Print verbose smt output" - , smtdebug :: w ::: Bool "Print smt queries sent to the solver" - , debug :: w ::: Bool "Debug printing of internal behaviour, and dump internal expressions" - , trace :: w ::: Bool "Dump trace" - , askSmtIterations :: w ::: Integer "1" "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 1)" - , numCexFuzz :: w ::: Integer "3" "Number of fuzzing tries to do to generate a counterexample (default: 3)" - , numSolvers :: w ::: Maybe Natural "Number of solver instances to use (default: number of cpu cores)" - , solverThreads :: w ::: Maybe Natural "Number of threads for each solver instance. Only respected for Z3 (default: 1)" - , loopDetectionHeuristic :: w ::: LoopHeuristic "StackBased" "Which heuristic should be used to determine if we are in a loop: StackBased (default) or Naive" - , noDecompose :: w ::: Bool "Don't decompose storage slots into separate arrays" - } - | Exec -- Execute a given program with specified env & calldata - { code :: w ::: Maybe ByteString "Program bytecode" - , calldata :: w ::: Maybe ByteString "Tx: calldata" - , address :: w ::: Maybe Addr "Tx: address" - , caller :: w ::: Maybe Addr "Tx: caller" - , origin :: w ::: Maybe Addr "Tx: origin" - , coinbase :: w ::: Maybe Addr "Block: coinbase" - , value :: w ::: Maybe W256 "Tx: Eth amount" - , nonce :: w ::: Maybe Word64 "Nonce of origin" - , gas :: w ::: Maybe Word64 "Tx: gas amount" - , number :: w ::: Maybe W256 "Block: number" - , timestamp :: w ::: Maybe W256 "Block: timestamp" - , basefee :: w ::: Maybe W256 "Block: base fee" - , priorityFee :: w ::: Maybe W256 "Tx: priority fee" - , gaslimit :: w ::: Maybe Word64 "Tx: gas limit" - , gasprice :: w ::: Maybe W256 "Tx: gas price" - , create :: w ::: Bool "Tx: creation" - , maxcodesize :: w ::: Maybe W256 "Block: max code size" - , prevRandao :: w ::: Maybe W256 "Block: prevRandao" - , chainid :: w ::: Maybe W256 "Env: chainId" - , debug :: w ::: Bool "Debug printing of internal behaviour, and dump internal expressions" - , trace :: w ::: Bool "Dump trace" - , rpc :: w ::: Maybe URL "Fetch state from a remote node" - , block :: w ::: Maybe W256 "Block state is be fetched from" - , root :: w ::: Maybe String "Path to project root directory (default: . )" - , projectType :: w ::: Maybe ProjectType "Is this a CombinedJSON or Foundry project (default: Foundry)" - , assertionType :: w ::: Maybe AssertionType "Assertions as per Forge or DSTest (default: Forge)" - } - | Test -- Run Foundry unit tests - { root :: w ::: Maybe String "Path to project root directory (default: . )" - , projectType :: w ::: Maybe ProjectType "Is this a CombinedJSON or Foundry project (default: Foundry)" - , assertionType :: w ::: Maybe AssertionType "Assertions as per Forge or DSTest (default: Forge)" - , rpc :: w ::: Maybe URL "Fetch state from a remote node" - , number :: w ::: Maybe W256 "Block: number" - , verbose :: w ::: Maybe Int "Append call trace: {1} failures {2} all" - , coverage :: w ::: Bool "Coverage analysis" - , match :: w ::: Maybe String "Test case filter - only run methods matching regex" - , solver :: w ::: Maybe Text "Used SMT solver: z3 (default), cvc5, or bitwuzla" - , numSolvers :: w ::: Maybe Natural "Number of solver instances to use (default: number of cpu cores)" - , solverThreads :: w ::: Maybe Natural "Number of threads for each solver instance. Only respected for Z3 (default: 1)" - , smtdebug :: w ::: Bool "Print smt queries sent to the solver" - , debug :: w ::: Bool "Debug printing of internal behaviour, and dump internal expressions" - , trace :: w ::: Bool "Dump trace" - , 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 seconds (default: 300)" - , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point. For no bound, set -1 (default: 5)" - , loopDetectionHeuristic :: w ::: LoopHeuristic "StackBased" "Which heuristic should be used to determine if we are in a loop: StackBased (default) or Naive" - , noDecompose :: w ::: Bool "Don't decompose storage slots into separate arrays" - , numCexFuzz :: w ::: Integer "3" "Number of fuzzing tries to do to generate a counterexample (default: 3)" - , askSmtIterations :: w ::: Integer "1" "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 1)" - } - | Version +sigParser :: Parser (Maybe Text) +sigParser = (optional $ strOption $ long "sig" <> help "Signature of types to decode/encode") - deriving (Options.Generic) +argParser :: Parser [String] +argParser = (many $ strOption $ long "arg" <> help "Value(s) to encode. Can be given multiple times, once for each argument") -type URL = Text +createParser :: Parser Bool +createParser = switch $ long "create" <> help "Tx: creation" +rpcParser :: Parser (Maybe URL) +rpcParser = (optional $ strOption $ long "rpc" <> help "Fetch state from a remote node") --- For some reason haskell can't derive a --- parseField instance for (Text, ByteString) -instance Options.ParseField (Text, ByteString) +data CommonOptions = CommonOptions + { askSmtIterations ::Integer + , loopDetectionHeuristic ::LoopHeuristic + , noDecompose ::Bool + , solver ::Text + , debug ::Bool + , calldata ::Maybe ByteString + , trace ::Bool + , verb ::Int + , root ::Maybe String + , assertionType ::AssertionType + , solverThreads ::Natural + , smttimeout ::Natural + , smtdebug ::Bool + , numSolvers ::Maybe Natural + , numCexFuzz ::Integer + , maxIterations ::Integer + , promiseNoReent::Bool + , maxBufSize ::Int + , maxWidth ::Int + , maxDepth ::Maybe Int + , noSimplify ::Bool + } -deriving instance Options.ParseField Word256 -deriving instance Options.ParseField [Word256] +commonOptions :: Parser CommonOptions +commonOptions = CommonOptions + <$> option auto ( long "ask-smt-iterations" <> value 1 <> + help "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability") + <*> option auto (long "loop-detection-heuristic" <> showDefault <> value StackBased <> + help "Which heuristic should be used to determine if we are in a loop: StackBased or Naive") + <*> (switch $ long "no-decompose" <> help "Don't decompose storage slots into separate arrays") + <*> (strOption $ long "solver" <> value "z3" <> help "Used SMT solver: z3, cvc5, or bitwuzla") + <*> (switch $ long "debug" <> help "Debug printing of internal behaviour, and dump internal expressions") + <*> (optional $ strOption $ long "calldata" <> help "Tx: calldata") + <*> (switch $ long "trace" <> help "Dump trace") + <*> (option auto $ long "verb" <> showDefault <> value 1 <> help "Append call trace: {1} failures {2} all") + <*> (optional $ strOption $ long "root" <> help "Path to project root directory") + <*> (option auto $ long "assertion-type" <> showDefault <> value Forge <> help "Assertions as per Forge or DSTest") + <*> (option auto $ long "solver-threads" <> showDefault <> value 1 <> help "Number of threads for each solver instance. Only respected for Z3") + <*> (option auto $ long "smttimeout" <> value 300 <> help "Timeout given to SMT solver in seconds") + <*> (switch $ long "smtdebug" <> help "Print smt queries sent to the solver") + <*> (optional $ option auto $ long "num-solvers" <> help "Number of solver instances to use (default: number of cpu cores)") + <*> (option auto $ long "num-cex-fuzz" <> showDefault <> value 3 <> help "Number of fuzzing tries to do to generate a counterexample") + <*> (option auto $ long "max-iterations" <> showDefault <> value 5 <> help "Number of times we may revisit a particular branching point. For no bound, set -1") + <*> (switch $ long "promise-no-reent" <> help "Promise no reentrancy is possible into the contract(s) being examined") + <*> (option auto $ long "max-buf-size" <> value 64 <> help "Maximum size of buffers such as calldata and returndata in exponents of 2 (default: 64, i.e. 2^64 bytes)") + <*> (option auto $ long "max-width" <> showDefault <> value 100 <> help "Max number of concrete values to explore when encountering a symbolic value. This is a form of branch width limitation per symbolic value") + <*> (optional $ option auto $ long "max-depth" <> help "Limit maximum depth of branching during exploration (default: unlimited)") + <*> (switch $ long "no-simplify" <> help "Don't perform simplification of expressions") -instance Options.ParseRecord (Command Options.Wrapped) where - parseRecord = - Options.parseRecordWithModifiers Options.lispCaseModifiers +data CommonExecOptions = CommonExecOptions + { address ::Maybe Addr + , caller ::Maybe Addr + , origin ::Maybe Addr + , coinbase ::Maybe Addr + , value ::Maybe W256 + , nonce ::Maybe Word64 + , gas ::Maybe Word64 + , number ::Maybe W256 + , timestamp ::Maybe W256 + , basefee ::Maybe W256 + , priorityFee ::Maybe W256 + , gaslimit ::Maybe Word64 + , gasprice ::Maybe W256 + , maxcodesize ::Maybe W256 + , prevRandao ::Maybe W256 + , chainid ::Maybe W256 + , rpc ::Maybe URL + , block ::Maybe W256 +} +commonExecOptions :: Parser CommonExecOptions +commonExecOptions = CommonExecOptions + <$> (optional $ option auto $ long "address" <> help "Tx: address") + <*> (optional $ option auto $ long "caller" <> help "Tx: caller") + <*> (optional $ option auto $ long "origin" <> help "Tx: origin") + <*> (optional $ option auto $ long "coinbase" <> help "Block: coinbase") + <*> (optional $ option auto $ long "value" <> help "Tx: Eth amount") + <*> (optional $ option auto $ long "nonce" <> help "Nonce of origin") + <*> (optional $ option auto $ long "gas" <> help "Tx: gas amount") + <*> (optional $ option auto $ long "number" <> help "Block: number") + <*> (optional $ option auto $ long "timestamp" <> help "Block: timestamp") + <*> (optional $ option auto $ long "basefee" <> help "Block: base fee") + <*> (optional $ option auto $ long "priority-fee" <> help "Tx: priority fee") + <*> (optional $ option auto $ long "gaslimit" <> help "Tx: gas limit") + <*> (optional $ option auto $ long "gasprice" <> help "Tx: gas price") + <*> (optional $ option auto $ long "maxcodesize" <> help "Block: max code size") + <*> (optional $ option auto $ long "prev-randao" <> help "Block: prevRandao") + <*> (optional $ option auto $ long "chainid" <> help "Env: chainId") + <*> rpcParser + <*> (optional $ option auto $ long "block" <> help "Block state is be fetched from") + +data CommonFileOptions = CommonFileOptions + { code ::Maybe ByteString + , codeFile ::Maybe String + } + +commonFileOptions :: Parser CommonFileOptions +commonFileOptions = CommonFileOptions + <$> (optional $ strOption $ long "code" <> help "Program bytecode") + <*> (optional $ strOption $ long "code-file" <> help "Program bytecode in a file") + +data TestOptions = TestOptions + { projectType ::ProjectType + , rpc ::Maybe URL + , number ::Maybe W256 + , coverage ::Bool + , match ::Maybe String + , prefix ::String + , ffi ::Bool + } + +testOptions :: Parser TestOptions +testOptions = TestOptions + <$> projectTypeParser + <*> rpcParser + <*> (optional $ option auto $ long "number" <> help "Block: number") + <*> (switch $ long "coverage" <> help "Coverage analysis") + <*> (optional $ strOption $ long "match" <> help "Test case filter - only run methods matching regex") + <*> (strOption $ long "prefix" <> showDefault <> value "prove" <> help "Prefix for test cases to prove") + <*> (switch $ long "ffi" <> help "Allow the usage of the hevm.ffi() cheatcode (WARNING: this allows test authors to execute arbitrary code on your machine)") + + +data EqOptions = EqOptions + { codeA ::Maybe ByteString + , codeB ::Maybe ByteString + , codeAFile ::Maybe String + , codeBFile ::Maybe String + , sig ::Maybe Text + , arg ::[String] + , create ::Bool + } + +eqOptions :: Parser EqOptions +eqOptions = EqOptions + <$> (optional $ strOption $ long "code-a" <> help "Bytecode of the first program") + <*> (optional $ strOption $ long "code-b" <> help "Bytecode of the second program") + <*> (optional $ strOption $ long "code-a-file" <> help "First program's bytecode in a file") + <*> (optional $ strOption $ long "code-b-file" <> help "Second program's bytecode in a file") + <*> sigParser + <*> argParser + <*> createParser + +data SymbolicOptions = SymbolicOptions + { projectType ::ProjectType + , initialStorage ::Maybe InitialStorage + , getModels ::Bool + , showTree ::Bool + , showReachableTree ::Bool + , assertions ::Maybe String + , sig ::Maybe Text + , arg ::[String] + , create ::Bool + } + +symbolicOptions :: Parser SymbolicOptions +symbolicOptions = SymbolicOptions + <$> projectTypeParser + <*> (optional $ option auto $ long "initial-storage" <> help "Starting state for storage: Empty, Abstract (default Abstract)") + <*> (switch $ long "get-models" <> help "Print example testcase for each execution path") + <*> (switch $ long "show-tree" <> help "Print branches explored in tree view") + <*> (switch $ long "show-reachable-tree" <> showDefault <> help "Print only reachable branches explored in tree view") + <*> (optional $ strOption $ long "assertions" <> help "Comma separated list of solc panic codes to check for (default: user defined assertion violations only)") + <*> sigParser + <*> argParser + <*> createParser + +data ExecOptions = ExecOptions + { projectType ::ProjectType + , create :: Bool + } +execOptions :: Parser ExecOptions +execOptions = ExecOptions + <$> projectTypeParser + <*> createParser + +-- Combined options data type +data Command + = Symbolic CommonFileOptions SymbolicOptions CommonExecOptions CommonOptions + | Equal EqOptions CommonOptions + | Test TestOptions CommonOptions + | Exec CommonFileOptions ExecOptions CommonExecOptions CommonOptions + | Version + +-- Parser for the subcommands +commandParser :: Parser Command +commandParser = subparser + ( command "test" + (info (Test <$> testOptions <*> commonOptions <**> helper) + (progDesc "Prove Foundry unit tests prefixed with `prove` by default" + <> footer "For more help: https://hevm.dev/std-test-tutorial.html" )) + <> command "equivalence" + (info (Equal <$> eqOptions <*> commonOptions <**> helper) + (progDesc "Prove equivalence between two programs" + <> footer "For more help: https://hevm.dev/equivalence-checking-tutorial.html" )) + <> command "symbolic" + (info (Symbolic <$> commonFileOptions <*> symbolicOptions <*> commonExecOptions <*> commonOptions <**> helper) + (progDesc "Symbolically explore an abstract program" + <> footer "For more help, see: https://hevm.dev/symbolic-execution-tutorial.html" )) + <> command "exec" + (info (Exec <$> commonFileOptions <*> execOptions <*> commonExecOptions <*> commonOptions <**> helper) + (progDesc "Concretely execute a given program" + <> footer "For more help, see https://hevm.dev/exec.html" )) + <> command "version" + (info (pure Version) + (progDesc "Show the version of the tool")) + ) + +type URL = Text + +deriving instance OptionsGeneric.ParseField Word256 +deriving instance OptionsGeneric.ParseField [Word256] + data InitialStorage = Empty | Abstract - deriving (Show, Read, Options.ParseField) + deriving (Show, Read, OptionsGeneric.ParseField) getFullVersion :: [Char] getFullVersion = showVersion Paths.version <> " [" <> gitVersion <> "]" @@ -205,165 +299,219 @@ Left _ -> "no git revision present" main :: IO () -main = withUtf8 $ do - cmd <- Options.unwrapRecord "hevm -- Ethereum evaluator" - let env = Env { config = defaultConfig - { dumpQueries = cmd.smtdebug - , debug = cmd.debug - , dumpExprs = cmd.debug - , numCexFuzz = cmd.numCexFuzz - , dumpTrace = cmd.trace - , decomposeStorage = Prelude.not cmd.noDecompose - } } +main = do + cmd <- execParser $ info (commandParser <**> helper) + ( Options.fullDesc + <> progDesc "hevm, a symbolic and concrete EVM bytecode execution framework" + <> footer "See https://hevm.dev for more information" + ) + case cmd of - Version {} ->putStrLn getFullVersion - Symbolic {} -> do - root <- getRoot cmd - withCurrentDirectory root $ runEnv env $ assert cmd - Equivalence {} -> runEnv env $ equivalence cmd - Exec {} -> runEnv env $ launchExec cmd - Test {} -> do - root <- getRoot cmd - solver <- getSolver cmd + Symbolic cFileOpts symbOpts cExecOpts cOpts -> do + env <- makeEnv cOpts + root <- getRoot cOpts + withCurrentDirectory root $ runEnv env $ symbCheck cFileOpts symbOpts cExecOpts cOpts + Equal eqOpts cOpts -> do + env <- makeEnv cOpts + runEnv env $ equivalence eqOpts cOpts + Test testOpts cOpts -> do + env <- makeEnv cOpts + root <- getRoot cOpts + solver <- getSolver cOpts.solver cores <- liftIO $ unsafeInto <$> getNumProcessors - let solverCount = fromMaybe cores cmd.numSolvers - runEnv env $ withSolvers solver solverCount (fromMaybe 1 cmd.solverThreads) cmd.smttimeout $ \solvers -> do - buildOut <- readBuildOutput root (getProjectType cmd) + let solverCount = fromMaybe cores cOpts.numSolvers + runEnv env $ withSolvers solver solverCount cOpts.solverThreads (Just cOpts.smttimeout) $ \solvers -> do + buildOut <- readBuildOutput root testOpts.projectType case buildOut of Left e -> liftIO $ do putStrLn $ "Error: " <> e exitFailure Right out -> do -- TODO: which functions here actually require a BuildOutput, and which can take it as a Maybe? - testOpts <- liftIO $ unitTestOptions cmd solvers (Just out) - res <- unitTest testOpts out.contracts - liftIO $ unless res exitFailure + unitTestOpts <- liftIO $ unitTestOptions testOpts cOpts solvers (Just out) + res <- unitTest unitTestOpts out.contracts + liftIO $ unless (uncurry (&&) res) exitFailure + Exec cFileOpts execOpts cExecOpts cOpts-> do + env <- makeEnv cOpts + runEnv env $ launchExec cFileOpts execOpts cExecOpts cOpts + Version {} ->putStrLn getFullVersion + where + makeEnv :: CommonOptions -> IO Env + makeEnv cOpts = do + when (cOpts.maxBufSize > 64) $ do + putStrLn "Error: maxBufSize must be less than or equal to 64. That limits buffers to a size of 2^64, which is more than enough for practical purposes" + exitFailure + when (cOpts.maxBufSize < 0) $ do + putStrLn "Error: maxBufSize must be at least 0. Negative values do not make sense. A value of zero means at most 1 byte long buffers" + exitFailure + pure Env { config = defaultConfig + { dumpQueries = cOpts.smtdebug + , debug = cOpts.debug + , dumpEndStates = cOpts.debug + , dumpExprs = cOpts.debug + , numCexFuzz = cOpts.numCexFuzz + , dumpTrace = cOpts.trace + , decomposeStorage = Prelude.not cOpts.noDecompose + , promiseNoReent = cOpts.promiseNoReent + , maxBufSize = cOpts.maxBufSize + , maxWidth = cOpts.maxWidth + , maxDepth = cOpts.maxDepth + , verb = cOpts.verb + , simp = Prelude.not cOpts.noSimplify + } } -equivalence :: App m => Command Options.Unwrapped -> m () -equivalence cmd = do - let bytecodeA' = hexByteString $ strip0x cmd.codeA - bytecodeB' = hexByteString $ strip0x cmd.codeB - if (isNothing bytecodeA') then liftIO $ do - putStrLn $ "Error, invalid bytecode for program A: " <> show cmd.codeA + +getCode :: Maybe String -> Maybe ByteString -> IO (Maybe ByteString) +getCode fname code = do + when (isJust fname && isJust code) $ do + putStrLn "Error: Cannot provide both a file and code" exitFailure - else if (isNothing bytecodeB') then liftIO $ do - putStrLn $ "Error, invalid bytecode for program B: " <> show cmd.codeB + case fname of + Nothing -> pure $ fmap strip code + Just f -> do + result <- try (BS.readFile f) :: IO (Either IOException BS.ByteString) + case result of + Left e -> do + putStrLn $ "Error reading file: " <> show e + exitFailure + Right content -> do + pure $ Just $ strip (BS.toStrict content) + where + strip = BC.filter (\c -> c /= ' ' && c /= '\n' && c /= '\r' && c /= '\t' && c /= '"') + +equivalence :: App m => EqOptions -> CommonOptions -> m () +equivalence eqOpts cOpts = do + bytecodeA' <- liftIO $ getCode eqOpts.codeAFile eqOpts.codeA + bytecodeB' <- liftIO $ getCode eqOpts.codeBFile eqOpts.codeB + let bytecodeA = decipher bytecodeA' + let bytecodeB = decipher bytecodeB' + when (isNothing bytecodeA) $ liftIO $ do + putStrLn "Error: invalid or no bytecode for program A. Provide a valid one with --code-a or --code-a-file" exitFailure - else do - let bytecodeA = fromJust bytecodeA' - bytecodeB = fromJust bytecodeB' - veriOpts = VeriOpts { simp = True - , maxIter = parseMaxIters cmd.maxIterations - , askSmtIters = cmd.askSmtIterations - , loopHeuristic = cmd.loopDetectionHeuristic - , rpcInfo = Nothing + when (isNothing bytecodeB) $ liftIO $ do + putStrLn "Error: invalid or no bytecode for program B. Provide a valid one with --code-b or --code-b-file" + exitFailure + let veriOpts = VeriOpts { iterConf = IterConfig { + maxIter = parseMaxIters cOpts.maxIterations + , askSmtIters = cOpts.askSmtIterations + , loopHeuristic = cOpts.loopDetectionHeuristic } - calldata <- liftIO $ buildCalldata cmd - solver <- liftIO $ getSolver cmd - cores <- liftIO $ unsafeInto <$> getNumProcessors - let solverCount = fromMaybe cores cmd.numSolvers - withSolvers solver solverCount (fromMaybe 1 cmd.solverThreads) cmd.smttimeout $ \s -> do - res <- equivalenceCheck s bytecodeA bytecodeB veriOpts calldata - case any isCex res of - False -> liftIO $ do - putStrLn "No discrepancies found" - when (any isUnknown res || any isError res) $ do - putStrLn "But the following issues occurred:" - forM_ (groupIssues (filter isError res)) $ \(num, str) -> putStrLn $ " " <> show num <> "x -> " <> str - forM_ (groupIssues (filter isUnknown res)) $ \(num, str) -> putStrLn $ " " <> show num <> "x -> " <> str - exitFailure - True -> liftIO $ do - let cexs = mapMaybe getCex res - T.putStrLn . T.unlines $ - [ "Not equivalent. The following inputs result in differing behaviours:" - , "" , "-----", "" - ] <> (intersperse (T.unlines [ "", "-----" ]) $ fmap (formatCex (AbstractBuf "txdata") Nothing) cexs) - exitFailure + , rpcInfo = Nothing + } + calldata <- buildCalldata cOpts eqOpts.sig eqOpts.arg + solver <- liftIO $ getSolver cOpts.solver + cores <- liftIO $ unsafeInto <$> getNumProcessors + let solverCount = fromMaybe cores cOpts.numSolvers + withSolvers solver solverCount cOpts.solverThreads (Just cOpts.smttimeout) $ \s -> do + eq <- equivalenceCheck s (fromJust bytecodeA) (fromJust bytecodeB) veriOpts calldata eqOpts.create + let anyIssues = not (null eq.partials) || any (isUnknown . fst) eq.res || any (isError . fst) eq.res + liftIO $ case (any (isCex . fst) eq.res, anyIssues) of + (False, False) -> putStrLn " \x1b[32m[PASS]\x1b[0m Contracts behave equivalently" + (True, _) -> putStrLn " \x1b[31m[FAIL]\x1b[0m Contracts do not behave equivalently" + (_, True) -> putStrLn " \x1b[31m[FAIL]\x1b[0m Contracts may not behave equivalently" + liftIO $ printWarnings eq.partials (map fst eq.res) "the contracts under test" + case any (isCex . fst) eq.res of + False -> liftIO $ do + when anyIssues exitFailure + putStrLn "No discrepancies found" + True -> liftIO $ do + let cexes = mapMaybe getCexP eq.res + T.putStrLn . T.unlines $ + [ "Not equivalent. The following inputs result in differing behaviours:" + , "" , "-----", "" + ] <> (intersperse (T.unlines [ "", "-----" ]) $ fmap formatCexes cexes) + exitFailure + where + decipher = maybe Nothing (hexByteString . strip0x) + getCexP :: (ProofResult a b, String) -> Maybe (a, String) + getCexP (Cex c, reason) = Just (c, reason) + getCexP _ = Nothing + formatCexes (cex, reason) = formatCex (AbstractBuf "txdata") Nothing cex <> "Difference: " <> T.pack reason -getSolver :: Command Options.Unwrapped -> IO Solver -getSolver cmd = case cmd.solver of - Nothing -> pure Z3 - Just s -> case T.unpack s of - "z3" -> pure Z3 - "cvc5" -> pure CVC5 - "bitwuzla" -> pure Bitwuzla - input -> do - putStrLn $ "unrecognised solver: " <> input - exitFailure +getSolver :: Text -> IO Solver +getSolver s = case T.unpack s of + "z3" -> pure Z3 + "cvc5" -> pure CVC5 + "bitwuzla" -> pure Bitwuzla + input -> do + putStrLn $ "unrecognised solver: " <> input + exitFailure -getSrcInfo :: App m => Command Options.Unwrapped -> m DappInfo -getSrcInfo cmd = do - root <- liftIO $ getRoot cmd +getSrcInfo :: App m => ExecOptions -> CommonOptions -> m DappInfo +getSrcInfo execOpts cOpts = do + root <- liftIO $ getRoot cOpts conf <- readConfig liftIO $ withCurrentDirectory root $ do - outExists <- doesDirectoryExist (root "out") + outExists <- doesDirectoryExist (root System.FilePath. "out") if outExists then do - buildOutput <- runEnv Env {config = conf} $ readBuildOutput root (getProjectType cmd) + buildOutput <- runEnv Env {config = conf} $ readBuildOutput root execOpts.projectType case buildOutput of Left _ -> pure emptyDapp Right o -> pure $ dappInfo root o else pure emptyDapp -getProjectType :: Command Options.Unwrapped -> ProjectType -getProjectType cmd = fromMaybe Foundry cmd.projectType - -getRoot :: Command Options.Unwrapped -> IO FilePath -getRoot cmd = maybe getCurrentDirectory makeAbsolute (cmd.root) +getRoot :: CommonOptions -> IO FilePath +getRoot cmd = maybe getCurrentDirectory makeAbsolute cmd.root -parseMaxIters :: Maybe Integer -> Maybe Integer -parseMaxIters i = if num < 0 then Nothing else Just num - where - num = fromMaybe (5::Integer) i +parseMaxIters :: Integer -> Maybe Integer +parseMaxIters num = if num < 0 then Nothing else Just num -- | Builds a buffer representing calldata based on the given cli arguments -buildCalldata :: Command Options.Unwrapped -> IO (Expr Buf, [Prop]) -buildCalldata cmd = case (cmd.calldata, cmd.sig) of +buildCalldata :: App m => CommonOptions -> Maybe Text -> [String] -> m (Expr Buf, [Prop]) +buildCalldata cOpts sig arg = case (cOpts.calldata, sig) of -- fully abstract calldata - (Nothing, Nothing) -> pure $ mkCalldata Nothing [] + (Nothing, Nothing) -> mkCalldata Nothing [] -- fully concrete calldata (Just c, Nothing) -> do let val = hexByteString $ strip0x c - if (isNothing val) then do + if (isNothing val) then liftIO $ do putStrLn $ "Error, invalid calldata: " <> show c exitFailure else pure (ConcreteBuf (fromJust val), []) -- calldata according to given abi with possible specializations from the `arg` list (Nothing, Just sig') -> do - method' <- functionAbi sig' - pure $ mkCalldata (Just (Sig method'.methodSignature (snd <$> method'.inputs))) cmd.arg + method' <- liftIO $ functionAbi sig' + mkCalldata (Just (Sig method'.methodSignature (snd <$> method'.inputs))) arg -- both args provided - (_, _) -> do + (_, _) -> liftIO $ do putStrLn "incompatible options provided: --calldata and --sig" exitFailure -- If function signatures are known, they should always be given for best results. -assert :: App m => Command Options.Unwrapped -> m () -assert cmd = do - let block' = maybe Fetch.Latest Fetch.BlockNumber cmd.block - rpcinfo = (,) block' <$> cmd.rpc - calldata <- liftIO $ buildCalldata cmd - preState <- liftIO $ symvmFromCommand cmd calldata - let errCodes = fromMaybe defaultPanicCodes cmd.assertions +symbCheck :: App m => CommonFileOptions -> SymbolicOptions -> CommonExecOptions -> CommonOptions -> m () +symbCheck cFileOpts sOpts cExecOpts cOpts = do + let block' = maybe Fetch.Latest Fetch.BlockNumber cExecOpts.block + rpcinfo = (,) block' <$> cExecOpts.rpc + calldata <- buildCalldata cOpts sOpts.sig sOpts.arg + preState <- liftIO $ symvmFromCommand cExecOpts sOpts cFileOpts calldata + errCodes <- case sOpts.assertions of + Nothing -> pure defaultPanicCodes + Just s -> case (mapM readMaybe $ splitOn "," s) of + Nothing -> liftIO $ do + putStrLn $ "Error: invalid assertion codes: " <> s + exitFailure + Just codes -> pure codes + when (cOpts.verb > 0) $ liftIO $ putStrLn $ "Using assertion code(s): " <> intercalate "," (map show errCodes) cores <- liftIO $ unsafeInto <$> getNumProcessors - let solverCount = fromMaybe cores cmd.numSolvers - solver <- liftIO $ getSolver cmd - withSolvers solver solverCount (fromMaybe 1 cmd.solverThreads) cmd.smttimeout $ \solvers -> do - let veriOpts = VeriOpts { simp = True - , maxIter = parseMaxIters cmd.maxIterations - , askSmtIters = cmd.askSmtIterations - , loopHeuristic = cmd.loopDetectionHeuristic - , rpcInfo = rpcinfo - } + let solverCount = fromMaybe cores cOpts.numSolvers + solver <- liftIO $ getSolver cOpts.solver + withSolvers solver solverCount cOpts.solverThreads (Just cOpts.smttimeout) $ \solvers -> do + let veriOpts = VeriOpts { iterConf = IterConfig { + maxIter = parseMaxIters cOpts.maxIterations + , askSmtIters = cOpts.askSmtIterations + , loopHeuristic = cOpts.loopDetectionHeuristic + } + , rpcInfo = rpcinfo + } (expr, res) <- verify solvers veriOpts preState (Just $ checkAssertions errCodes) case res of - [Qed _] -> do + [Qed] -> do liftIO $ putStrLn "\nQED: No reachable property violations discovered\n" - showExtras solvers cmd calldata expr + showExtras solvers sOpts calldata expr _ -> do let cexs = snd <$> mapMaybe getCex res - smtUnknowns = mapMaybe getUnknown res counterexamples | null cexs = [] | otherwise = @@ -371,30 +519,24 @@ , ("Discovered the following " <> (T.pack $ show (length cexs)) <> " counterexample(s):") , "" ] <> fmap (formatCex (fst calldata) Nothing) cexs - unknowns - | null smtUnknowns = [] - | otherwise = - [ "" - , "Could not determine reachability of the following end state(s):" - , "" - ] <> fmap (formatExpr) smtUnknowns - liftIO $ T.putStrLn $ T.unlines (counterexamples <> unknowns) - showExtras solvers cmd calldata expr + liftIO $ T.putStrLn $ T.unlines counterexamples + liftIO $ printWarnings [expr] res "symbolically" + showExtras solvers sOpts calldata expr liftIO exitFailure -showExtras :: App m => SolverGroup -> Command Options.Unwrapped -> (Expr Buf, [Prop]) -> Expr End -> m () -showExtras solvers cmd calldata expr = do - when cmd.showTree $ liftIO $ do +showExtras :: App m => SolverGroup ->SymbolicOptions -> (Expr Buf, [Prop]) -> Expr End -> m () +showExtras solvers sOpts calldata expr = do + when sOpts.showTree $ liftIO $ do putStrLn "=== Expression ===\n" T.putStrLn $ formatExpr expr putStrLn "" - when cmd.showReachableTree $ do + when sOpts.showReachableTree $ do reached <- reachable solvers expr liftIO $ do - putStrLn "=== Reachable Expression ===\n" + putStrLn "=== Potentially Reachable Expression ===\n" T.putStrLn (formatExpr . snd $ reached) putStrLn "" - when cmd.getModels $ do + when sOpts.getModels $ do liftIO $ putStrLn $ "=== Models for " <> show (Expr.numBranches expr) <> " branches ===" ms <- produceModels solvers expr liftIO $ forM_ ms (showModel (fst calldata)) @@ -405,13 +547,13 @@ areAnyPrefixOf :: [Text] -> Text -> Bool areAnyPrefixOf prefixes t = any (flip T.isPrefixOf t) prefixes -launchExec :: App m => Command Options.Unwrapped -> m () -launchExec cmd = do - dapp <- getSrcInfo cmd - vm <- liftIO $ vmFromCommand cmd +launchExec :: App m => CommonFileOptions -> ExecOptions -> CommonExecOptions -> CommonOptions -> m () +launchExec cFileOpts execOpts cExecOpts cOpts = do + dapp <- getSrcInfo execOpts cOpts + vm <- liftIO $ vmFromCommand cOpts cExecOpts cFileOpts execOpts let - block = maybe Fetch.Latest Fetch.BlockNumber cmd.block - rpcinfo = (,) block <$> cmd.rpc + block = maybe Fetch.Latest Fetch.BlockNumber cExecOpts.block + rpcinfo = (,) block <$> cExecOpts.rpc -- TODO: we shouldn't need solvers to execute this code withSolvers Z3 0 1 Nothing $ \solvers -> do @@ -436,10 +578,10 @@ internalError "no EVM result" -- | Creates a (concrete) VM from command line options -vmFromCommand :: Command Options.Unwrapped -> IO (VM Concrete RealWorld) -vmFromCommand cmd = do - (miner,ts,baseFee,blockNum,prevRan) <- case cmd.rpc of - Nothing -> pure (LitAddr 0,Lit 0,0,0,0) +vmFromCommand :: CommonOptions -> CommonExecOptions -> CommonFileOptions -> ExecOptions -> IO (VM Concrete RealWorld) +vmFromCommand cOpts cExecOpts cFileOpts execOpts= do + (miner,ts,baseFee,blockNum,prevRan) <- case cExecOpts.rpc of + Nothing -> pure (LitAddr 0,Lit 0,0,Lit 0,0) Just url -> Fetch.fetchBlockFrom block url >>= \case Nothing -> do putStrLn $ "Error, Could not fetch block" <> show block <> " from URL: " <> show url @@ -451,10 +593,11 @@ , prevRandao ) - contract <- case (cmd.rpc, cmd.address, cmd.code) of + codeWrapped <- getCode cFileOpts.codeFile cFileOpts.code + contract <- case (cExecOpts.rpc, cExecOpts.address, codeWrapped) of (Just url, Just addr', Just c) -> do let code = hexByteString $ strip0x c - if (isNothing code) then do + if isNothing code then do putStrLn $ "Error, invalid code: " <> show c exitFailure else @@ -489,7 +632,7 @@ putStrLn "Error, must provide at least (rpc + address) or code" exitFailure - let ts' = case maybeLitWord ts of + let ts' = case maybeLitWordSimp ts of Just t -> t Nothing -> internalError "unexpected symbolic timestamp when executing vm test" @@ -501,24 +644,24 @@ pure $ EVM.Transaction.initTx vm where bsCallData = bytes (.calldata) (pure "") - block = maybe Fetch.Latest Fetch.BlockNumber cmd.block - value = word (.value) 0 + block = maybe Fetch.Latest Fetch.BlockNumber cExecOpts.block + val = word (.value) 0 caller = addr (.caller) (LitAddr 0) origin = addr (.origin) (LitAddr 0) calldata = ConcreteBuf $ fromJust bsCallData decipher = hexByteString . strip0x - mkCode bs = if cmd.create + mkCode bs = if execOpts.create then InitCode bs mempty else RuntimeCode (ConcreteRuntimeCode bs) - address = if cmd.create - then addr (.address) (Concrete.createAddress (fromJust $ maybeLitAddr origin) (W64 $ word64 (.nonce) 0)) + address = if execOpts.create + then addr (.address) (Concrete.createAddress (fromJust $ maybeLitAddrSimp origin) (W64 $ word64 (.nonce) 0)) else addr (.address) (LitAddr 0xacab) vm0 baseFee miner ts blockNum prevRan c = makeVm $ VMOpts { contract = c , otherContracts = [] , calldata = (calldata, []) - , value = Lit value + , value = Lit val , address = address , caller = caller , origin = origin @@ -527,7 +670,7 @@ , priorityFee = word (.priorityFee) 0 , gaslimit = word64 (.gaslimit) 0xffffffffffffffff , coinbase = addr (.coinbase) miner - , number = word (.number) blockNum + , number = maybe blockNum Lit cExecOpts.number , timestamp = Lit $ word (.timestamp) ts , blockGaslimit = word64 (.gaslimit) 0xffffffffffffffff , gasprice = word (.gasprice) 0 @@ -535,22 +678,22 @@ , prevRandao = word (.prevRandao) prevRan , schedule = feeSchedule , chainId = word (.chainid) 1 - , create = (.create) cmd + , create = (.create) execOpts , baseState = EmptyBase , txAccessList = mempty -- TODO: support me soon , allowFFI = False , freshAddresses = 0 , beaconRoot = 0 } - word f def = fromMaybe def (f cmd) - word64 f def = fromMaybe def (f cmd) - addr f def = maybe def LitAddr (f cmd) - bytes f def = maybe def decipher (f cmd) + word f def = fromMaybe def (f cExecOpts) + word64 f def = fromMaybe def (f cExecOpts) + addr f def = maybe def LitAddr (f cExecOpts) + bytes f def = maybe def decipher (f cOpts) -symvmFromCommand :: Command Options.Unwrapped -> (Expr Buf, [Prop]) -> IO (VM EVM.Types.Symbolic RealWorld) -symvmFromCommand cmd calldata = do - (miner,blockNum,baseFee,prevRan) <- case cmd.rpc of - Nothing -> pure (SymAddr "miner",0,0,0) +symvmFromCommand :: CommonExecOptions -> SymbolicOptions -> CommonFileOptions -> (Expr Buf, [Prop]) -> IO (VM EVM.Types.Symbolic RealWorld) +symvmFromCommand cExecOpts sOpts cFileOpts calldata = do + (miner,blockNum,baseFee,prevRan) <- case cExecOpts.rpc of + Nothing -> pure (SymAddr "miner",Lit 0,0,0) Just url -> Fetch.fetchBlockFrom block url >>= \case Nothing -> do putStrLn $ "Error, Could not fetch block" <> show block <> " from URL: " <> show url @@ -562,24 +705,25 @@ ) let - caller = maybe (SymAddr "caller") LitAddr cmd.caller - ts = maybe Timestamp Lit cmd.timestamp - callvalue = maybe TxValue Lit cmd.value - storageBase = maybe AbstractBase parseInitialStorage (cmd.initialStorage) + caller = maybe (SymAddr "caller") LitAddr cExecOpts.caller + ts = maybe Timestamp Lit cExecOpts.timestamp + callvalue = maybe TxValue Lit cExecOpts.value + storageBase = maybe AbstractBase parseInitialStorage (sOpts.initialStorage) - contract <- case (cmd.rpc, cmd.address, cmd.code) of + codeWrapped <- getCode cFileOpts.codeFile cFileOpts.code + contract <- case (cExecOpts.rpc, cExecOpts.address, codeWrapped) of (Just url, Just addr', _) -> Fetch.fetchContractFrom block url addr' >>= \case Nothing -> do putStrLn "Error, contract not found." exitFailure - Just contract' -> case cmd.code of + Just contract' -> case codeWrapped of Nothing -> pure contract' -- if both code and url is given, -- fetch the contract and overwrite the code Just c -> do let c' = decipher c - if (isNothing c') then do + if isNothing c' then do putStrLn $ "Error, invalid code: " <> show c exitFailure else pure $ do @@ -591,7 +735,7 @@ (_, _, Just c) -> do let c' = decipher c - if (isNothing c') then do + if isNothing c' then do putStrLn $ "Error, invalid code: " <> show c exitFailure else case storageBase of @@ -607,9 +751,9 @@ where decipher = hexByteString . strip0x - block = maybe Fetch.Latest Fetch.BlockNumber cmd.block + block = maybe Fetch.Latest Fetch.BlockNumber cExecOpts.block origin = eaddr (.origin) (SymAddr "origin") - mkCode bs = if cmd.create + mkCode bs = if sOpts.create then InitCode bs mempty else RuntimeCode (ConcreteRuntimeCode bs) address = eaddr (.address) (SymAddr "entrypoint") @@ -626,7 +770,7 @@ , baseFee = baseFee , priorityFee = word (.priorityFee) 0 , coinbase = eaddr (.coinbase) miner - , number = word (.number) blockNum + , number = maybe blockNum Lit cExecOpts.number , timestamp = ts , blockGaslimit = word64 (.gaslimit) 0xffffffffffffffff , gasprice = word (.gasprice) 0 @@ -634,49 +778,44 @@ , prevRandao = word (.prevRandao) prevRan , schedule = feeSchedule , chainId = word (.chainid) 1 - , create = (.create) cmd + , create = (.create) sOpts , baseState = baseState , txAccessList = mempty , allowFFI = False , freshAddresses = 0 , beaconRoot = 0 } - word f def = fromMaybe def (f cmd) - word64 f def = fromMaybe def (f cmd) - eaddr f def = maybe def LitAddr (f cmd) + word f def = fromMaybe def (f cExecOpts) + word64 f def = fromMaybe def (f cExecOpts) + eaddr f def = maybe def LitAddr (f cExecOpts) -unitTestOptions :: Command Options.Unwrapped -> SolverGroup -> Maybe BuildOutput -> IO (UnitTestOptions RealWorld) -unitTestOptions cmd solvers buildOutput = do - root <- getRoot cmd +unitTestOptions :: TestOptions -> CommonOptions -> SolverGroup -> Maybe BuildOutput -> IO (UnitTestOptions RealWorld) +unitTestOptions testOpts cOpts solvers buildOutput = do + root <- getRoot cOpts let srcInfo = maybe emptyDapp (dappInfo root) buildOutput - - let rpcinfo = case (cmd.number, cmd.rpc) of + let rpcinfo = case (testOpts.number, testOpts.rpc) of (Just block, Just url) -> Just (Fetch.BlockNumber block, url) (Nothing, Just url) -> Just (Fetch.Latest, url) _ -> Nothing params <- paramsFromRpc rpcinfo - - let - testn = params.number - block' = if 0 == testn + let testn = params.number + block' = if 0 == testn then Fetch.Latest else Fetch.BlockNumber testn - pure UnitTestOptions { solvers = solvers - , rpcInfo = case cmd.rpc of + , rpcInfo = case testOpts.rpc of Just url -> Just (block', url) Nothing -> Nothing - , maxIter = parseMaxIters cmd.maxIterations - , askSmtIters = cmd.askSmtIterations - , smtTimeout = cmd.smttimeout - , solver = cmd.solver - , verbose = cmd.verbose - , match = T.pack $ fromMaybe ".*" cmd.match + , maxIter = parseMaxIters cOpts.maxIterations + , askSmtIters = cOpts.askSmtIterations + , smtTimeout = Just cOpts.smttimeout + , match = T.pack $ fromMaybe ".*" testOpts.match + , prefix = T.pack testOpts.prefix , testParams = params , dapp = srcInfo - , ffiAllowed = cmd.ffi - , checkFailBit = (fromMaybe Forge cmd.assertionType) == DSTest + , ffiAllowed = testOpts.ffi + , checkFailBit = cOpts.assertionType == DSTest } parseInitialStorage :: InitialStorage -> BaseState parseInitialStorage Empty = EmptyBase diff --git a/hevm.cabal b/hevm.cabal --- a/hevm.cabal +++ b/hevm.cabal @@ -2,7 +2,7 @@ name: hevm version: - 0.54.2 + 0.55.1 synopsis: Symbolic EVM Evaluator description: @@ -12,7 +12,7 @@ license: AGPL-3.0-only author: - dxo, Martin Lundfall, Mikael Brockman + dxo, Martin Lundfall, Mikael Brockman, Martin Blicha, Zoe Paraskevopoulou, Mate Soos maintainer: git@d-xo.org category: @@ -89,6 +89,7 @@ library import: shared + default-language: GHC2021 exposed-modules: EVM, EVM.ABI, @@ -146,11 +147,11 @@ containers >= 0.6.0 && < 0.7, transformers >= 0.5 && < 0.7, tree-view >= 0.5 && < 0.6, - aeson >= 2.0.0 && < 2.2, - bytestring >= 0.11.3.1 && < 0.12, + aeson >= 2.0.0 && < 2.3, + bytestring >= 0.11.3.1 && < 0.13, scientific >= 0.3.6 && < 0.4, binary >= 0.8.6 && < 0.9, - text >= 1.2.3 && < 2.1, + text >= 1.2.3 && < 2.2, unordered-containers >= 0.2.10 && < 0.3, vector >= 0.12.1 && < 0.14, base16 >= 1.0 && < 1.1, @@ -190,6 +191,7 @@ executable hevm import: shared + default-language: GHC2021 hs-source-dirs: cli main-is: @@ -203,21 +205,23 @@ base, bytestring, data-dword, - directory, + directory >= 1.3.6 && < 1.4, filepath, hevm, optparse-generic, + optparse-applicative >= 0.18.0.0 && < 0.20.0.0, text, optics-core, - githash, + githash >= 0.1.5 && < 0.2, witch, unliftio-core, - with-utf8, + split, --- Test Helpers --- common test-base import: shared + default-language: GHC2021 hs-source-dirs: test other-modules: @@ -231,12 +235,10 @@ base, containers, directory, - extra, bytestring, filemanip, filepath, hevm, - here, mtl, process, tasty, @@ -256,6 +258,7 @@ library test-utils import: test-base + default-language: GHC2021 exposed-modules: EVM.Test.Utils EVM.Test.Tracing @@ -263,6 +266,7 @@ common test-common import: test-base + default-language: GHC2021 if flag(devel) ghc-options: -threaded -with-rtsopts=-N build-depends: @@ -276,6 +280,7 @@ test-suite test import: test-common + default-language: GHC2021 type: exitcode-stdio-1.0 main-is: @@ -284,6 +289,8 @@ base16, binary, data-dword, + extra, + here, time, regex @@ -291,6 +298,7 @@ -- suite to make it easy to skip them when running nix-build test-suite rpc-tests import: test-common + default-language: GHC2021 type: exitcode-stdio-1.0 main-is: @@ -298,15 +306,36 @@ test-suite ethereum-tests import: test-common + default-language: GHC2021 type: exitcode-stdio-1.0 main-is: BlockchainTests.hs +test-suite cli-test + type: + exitcode-stdio-1.0 + default-language: GHC2021 + hs-source-dirs: + test + main-is: + clitest.hs + build-depends: + base, + hevm, + hspec, + process, + text, + bytestring, + filepath, + split, + here, + --- Benchmarks --- benchmark bench import: shared + default-language: GHC2021 type: exitcode-stdio-1.0 main-is: @@ -331,3 +360,27 @@ filepath, containers, unliftio-core + +benchmark bench-perf + import: shared + default-language: GHC2021 + type: + exitcode-stdio-1.0 + main-is: + bench-perf.hs + hs-source-dirs: + bench + ghc-options: + -O2 -threaded -with-rtsopts=-N -fproc-alignment=64 + other-modules: + Paths_hevm + autogen-modules: + Paths_hevm + build-depends: + base, + here, + hevm, + mtl, + tasty-bench, + test-utils, + utf8-string diff --git a/src/EVM.hs b/src/EVM.hs --- a/src/EVM.hs +++ b/src/EVM.hs @@ -9,7 +9,6 @@ import Optics.State import Optics.State.Operators import Optics.Zoom -import Optics.Operators.Unsafe import EVM.ABI import EVM.Expr (readStorage, writeStorage, readByte, readWord, writeWord, @@ -24,6 +23,8 @@ import EVM.Sign qualified import EVM.Concrete qualified as Concrete import EVM.CheatsTH +import EVM.Expr (maybeLitByteSimp, maybeLitWordSimp, maybeLitAddrSimp) +import EVM.Effects (Config (..)) import Control.Monad (unless, when) import Control.Monad.ST (ST) @@ -45,7 +46,7 @@ import Data.List.Split (splitOn) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe, fromJust, isJust) +import Data.Maybe (fromMaybe, fromJust, isJust, isNothing) import Data.Set (insert, member, fromList) import Data.Sequence (Seq) import Data.Sequence qualified as Seq @@ -55,10 +56,9 @@ import Data.Tree.Zipper qualified as Zipper import Data.Typeable import Data.Vector qualified as V -import Data.Vector.Storable qualified as SV -import Data.Vector.Storable.Mutable qualified as SV -import Data.Vector.Unboxed qualified as VUnboxed -import Data.Vector.Unboxed.Mutable qualified as VUnboxed.Mutable +import Data.Vector.Storable qualified as VS +import Data.Vector.Storable.Mutable qualified as VS.Mutable +import Data.Vector.Storable.ByteString (vectorToByteString) import Data.Word (Word8, Word32, Word64) import Text.Read (readMaybe) import Witch (into, tryFrom, unsafeInto, tryInto) @@ -69,7 +69,7 @@ blankState :: VMOps t => ST s (FrameState t s) blankState = do - memory <- ConcreteMemory <$> VUnboxed.Mutable.new 0 + memory <- ConcreteMemory <$> VS.Mutable.new 0 pure $ FrameState { contract = LitAddr 0 , codeContract = LitAddr 0 @@ -116,7 +116,7 @@ ++ (Map.keys txaccessList) initialAccessedStorageKeys = fromList $ foldMap (uncurry (map . (,))) (Map.toList txaccessList) touched = if o.create then [txorigin] else [txorigin, txtoAddr] - memory <- ConcreteMemory <$> VUnboxed.Mutable.new 0 + memory <- ConcreteMemory <$> VS.Mutable.new 0 pure $ setEIP4788Storage o $ VM { result = Nothing , frames = mempty @@ -164,6 +164,8 @@ , currentFork = 0 , labels = mempty , osEnv = mempty + , freshVar = 0 + , exploreDepth = 0 } where env = Env @@ -281,14 +283,14 @@ RuntimeCode (ConcreteRuntimeCode bs) -> BS.index bs state.pc RuntimeCode (SymbolicRuntimeCode ops) -> fromMaybe (internalError "could not analyze symbolic code") $ - maybeLitByte $ ops V.! state.pc + maybeLitByteSimp $ ops V.! state.pc getOpName :: forall (t :: VMType) s . FrameState t s -> [Char] getOpName state = intToOpName $ fromEnum $ getOpW8 state -- | Executes the EVM one step -exec1 :: forall (t :: VMType) s. VMOps t => EVM t s () -exec1 = do +exec1 :: forall (t :: VMType) s. (VMOps t) => Config -> EVM t s () +exec1 conf = do vm <- get let @@ -296,12 +298,9 @@ stk = vm.state.stack self = vm.state.contract this = fromMaybe (internalError "state contract") (Map.lookup self vm.env.contracts) - fees@FeeSchedule {..} = vm.block.schedule - doStop = finishFrame (FrameReturned mempty) - - litSelf = maybeLitAddr self + litSelf = maybeLitAddrSimp self if isJust litSelf && (fromJust litSelf) > 0x0 && (fromJust litSelf) <= 0xa then do -- call to precompile @@ -321,8 +320,7 @@ touchAccount self out <- use (#state % #returndata) finishFrame (FrameReturned out) - e -> partial $ - UnexpectedSymbolicArg vmx.state.pc (getOpName vmx.state) "precompile returned a symbolic value" (wrap [e]) + e -> unexpectedSymArg "precompile returned a symbolic value" [e] _ -> underrun @@ -330,9 +328,8 @@ then doStop else do + let ?conf = conf let ?op = getOpW8 vm.state - let opName = getOpName vm.state - case getOp (?op) of OpPush0 -> do @@ -365,14 +362,16 @@ pushSym y OpSwap i -> - if length stk < (into i) + 1 - then underrun - else + case (stk ^? ix_i, stk ^? ix_0) of + (Just ei, Just e0) -> burn g_verylow $ do next zoom (#state % #stack) $ do - assign (ix 0) (stk ^?! ix (into i)) - assign (ix (into i)) (stk ^?! ix 0) + ix_i .= e0 + ix_0 .= ei + _ -> underrun + where + (ix_i, ix_0) = (ix (into i), ix 0) OpLog n -> notStatic $ @@ -450,14 +449,13 @@ OpBalance -> case stk of - x:xs -> forceAddr x "BALANCE" $ \a -> + x:xs -> forceAddr x (freshVarFallback xs) $ \a -> accessAndBurn a $ - fetchAccount a $ \c -> do + fetchAccountWithFallback a (freshVarFallback xs) $ \c -> do next assign (#state % #stack) xs pushSym c.balance - [] -> - underrun + [] -> underrun OpOrigin -> limitStack 1 . burn g_base $ @@ -510,9 +508,9 @@ OpExtcodesize -> case stk of - x':xs -> forceAddr x' "EXTCODESIZE" $ \x -> do + x':xs -> forceAddr x' (freshVarFallback xs) $ \x -> do let impl = accessAndBurn x $ - fetchAccount x $ \c -> do + fetchAccountWithFallback x (freshVarFallback xs) $ \c -> do next assign (#state % #stack) xs case view bytecode c of @@ -532,7 +530,7 @@ OpExtcodecopy -> case stk of extAccount':memOffset:codeOffset:codeSize:xs -> - forceAddr extAccount' "EXTCODECOPY" $ \extAccount -> do + forceAddr extAccount' (unexpectedSymArgW "EXTCODECOPY") $ \extAccount -> do burnExtcodecopy extAccount codeSize $ accessMemoryRange memOffset codeSize $ fetchAccount extAccount $ \c -> do @@ -540,9 +538,7 @@ assign (#state % #stack) xs case view bytecode c of Just b -> copyBytesToMemory b codeSize codeOffset memOffset - Nothing -> do - pc <- use (#state % #pc) - partial $ UnexpectedSymbolicArg pc opName "Cannot copy from unknown code at" (wrap [extAccount]) + Nothing -> unexpectedSymArg "Cannot copy from unknown code at" [extAccount] _ -> underrun OpReturndatasize -> @@ -566,16 +562,16 @@ _ -> do let oob = Expr.lt (bufLength vm.state.returndata) (Expr.add xFrom xSize) overflow = Expr.lt (Expr.add xFrom xSize) (xFrom) - branch (Expr.or oob overflow) jump + branch conf.maxDepth (Expr.or oob overflow) jump _ -> underrun OpExtcodehash -> case stk of - x':xs -> forceAddr x' "EXTCODEHASH" $ \x -> + x':xs -> forceAddr x' (freshVarFallback xs) $ \x -> accessAndBurn x $ do - next - assign (#state % #stack) xs - fetchAccount x $ \c -> + fetchAccountWithFallback x (freshVarFallback xs) $ \c -> do + next + assign (#state % #stack) xs if accountEmpty c then push (W256 0) else case view bytecode c of @@ -585,13 +581,21 @@ 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 (into i :: Integer) & show & Char8.pack & keccak' & Lit + Lit i -> case vm.block.number of + Lit vmBlockNumber -> + if i + 256 < vmBlockNumber || i >= vmBlockNumber + -- blockhash is 0 if block is too old or too new as per EVM spec + then Lit 0 + -- We adopt the fake block hash scheme of the VMTests, + -- so that blockhash(i) is the hash of i as decimal ASCII. + else fakeBlockHash i + -- For symbolic block numbers, we don't know if it's too old or too new, + -- so we return fake block hash + _ -> fakeBlockHash i i -> BlockHash i + where + fakeBlockHash i = (into i :: Integer) & show & Char8.pack & keccak' & Lit OpCoinbase -> limitStack 1 . burn g_base $ @@ -603,7 +607,7 @@ OpNumber -> limitStack 1 . burn g_base $ - next >> push vm.block.number + next >> pushSym vm.block.number OpPrevRandao -> do limitStack 1 . burn g_base $ @@ -670,9 +674,9 @@ mcopy sz srcOff dstOff = do m <- gets (.state.memory) case m of - ConcreteMemory mem -> do - buf <- freezeMemory mem - copyBytesToMemory buf sz srcOff dstOff + ConcreteMemory _ -> do + buf <- readMemory srcOff sz + copyBytesToMemory buf sz (Lit 0) dstOff SymbolicMemory mem -> do assign (#state % #memory) (SymbolicMemory $ copySlice srcOff dstOff sz mem mem) @@ -741,7 +745,7 @@ Lit v -> v _ -> 0 storage_cost = - case (maybeLitWord current, maybeLitWord new) of + case (maybeLitWordSimp current, maybeLitWordSimp new) of (Just current', Just new') -> if (current' == new') then g_sload else if (current' == original) && (original == 0) then g_sset @@ -759,7 +763,7 @@ assign (#state % #stack) xs modifying (#env % #contracts % ix self % #storage) (writeStorage x new) - case (maybeLitWord current, maybeLitWord new) of + case (maybeLitWordSimp current, maybeLitWordSimp new) of (Just current', Just new') -> unless (current' == new') $ if current' == original then @@ -801,7 +805,7 @@ OpJump -> case stk of x:xs -> - burn g_mid $ forceConcrete x "JUMP: symbolic jumpdest" $ \x' -> + burn g_mid $ forceConcreteLimitSz x 2 "JUMP: symbolic jumpdest" $ \x' -> case tryInto x' of Left _ -> vmError BadJumpDestination Right i -> checkJump i xs @@ -809,14 +813,14 @@ OpJumpi -> case stk of - x:y:xs -> forceConcrete x "JUMPI: symbolic jumpdest" $ \x' -> + x:y:xs -> forceConcreteLimitSz x 2 "JUMPI: symbolic jumpdest" $ \x' -> burn g_high $ let jump :: Bool -> EVM t s () jump False = assign (#state % #stack) xs >> next jump _ = case tryInto x' of Left _ -> vmError BadJumpDestination Right i -> checkJump i xs - in branch y jump + in branch conf.maxDepth y jump _ -> underrun OpPc -> @@ -861,7 +865,12 @@ assign (#state % #overrideCaller) Nothing assign (#state % #resetCaller) False - newAddr <- createAddress from' this.nonce + touchAddress from' + nonce <- zoom (#env % #contracts) $ do + contr <- use (at from') + pure $ (\c -> c.nonce) =<< contr + + newAddr <- createAddress from' nonce _ <- accessAccountForGas newAddr burn' cost $ do initCode <- readMemory xOffset xSize @@ -871,14 +880,18 @@ OpCall -> case stk of xGas:xTo':xValue:xInOffset:xInSize:xOutOffset:xOutSize:xs -> - branch (Expr.gt xValue (Lit 0)) $ \gt0 -> do + branch conf.maxDepth (Expr.gt xValue (Lit 0)) $ \gt0 -> do + let addrFallback = if conf.promiseNoReent then const fallback + else unexpectedSymArgW "unable to determine a call target" (if gt0 then notStatic else id) $ - forceAddr xTo' "unable to determine a call target" $ \xTo -> + forceAddr xTo' addrFallback $ \xTo -> case gasTryFrom xGas of Left _ -> vmError IllegalOverflow Right gas -> do overrideC <- use $ #state % #overrideCaller - delegateCall this gas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ + let delegateFallback = if conf.promiseNoReent then const fallback + else unknownCode + delegateCall this gas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs delegateFallback $ \callee -> do let from' = fromMaybe self overrideC zoom #state $ do @@ -888,24 +901,23 @@ touchAccount from' touchAccount callee transfer from' callee xValue - _ -> - underrun + where fallback = freshBufFallback xs + _ -> underrun OpCallcode -> case stk of xGas:xTo':xValue:xInOffset:xInSize:xOutOffset:xOutSize:xs -> - forceAddr xTo' "unable to determine a call target" $ \xTo -> + forceAddr xTo' (unexpectedSymArgW "unable to determine a call target") $ \xTo -> case gasTryFrom xGas of Left _ -> vmError IllegalOverflow Right gas -> do overrideC <- use $ #state % #overrideCaller - delegateCall this gas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do + delegateCall this gas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs unknownCode $ \_ -> do zoom #state $ do assign #callvalue xValue assign #caller $ fromMaybe self overrideC touchAccount self - _ -> - underrun + _ -> underrun OpReturn -> case stk of @@ -914,7 +926,7 @@ output <- readMemory xOffset xSize let codesize = fromMaybe (internalError "processing opcode RETURN. Cannot return dynamically sized abstract data") - . maybeLitWord . bufLength $ output + . maybeLitWordSimp . bufLength $ output maxsize = vm.block.maxCodeSize creation = case vm.frames of [] -> vm.tx.isCreate @@ -933,7 +945,7 @@ case readByte (Lit 0) output of LitByte 0xef -> frameErrored LitByte _ -> frameReturned - y -> branch (Expr.eqByte y (LitByte 0xef)) $ \case + y -> branch conf.maxDepth (Expr.eqByte y (LitByte 0xef)) $ \case True -> frameErrored False -> frameReturned else @@ -943,16 +955,13 @@ OpDelegatecall -> case stk of xGas:xTo:xInOffset:xInSize:xOutOffset:xOutSize:xs -> - case wordToAddr xTo of - Nothing -> do - loc <- codeloc - let msg = "Unable to determine a call target" - partial $ UnexpectedSymbolicArg (snd loc) opName msg [SomeExpr xTo] - Just xTo' -> + forceAddr xTo (const $ unexpectedSymArg "unable to determine a call target" [xTo]) $ \xTo' -> case gasTryFrom xGas of Left _ -> vmError IllegalOverflow Right gas -> - delegateCall this gas xTo' self (Lit 0) xInOffset xInSize xOutOffset xOutSize xs $ + -- NOTE: we don't update overrideCaller in this case because + -- forge-std doesn't. see: https://github.com/foundry-rs/foundry/pull/8863 + delegateCall this gas xTo' self (Lit 0) xInOffset xInSize xOutOffset xOutSize xs unknownCode $ \_ -> touchAccount self _ -> underrun @@ -972,6 +981,8 @@ assign (#state % #overrideCaller) Nothing assign (#state % #resetCaller) False + touchAddress from' + let (cost, gas') = costOfCreate fees availableGas xSize True newAddr <- create2Address self xSalt initCode _ <- accessAccountForGas newAddr @@ -982,33 +993,28 @@ OpStaticcall -> case stk of xGas:xTo:xInOffset:xInSize:xOutOffset:xOutSize:xs -> - case wordToAddr xTo of - Nothing -> do - loc <- codeloc - let msg = "Unable to determine a call target" - partial $ UnexpectedSymbolicArg (snd loc) opName msg [SomeExpr xTo] - Just xTo' -> - case gasTryFrom xGas of - Left _ -> vmError IllegalOverflow - Right gas -> do - overrideC <- use $ #state % #overrideCaller - delegateCall this gas xTo' xTo' (Lit 0) xInOffset xInSize xOutOffset xOutSize xs $ - \callee -> do - zoom #state $ do - assign #callvalue (Lit 0) - assign #caller $ fromMaybe self overrideC - assign #contract callee - assign #static True - touchAccount self - touchAccount callee - _ -> - underrun + forceAddr xTo (const fallback) $ \xTo' -> case gasTryFrom xGas of + Left _ -> vmError IllegalOverflow + Right gas -> do + overrideC <- use $ #state % #overrideCaller + delegateCall this gas xTo' xTo' (Lit 0) xInOffset xInSize xOutOffset xOutSize xs (const fallback) $ + \callee -> do + zoom #state $ do + assign #callvalue (Lit 0) + assign #caller $ fromMaybe self overrideC + assign #contract callee + assign #static True + touchAccount self + touchAccount callee + where + fallback = freshBufFallback xs + _ -> underrun OpSelfdestruct -> notStatic $ case stk of [] -> underrun - (xTo':_) -> forceAddr xTo' "SELFDESTRUCT" $ \case + (xTo':_) -> forceAddr xTo' (unexpectedSymArgW "SELFDESTRUCT") $ \case xTo@(LitAddr _) -> do cc <- gets (.tx.subState.createdContracts) let createdThisTr = self `member` cc @@ -1016,7 +1022,7 @@ let cost = if acc then 0 else g_cold_account_access funds = this.balance recipientExists = accountExists xTo vm - branch (Expr.iszero $ Expr.eq funds (Lit 0)) $ \hasFunds -> do + branch conf.maxDepth (Expr.iszero $ Expr.eq funds (Lit 0)) $ \hasFunds -> do let c_new = if (not recipientExists) && hasFunds then g_selfdestruct_newaccount else 0 @@ -1033,9 +1039,7 @@ doStop else doStop - a -> do - pc <- use (#state % #pc) - partial $ UnexpectedSymbolicArg pc opName "trying to self destruct to a symbolic address" (wrap [a]) + a -> unexpectedSymArg "trying to self destruct to a symbolic address" [a] OpRevert -> case stk of @@ -1045,22 +1049,17 @@ finishFrame (FrameReverted output) _ -> underrun - OpUnknown xxx -> - vmError $ UnrecognizedOpcode xxx + OpUnknown xxx -> vmError $ UnrecognizedOpcode xxx -transfer :: VMOps t => Expr EAddr -> Expr EAddr -> Expr EWord -> EVM t s () +transfer :: (VMOps t, ?conf::Config) => Expr EAddr -> Expr EAddr -> Expr EWord -> EVM t s () transfer _ _ (Lit 0) = pure () transfer src dst val = do sb <- preuse $ #env % #contracts % ix src % #balance db <- preuse $ #env % #contracts % ix dst % #balance - baseState <- use (#config % #baseState) - let mkc = case baseState of - AbstractBase -> unknownContract - EmptyBase -> const emptyContract case (sb, db) of -- both sender and recipient in state (Just srcBal, Just _) -> - branch (Expr.gt val srcBal) $ \case + branch (?conf).maxDepth (Expr.gt val srcBal) $ \case True -> vmError $ BalanceTooLow val srcBal False -> do (#env % #contracts % ix src % #balance) %= (`Expr.sub` val) @@ -1069,28 +1068,22 @@ (Nothing, Just _) -> do case src of LitAddr _ -> do - (#env % #contracts) %= (Map.insert src (mkc src)) + touchAddress src transfer src dst val - SymAddr _ -> do - pc <- use (#state % #pc) - state <- use #state - partial $ UnexpectedSymbolicArg pc (getOpName state) "Attempting to transfer eth from a symbolic address that is not present in the state" (wrap [src]) + SymAddr _ -> unexpectedSymArg "Attempting to transfer eth from a symbolic address that is not present in the state" [src] GVar _ -> internalError "Unexpected GVar" -- recipient not in state (_ , Nothing) -> do case dst of LitAddr _ -> do - (#env % #contracts) %= (Map.insert dst (mkc dst)) + touchAddress dst transfer src dst val - SymAddr _ -> do - pc <- use (#state % #pc) - state <- use #state - partial $ UnexpectedSymbolicArg pc (getOpName state) "Attempting to transfer eth to a symbolic address that is not present in the state" (wrap [dst]) + SymAddr _ -> unexpectedSymArg "Attempting to transfer eth to a symbolic address that is not present in the state" [dst] GVar _ -> internalError "Unexpected GVar" -- | Checks a *CALL for failure; OOG, too many callframes, memory access etc. callChecks - :: forall (t :: VMType) s. (?op :: Word8, VMOps t) + :: forall (t :: VMType) s. (?op :: Word8, ?conf :: Config, VMOps t) => Contract -> Gas t -> Expr EAddr @@ -1129,7 +1122,7 @@ -- from is in the state, we check if they have enough balance (Just fb, _) -> do burn (cost - gas') $ - branch (Expr.gt xValue fb) $ \case + branch (?conf).maxDepth (Expr.gt xValue fb) $ \case True -> do assign (#state % #stack) (Lit 0 : xs) assign (#state % #returndata) mempty @@ -1149,14 +1142,11 @@ callChecks this xGas xContext xTo xValue xInOffset xInSize xOutOffset xOutSize xs continue -- adding a symbolic address into the state here would be unsound (due to potential aliasing) - SymAddr _ -> do - pc <- use (#state % #pc) - state <- use #state - partial $ UnexpectedSymbolicArg pc (getOpName state) "Attempting to transfer eth from a symbolic address that is not present in the state" (wrap [from]) + SymAddr _ -> unexpectedSymArg "Attempting to transfer eth from a symbolic address that is not present in the state" [from] GVar _ -> internalError "Unexpected GVar" precompiledContract - :: (?op :: Word8, VMOps t) + :: (?conf :: Config, ?op :: Word8, VMOps t) => Contract -> Gas t -> Addr @@ -1171,12 +1161,10 @@ executePrecompile precompileAddr gas' inOffset inSize outOffset outSize xs self <- use (#state % #contract) stk <- use (#state % #stack) - pc' <- use (#state % #pc) result' <- use #result - vm <- get case result' of Nothing -> case stk of - x:_ -> case maybeLitWord x of + x:_ -> case maybeLitWordSimp x of Just 0 -> pure () Just 1 -> @@ -1184,8 +1172,7 @@ touchAccount self touchAccount (LitAddr recipient) transfer self (LitAddr recipient) xValue - _ -> partial $ - UnexpectedSymbolicArg pc' (getOpName vm.state) "unexpected return value from precompile" (wrap [x]) + _ -> unexpectedSymArg "unexpected return value from precompile" [x] _ -> underrun _ -> pure () @@ -1380,21 +1367,36 @@ getCodeLocation vm = (vm.state.contract, vm.state.pc) query :: Query t s -> EVM t s () -query = assign #result . Just . HandleEffect . Query +query q = assign #result $ Just $ HandleEffect (Query q) -choose :: Choose s -> EVM Symbolic s () -choose = assign #result . Just . HandleEffect . Choose +runBoth :: Maybe Int -> Int -> RunBoth s -> EVM Symbolic s () +runBoth depthLimit exploreDepth c = do + if (isNothing depthLimit || (exploreDepth < fromJust depthLimit)) then do + assign #result $ Just $ HandleEffect (RunBoth c) + else do + vm <- get + assign #result $ Just $ Unfinished (BranchTooDeep {pc = vm.state.pc}) --- | Construct RPC Query and halt execution until resolved +runAll :: Maybe Int -> Int -> RunAll s -> EVM Symbolic s () +runAll depthLimit exploreDepth c = do + if (isNothing depthLimit || (exploreDepth < fromJust depthLimit)) then do + assign #result $ Just $ HandleEffect (RunAll c) + else do + vm <- get + assign #result $ Just $ Unfinished (BranchTooDeep {pc = vm.state.pc}) + fetchAccount :: VMOps t => Expr EAddr -> (Contract -> EVM t s ()) -> EVM t s () fetchAccount addr continue = + let fallback = unexpectedSymArgW "trying to access a symbolic address that isn't already present in storage" + in fetchAccountWithFallback addr fallback continue + +-- | Construct RPC Query and halt execution until resolved +fetchAccountWithFallback :: VMOps t => Expr EAddr -> (Expr EAddr -> EVM t s ()) -> (Contract -> EVM t s ()) -> EVM t s () +fetchAccountWithFallback addr fallback continue = use (#env % #contracts % at addr) >>= \case Just c -> continue c Nothing -> case addr of - SymAddr _ -> do - pc <- use (#state % #pc) - state <- use #state - partial $ UnexpectedSymbolicArg pc (getOpName state) "trying to access a symbolic address that isn't already present in storage" (wrap [addr]) + SymAddr _ -> fallback addr LitAddr a -> do use (#cache % #fetched % at a) >>= \case Just c -> do @@ -1403,15 +1405,15 @@ Nothing -> do base <- use (#config % #baseState) assign (#result) . Just . HandleEffect . Query $ - PleaseFetchContract a base - (\c -> do assign (#cache % #fetched % at a) (Just c) - assign (#env % #contracts % at addr) (Just c) - assign #result Nothing - continue c) + PleaseFetchContract a base $ \c -> do + assign (#cache % #fetched % at a) (Just c) + assign (#env % #contracts % at addr) (Just c) + assign #result Nothing + continue c GVar _ -> internalError "Unexpected GVar" accessStorage - :: VMOps t => Expr EAddr + :: (?conf :: Config, VMOps t) => Expr EAddr -> Expr EWord -> (Expr EWord -> EVM t s ()) -> EVM t s () @@ -1446,13 +1448,11 @@ else do modifying (#env % #contracts % ix addr % #storage) (writeStorage slot (Lit 0)) continue $ Lit 0 - mkQuery a s = query $ - PleaseFetchSlot a s - (\x -> do + mkQuery a s = query $ PleaseFetchSlot a s $ \x -> do modifying (#cache % #fetched % ix a % #storage) (writeStorage (Lit s) (Lit x)) modifying (#env % #contracts % ix (LitAddr a) % #storage) (writeStorage (Lit s) (Lit x)) assign #result Nothing - continue (Lit x)) + continue $ Lit x accessTStorage :: VMOps t => Expr EAddr @@ -1494,6 +1494,16 @@ -- TODO: handle symbolic balance... && c.balance == Lit 0 +-- Adds constraints such that two symbolic addresses cannot alias each other +-- and symbolic addresses cannot alias concrete addresses +addAliasConstraints :: EVM t s () +addAliasConstraints = do + vm <- get + let addrConstr = noClash $ Map.keys vm.env.contracts + modifying #constraints ((++) addrConstr) + where + noClash addrs = [a ./= b | a <- addrs, b <- addrs, Expr.isSymAddr b, a < b] + -- * How to finalize a transaction finalize :: VMOps t => EVM t s () finalize = do @@ -1501,6 +1511,7 @@ revertContracts = use (#tx % #txReversion) >>= assign (#env % #contracts) revertSubstate = assign (#tx % #subState) (SubState mempty mempty mempty mempty mempty mempty) + addAliasConstraints use #result >>= \case Just (VMFailure (Revert _)) -> do revertContracts @@ -1513,22 +1524,16 @@ Just (VMSuccess output) -> do clearTStorages -- 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) when (creation && createeExists) $ case output of - ConcreteBuf bs -> - replaceCode createe (RuntimeCode (ConcreteRuntimeCode bs)) + ConcreteBuf bs -> replaceCode createe (RuntimeCode (ConcreteRuntimeCode bs)) _ -> case Expr.toList output of - Nothing -> do - state <- use #state - partial $ - UnexpectedSymbolicArg pc' (getOpName state) "runtime code cannot have an abstract length" (wrap [output]) - Just ops -> - replaceCode createe (RuntimeCode (SymbolicRuntimeCode ops)) + Nothing -> unexpectedSymArg "runtime code cannot have an abstract length" [output] + Just ops -> replaceCode createe (RuntimeCode (SymbolicRuntimeCode ops)) _ -> internalError "Finalising an unfinished tx." @@ -1583,46 +1588,97 @@ then vmError StateChangeWhileStatic else continue -forceAddr :: VMOps t => Expr EWord -> String -> (Expr EAddr -> EVM t s ()) -> EVM t s () -forceAddr n msg continue = case wordToAddr n of - Nothing -> do - vm <- get - partial $ UnexpectedSymbolicArg vm.state.pc (getOpName vm.state) msg (wrap [n]) +-- Ensures the account `addr` exists on the VM environment. +-- Useful when `addr` needs to e.g. keep a eth balance or +-- be the source of contract deployments via pranks +touchAddress :: VMOps t => Expr EAddr -> EVM t s () +touchAddress addr = do + baseState <- use (#config % #baseState) + let mkc = case baseState of + AbstractBase -> unknownContract + EmptyBase -> const emptyContract + (#env % #contracts) %= (Map.insertWith (\_ e -> e) addr (mkc addr)) + +forceAddr :: (?conf :: Config, VMOps t) => + Expr EWord + -> (Expr EWord -> EVM t s ()) + -> (Expr EAddr -> EVM t s ()) + -> EVM t s () +forceAddr n fallback continue = case wordToAddr n of + Nothing -> manySolutions (?conf).maxDepth n 20 $ \case + Just sol -> continue $ LitAddr (truncateToAddr sol) + Nothing -> fallback n Just c -> continue c -forceConcrete :: VMOps t => Expr EWord -> String -> (W256 -> EVM t s ()) -> EVM t s () -forceConcrete n msg continue = case maybeLitWord n of - Nothing -> do - vm <- get - partial $ UnexpectedSymbolicArg vm.state.pc (getOpName vm.state) msg (wrap [n]) +unexpectedSymArg :: (Typeable a, VMOps t) => String -> [Expr a] -> EVM t s () +unexpectedSymArg msg n = do + pc <- use (#state % #pc) + state <- use #state + let opName = getOpName state + partial $ UnexpectedSymbolicArg pc opName msg (wrap n) + +unexpectedSymArgW :: (Typeable a, VMOps t) => String -> Expr a -> EVM t s () +unexpectedSymArgW msg n = unexpectedSymArg msg [n] + +unknownCode :: VMOps t => Expr EAddr -> EVM t s () +unknownCode n = unexpectedSymArg "call target has unknown code" [n] + +freshBufFallback :: (?conf :: Config, VMOps t, ?op :: Word8) => [Expr EWord] -> EVM t s () +freshBufFallback xs = do + -- Reset caller if needed + resetCaller <- use $ #state % #resetCaller + when resetCaller $ assign (#state % #overrideCaller) Nothing + -- overapproximate by returning a symbolic value + freshVar <- use #freshVar + assign #freshVar (freshVar + 1) + let opName = pack $ show $ getOp ?op + let freshVarExpr = Var (opName <> "-result-stack-fresh-" <> (pack . show) freshVar) + modifying #constraints ((:) (PLEq freshVarExpr (Lit 1) )) + let freshReturndataExpr = AbstractBuf (opName <> "-result-data-fresh-" <> (pack . show) freshVar) + modifying #constraints ((:) (PLEq (bufLength freshReturndataExpr) (Lit (2 ^ ?conf.maxBufSize)))) + assign (#state % #returndata) freshReturndataExpr + next >> assign (#state % #stack) (freshVarExpr:xs) + +freshVarFallback:: (VMOps t, ?op :: Word8) => [Expr EWord] -> Expr a -> EVM t s () +freshVarFallback xs _ = do + -- Reset caller if needed + resetCaller <- use $ #state % #resetCaller + when resetCaller $ assign (#state % #overrideCaller) Nothing + -- overapproximate by returning a symbolic value + freshVar <- use #freshVar + assign #freshVar (freshVar + 1) + let opName = pack $ show $ getOp ?op + let freshVarExpr = Var (opName <> "-result-stack-fresh-" <> (pack . show) freshVar) + next >> assign (#state % #stack) (freshVarExpr:xs) + +forceConcrete :: (?conf :: Config, VMOps t) => Expr EWord -> String -> (W256 -> EVM t s ()) -> EVM t s () +forceConcrete n = forceConcreteLimitSz n 32 + +forceConcreteLimitSz :: (?conf :: Config, VMOps t) => Expr EWord -> Int -> String -> (W256 -> EVM t s ()) -> EVM t s () +forceConcreteLimitSz n bytes msg continue = case maybeLitWordSimp n of + Nothing -> manySolutions (?conf).maxDepth n bytes $ maybe fallback continue Just c -> continue c + where fallback = unexpectedSymArg msg [n] -forceConcreteAddr :: VMOps t => Expr EAddr -> String -> (Addr -> EVM t s ()) -> EVM t s () -forceConcreteAddr n msg continue = case maybeLitAddr n of - Nothing -> do - vm <- get - partial $ UnexpectedSymbolicArg vm.state.pc (getOpName vm.state) msg (wrap [n]) +forceConcreteAddr :: (?conf :: Config, VMOps t) => Expr EAddr -> String -> (Addr -> EVM t s ()) -> EVM t s () +forceConcreteAddr n msg continue = case maybeLitAddrSimp n of + Nothing -> manySolutions (?conf).maxDepth (WAddr n) 20 $ maybe fallback $ \c -> continue (truncateToAddr c) Just c -> continue c + where fallback = unexpectedSymArg msg [n] forceConcreteAddr2 :: VMOps t => (Expr EAddr, Expr EAddr) -> String -> ((Addr, Addr) -> EVM t s ()) -> EVM t s () -forceConcreteAddr2 (n,m) msg continue = case (maybeLitAddr n, maybeLitAddr m) of +forceConcreteAddr2 (n,m) msg continue = case (maybeLitAddrSimp n, maybeLitAddrSimp m) of (Just c, Just d) -> continue (c,d) - _ -> do - vm <- get - partial $ UnexpectedSymbolicArg vm.state.pc (getOpName vm.state) msg (wrap [n, m]) + _ -> unexpectedSymArg msg [n, m] forceConcrete2 :: VMOps t => (Expr EWord, Expr EWord) -> String -> ((W256, W256) -> EVM t s ()) -> EVM t s () -forceConcrete2 (n,m) msg continue = case (maybeLitWord n, maybeLitWord m) of +forceConcrete2 (n,m) msg continue = case (maybeLitWordSimp n, maybeLitWordSimp m) of (Just c, Just d) -> continue (c, d) - _ -> do - vm <- get - partial $ UnexpectedSymbolicArg vm.state.pc (getOpName vm.state) msg (wrap [n, m]) + _ -> unexpectedSymArg msg [n, m] forceConcreteBuf :: VMOps t => Expr Buf -> String -> (ByteString -> EVM t s ()) -> EVM t s () forceConcreteBuf (ConcreteBuf b) _ continue = continue b -forceConcreteBuf b msg _ = do - vm <- get - partial $ UnexpectedSymbolicArg vm.state.pc (getOpName vm.state) msg (wrap [b]) +forceConcreteBuf b msg _ = unexpectedSymArg msg [b] -- * Substate manipulation refund :: Word64 -> EVM t s () @@ -1664,7 +1720,7 @@ accessStorageForGas :: Expr EAddr -> Expr EWord -> EVM t s Bool accessStorageForGas addr key = do accessedStrkeys <- use (#tx % #subState % #accessedStorageKeys) - case maybeLitWord key of + case maybeLitWordSimp key of Just litword -> do let accessed = member (addr, litword) accessedStrkeys assign (#tx % #subState % #accessedStorageKeys) (insert (addr, litword) accessedStrkeys) @@ -1681,7 +1737,7 @@ cheatCode = LitAddr $ unsafeInto (keccak' "hevm cheat code") cheat - :: (?op :: Word8, VMOps t) + :: forall t s . (?conf :: Config, ?op :: Word8, VMOps t) => Gas t -> (Expr EWord, Expr EWord) -> (Expr EWord, Expr EWord) -> [Expr EWord] -> EVM t s () cheat gas (inOffset, inSize) (outOffset, outSize) xs = do @@ -1689,7 +1745,7 @@ input <- readMemory (Expr.add inOffset (Lit 4)) (Expr.sub inSize (Lit 4)) calldata <- readMemory inOffset inSize abi <- readBytes 4 (Lit 0) <$> readMemory inOffset (Lit 4) - let newContext = CallContext cheatCode cheatCode outOffset outSize (Lit 0) (maybeLitWord abi) calldata vm.env.contracts vm.tx.subState + let newContext = CallContext cheatCode cheatCode outOffset outSize (Lit 0) (maybeLitWordSimp abi) calldata vm.env.contracts vm.tx.subState pushTrace $ FrameTrace newContext next @@ -1698,16 +1754,25 @@ { state = vm1.state { stack = xs } , context = newContext } - case maybeLitWord abi of - Nothing -> partial $ UnexpectedSymbolicArg vm.state.pc (getOpName vm.state) "symbolic cheatcode selector" (wrap [abi]) - Just (unsafeInto -> abi') -> + case maybeLitWordSimp abi of + -- 4-byte function selector + Nothing -> manySolutions (?conf).maxDepth abi 4 $ \case + Just concAbi -> runCheat concAbi input + Nothing -> unexpectedSymArg "symbolic cheatcode selector" [abi] + Just concAbi -> runCheat concAbi input + where + runCheat :: W256 -> Expr 'Buf -> EVM t s () + runCheat abi input = do + let abi' = unsafeInto abi case Map.lookup abi' cheatActions of - Nothing -> vmError (BadCheatCode "Cannot understand cheatcode." abi') + Nothing -> do + vm <- get + partial $ CheatCodeMissing vm.state.pc abi' Just action -> action input type CheatAction t s = Expr Buf -> EVM t s () -cheatActions :: VMOps t => Map FunctionSelector (CheatAction t s) +cheatActions :: (?conf :: Config, VMOps t) => Map FunctionSelector (CheatAction t s) cheatActions = Map.fromList [ action "ffi(string[])" $ \sig input -> do @@ -1727,9 +1792,7 @@ in query (PleaseDoFFI cmd vm.osEnv cont) _ -> vmError (BadCheatCode "ffi(string[]) decoding of string failed" sig) _ -> vmError (BadCheatCode "ffi(string[]) parameter decoding failed" sig) - else - let msg = "ffi disabled: run again with --ffi if you want to allow tests to call external scripts" - in partial $ UnexpectedSymbolicArg vm.state.pc (getOpName vm.state) msg [] + else unexpectedSymArg "ffi disabled: run again with --ffi if you want to allow tests to call external scripts" ([] :: [Expr EWord]) , action "warp(uint256)" $ \sig input -> case decodeStaticArgs 0 1 input of @@ -1741,7 +1804,7 @@ , action "deal(address,uint256)" $ \sig input -> case decodeStaticArgs 0 2 input of [a, amt] -> - forceAddr a "vm.deal: cannot decode target into an address" $ \usr -> + forceAddr a (unexpectedSymArgW "vm.deal: cannot decode target into an address") $ \usr -> fetchAccount usr $ \_ -> do assign (#env % #contracts % ix usr % #balance) amt doStop @@ -1756,8 +1819,8 @@ , action "roll(uint256)" $ \sig input -> case decodeStaticArgs 0 1 input of - [x] -> forceConcrete x "cannot roll to a symbolic block number" $ \block -> do - assign (#block % #number) block + [x] -> do + assign (#block % #number) x doStop _ -> vmError (BadCheatCode "roll(uint256) parameter decoding failed" sig) @@ -1918,7 +1981,7 @@ SAbi [eword] -> case (Expr.simplify (Expr.iszero eword)) of Lit 1 -> frameRevert "assertion failed" Lit 0 -> doStop - ew -> branch ew $ \case + ew -> branch (?conf).maxDepth ew $ \case True -> frameRevert "assertion failed" False -> doStop k -> vmError $ BadCheatCode ("assertTrue(bool) parameter decoding failed: " <> show k) sig @@ -1929,7 +1992,7 @@ SAbi [eword] -> case (Expr.simplify (Expr.iszero eword)) of Lit 0 -> frameRevert "assertion failed" Lit 1 -> doStop - ew -> branch ew $ \case + ew -> branch (?conf).maxDepth ew $ \case False -> frameRevert "assertion failed" True -> doStop k -> vmError $ BadCheatCode ("assertFalse(bool) parameter decoding failed: " <> show k) sig @@ -1948,13 +2011,13 @@ , action "assertNotEq(string,string)" $ assertNotEq (AbiStringType) -- , action "assertLt(uint256,uint256)" $ assertLt (AbiUIntType 256) - , action "assertLt(int256,int256)" $ assertLt (AbiIntType 256) + , action "assertLt(int256,int256)" $ assertSLt (AbiIntType 256) , action "assertLe(uint256,uint256)" $ assertLe (AbiUIntType 256) - , action "assertLe(int256,int256)" $ assertLe (AbiIntType 256) + , action "assertLe(int256,int256)" $ assertSLe (AbiIntType 256) , action "assertGt(uint256,uint256)" $ assertGt (AbiUIntType 256) - , action "assertGt(int256,int256)" $ assertGt (AbiIntType 256) + , action "assertGt(int256,int256)" $ assertSGt (AbiIntType 256) , action "assertGe(uint256,uint256)" $ assertGe (AbiUIntType 256) - , action "assertGe(int256,int256)" $ assertGe (AbiIntType 256) + , action "assertGe(int256,int256)" $ assertSGe (AbiIntType 256) ] where action s f = (abiKeccak s, f (abiKeccak s)) @@ -2005,22 +2068,25 @@ SAbi [ew1, ew2] -> case (Expr.simplify (Expr.iszero $ exprComp ew1 ew2)) of Lit 0 -> doStop Lit _ -> revertErr ew1 ew2 invComp - ew -> branch ew $ \case + ew -> branch (?conf).maxDepth ew $ \case False -> doStop True -> revertErr ew1 ew2 invComp abivals -> vmError (BadCheatCode (paramDecodeErr abitype name abivals) sig) - assertEq = genAssert (==) Expr.eq "!=" "assertEq" + assertEq = genAssert (==) Expr.eq "!=" "assertEq" assertNotEq = genAssert (/=) (\a b -> Expr.iszero $ Expr.eq a b) "==" "assertNotEq" - assertLt = genAssert (<) Expr.lt ">=" "assertLt" - assertGt = genAssert (>) Expr.gt "<=" "assertGt" - assertLe = genAssert (<=) Expr.leq ">" "assertLe" - assertGe = genAssert (>=) Expr.geq "<" "assertGe" - + assertLt = genAssert (<) Expr.lt ">=" "assertLt" + assertSLt = genAssert (<) Expr.slt ">=" "assertLt" + assertGt = genAssert (>) Expr.gt "<=" "assertGt" + assertSGt = genAssert (>) Expr.sgt "<=" "assertGt" + assertLe = genAssert (<=) Expr.leq ">" "assertLe" + assertSLe = genAssert (<=) (\a b -> Expr.iszero $ Expr.sgt a b) ">" "assertLe" + assertGe = genAssert (>=) Expr.geq "<" "assertGe" + assertSGe = genAssert (>=) (\a b -> Expr.iszero $ Expr.slt a b) "<" "assertGe" -- * General call implementation ("delegateCall") -- note that the continuation is ignored in the precompile case delegateCall - :: (VMOps t, ?op :: Word8) + :: (VMOps t, ?op :: Word8, ?conf :: Config) => Contract -> Gas t -> Expr EAddr @@ -2031,9 +2097,10 @@ -> Expr EWord -> Expr EWord -> [Expr EWord] - -> (Expr EAddr -> EVM t s ()) + -> (Expr EAddr -> EVM t s ()) -- fallback + -> (Expr EAddr -> EVM t s ()) -- continue -> EVM t s () -delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue +delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOutSize xs fallback continue | isPrecompileAddr xTo = forceConcreteAddr2 (xTo, xContext) "Cannot call precompile with symbolic addresses" $ \(xTo', xContext') -> @@ -2046,15 +2113,12 @@ resetCaller <- use $ #state % #resetCaller when resetCaller $ assign (#state % #overrideCaller) Nothing vm0 <- get - fetchAccount xTo $ \target -> case target.code of - UnknownCode _ -> do - pc <- use (#state % #pc) - state <- use #state - partial $ UnexpectedSymbolicArg pc (getOpName state) "call target has unknown code" (wrap [xTo]) + fetchAccountWithFallback xTo fallback $ \target -> case target.code of + UnknownCode _ -> fallback xTo _ -> do burn' xGas $ do calldata <- readMemory xInOffset xInSize - abi <- maybeLitWord . readBytes 4 (Lit 0) <$> readMemory xInOffset (Lit 4) + abi <- maybeLitWordSimp . readBytes 4 (Lit 0) <$> readMemory xInOffset (Lit 4) let newContext = CallContext { target = xTo , context = xContext @@ -2078,7 +2142,7 @@ (InitCode _ _) -> InitCode mempty mempty a -> a - newMemory <- ConcreteMemory <$> VUnboxed.Mutable.new 0 + newMemory <- ConcreteMemory <$> VS.Mutable.new 0 zoom #state $ do assign #gas xGas assign #pc 0 @@ -2104,28 +2168,35 @@ _ -> True Nothing -> False -create :: forall t s. (?op :: Word8, VMOps t) +create :: forall t s. (?op :: Word8, ?conf::Config, VMOps t) => Expr EAddr -> Contract -> Expr EWord -> Gas t -> Expr EWord -> [Expr EWord] -> Expr EAddr -> Expr Buf -> EVM t s () create self this xSize xGas xValue xs newAddr initCode = do vm0 <- get + -- are we exceeding the max init code size if xSize > Lit (vm0.block.maxCodeSize * 2) then do assign (#state % #stack) (Lit 0 : xs) assign (#state % #returndata) mempty vmError $ MaxInitCodeSizeExceeded (vm0.block.maxCodeSize * 2) xSize + -- are we overflowing the nonce else if this.nonce == Just maxBound then do assign (#state % #stack) (Lit 0 : xs) assign (#state % #returndata) mempty pushTrace $ ErrorTrace NonceOverflow next + -- are we overflowing the stack else if length vm0.frames >= 1024 then do assign (#state % #stack) (Lit 0 : xs) assign (#state % #returndata) mempty pushTrace $ ErrorTrace CallDepthLimitReached next + -- are we deploying to an address that already has a contract? + -- note: the symbolic interpreter generates constraints ensuring that + -- symbolic storage keys cannot alias other storage keys, making this check + -- safe to perform statically else if collision $ Map.lookup newAddr vm0.env.contracts then burn' xGas $ do assign (#state % #stack) (Lit 0 : xs) @@ -2133,7 +2204,7 @@ modifying (#env % #contracts % ix self % #nonce) (fmap ((+) 1)) next -- do we have enough balance - else branch (Expr.gt xValue this.balance) $ \case + else branch (?conf).maxDepth (Expr.gt xValue this.balance) $ \case True -> do assign (#state % #stack) (Lit 0 : xs) assign (#state % #returndata) mempty @@ -2144,8 +2215,7 @@ -- are we overflowing the nonce False -> burn' xGas $ do case parseInitCode initCode of - Nothing -> - partial $ UnexpectedSymbolicArg vm0.state.pc (getOpName vm0.state) "initcode must have a concrete prefix" [] + Nothing -> unexpectedSymArg "initcode must have a concrete prefix" ([] :: [Expr EWord]) Just c -> do let newContract = initialContract c @@ -2267,6 +2337,15 @@ | FrameErrored EvmError -- ^ Any other error deriving Show +finishAllFramesAndStop :: VMOps t => EVM t s () +finishAllFramesAndStop = do + vm <- get + case vm.frames of + [] -> finishFrame (FrameReturned mempty) + _ -> do + finishFrame (FrameReturned mempty) + finishAllFramesAndStop + -- | This function defines how to pop the current stack frame in either of -- the ways specified by 'FrameResult'. -- @@ -2461,8 +2540,7 @@ assign (#state % #memory) $ SymbolicMemory $ copySlice srcOffset memOffset size bs buf SymbolicMemory mem -> - assign (#state % #memory) $ - SymbolicMemory $ copySlice srcOffset memOffset size bs mem + assign (#state % #memory) $ SymbolicMemory $ copySlice srcOffset memOffset size bs mem copyCallBytesToMemory :: Expr Buf -> Expr EWord -> Expr EWord -> EVM t s () @@ -2476,7 +2554,7 @@ ConcreteMemory mem -> do case (offset', size') of (Lit offset, Lit size) -> do - let memSize :: Word64 = unsafeInto (VUnboxed.Mutable.length mem) + let memSize :: Word64 = unsafeInto (VS.Mutable.length mem) if size > Expr.maxBytes || offset + size > Expr.maxBytes || offset >= into memSize then @@ -2486,8 +2564,8 @@ let pastEnd = (unsafeInto offset + unsafeInto size) - unsafeInto memSize let fromMemSize = if pastEnd > 0 then unsafeInto size - pastEnd else unsafeInto size - buf <- VUnboxed.freeze $ VUnboxed.Mutable.slice (unsafeInto offset) fromMemSize mem - let dataFromMem = BS.pack $ VUnboxed.toList buf + buf <- VS.freeze $ VS.Mutable.slice (unsafeInto offset) fromMemSize mem + let dataFromMem = vectorToByteString buf pure $ ConcreteBuf $ dataFromMem <> BS.replicate pastEnd 0 _ -> do buf <- freezeMemory mem @@ -2504,7 +2582,7 @@ pure Trace { tracedata = x , contract = this - , opIx = fromMaybe 0 $ this.opIxMap SV.!? vm.state.pc + , opIx = fromMaybe 0 $ this.opIxMap VS.!? vm.state.pc } pushTrace :: TraceData -> EVM t s () @@ -2651,10 +2729,12 @@ UnknownCode _ -> internalError "Cannot analyze jumpdests for unknown code" InitCode ops _ -> BS.indexMaybe ops x RuntimeCode (ConcreteRuntimeCode ops) -> BS.indexMaybe ops x - RuntimeCode (SymbolicRuntimeCode ops) -> ops V.!? x >>= maybeLitByte + RuntimeCode (SymbolicRuntimeCode ops) -> ops V.!? x >>= maybeLitByteSimp in case op of Nothing -> False - Just b -> 0x5b == b && OpJumpdest == snd (contract.codeOps V.! (contract.opIxMap SV.! x)) + Just b -> 0x5b == b && (isJust $ contract.opIxMap VS.!? x) + && (isJust $ contract.codeOps V.!? (contract.opIxMap VS.! x)) + && OpJumpdest == snd (contract.codeOps V.! (contract.opIxMap VS.! x)) opSize :: Word8 -> Int opSize x | x >= 0x60 && x <= 0x7f = into x - 0x60 + 2 @@ -2663,10 +2743,10 @@ -- 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 -> SV.Vector Int +mkOpIxMap :: ContractCode -> VS.Vector Int mkOpIxMap (UnknownCode _) = internalError "Cannot build opIxMap for unknown code" mkOpIxMap (InitCode conc _) - = SV.create $ SV.new (BS.length conc) >>= \v -> + = VS.create $ VS.Mutable.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 @@ -2674,34 +2754,34 @@ 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 >> SV.write v i j) + {- Start of PUSH op. -} (x - 0x60 + 1, i + 1, j, m >> VS.Mutable.write v i j) go v (1, !i, !j, !m) _ = - {- End of PUSH op. -} (0, i + 1, j + 1, m >> SV.write v i j) + {- End of PUSH op. -} (0, i + 1, j + 1, m >> VS.Mutable.write v i j) go v (0, !i, !j, !m) _ = - {- Other op. -} (0, i + 1, j + 1, m >> SV.write v i j) + {- Other op. -} (0, i + 1, j + 1, m >> VS.Mutable.write v i j) go v (n, !i, !j, !m) _ = - {- PUSH data. -} (n - 1, i + 1, j, m >> SV.write v i j) + {- PUSH data. -} (n - 1, i + 1, j, m >> VS.Mutable.write v i j) mkOpIxMap (RuntimeCode (ConcreteRuntimeCode ops)) = mkOpIxMap (InitCode ops mempty) -- a bit hacky mkOpIxMap (RuntimeCode (SymbolicRuntimeCode ops)) - = SV.create $ SV.new (length ops) >>= \v -> + = VS.create $ VS.Mutable.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 maybeLitByte x of + go v (0, !i, !j, !m) x = case maybeLitByteSimp x of Just x' -> if x' >= 0x60 && x' <= 0x7f -- start of PUSH op -- - then (x' - 0x60 + 1, i + 1, j, m >> SV.write v i j) + then (x' - 0x60 + 1, i + 1, j, m >> VS.Mutable.write v i j) -- other data -- - else (0, i + 1, j + 1, m >> SV.write v i j) + else (0, i + 1, j + 1, m >> VS.Mutable.write v i j) _ -> internalError $ "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 >> SV.write v i j) + {- End of PUSH op. -} (0, i + 1, j + 1, m >> VS.Mutable.write v i j) go v (n, !i, !j, !m) _ = - {- PUSH data. -} (n - 1, i + 1, j, m >> SV.write v i j) + {- PUSH data. -} (n - 1, i + 1, j, m >> VS.Mutable.write v i j) vmOp :: VM t s -> Maybe Op @@ -2715,7 +2795,7 @@ RuntimeCode (ConcreteRuntimeCode xs') -> (BS.index xs' i, fmap LitByte $ BS.unpack $ BS.drop i xs') RuntimeCode (SymbolicRuntimeCode xs') -> - ( fromMaybe (internalError "unexpected symbolic code") . maybeLitByte $ xs' V.! i , V.toList $ V.drop i xs') + ( fromMaybe (internalError "unexpected symbolic code") . maybeLitByteSimp $ xs' V.! i , V.toList $ V.drop i xs') in if (opslen code' < i) then Nothing else Just (readOp op pushdata) @@ -2723,7 +2803,7 @@ vmOpIx :: VM t s -> Maybe Int vmOpIx vm = do self <- currentContract vm - self.opIxMap SV.!? vm.state.pc + self.opIxMap VS.!? vm.state.pc -- Maps operation indices into a pair of (bytecode index, operation) mkCodeOps :: ContractCode -> V.Vector (Int, Op) @@ -2743,7 +2823,7 @@ Nothing -> mempty Just (x, xs') -> - let x' = fromMaybe (internalError "unexpected symbolic code argument") $ maybeLitByte x + let x' = fromMaybe (internalError "unexpected symbolic code argument") $ maybeLitByteSimp x j = opSize x' in (i, readOp x' xs') Seq.<| go (i + j) (drop j xs) @@ -2890,13 +2970,21 @@ writeMemory :: MutableMemory s -> Int -> ByteString -> EVM t s () writeMemory memory offset buf = do memory' <- expandMemory (offset + BS.length buf) - mapM_ (uncurry (VUnboxed.Mutable.write memory')) + mapM_ (uncurry (VS.Mutable.write memory')) (zip [offset..] (BS.unpack buf)) where - expandMemory targetSize = do - let toAlloc = targetSize - VUnboxed.Mutable.length memory + expandMemory requiredSize = do + let currentSize = VS.Mutable.length memory + let toAlloc = requiredSize - currentSize if toAlloc > 0 then do - memory' <- VUnboxed.Mutable.grow memory toAlloc + -- As grow does a larger *copy* of the vector on a new place, + -- we double the vector size to avoid the performance impact + -- that would happen with repeated small expansion operations. + let growthFactor = 2 + let targetSize = requiredSize * growthFactor + -- Always grow at least 8k + let toGrow = max 8192 $ targetSize - currentSize + memory' <- VS.Mutable.grow memory toGrow assign (#state % #memory) (ConcreteMemory memory') pure memory' else @@ -2904,7 +2992,7 @@ freezeMemory :: MutableMemory s -> EVM t s (Expr Buf) freezeMemory memory = - ConcreteBuf . BS.pack . VUnboxed.toList <$> VUnboxed.freeze memory + ConcreteBuf . vectorToByteString <$> VS.freeze memory instance VMOps Symbolic where @@ -2927,21 +3015,22 @@ pushGas = do modifying (#env % #freshGasVals) (+ 1) n <- use (#env % #freshGasVals) - pushSym $ Expr.Gas n + pushSym $ Expr.Gas "" n enoughGas _ _ = True subGas _ _ = () toGas _ = () whenSymbolicElse a _ = a - partial e = assign #result (Just (Unfinished e)) - branch cond continue = do + partial e = assign #result $ Just (Unfinished e) + branch depthLimit cond continue = do loc <- codeloc pathconds <- use #constraints - query $ PleaseAskSMT cond pathconds (choosePath loc) + vm <- get + query $ PleaseAskSMT cond pathconds (runBothPaths loc vm.exploreDepth) where condSimp = Expr.simplify cond condSimpConc = Expr.concKeccakSimpExpr condSimp - choosePath loc (Case v) = do + runBothPaths loc _ (Case v) = do assign #result Nothing pushTo #constraints $ if v then Expr.simplifyProp (condSimpConc ./= Lit 0) else Expr.simplifyProp (condSimpConc .== Lit 0) @@ -2951,9 +3040,36 @@ assign (#iterations % at loc) (Just (iteration + 1, stack)) continue v -- Both paths are possible; we ask for more input - choosePath loc Unknown = - choose . PleaseChoosePath condSimp $ choosePath loc . Case + runBothPaths loc exploreDepth UnknownBranch = + (runBoth depthLimit exploreDepth ) . PleaseRunBoth condSimp $ (runBothPaths loc exploreDepth) . Case + -- numBytes allows us to specify how many bytes of the returned value is relevant + -- if it's e.g.a JUMP, only 2 bytes can be relevant. This allows us to avoid + -- getting solutions that are nonsensical + manySolutions depthLimit ewordExpr numBytes continue = do + pathconds <- use #constraints + vm <- get + query $ PleaseGetSols ewordExpr numBytes pathconds $ \case + Just concVals -> do + assign #result Nothing + case concVals of + -- zero solutions means that we are in a branch that's not possible + -- so revert all frames and stop all execution on this branch + [] -> finishAllFramesAndStop + [val] -> do + assign #result Nothing + pushTo #constraints $ Expr.simplifyProp (ewordExpr .== (Lit val)) + continue $ Just val + _ -> runAll depthLimit vm.exploreDepth $ PleaseRunAll ewordExpr concVals runAllPaths + Nothing -> do + assign #result Nothing + continue Nothing + where + runAllPaths val = do + assign #result Nothing + pushTo #constraints $ Expr.simplifyProp (ewordExpr .== Lit val) + continue $ Just val + instance VMOps Concrete where burn' n continue = do available <- use (#state % #gas) @@ -3076,16 +3192,12 @@ push (into vm.state.gas) enoughGas cost gasCap = cost <= gasCap - subGas gasCap cost = gasCap - cost - toGas = id - whenSymbolicElse _ a = a - partial _ = internalError "won't happen during concrete exec" - - branch (forceLit -> cond) continue = continue (cond > 0) + branch _ (forceLit -> cond) continue = continue (cond > 0) + manySolutions _ _ _ = internalError "SMT solver should never be needed in concrete mode" -- Create symbolic VM from concrete VM symbolify :: VM Concrete s -> VM Symbolic s diff --git a/src/EVM/ABI.hs b/src/EVM/ABI.hs --- a/src/EVM/ABI.hs +++ b/src/EVM/ABI.hs @@ -60,6 +60,7 @@ import EVM.Expr (readWord, isLitWord) import EVM.Types +import EVM.Expr (maybeLitWordSimp) import Control.Applicative ((<|>)) import Control.Monad (replicateM, replicateM_, forM_, void) @@ -511,7 +512,7 @@ else let vs = decodeStaticArgs 0 (length tps) buf - asBS = mconcat $ fmap word256Bytes (mapMaybe maybeLitWord vs) + asBS = mconcat $ fmap word256Bytes (mapMaybe maybeLitWordSimp vs) in if not (all isLitWord vs) then SAbi vs else case runGetOrFail (getAbiSeq (length tps) tps) (BSLazy.fromStrict asBS) of diff --git a/src/EVM/Dapp.hs b/src/EVM/Dapp.hs --- a/src/EVM/Dapp.hs +++ b/src/EVM/Dapp.hs @@ -4,6 +4,7 @@ import EVM.Concrete import EVM.Solidity import EVM.Types +import EVM.Expr (maybeLitByteSimp, maybeLitWordSimp) import Control.Arrow ((>>>), second) import Data.Aeson (Value) @@ -26,7 +27,6 @@ , solcByHash :: Map W256 (CodeType, SolcContract) , solcByCode :: [(Code, SolcContract)] -- for contracts with `immutable` vars. , sources :: SourceCache - , unitTests :: [(Text, [Sig])] , abiMap :: Map FunctionSelector Method , eventMap :: Map W256 Event , errorMap :: Map W256 SolError @@ -56,7 +56,6 @@ in DappInfo { root = root - , unitTests = findAllUnitTests solcs , sources = sources , solcByName = cs , solcByHash = @@ -91,37 +90,33 @@ unitTestMarkerAbi :: FunctionSelector unitTestMarkerAbi = abiKeccak (encodeUtf8 "IS_TEST()") -findAllUnitTests :: [SolcContract] -> [(Text, [Sig])] -findAllUnitTests = findUnitTests ".*:.*\\.(check|prove).*" - -mkSig :: Method -> Maybe Sig -mkSig method - | "prove" `isPrefixOf` testname = Just (Sig testname argtypes) - | "check" `isPrefixOf` testname = Just (Sig testname argtypes) +mkSig :: Text -> Method -> Maybe Sig +mkSig prefix method + | prefix `isPrefixOf` testname = Just (Sig testname argtypes) | otherwise = Nothing where testname = method.name argtypes = snd <$> method.inputs -findUnitTests :: Text -> ([SolcContract] -> [(Text, [Sig])]) -findUnitTests match = +findUnitTests :: Text -> Text -> ([SolcContract] -> [(Text, [Sig])]) +findUnitTests prefix match = concatMap $ \c -> case Map.lookup unitTestMarkerAbi c.abiMap of Nothing -> [] Just _ -> - let testNames = unitTestMethodsFiltered (regexMatches match) c + let testNames = unitTestMethodsFiltered prefix (regexMatches match) c in [(c.contractName, testNames) | not (BS.null c.runtimeCode) && not (null testNames)] -unitTestMethodsFiltered :: (Text -> Bool) -> (SolcContract -> [Sig]) -unitTestMethodsFiltered matcher c = +unitTestMethodsFiltered :: Text -> (Text -> Bool) -> (SolcContract -> [Sig]) +unitTestMethodsFiltered prefix matcher c = let testName (Sig n _) = c.contractName <> "." <> n - in filter (matcher . testName) (unitTestMethods c) + in filter (matcher . testName) (unitTestMethods prefix c) -unitTestMethods :: SolcContract -> [Sig] -unitTestMethods = +unitTestMethods :: Text -> SolcContract -> [Sig] +unitTestMethods prefix = (.abiMap) >>> Map.elems - >>> mapMaybe mkSig + >>> mapMaybe (mkSig prefix) traceSrcMap :: DappInfo -> Trace -> Maybe SrcMap traceSrcMap dapp trace = srcMap dapp trace.contract trace.opIx @@ -138,7 +133,7 @@ findSrc :: Contract -> DappInfo -> Maybe SolcContract findSrc c dapp = do - hash <- maybeLitWord c.codehash + hash <- maybeLitWordSimp c.codehash case Map.lookup hash dapp.solcByHash of Just (_, v) -> Just v Nothing -> lookupCode c.code dapp @@ -153,7 +148,7 @@ Just x -> pure x Nothing -> snd <$> find (compareCode c . fst) a.solcByCode lookupCode (RuntimeCode (SymbolicRuntimeCode c)) a = let - code = BS.pack $ mapMaybe maybeLitByte $ V.toList c + code = BS.pack $ mapMaybe maybeLitByteSimp $ V.toList c in case snd <$> Map.lookup (keccak' (stripBytecodeMetadata code)) a.solcByHash of Just x -> pure x Nothing -> snd <$> find (compareCode code . fst) a.solcByCode diff --git a/src/EVM/Effects.hs b/src/EVM/Effects.hs --- a/src/EVM/Effects.hs +++ b/src/EVM/Effects.hs @@ -43,6 +43,12 @@ -- Returns Unknown if the Cex cannot be found via fuzzing , onlyCexFuzz :: Bool , decomposeStorage :: Bool + , promiseNoReent :: Bool + , maxBufSize :: Int + , maxWidth :: Int + , maxDepth :: Maybe Int + , verb :: Int + , simp :: Bool } deriving (Show, Eq) @@ -56,6 +62,12 @@ , numCexFuzz = 10 , onlyCexFuzz = False , decomposeStorage = True + , promiseNoReent = False + , maxBufSize = 64 + , maxWidth = 100 + , maxDepth = Nothing + , verb = 0 + , simp = True } -- Write to the console diff --git a/src/EVM/Exec.hs b/src/EVM/Exec.hs --- a/src/EVM/Exec.hs +++ b/src/EVM/Exec.hs @@ -10,6 +10,7 @@ import Data.Maybe (isNothing) import Optics.Core import Control.Monad.ST (ST) +import EVM.Effects (Config) ethrunAddress :: Addr ethrunAddress = Addr 0x00a329c0648769a73afac7f9381e08fb43dbea72 @@ -26,7 +27,7 @@ , caller = LitAddr ethrunAddress , origin = LitAddr ethrunAddress , coinbase = LitAddr 0 - , number = 0 + , number = Lit 0 , timestamp = Lit 0 , blockGaslimit = 0 , gasprice = 0 @@ -46,18 +47,18 @@ }) <&> set (#env % #contracts % at (LitAddr ethrunAddress)) (Just (initialContract (RuntimeCode (ConcreteRuntimeCode "")))) -exec :: VMOps t => EVM t s (VMResult t s) -exec = do +exec :: (VMOps t) => Config -> EVM t s (VMResult t s) +exec conf = do vm <- get case vm.result of - Nothing -> exec1 >> exec + Nothing -> exec1 conf >> exec conf Just r -> pure r -run :: VMOps t => EVM t s (VM t s) -run = do +run :: (VMOps t) => Config -> EVM t s (VM t s) +run conf = do vm <- get case vm.result of - Nothing -> exec1 >> run + Nothing -> exec1 conf >> run conf Just _ -> pure vm execWhile :: (VM t s -> Bool) -> State (VM t s) Int diff --git a/src/EVM/Expr.hs b/src/EVM/Expr.hs --- a/src/EVM/Expr.hs +++ b/src/EVM/Expr.hs @@ -15,6 +15,7 @@ import Data.ByteString qualified as BS import Data.DoubleWord (Int256, Word256(Word256), Word128(Word128)) import Data.List +import Data.Map qualified as LMap import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe, isJust, fromMaybe) import Data.Semigroup (Any, Any(..), getAny) @@ -39,6 +40,12 @@ maxLit :: W256 maxLit = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +maxLitSigned :: W256 +maxLitSigned = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +minLitSigned :: W256 +minLitSigned = 0x1000000000000000000000000000000000000000000000000000000000000000 + -- ** Stack Ops ** --------------------------------------------------------------------------------- @@ -60,14 +67,11 @@ op3 _ concrete (Lit x) (Lit y) (Lit z) = Lit (concrete x y z) op3 symbolic _ x y z = symbolic x y z --- | If a given binary op is commutative, then we always force Lits to the lhs if --- only one argument is a Lit. This makes writing pattern matches in the --- simplifier easier. +-- | If a given binary op is commutative, then we always order the arguments. +-- This makes writing pattern matches in the simplifier easier. +-- It will also force Lit to be the 1st argument, since Lit is the 1st element of Expr (see Types.hs). normArgs :: (Expr EWord -> Expr EWord -> Expr EWord) -> (W256 -> W256 -> W256) -> Expr EWord -> Expr EWord -> Expr EWord -normArgs sym conc l r = case (l, r) of - (Lit _, _) -> doOp l r - (_, Lit _) -> doOp r l - _ -> doOp l r +normArgs sym conc l r = if l <= r then doOp l r else doOp r l where doOp = op2 sym conc @@ -105,14 +109,12 @@ addmod :: Expr EWord -> Expr EWord -> Expr EWord -> Expr EWord addmod = op3 AddMod (\x y z -> - if z == 0 - then 0 + if z == 0 then 0 else fromIntegral $ (into @Word512 x + into y) `Prelude.mod` into z) mulmod :: Expr EWord -> Expr EWord -> Expr EWord -> Expr EWord mulmod = op3 MulMod (\x y z -> - if z == 0 - then 0 + if z == 0 then 0 else fromIntegral $ (into @Word512 x * into y) `Prelude.mod` into z) exp :: Expr EWord -> Expr EWord -> Expr EWord @@ -195,7 +197,7 @@ sar = op2 SAR (\x y -> let msb = testBit y 255 asSigned = fromIntegral y :: Int256 - in if x > 256 then + in if x >= 255 then if msb then maxBound else 0 else fromIntegral $ shiftR asSigned (fromIntegral x)) @@ -205,12 +207,20 @@ peq :: (Typeable a) => Expr a -> Expr a -> Prop peq (Lit x) (Lit y) = PBool (x == y) -peq a@(Lit _) b = PEq a b -peq a b@(Lit _) = PEq b a -- we always put concrete values on LHS +peq (LitAddr x) (LitAddr y) = PBool (x == y) +peq (LitByte x) (LitByte y) = PBool (x == y) +peq (ConcreteBuf x) (ConcreteBuf y) = PBool (x == y) peq a b | a == b = PBool True - | otherwise = PEq a b + | otherwise = let args = sort [a, b] + in PEq (args !! 0) (args !! 1) +pleq :: Expr EWord -> Expr EWord -> Prop +pleq (Lit a) (Lit b) = PBool (a <= b) +pleq a b + | a == b = PBool True + | otherwise = PLEq a b + -- ** Bufs ** -------------------------------------------------------------------------------------- @@ -242,6 +252,9 @@ (Lit _) -> indexWord (Lit $ x - idx) val _ -> IndexWord (Lit $ x - idx) val else readByte i src +-- reading a byte that is lower than the dstOffset of a CopySlice, so it's just reading from dst +readByte i@(Lit x) (CopySlice _ (Lit dstOffset) _ _ dst) | dstOffset > x = + readByte i dst readByte i@(Lit x) (CopySlice (Lit srcOffset) (Lit dstOffset) (Lit size) src dst) = if x - dstOffset < size then readByte (Lit $ x - (dstOffset - srcOffset)) src @@ -278,6 +291,9 @@ -- we do not have enough information to statically determine whether or not -- the region we want to read overlaps the WriteWord _ -> readWordFromBytes idx b +-- reading a Word that is lower than the dstOffset-32 of a CopySlice, so it's just reading from dst +readWord i@(Lit x) (CopySlice _ (Lit dstOffset) _ _ dst) | dstOffset >= x+32 = + readWord i dst 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) < size && 32 <= size - (idx - dstOff) = readWord (Lit $ srcOff + (idx - dstOff)) src @@ -297,7 +313,7 @@ readWordFromBytes i@(Lit idx) buf = let bytes = [readByte (Lit i') buf | i' <- [idx .. idx + 31]] in if all isLitByte bytes - then Lit (bytesToW256 . mapMaybe maybeLitByte $ bytes) + then Lit (bytesToW256 . mapMaybe maybeLitByteSimp $ bytes) else ReadWord i buf readWordFromBytes idx buf = ReadWord idx buf @@ -351,8 +367,8 @@ hd = padRight (unsafeInto dstOffset) $ BS.take (unsafeInto dstOffset) dst sl = [readByte (Lit i) src | i <- [srcOffset .. srcOffset + (size - 1)]] tl = BS.drop (unsafeInto dstOffset + unsafeInto size) dst - in if Prelude.and . (fmap isLitByte) $ sl - then ConcreteBuf $ hd <> (BS.pack . (mapMaybe maybeLitByte) $ sl) <> tl + in if all isLitByte sl + then ConcreteBuf $ hd <> (BS.pack . (mapMaybe maybeLitByteSimp) $ sl) <> tl else CopySlice s d sz src ds | otherwise = CopySlice s d sz src ds @@ -529,8 +545,8 @@ _ -> Nothing fromList :: V.Vector (Expr Byte) -> Expr Buf -fromList bs = case Prelude.and (fmap isLitByte bs) of - True -> ConcreteBuf . BS.pack . V.toList . V.mapMaybe maybeLitByte $ bs +fromList bs = case all isLitByte bs of + True -> ConcreteBuf . vectorToByteString . VS.convert $ V.map getLitByte bs -- we want to minimize the size of the resulting expression, so we do two passes: -- 1. write all concrete bytes to some base buffer -- 2. write all symbolic writes on top of this buffer @@ -538,17 +554,21 @@ -- runs in O(2n) time, and has pretty minimal allocation & copy overhead in -- the concrete part (a single preallocated vec, with no copies) False -> V.ifoldl' applySymWrites (ConcreteBuf concreteBytes) bs - where - concreteBytes :: ByteString - concreteBytes = vectorToByteString $ VS.generate (V.length bs) (\idx -> - case bs V.! idx of - LitByte b -> b - _ -> 0) + where + getLitByte :: (Expr Byte) -> Word8 + getLitByte (LitByte w) = w + getLitByte _ = internalError "Impossible!" - applySymWrites :: Expr Buf -> Int -> Expr Byte -> Expr Buf - applySymWrites buf _ (LitByte _) = buf - applySymWrites buf idx by = WriteByte (Lit $ unsafeInto idx) by buf + concreteBytes :: ByteString + concreteBytes = vectorToByteString $ VS.generate (V.length bs) (\idx -> + case bs V.! idx of + LitByte b -> b + _ -> 0) + applySymWrites :: Expr Buf -> Int -> Expr Byte -> Expr Buf + applySymWrites buf _ (LitByte _) = buf + applySymWrites buf idx by = WriteByte (Lit $ unsafeInto idx) by buf + instance Semigroup (Expr Buf) where (ConcreteBuf a) <> (ConcreteBuf b) = ConcreteBuf $ a <> b a <> b = copySlice (Lit 0) (bufLength a) (bufLength b) b a @@ -617,7 +637,7 @@ -- test for an example where this happens. Note that decomposition solves this, though late in -- the simplification lifecycle (just before SMT generation, which can be too late) readStorage :: Expr EWord -> Expr Storage -> Maybe (Expr EWord) -readStorage w st = go (simplify w) st +readStorage w st = go (simplifyNoLitToKeccak w) (simplifyNoLitToKeccak st) where go :: Expr EWord -> Expr Storage -> Maybe (Expr EWord) go _ (GVar _) = internalError "Can't read from a GVar" @@ -627,21 +647,23 @@ go slot s@(SStore prevSlot val prev) = case (prevSlot, slot) of -- if address and slot match then we return the val in this write _ | prevSlot == slot -> Just val - - -- if the slots don't match (see previous guard) and are lits, we can skip this write - (Lit _, Lit _) -> go slot prev + (a, b) | surelyEqual a b -> Just val + (a, b) | surelyNotEqual a b -> go slot prev -- slot is for a map + map -> skip write - (MappingSlot idA _, MappingSlot idB _) | BS.length idB == 64 && BS.length idA == 64 && idsDontMatch idA idB -> go slot prev - (MappingSlot idA keyA, MappingSlot idB keyB) | BS.length idB == 64 && BS.length idA == 64 && surelyNotEq keyA keyB -> go slot prev + (MappingSlot idA _, MappingSlot idB _) | isMap' idB, isMap' idA, idsDontMatch idA idB -> go slot prev + (MappingSlot idA keyA, MappingSlot idB keyB) | isMap' idB, isMap' idA, surelyNotEqual keyA keyB -> go slot prev -- special case of array + map -> skip write - (ArraySlotWithOffs idA _, Keccak k) | bufLength k == Lit 64 && BS.length idA == 32 -> go slot prev - (ArraySlotZero idA, Keccak k) | bufLength k == Lit 64 && BS.length idA == 32 -> go slot prev + (ArraySlotWithOffs idA _, Keccak k) | isMap k, isArray idA -> go slot prev + (ArraySlotWithOffs2 idA _ _, Keccak k) | isMap k, isArray idA -> go slot prev + (ArraySlotZero idA, Keccak k) | isMap k, isArray idA -> go slot prev -- special case of map + array -> skip write - (Keccak k, ArraySlotWithOffs idA _) | bufLength k == Lit 64 && BS.length idA == 32 -> go slot prev - (ArraySlotWithOffs idA _, Keccak k) | bufLength k == Lit 64 && BS.length idA == 32 -> go slot prev + (Keccak k, ArraySlotWithOffs idA _) | isMap k, isArray idA -> go slot prev + (Keccak k, ArraySlotWithOffs2 idA _ _) | isMap k, isArray idA -> go slot prev + (ArraySlotWithOffs idA _, Keccak k) | isMap k, isArray idA -> go slot prev + (ArraySlotWithOffs2 idA _ _, Keccak k) | isMap k, isArray idA -> go slot prev -- Fixed SMALL value will never match Keccak (well, it might, but that's VERY low chance) (Lit a, Keccak _) | a < 256 -> go slot prev @@ -652,12 +674,8 @@ -- occurring here is 2^32/2^256 = 2^-224, which is close enough to zero -- for our purposes. This lets us completely simplify reads from write -- chains involving writes to arrays at literal offsets. - (Lit a, Add (Lit b) (Keccak _) ) | a < 256, b < maxW32 -> go slot prev - (Add (Lit a) (Keccak _) , Lit b) | b < 256, a < maxW32 -> go slot prev - - --- NOTE these are needed to succeed in rewriting arrays with a variable index - -- (Lit a, Add (Keccak _) (Var _) ) | a < 256 -> go slot prev - -- (Add (Keccak _) (Var _) , Lit b) | b < 256 -> go slot prev + (Lit a, Add (Lit b) (Keccak _)) | a < 256, b < maxW32 -> go slot prev + (Add (Lit a) (Keccak _) ,Lit b) | b < 256, a < maxW32 -> go slot prev -- Finding two Keccaks that are < 256 away from each other should be VERY hard -- This simplification allows us to deal with maps of structs @@ -665,48 +683,65 @@ (Add (Lit a2) (Keccak _), (Keccak _)) | a2 > 0, a2 < 256 -> go slot prev ((Keccak _), Add (Lit b2) (Keccak _)) | b2 > 0, b2 < 256 -> go slot prev - -- case of array + array, but different id's or different concrete offsets -- zero offs vs zero offs - (ArraySlotZero idA, ArraySlotZero idB) | BS.length idA == 32, BS.length idB == 32, idA /= idB -> go slot prev + (ArraySlotZero idA, ArraySlotZero idB) | isArray idA, isArray idB, idA /= idB -> go slot prev + -- zero offs vs non-zero offs - (ArraySlotZero idA, ArraySlotWithOffs idB _) | BS.length idA == 32, BS.length idB == 32, idA /= idB -> go slot prev - (ArraySlotZero idA, ArraySlotWithOffs idB (Lit offB)) | BS.length idA == 32, BS.length idB == 32, offB /= 0 -> go slot prev + (ArraySlotZero idA, ArraySlotWithOffs idB _) | isArray idA, isArray idB, idA /= idB -> go slot prev + (ArraySlotZero idA, ArraySlotWithOffs idB (Lit offB)) | isArray idA, idA == idB, offB /= 0 -> go slot prev + (ArraySlotZero idA, ArraySlotWithOffs2 idB _ _) | isArray idA, isArray idB, idA /= idB -> go slot prev + -- non-zero offs vs zero offs - (ArraySlotWithOffs idA _, ArraySlotZero idB) | BS.length idA == 32, BS.length idB == 32, idA /= idB -> go slot prev - (ArraySlotWithOffs idA (Lit offA), ArraySlotZero idB) | BS.length idA == 32, BS.length idB == 32, offA /= 0 -> go slot prev - -- non-zero offs vs non-zero offs - (ArraySlotWithOffs idA _, ArraySlotWithOffs idB _) | BS.length idA == 32, BS.length idB == 32, idA /= idB -> go slot prev + (ArraySlotWithOffs idA _, ArraySlotZero idB) | isArray idA, isArray idB, idA /= idB -> go slot prev + (ArraySlotWithOffs idA (Lit offA), ArraySlotZero idB) | isArray idA, idA == idB, offA /= 0 -> go slot prev - (ArraySlotWithOffs idA offA, ArraySlotWithOffs idB offB) | BS.length idA == 32, BS.length idB == 32, surelyNotEq offA offB -> go slot prev + -- non-zero offs vs non-zero offs, different ids + (ArraySlotWithOffs idA _, ArraySlotWithOffs idB _) | isArray idA, isArray idB, idA /= idB -> go slot prev + -- non-zero offs vs non-zero offs, same ids + (ArraySlotWithOffs idA a, ArraySlotWithOffs idB b) | isArray idA, idA == idB, + surelyNotEqual a b -> go slot prev + (ArraySlotWithOffs idB offB2, ArraySlotWithOffs2 idA offA1 offA2) | isArray idA, idA == idB, + surelyNotEqual (Add (Lit offA1) offA2) offB2 -> go slot prev + (ArraySlotWithOffs2 idA offA1 offA2, ArraySlotWithOffs idB offB2) | isArray idA, idA == idB, + surelyNotEqual (Add (Lit offA1) offA2) offB2 -> go slot prev + (ArraySlotWithOffs2 idA offA1 offA2, ArraySlotWithOffs2 idB offB1 offB2) | isArray idA, idA == idB, + surelyNotEqual (Add (Lit offA1) offA2) (Add (Lit offB1) offB2) -> go slot prev + -- we are unable to determine statically whether or not we can safely move deeper in the write chain, so return an abstract term _ -> Just $ SLoad slot s - surelyNotEq :: Expr a -> Expr a -> Bool - surelyNotEq (Lit a) (Lit b) = a /= b - -- never equal: x+y (y is concrete) vs x+z (z is concrete), y!=z - surelyNotEq (Add (Lit l1) v1) (Add (Lit l2) v2) = l1 /= l2 && v1 == v2 - -- never equal: x+y (y is concrete, non-zero) vs x - surelyNotEq v1 (Add (Lit l2) v2) = l2 /= 0 && v1 == v2 - surelyNotEq (Add (Lit l1) v1) v2 = l1 /= 0 && v1 == v2 - surelyNotEq _ _ = False - maxW32 :: W256 maxW32 = into (maxBound :: Word32) + isArray :: ByteString -> Bool + isArray b = BS.length b == 32 + isMap :: Expr Buf -> Bool + isMap b = bufLength b == Lit 64 + isMap' :: ByteString -> Bool + isMap' b = BS.length b == 64 + surelyNotEqual :: Expr EWord -> Expr EWord -> Bool + surelyNotEqual a b = case (simplifyNoLitToKeccak (Sub a b)) of + Lit k | k > 0 -> True + _ -> False + surelyEqual :: Expr EWord -> Expr EWord -> Bool + surelyEqual a b = simplifyNoLitToKeccak (Sub a b) == Lit 0 + -- storage slots for maps are determined by (keccak (bytes32(key) ++ bytes32(id))) pattern MappingSlot :: ByteString -> Expr EWord -> Expr EWord pattern MappingSlot idx key = Keccak (WriteWord (Lit 0) key (ConcreteBuf idx)) -- storage slots for arrays are determined by (keccak(bytes32(id)) + offset) --- note that `normArgs` puts the Lit as the 2nd argument to `Add` +-- note that `normArgs` puts the Lit as the 1st argument to `Add` pattern ArraySlotWithOffs :: ByteString -> Expr EWord -> Expr EWord -pattern ArraySlotWithOffs id offset = Add (Keccak (ConcreteBuf id)) offset +pattern ArraySlotWithOffs id offset = Add offset (Keccak (ConcreteBuf id)) +pattern ArraySlotWithOffs2 :: ByteString -> W256 -> Expr EWord -> Expr EWord +pattern ArraySlotWithOffs2 id offs1 offs2 = Add (Lit offs1) (Add offs2 (Keccak (ConcreteBuf id))) + -- special pattern to match the 0th element because the `Add` term gets simplified out pattern ArraySlotZero :: ByteString -> Expr EWord pattern ArraySlotZero id = Keccak (ConcreteBuf id) - -- checks if two mapping ids match or not idsDontMatch :: ByteString -> ByteString -> Bool idsDontMatch a b = BS.length a >= 64 && BS.length b >= 64 && diff32to64Byte a b @@ -720,25 +755,38 @@ slotPos :: Word8 -> ByteString slotPos pos = BS.pack ((replicate 31 (0::Word8))++[pos]) --- | Turns Literals into keccak(bytes32(id)) + offset (i.e. writes to arrays) -structureArraySlots :: Expr a -> Expr a -structureArraySlots e = mapExpr go e +-- Optimized litToArrayPreimage using the pre-computed map +litToArrayPreimage :: W256 -> Maybe (Word8, W256) +litToArrayPreimage val = + -- Find the largest 'imageHashKey' in our map such that 'imageHashKey <= val'. + case Map.lookupLE val preImageLookupMap of + Just (foundImageHashKey, array_id) -> + -- 'foundImageHashKey' is one of the keccak hashes from preImagesSource. + -- 'array_id' is the original Word8 (0-255) that produced this hash. + + -- We have found an 'foundImageHashKey' such that 'foundImageHashKey <= val'. + -- Now we must check if 'val' is also within the 256-byte range starting at 'foundImageHashKey', + -- i.e., 'val <= foundImageHashKey + 255'. + if val <= foundImageHashKey + 255 then + Just (array_id, val - foundImageHashKey) -- Return the id and the offset from the hash + else + -- 'val' is greater than the upper bound for 'foundImageHashKey'. + -- Since 'foundImageHashKey' was the largest key <= 'val', no other + -- (smaller) key in the map could satisfy the condition for its interval if this one doesn't. + Nothing + Nothing -> + -- No key in 'preImageLookupMap' is less than or equal to 'val'. + -- This implies 'val' is smaller than all computed 'image' hashes. + Nothing + +litToKeccak :: Expr a -> Expr a +litToKeccak e = mapExpr go e where go :: Expr a -> Expr a go orig@(Lit key) = case litToArrayPreimage key of Just (array, offset) -> ArraySlotWithOffs (slotPos array) (Lit offset) _ -> orig - go a = a - --- Takes in value, checks if it's within 256 of a pre-computed array hash value --- if it is, it returns (array_number, offset) -litToArrayPreimage :: W256 -> Maybe (Word8, W256) -litToArrayPreimage val = go preImages - where - go :: [(W256, Word8)] -> Maybe (Word8, W256) - go ((image, preimage):ax) = if val >= image && val-image <= 255 then Just (preimage, val-image) - else go ax - go [] = Nothing + go otherNode = otherNode -- | Writes a value to a key in a storage expression. -- @@ -816,6 +864,7 @@ Lit 64 -> setMap e _ -> setMixed e go e@(SLoad (ArraySlotWithOffs x _) _) = if BS.length x == 32 then setArray e else setMixed e + go e@(SLoad (ArraySlotWithOffs2 x _ _) _) = if BS.length x == 32 then setArray e else setMixed e go e@(SLoad (Lit x) _) | x < 256 = setSmall e go e@(SLoad _ _) = setMixed e go e@(SStore (MappingSlot x _) _ _) = if BS.length x == 64 then setMap e else setMixed e @@ -824,6 +873,7 @@ Lit 64 -> setMap e _ -> setMixed e go e@(SStore (ArraySlotWithOffs x _) _ _) = if BS.length x == 32 then setArray e else setMixed e + go e@(SStore (ArraySlotWithOffs2 x _ _) _ _) = if BS.length x == 32 then setArray e else setMixed e go e@(SStore (Lit x) _ _) | x < 256 = setSmall e go e@(SStore _ _ _) = setMixed e go _ = pure () @@ -897,6 +947,7 @@ (MappingSlot idx key) | BS.length idx == 64 -> Just (Just $ idxToWord idx, key) -- arrays (ArraySlotWithOffs idx offset) | BS.length idx == 32 -> Just (Just $ idxToWord64 idx, offset) + (ArraySlotWithOffs2 idx offs1 offs2) | BS.length idx == 32 -> Just (Just $ idxToWord64 idx, Add (Lit offs1) offs2) (ArraySlotZero idx) | BS.length idx == 32 -> Just (Just $ idxToWord64 idx, Lit 0) _ -> Nothing @@ -935,9 +986,12 @@ -- | Simple recursive match based AST simplification -- Note: may not terminate! simplify :: Expr a -> Expr a -simplify e = if (mapExpr go e == e) - then e - else simplify (mapExpr go (structureArraySlots e)) +simplify e = untilFixpoint (simplifyNoLitToKeccak . litToKeccak) e + +simplifyNoLitToKeccak :: Expr a -> Expr a +simplifyNoLitToKeccak l@(Lit _) = l +simplifyNoLitToKeccak s@(ConcreteStore _) = s +simplifyNoLitToKeccak e = untilFixpoint (mapExpr go) e where go :: Expr a -> Expr a @@ -947,6 +1001,12 @@ -- redundant CopySlice go (CopySlice (Lit 0x0) (Lit 0x0) (Lit 0x0) _ dst) = dst + -- We write over dst with data from src. As long as we read from where we write, and + -- it's the same size, we can just skip the 2nd CopySlice + go (CopySlice readOff dstOff size2 (CopySlice srcOff writeOff size1 src _) dst) | + size1 == size2 && readOff == writeOff = CopySlice srcOff dstOff size1 src dst + -- overwrite empty buf with a buf, return is the buf + go (CopySlice (Lit 0) (Lit 0) (BufLength src1) src2 (ConcreteBuf "")) | src1 == src2 = src1 -- simplify storage go (SLoad slot store) = readStorage' slot store @@ -992,21 +1052,26 @@ where simplifiedBuf = BS.take (unsafeInto (n+sz)) buf go (CopySlice a b c d f) = copySlice a b c d f + go (JoinBytes (LitByte a0) (LitByte a1) (LitByte a2) (LitByte a3) + (LitByte a4) (LitByte a5) (LitByte a6) (LitByte a7) + (LitByte a8) (LitByte a9) (LitByte a10) (LitByte a11) + (LitByte a12) (LitByte a13) (LitByte a14) (LitByte a15) + (LitByte a16) (LitByte a17) (LitByte a18) (LitByte a19) + (LitByte a20) (LitByte a21) (LitByte a22) (LitByte a23) + (LitByte a24) (LitByte a25) (LitByte a26) (LitByte a27) + (LitByte a28) (LitByte a29) (LitByte a30) (LitByte a31)) = + let b = map fromIntegral [a0, a1, a2, a3 ,a4, a5, a6, a7 + ,a8, a9, a10, a11 ,a12, a13, a14, a15 + ,a16, a17, a18, a19 ,a20, a21, a22, a23 + ,a24, a25, a26, a27 ,a28, a29, a30, a31] + in Lit (constructWord256 b) + go (IndexWord a b) = indexWord a b - -- LT - go (EVM.Types.LT (Lit a) (Lit b)) - | a < b = Lit 1 - | otherwise = Lit 0 - go (EVM.Types.LT _ (Lit 0)) = Lit 0 - go (EVM.Types.LT a (Lit 1)) = iszero a - -- normalize all comparisons in terms of LT - go (EVM.Types.GT a b) = lt b a - go (EVM.Types.GEq a b) = leq b a - go (EVM.Types.LEq a b) = iszero (lt b a) - go (SLT a@(Lit _) b@(Lit _)) = slt a b - go (SGT a b) = SLT b a + go (SEx a (SEx a2 b)) | a == a2 = sex a b + go (SEx _ (Lit 0)) = Lit 0 + go (SEx a b) = sex a b -- IsZero go (IsZero (IsZero (IsZero a))) = iszero a @@ -1030,23 +1095,16 @@ | x == 0 = b | otherwise = a + -- Masking as as per Solidity bit-packing of e.g. function parameters + go (And (Lit mask1) (Or (And (Lit mask2) _) x)) | (mask1 .&. mask2 == 0) + = And (Lit mask1) x + -- address masking go (And (Lit 0xffffffffffffffffffffffffffffffffffffffff) a@(WAddr _)) = a -- literal addresses go (WAddr (LitAddr a)) = Lit $ into a - -- XOR normalization - go (Xor a b) = EVM.Expr.xor a b - - -- simple div/mod/add/sub - go (Div o1@(Lit _) o2@(Lit _)) = EVM.Expr.div o1 o2 - go (SDiv o1@(Lit _) o2@(Lit _)) = EVM.Expr.sdiv o1 o2 - go (Mod o1@(Lit _) o2@(Lit _)) = EVM.Expr.mod o1 o2 - go (SMod o1@(Lit _) o2@(Lit _)) = EVM.Expr.smod o1 o2 - go (Add o1@(Lit _) o2@(Lit _)) = EVM.Expr.add o1 o2 - go (Sub o1@(Lit _) o2@(Lit _)) = EVM.Expr.sub o1 o2 - -- Mod go (Mod _ (Lit 0)) = Lit 0 go (SMod _ (Lit 0)) = Lit 0 @@ -1055,6 +1113,21 @@ go (Mod (Lit 0) _) = Lit 0 go (SMod (Lit 0) _) = Lit 0 + -- MulMod + go (MulMod (Lit 0) _ _) = Lit 0 + go (MulMod _ (Lit 0) _) = Lit 0 + go (MulMod _ _ (Lit 0)) = Lit 0 + go (MulMod a b c) = mulmod a b c + + -- AddMod + go (AddMod (Lit 0) a b) = Mod a b + go (AddMod a (Lit 0) b) = Mod a b + go (AddMod _ _ (Lit 0)) = Lit 0 + go (AddMod a b c) = addmod a b c + + -- Triple And (must be before 3-way sort below) + go (And (Lit a) (And (Lit b) c)) = And (EVM.Expr.and (Lit a) (Lit b)) c + -- double add/sub. -- Notice that everything is done mod 2**256. So for example: -- (a-b)+c observes the same arithmetic equalities as we are used to @@ -1067,7 +1140,6 @@ -- Notice: all Add is normalized, hence the 1st argument is -- expected to be Lit, if any. Hence `orig` needs to be the -- 2nd argument for Add. However, Sub is not normalized - go (Add (Lit x) (Add (Lit y) orig)) = add (Lit (x+y)) orig -- add + sub NOTE: every combination of Sub is needed (2) go (Add (Lit x) (Sub (Lit y) orig)) = sub (Lit (x+y)) orig go (Add (Lit x) (Sub orig (Lit y))) = add (Lit (x-y)) orig @@ -1080,18 +1152,52 @@ go (Sub (Lit x) (Add (Lit y) orig)) = sub (Lit (x-y)) orig go (Sub (Add (Lit x) orig) (Lit y) ) = add (Lit (x-y)) orig + -- Add+Add / Mul+Mul / Xor+Xor simplifications, taking + -- advantage of associativity and commutativity + -- Since Lit is smallest in the ordering, it will always be the first argument + -- hence these will collect Lits. See `simp-assoc..` tests + go (Add (Lit a) (Add (Lit b) x)) = add (Lit (a+b)) x + go (Mul (Lit a) (Mul (Lit b) x)) = mul (Lit (a*b)) x + go (Xor (Lit a) (Xor (Lit b) x)) = EVM.Expr.xor (Lit (Data.Bits.xor a b)) x + go (Add (Add a b) c) = add (l !! 0) (add (l !! 1) (l !! 2)) + where l = sort [a, b, c] + go (Add a (Add b c)) = add (l !! 0) (add (l !! 1) (l !! 2)) + where l = sort [a, b, c] + go (Mul (Mul a b) c) = mul (l !! 0) (mul (l !! 1) (l !! 2)) + where l = sort [a, b, c] + go (Mul a (Mul b c)) = mul (l !! 0) (mul (l !! 1) (l !! 2)) + where l = sort [a, b, c] + go (Xor (Xor a b) c) = x (l !! 0) (x (l !! 1) (l !! 2)) + where l = sort [a, b, c] + x = EVM.Expr.xor + go (Xor a (Xor b c)) = x (l !! 0) (x (l !! 1) (l !! 2)) + where l = sort [a, b, c] + x = EVM.Expr.xor + go (Or (Or a b) c) = o (l !! 0) (o (l !! 1) (l !! 2)) + where l = sort [a, b, c] + o = EVM.Expr.or + go (Or a (Or b c)) = o (l !! 0) (o (l !! 1) (l !! 2)) + where l = sort [a, b, c] + o = EVM.Expr.or + go (And (And a b) c) = an (l !! 0) (an (l !! 1) (l !! 2)) + where l = sort [a, b, c] + an = EVM.Expr.and + go (And a (And b c)) = an (l !! 0) (an (l !! 1) (l !! 2)) + where l = sort [a, b, c] + an = EVM.Expr.and + + -- A special pattern sometimes generated from Solidity that uses exponentiation to simulate bit shift. + -- We can rewrite the exponentiation into a bit-shift under certain conditions. + go (Exp (Lit 0x100) offset@(Mul (Lit a) (Mod _ (Lit b)))) + | a * b <= 32 && (maxWord256 `Prelude.div` a) > b = shl (mul (Lit 8) offset) (Lit 1) + go (Exp (Lit 0x100) offset@(Mod _ (Lit 32))) = (shl (mul (Lit 8) offset)) (Lit 1) + -- redundant add / sub go (Sub (Add a b) c) | a == c = b | b == c = a | otherwise = sub (add a b) c - -- Add is associative. We are doing left-growing trees because LIT is - -- arranged to the left. This way, they accumulate in all combinations. - -- See `sim-assoc-add` test cases in test.hs - go (Add a (Add b c)) = add (add a b) c - go (Add (Add (Lit a) x) (Lit b)) = add (Lit (a+b)) x - -- add / sub identities go (Add a b) | b == (Lit 0) = a @@ -1102,19 +1208,25 @@ | b == (Lit 0) = a | otherwise = sub a b - -- SHL / SHR by 0 + -- XOR normalization + go (Xor a b) = EVM.Expr.xor a b + + go (EqByte a b) = eqByte a b + + -- SHL / SHR / SAR go (SHL a v) | a == (Lit 0) = v + | v == (Lit 0) = v | otherwise = shl a v go (SHR a v) | a == (Lit 0) = v + | v == (Lit 0) = v | otherwise = shr a v - - -- doubled And - go o@(And a (And b c)) - | a == c = (And a b) - | a == b = (And b c) - | otherwise = o + go (SAR _ (Lit v)) | v == maxBound = Lit v + go (SAR a v) + | a == (Lit 0) = v + | v == (Lit 0) = v + | otherwise = sar a v -- Bitwise AND & OR. These MUST preserve bitwise equivalence go (And a b) @@ -1155,11 +1267,6 @@ (Lit 0, _) -> Lit 0 _ -> EVM.Expr.min a b - -- Mul is associative. We are doing left-growing trees because LIT is - -- arranged to the left. This way, they accumulate in all combinations. - -- See `sim-assoc-add` test cases in test.hs - go (Mul a (Mul b c)) = mul (mul a b) c - go (Mul (Mul (Lit a) x) (Lit b)) = mul (Lit (a*b)) x -- Some trivial mul eliminations go (Mul a b) = case (a, b) of @@ -1175,6 +1282,12 @@ go (SDiv _ (Lit 0)) = Lit 0 -- divide anything by 0 is zero in EVM go (SDiv a (Lit 1)) = a -- NOTE: Div x x is NOT 1, because Div 0 0 is 0, not 1. + -- + go (Exp _ (Lit 0)) = Lit 1 -- everything, including 0, to the power of 0 is 1 + go (Exp a (Lit 1)) = a -- everything, including 0, to the power of 1 is itself + go (Exp (Lit 1) _) = Lit 1 -- 1 to any value (including 0) is 1 + -- NOTE: we can't simplify (Lit 0)^k. If k is 0 it's 1, otherwise it's 0. + -- this is encoded in SMT.hs instead, via an SMT "ite" -- If a >= b then the value of the `Max` expression can never be < b go o@(LT (Max (Lit a) _) (Lit b)) @@ -1189,6 +1302,29 @@ then Lit 0 else o + -- normalize all comparisons in terms of (S)LT + go (EVM.Types.GT a b) = lt b a + go (EVM.Types.GEq a b) = leq b a + go (EVM.Types.LEq a b) = iszero (lt b a) + go (SGT a b) = slt b a + + -- LT + go (EVM.Types.LT _ (Lit 0)) = Lit 0 + go (EVM.Types.LT a (Lit 1)) = iszero a + go (EVM.Types.LT (Lit 0) a) = iszero (Eq (Lit 0) a) + go (EVM.Types.LT a b) = lt a b + + -- SLT + go (SLT _ (Lit a)) | a == minLitSigned = Lit 0 + go (SLT (Lit a) _) | a == maxLitSigned = Lit 0 + go (SLT a b) = slt a b + + -- simple div/mod/add/sub + go (Div o1 o2) = EVM.Expr.div o1 o2 + go (SDiv o1 o2) = EVM.Expr.sdiv o1 o2 + go (Mod o1 o2) = EVM.Expr.mod o1 o2 + go (SMod o1 o2) = EVM.Expr.smod o1 o2 + go a = a @@ -1198,9 +1334,12 @@ simplifyProps :: [Prop] -> [Prop] simplifyProps ps = if cannotBeSat then [PBool False] else simplified where - simplified = remRedundantProps . map simplifyProp . flattenProps $ ps - cannotBeSat = isUnsat simplified + simplified = untilFixpoint goOne ps + cannotBeSat = PBool False `elem` simplified + goOne :: [Prop] -> [Prop] + goOne = remRedundantProps . map simplifyProp . constPropagate . flattenProps + -- | Evaluate the provided proposition down to its most concrete result -- Also simplifies the inner Expr, if it exists simplifyProp :: Prop -> Prop @@ -1210,29 +1349,60 @@ where go :: Prop -> Prop - -- LT/LEq comparisons + -- Rewrite PGT/GEq to PLT/PLEq go (PGT a b) = PLT b a go (PGEq a b) = PLEq b a + + -- PLT/PLEq comparisons go (PLT (Var _) (Lit 0)) = PBool False go (PLEq (Lit 0) _) = PBool True go (PLEq (WAddr _) (Lit 1461501637330902918203684832716283019655932542975)) = PBool True go (PLEq _ (Lit x)) | x == maxLit = PBool True go (PLT (Lit val) (Var _)) | val == maxLit = PBool False go (PLEq (Var _) (Lit val)) | val == maxLit = PBool True + go (PLT a b) | a == b = PBool False go (PLT (Lit l) (Lit r)) = PBool (l < r) + go (PLEq a b) | a == b = PBool True go (PLEq (Lit l) (Lit r)) = PBool (l <= r) go (PLEq a (Max b _)) | a == b = PBool True go (PLEq a (Max _ b)) | a == b = PBool True go (PLEq (Sub a b) c) | a == c = PLEq b a go (PLT (Max (Lit a) b) (Lit c)) | a < c = PLT b (Lit c) go (PLT (Lit 0) (Eq a b)) = peq a b + go (PLEq a b) = pleq a b + -- when it's PLT but comparison on the RHS then it's just (PEq 1 RHS) + go (PLT (Lit 0) (a@LT {})) = peq (Lit 1) a + go (PLT (Lit 0) (a@LEq {})) = peq (Lit 1) a + go (PLT (Lit 0) (a@SLT {})) = peq (Lit 1) a + go (PLT (Lit 0) (a@GT {})) = peq (Lit 1) a + go (PLT (Lit 0) (a@GEq {})) = peq (Lit 1) a + go (PLT (Lit 0) (a@SGT {})) = peq (Lit 1) a + go (POr (PLEq a1 (Lit b)) (PLEq (Lit c) a2)) | a1 == a2 && c == b+1 = PBool True + -- negations go (PNeg (PBool b)) = PBool (Prelude.not b) go (PNeg (PNeg a)) = a + go (PNeg (PGT a b)) = PLEq a b + go (PNeg (PGEq a b)) = PLT a b + go (PNeg (PLT a b)) = PGEq a b + go (PNeg (PLEq a b)) = PGT a b + go (PNeg (PAnd a b)) = POr (PNeg a) (PNeg b) + go (PNeg (POr a b)) = PAnd (PNeg a) (PNeg b) + go (PNeg (PEq (Lit 1) (IsZero b))) = PEq (Lit 0) (IsZero b) + -- Empty buf + go (PEq (Lit 0) (BufLength k)) = peq k (ConcreteBuf "") + go (PEq (Lit 0) (Or a b)) = peq a (Lit 0) `PAnd` peq b (Lit 0) + + -- PEq rewrites (notice -- GT/GEq is always rewritten to LT by simplify) + go (PEq (Lit 1) (IsZero (LT a b))) = PLT a b + go (PEq (Lit 1) (IsZero (LEq a b))) = PLEq a b + go (PEq (Lit 0) (IsZero a)) = PLT (Lit 0) a + go (PEq a1 (Add a2 y)) | a1 == a2 = peq y (Lit 0) + -- solc specific stuff - go (PEq (Lit 0) (IsZero (IsZero (Eq a b)))) = PNeg (peq a b) + go (PLT (Lit 0) (IsZero (Eq a b))) = PNeg (peq a b) -- iszero(a) -> (a == 0) -- iszero(iszero(a))) -> ~(a == 0) -> a > 0 @@ -1266,18 +1436,18 @@ go (PImpl (PBool True) b) = b go (PImpl (PBool False) _) = PBool True - -- Double negation - go (PEq (Lit 0) (IsZero (Eq a b))) = peq a b - go (PEq (Lit 0) (IsZero (LT a b))) = PLT a b - go (PEq (Lit 0) (IsZero (GT a b))) = PGT a b - go (PEq (Lit 0) (IsZero (LEq a b))) = PLEq a b - go (PEq (Lit 0) (IsZero (GEq a b))) = PGEq a b + -- Double negation (no need for GT/GEq, as it's rewritten to LT/LEq) -- Eq go (PEq (Lit 0) (Eq a b)) = PNeg (peq a b) go (PEq (Lit 1) (Eq a b)) = peq a b go (PEq (Lit 0) (Sub a b)) = peq a b go (PEq (Lit 0) (LT a b)) = PLEq b a + go (PEq (Lit 0) (LEq a b)) = PLT b a + go (PEq (Lit 1) (LT a b)) = PLT a b + go (PEq (Lit 1) (LEq a b)) = PLEq a b + go (PEq (Lit 1) (GT a b)) = PGT a b + go (PEq (Lit 1) (GEq a b)) = PGEq a b go (PEq l r) = peq l r go p = p @@ -1326,13 +1496,10 @@ -- TODO: make this smarter, probably we will need to use the solver here? wordToAddr :: Expr EWord -> Maybe (Expr EAddr) -wordToAddr = go . simplify - where - go :: Expr EWord -> Maybe (Expr EAddr) - go = \case - WAddr a -> Just a - Lit a -> Just $ LitAddr (truncateToAddr a) - _ -> Nothing +wordToAddr e = case (concKeccakSimpExpr e) of + WAddr a -> Just a + Lit a -> Just $ LitAddr (truncateToAddr a) + _ -> Nothing litCode :: BS.ByteString -> [Expr Byte] litCode bs = fmap LitByte (BS.unpack bs) @@ -1367,6 +1534,10 @@ Partial {} -> True _ -> False +isSymAddr :: Expr EAddr -> Bool +isSymAddr (SymAddr _) = True +isSymAddr _ = False + -- | Returns the byte at idx from the given word. indexWord :: Expr EWord -> Expr EWord -> Expr Byte -- Simplify masked reads: @@ -1420,6 +1591,11 @@ fullWordMask = (2 ^ (256 :: W256)) - 1 unmaskedBytes = fromIntegral $ (countLeadingZeros mask) `Prelude.div` 8 isByteAligned m = (countLeadingZeros m) `Prelude.mod` 8 == 0 +-- This pattern happens in Solidity for function selectors. Since Lit 0xfff... (28 bytes of 0xff) +-- is masking the function selector, it can be simplified to just the function selector bytes. Remember, +-- indexWord takes the MSB i-th byte when called with (indexWord i). +indexWord (Lit a) (Or funSel (And (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffff) _)) | a < 4 = + indexWord (Lit a) funSel indexWord (Lit idx) (Lit w) | idx <= 31 = LitByte . fromIntegral $ shiftR w (248 - unsafeInto idx * 8) | otherwise = LitByte 0 @@ -1484,7 +1660,7 @@ joinBytes :: [Expr Byte] -> Expr EWord joinBytes bs - | Prelude.and . (fmap isLitByte) $ bs = Lit . bytesToW256 . (mapMaybe maybeLitByte) $ bs + | all isLitByte bs = Lit . bytesToW256 . (mapMaybe maybeLitByteSimp) $ bs | otherwise = let bytes = padBytesLeft 32 bs in JoinBytes @@ -1499,7 +1675,7 @@ eqByte :: Expr Byte -> Expr Byte -> Expr EWord eqByte (LitByte x) (LitByte y) = Lit $ if x == y then 1 else 0 -eqByte x y = EqByte x y +eqByte x y = if x < y then EqByte x y else EqByte y x min :: Expr EWord -> Expr EWord -> Expr EWord min x y = normArgs Min Prelude.min x y @@ -1514,7 +1690,7 @@ numBranches _ = 1 allLit :: [Expr Byte] -> Bool -allLit = Data.List.and . fmap (isLitByte) +allLit = all isLitByte -- | True if the given expression contains any node that satisfies the -- input predicate @@ -1526,64 +1702,89 @@ go _ = Any False inRange :: Int -> Expr EWord -> Prop -inRange sz e = PAnd (PGEq e (Lit 0)) (PLEq e (Lit $ 2 ^ sz - 1)) +inRange sz e = if sz == 256 then PBool True else PLEq e (Lit $ 2 ^ sz - 1) +inRangeSigned :: Int -> Expr EWord -> Prop +inRangeSigned sz e = ((PLEq e (Lit $ 2 ^ (sz - 1) - 1)) `POr` (PGEq e $ Lit $ ((2 ^ sz) - 2 ^ (sz - 1)))) -- | images of keccak(bytes32(x)) where 0 <= x < 256 preImages :: [(W256, Word8)] preImages = [(keccak' (word256Bytes . into $ i), i) | i <- [0..255]] +-- | images of keccak(bytes32(x)) where 0 <= x < 256 +preImageLookupMap :: Map.Map W256 Word8 +preImageLookupMap = Map.fromList preImages data ConstState = ConstState { values :: Map.Map (Expr EWord) W256 , canBeSat :: Bool } deriving (Show) --- | Checks if a conjunction of propositions is definitely unsatisfiable -isUnsat :: [Prop] -> Bool -isUnsat ps = Prelude.not $ oneRun ps (ConstState mempty True) +-- | Performs constant propagation +constPropagate :: [Prop] -> [Prop] +constPropagate ps = + let consts = collectConsts ps (ConstState mempty True) + in if consts.canBeSat then substitute consts ps ++ fixVals consts + else [PBool False] where - oneRun ps2 startState = (execState (mapM (go . simplifyProp) ps2) startState).canBeSat + -- Fixes the values of the constants + fixVals :: ConstState -> [Prop] + fixVals cs = Map.foldrWithKey (\k v acc -> peq (Lit v) k : acc) [] cs.values + + -- Substitutes the constants in the props. + -- NOTE: will create PEq (Lit x) (Lit x) if x is a constant + -- hence we need the fixVals function to add them back in + substitute :: ConstState -> [Prop] -> [Prop] + substitute cs ps2 = map (mapProp (subsGo cs)) ps2 + subsGo :: ConstState -> Expr a-> Expr a + subsGo cs (Var v) = case Map.lookup (Var v) cs.values of + Just x -> Lit x + Nothing -> Var v + subsGo _ x = x + + -- Collects all the constants in the given props, and sets canBeSat to False if UNSAT + collectConsts ps2 startState = execState (mapM go ps2) startState go :: Prop -> State ConstState () go = \case - -- PEq PEq (Lit l) a -> do s <- get case Map.lookup a s.values of Just l2 -> unless (l==l2) $ put ConstState {canBeSat=False, values=mempty} Nothing -> modify (\s' -> s'{values=Map.insert a l s'.values}) PEq a b@(Lit _) -> go (PEq b a) - -- PNeg PNeg (PEq (Lit l) a) -> do s <- get case Map.lookup a s.values of Just l2 -> when (l==l2) $ put ConstState {canBeSat=False, values=mempty} Nothing -> pure () PNeg (PEq a b@(Lit _)) -> go $ PNeg (PEq b a) - -- Others PAnd a b -> do go a go b POr a b -> do s <- get let - v1 = oneRun [a] s - v2 = oneRun [b] s - unless v1 $ go b - unless v2 $ go a + v1 = collectConsts [a] s + v2 = collectConsts [b] s + unless v1.canBeSat $ go b + unless v2.canBeSat $ go a PBool False -> put $ ConstState {canBeSat=False, values=mempty} _ -> pure () -- Concretize & simplify Keccak expressions until fixed-point. concKeccakSimpExpr :: Expr a -> Expr a -concKeccakSimpExpr orig = untilFixpoint ((mapExpr concKeccakOnePass) . simplify) orig +concKeccakSimpExpr orig = untilFixpoint (simplifyNoLitToKeccak . (mapExpr concKeccakOnePass)) (simplify orig) --- Only concretize Keccak in Props +-- Concretize Keccak in Props, but don't simplify -- Needed because if it also simplified, we may not find some simplification errors, as -- simplification would always be ON concKeccakProps :: [Prop] -> [Prop] concKeccakProps orig = untilFixpoint (map (mapProp concKeccakOnePass)) orig +-- As above, but also simplify, to fixedpoint +concKeccakSimpProps :: [Prop] -> [Prop] +concKeccakSimpProps orig = untilFixpoint (simplifyProps . map (mapProp concKeccakOnePass)) orig + -- Simplifies in case the input to the Keccak is of specific array/map format and -- can be simplified into a concrete value -- Turns (Keccak ConcreteBuf) into a Lit @@ -1616,3 +1817,30 @@ -- Commutative operators should have the constant on the LHS checkLHSConst :: Expr a -> Bool checkLHSConst a = isJust $ mapExprM_ lhsConstHelper a + +maybeLitByteSimp :: Expr Byte -> Maybe Word8 +maybeLitByteSimp (LitByte x) = Just x +maybeLitByteSimp e = case concKeccakSimpExpr e of + LitByte x -> Just x + _ -> Nothing + +maybeLitWordSimp :: Expr EWord -> Maybe W256 +maybeLitWordSimp (Lit w) = Just w +maybeLitWordSimp (WAddr (LitAddr w)) = Just (into w) +maybeLitWordSimp e = case concKeccakSimpExpr e of + Lit w -> Just w + WAddr (LitAddr w) -> Just (into w) + _ -> Nothing + +maybeLitAddrSimp :: Expr EAddr -> Maybe Addr +maybeLitAddrSimp (LitAddr a) = Just a +maybeLitAddrSimp e = case concKeccakSimpExpr e of + LitAddr a -> Just a + _ -> Nothing + +maybeConcStoreSimp :: Expr Storage -> Maybe (LMap.Map W256 W256) +maybeConcStoreSimp (ConcreteStore s) = Just s +maybeConcStoreSimp e = case concKeccakSimpExpr e of + ConcreteStore s -> Just s + _ -> Nothing + diff --git a/src/EVM/Fetch.hs b/src/EVM/Fetch.hs --- a/src/EVM/Fetch.hs +++ b/src/EVM/Fetch.hs @@ -27,7 +27,9 @@ import System.Environment (lookupEnv, getEnvironment) import System.Process import Control.Monad.IO.Class +import Control.Monad (when) import EVM.Effects +import qualified EVM.Expr as Expr -- | Abstract representation of an RPC fetch request data RpcQuery a where @@ -113,7 +115,7 @@ parseBlock j = do coinbase <- LitAddr . readText <$> j ^? key "miner" % _String timestamp <- Lit . readText <$> j ^? key "timestamp" % _String - number <- readText <$> j ^? key "number" % _String + number <- Lit . readText <$> j ^? key "number" % _String gasLimit <- readText <$> j ^? key "gasLimit" % _String let baseFee = readText <$> j ^? key "baseFeePerGas" % _String @@ -183,11 +185,7 @@ sess <- Session.newAPISession fetchQuery Latest (fetchWithSession url sess) QueryChainId -http :: Natural -> Maybe Natural -> BlockNumber -> Text -> Fetcher t m s -http smtjobs smttimeout n url q = - withSolvers Z3 smtjobs 1 smttimeout $ \s -> - oracle s (Just (n, url)) q - +-- Only used for testing (test.hs, BlockchainTests.hs) zero :: Natural -> Maybe Natural -> Fetcher t m s zero smtjobs smttimeout q = withSolvers Z3 smtjobs 1 smttimeout $ \s -> @@ -212,7 +210,14 @@ -- Is is possible to satisfy the condition? continue <$> checkBranch solvers (branchcondition ./= (Lit 0)) pathconds + PleaseGetSols symExpr numBytes pathconditions continue -> do + let pathconds = foldl' PAnd (PBool True) pathconditions + continue <$> getSolutions solvers symExpr numBytes pathconds + PleaseFetchContract addr base continue -> do + conf <- readConfig + when (conf.debug) $ liftIO $ putStrLn $ "Fetching contract at " ++ show addr + when (addr == 0 && conf.verb > 0) $ liftIO $ putStrLn "Warning: fetching contract at address 0" contract <- case info of Nothing -> let c = case base of @@ -224,7 +229,10 @@ Just x -> pure $ continue x Nothing -> internalError $ "oracle error: " ++ show q - PleaseFetchSlot addr slot continue -> + PleaseFetchSlot addr slot continue -> do + conf <- readConfig + when (conf.debug) $ liftIO $ putStrLn $ "Fetching slot " <> (show slot) <> " at " <> (show addr) + when (addr == 0 && conf.verb > 0) $ liftIO $ putStrLn "Warning: fetching slot from a contract at address 0" case info of Nothing -> pure (continue 0) Just (n, url) -> @@ -239,6 +247,24 @@ type Fetcher t m s = App m => Query t s -> m (EVM t s ()) +getSolutions :: forall m . App m => SolverGroup -> Expr EWord -> Int -> Prop -> m (Maybe [W256]) +getSolutions solvers symExprPreSimp numBytes pathconditions = do + conf <- readConfig + liftIO $ do + let symExpr = Expr.concKeccakSimpExpr symExprPreSimp + -- when conf.debug $ putStrLn $ "Collecting solutions to symbolic query: " <> show symExpr + ret <- collectSolutions symExpr pathconditions conf + case ret of + Nothing -> pure Nothing + Just r -> case length r of + 0 -> pure Nothing + _ -> pure $ Just r + where + collectSolutions :: Expr EWord -> Prop -> Config -> IO (Maybe [W256]) + collectSolutions symExpr conds conf = do + let smt2 = assertProps conf [(PEq (Var "multiQueryVar") symExpr) .&& conds] + checkMulti solvers smt2 $ MultiSol { maxSols = conf.maxWidth , numBytes = numBytes , var = "multiQueryVar" } + -- | Checks which branches are satisfiable, checking the pathconditions for consistency -- if the third argument is true. -- When in debug mode, we do not want to be able to navigate to dead paths, @@ -246,19 +272,20 @@ -- will be pruned anyway. checkBranch :: App m => SolverGroup -> Prop -> Prop -> m BranchCondition checkBranch solvers branchcondition pathconditions = do - conf <- readConfig - liftIO $ checkSat solvers (assertProps conf [(branchcondition .&& pathconditions)]) >>= \case + let props = [pathconditions .&& branchcondition] + checkSatWithProps solvers props >>= \case -- the condition is unsatisfiable - Unsat -> -- if pathconditions are consistent then the condition must be false + (Qed, _) -> -- if pathconditions are consistent then the condition must be false pure $ Case False -- Sat means its possible for condition to hold - Sat _ -> do -- is its negation also possible? - checkSat solvers (assertProps conf [(pathconditions .&& (PNeg branchcondition))]) >>= \case + (Cex {}, _) -> do -- is its negation also possible? + let propsNeg = [pathconditions .&& (PNeg branchcondition)] + checkSatWithProps solvers propsNeg >>= \case -- No. The condition must hold - Unsat -> pure $ Case True + (Qed, _) -> pure $ Case True -- Yes. Both branches possible - Sat _ -> pure EVM.Types.Unknown - -- If the query times out, or can't be executed (e.g. symbolic copyslice) we simply explore both paths - _ -> pure EVM.Types.Unknown + (Cex {}, _) -> pure UnknownBranch + -- If the query times out, or can't be executed (e.g. symbolic copyslice) we simply explore both paths + _ -> pure UnknownBranch -- If the query times out, or can't be executed (e.g. symbolic copyslice) we simply explore both paths - _ -> pure EVM.Types.Unknown + _ -> pure UnknownBranch diff --git a/src/EVM/Format.hs b/src/EVM/Format.hs --- a/src/EVM/Format.hs +++ b/src/EVM/Format.hs @@ -4,7 +4,10 @@ ( formatExpr , formatSomeExpr , formatPartial + , formatPartialShort , formatProp + , formatState + , formatError , contractNamePart , contractPathPart , showError @@ -28,7 +31,6 @@ , strip0x' , hexByteString , hexText - , bsToHex , showVal ) where @@ -38,8 +40,9 @@ import EVM.ABI (getAbiSeq, parseTypeName, AbiValue(..), AbiType(..), SolError(..), Indexed(..), Event(..)) import EVM.Dapp (DappContext(..), DappInfo(..), findSrc, showTraceLocation) import EVM.Expr qualified as Expr -import EVM.Solidity (SolcContract(..), Method(..), contractName, abiMap) +import EVM.Solidity (SolcContract(..), Method(..)) import EVM.Types +import EVM.Expr (maybeLitWordSimp, maybeLitAddrSimp) import Control.Arrow ((>>>)) import Optics.Core @@ -56,7 +59,7 @@ import Data.Foldable (toList) import Data.List (isPrefixOf, sort) import Data.Map qualified as Map -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Text (Text, pack, unpack, intercalate, dropEnd, splitOn) import Data.Text qualified as T import Data.Text.Encoding qualified as T @@ -121,6 +124,13 @@ Left (_, _, _) -> [formatBinary bs] textValues ts _ = fmap (const "") ts +textValue :: (?context :: DappContext) => AbiType -> Expr Buf -> Text +textValue ts (ConcreteBuf bs) = + case runGetOrFail (getAbiSeq 1 [ts]) (fromStrict bs) of + Right (_, _, xs) -> fromMaybe (internalError "impossible empty list") $ listToMaybe $ textAbiValues xs + Left (_, _, _) -> formatBinary bs +textValue _ _ = "" + parenthesise :: [Text] -> Text parenthesise ts = "(" <> intercalate ", " ts <> ")" @@ -128,7 +138,7 @@ showValues ts b = parenthesise $ textValues ts b showValue :: (?context :: DappContext) => AbiType -> Expr Buf -> Text -showValue t b = head $ textValues [t] b +showValue t b = textValue t b showCall :: (?context :: DappContext) => [AbiType] -> Expr Buf -> Text showCall ts (ConcreteBuf bs) = showValues ts $ ConcreteBuf (BS.drop 4 bs) @@ -211,7 +221,7 @@ [] -> logn firstTopic:restTopics -> - case maybeLitWord firstTopic of + case maybeLitWordSimp firstTopic of Just topic -> case Map.lookup topic dapp.eventMap of Just (Event name _ argInfos) -> @@ -229,7 +239,7 @@ -- ) anonymous; let sig = unsafeInto $ shiftR topic 224 :: FunctionSelector - usr = case maybeLitWord t2 of + usr = case maybeLitWordSimp t2 of Just w -> pack $ show (unsafeInto w :: Addr) Nothing -> @@ -274,8 +284,8 @@ where showTopic :: AbiType -> Expr EWord -> Text showTopic abiType topic = - case maybeLitWord (Expr.concKeccakSimpExpr topic) of - Just w -> head $ textValues [abiType] (ConcreteBuf (word256Bytes w)) + case maybeLitWordSimp (Expr.concKeccakSimpExpr topic) of + Just w -> textValue abiType (ConcreteBuf (word256Bytes w)) _ -> "" withName :: Text -> Text -> Text @@ -369,7 +379,7 @@ case (findSrc contract ?context.info) of Just x -> Just (contractNamePart x.contractName) Nothing -> Nothing - label = case do litAddr <- maybeLitAddr addr + label = case do litAddr <- maybeLitAddrSimp addr Map.lookup litAddr ?context.labels of Nothing -> "" Just l -> "[" <> "\x1b[1m" <> l <> "\x1b[0m" <> "]" @@ -457,7 +467,7 @@ formatPartial :: PartialExec -> Text formatPartial = \case - (UnexpectedSymbolicArg pc opcode msg args) -> T.unlines + UnexpectedSymbolicArg pc opcode msg args -> T.unlines [ "Unexpected Symbolic Arguments to Opcode" , indent 2 $ T.unlines [ "msg: " <> T.pack (show msg) @@ -469,10 +479,31 @@ ] MaxIterationsReached pc addr -> "Max Iterations Reached in contract: " <> formatAddr addr <> " pc: " <> pack (show pc) <> " To increase the maximum, set a fixed large (or negative) value for `--max-iterations` on the command line" JumpIntoSymbolicCode pc idx -> "Encountered a jump into a potentially symbolic code region while executing initcode. pc: " <> pack (show pc) <> " jump dst: " <> pack (show idx) + CheatCodeMissing pc selector ->T.unlines + [ "Cheat code not recognized" + , "program counter: " <> T.pack (show pc) + , "function selector: " <> T.pack (show selector) + ] + BranchTooDeep pc -> T.unlines ["Branches too deep at program counter: " <> pack (show pc)] +formatPartialShort :: PartialExec -> Text +formatPartialShort = \case + UnexpectedSymbolicArg _ opcode _ _ -> "Unexpected symbolic arguments to opcode: " <> T.pack opcode + MaxIterationsReached {} -> "Max iterations reached" + JumpIntoSymbolicCode {} -> "Encountered a jump into a potentially symbolic code region while executing initcode" + CheatCodeMissing _ selector -> "Cheat code not recognized: " <> T.pack (show selector) + BranchTooDeep pc -> "Branches too deep at program counter: " <> pack (show pc) + formatSomeExpr :: SomeExpr -> Text -formatSomeExpr (SomeExpr e) = formatExpr e +formatSomeExpr (SomeExpr e) = formatExpr $ Expr.simplify e +formatState :: Map.Map (Expr EAddr) (Expr EContract) -> Text +formatState store = indent 2 $ T.unlines (fmap (\(k,v) -> + T.unlines + [ formatExpr k <> ":" + , indent 2 $ formatExpr v + ]) (Map.toList store)) + formatExpr :: Expr a -> Text formatExpr = go where @@ -494,17 +525,10 @@ Success asserts _ buf store -> T.unlines [ "(Success" , indent 2 $ T.unlines - [ "Data:" - , indent 2 $ formatExpr buf + [ "Data:" , indent 2 $ formatExpr buf , "" - , "State:" - , indent 2 $ T.unlines (fmap (\(k,v) -> - T.unlines - [ formatExpr k <> ":" - , indent 2 $ formatExpr v - ]) (Map.toList store)) - , "Assertions:" - , indent 2 . T.unlines $ fmap formatProp asserts + , "State:", formatState store + , "Assertions:", indent 2 . T.unlines $ fmap formatProp asserts ] , ")" ] @@ -837,9 +861,6 @@ case BS16.decodeBase16Untyped (T.encodeUtf8 (T.drop 2 t)) of Right x -> x _ -> internalError $ "invalid hex bytestring " ++ show t - -bsToHex :: ByteString -> String -bsToHex bs = concatMap (paddedShowHex 2) (BS.unpack bs) showVal :: AbiValue -> Text showVal (AbiBytes _ bs) = formatBytes bs diff --git a/src/EVM/Fuzz.hs b/src/EVM/Fuzz.hs --- a/src/EVM/Fuzz.hs +++ b/src/EVM/Fuzz.hs @@ -15,7 +15,7 @@ import EVM.Expr qualified as Expr import EVM.Expr (bytesToW256) -import EVM.SMT qualified as SMT (BufModel(..), SMTCex(..)) +import EVM.Types qualified as SMT import EVM.Traversals import EVM.Types (Prop(..), W256, Expr(..), EType(..), internalError, keccak') @@ -27,7 +27,7 @@ tryCexFuzz :: [Prop] -> Integer -> (Maybe (SMT.SMTCex)) tryCexFuzz prePs tries = unGen (testVals tries) (mkQCGen 0) 1337 where - ps = Expr.simplifyProps $ Expr.concKeccakProps prePs + ps = Expr.concKeccakSimpProps prePs vars = extractVars ps bufs = extractBufs ps stores = extractStorage ps @@ -39,7 +39,7 @@ storeVals <- getStores stores let ret = filterCorrectKeccak $ map (substituteEWord varvals . substituteBuf bufVals . substituteStores storeVals) ps - retSimp = Expr.simplifyProps $ Expr.concKeccakProps ret + retSimp = Expr.concKeccakSimpProps ret if null retSimp then pure $ Just (SMT.SMTCex { vars = varvals , addrs = mempty diff --git a/src/EVM/Keccak.hs b/src/EVM/Keccak.hs --- a/src/EVM/Keccak.hs +++ b/src/EVM/Keccak.hs @@ -63,10 +63,10 @@ keccakAssumptions ps bufs stores = injectivity <> minValue <> minDiffOfPairs where (_, st) = runState (findKeccakPropsExprs ps bufs stores) initState - - keccakPairs = uniquePairs (Set.toList st.keccakExprs) + ks = Set.toList $ Set.map concretizeKeccakParam st.keccakExprs + keccakPairs = uniquePairs ks injectivity = map injProp keccakPairs - minValue = map minProp (Set.toList st.keccakExprs) + minValue = map minProp ks minDiffOfPairs = map minDistance keccakPairs where minDistance :: (Expr EWord, Expr EWord) -> Prop @@ -76,23 +76,28 @@ req2 = (PGEq (Sub kb ka) (Lit 256)) minDistance _ = internalError "expected Keccak expression" -compute :: forall a. Expr a -> [Prop] +concretizeKeccakParam :: Expr EWord -> Expr EWord +concretizeKeccakParam (Keccak buf) = Keccak (concKeccakSimpExpr buf) +concretizeKeccakParam _ = internalError "Cannot happen" + +compute :: forall a. Expr a -> Set Prop compute = \case e@(Keccak buf) -> do let b = simplify buf case keccak b of - lit@(Lit _) -> [PEq lit e] - _ -> [] - _ -> [] + lit@(Lit _) -> Set.singleton (PEq lit (concretizeKeccakParam e)) + _ -> Set.empty + _ -> Set.empty -computeKeccakExpr :: forall a. Expr a -> [Prop] -computeKeccakExpr e = foldExpr compute [] e +computeKeccakExpr :: forall a. Expr a -> Set Prop +computeKeccakExpr e = foldExpr compute Set.empty e -computeKeccakProp :: Prop -> [Prop] -computeKeccakProp p = foldProp compute [] p +computeKeccakProp :: Prop -> Set Prop +computeKeccakProp p = foldProp compute Set.empty p keccakCompute :: [Prop] -> [Expr Buf] -> [Expr Storage] -> [Prop] keccakCompute ps buf stores = - concatMap computeKeccakProp ps <> - concatMap computeKeccakExpr buf <> - concatMap computeKeccakExpr stores + Set.toList $ + (foldMap computeKeccakProp ps) <> + (foldMap computeKeccakExpr buf) <> + (foldMap computeKeccakExpr stores) diff --git a/src/EVM/SMT.hs b/src/EVM/SMT.hs --- a/src/EVM/SMT.hs +++ b/src/EVM/SMT.hs @@ -9,15 +9,16 @@ import Prelude hiding (LT, GT) import Control.Monad -import Data.Containers.ListUtils (nubOrd) +import Data.Containers.ListUtils (nubOrd, nubInt) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.List qualified as List import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty qualified as NonEmpty import Data.String.Here -import Data.Maybe (fromJust, fromMaybe, isJust) +import Data.Maybe (fromJust, fromMaybe, isJust, listToMaybe) import Data.Either.Extra (fromRight') +import Data.Foldable (fold) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) @@ -27,6 +28,7 @@ import Data.Text qualified as TS import Data.Text.Lazy qualified as T import Data.Text.Lazy.Builder +import Data.Text.Read (decimal) import Language.SMT2.Parser (getValueRes, parseCommentFreeFileMsg) import Language.SMT2.Syntax (Symbol, SpecConstant(..), GeneralRes(..), Term(..), QualIdentifier(..), Identifier(..), Sort(..), Index(..), VarBinding(..)) import Numeric (readHex, readBin) @@ -75,58 +77,7 @@ , txContext = mempty } --- | A model for a buffer, either in it's compressed form (for storing parsed --- models from a solver), or as a bytestring (for presentation to users) -data BufModel - = Comp CompressedBuf - | Flat ByteString - deriving (Eq, Show) --- | This representation lets us store buffers of arbitrary length without --- exhausting the available memory, it closely matches the format used by --- smt-lib when returning models for arrays -data CompressedBuf - = Base { byte :: Word8, length :: W256} - | Write { byte :: Word8, idx :: W256, next :: CompressedBuf } - deriving (Eq, Show) - - --- | a final post shrinking cex, buffers here are all represented as concrete bytestrings -data SMTCex = SMTCex - { vars :: Map (Expr EWord) W256 - , addrs :: Map (Expr EAddr) Addr - , buffers :: Map (Expr Buf) BufModel - , store :: Map (Expr EAddr) (Map W256 W256) - , blockContext :: Map (Expr EWord) W256 - , txContext :: Map (Expr EWord) W256 - } - deriving (Eq, Show) - -instance Semigroup SMTCex where - a <> b = SMTCex - { vars = a.vars <> b.vars - , addrs = a.addrs <> b.addrs - , buffers = a.buffers <> b.buffers - , store = a.store <> b.store - , blockContext = a.blockContext <> b.blockContext - , txContext = a.txContext <> b.txContext - } - -instance Monoid SMTCex where - mempty = SMTCex - { vars = mempty - , addrs = mempty - , buffers = mempty - , store = mempty - , blockContext = mempty - , txContext = mempty - } - -flattenBufs :: SMTCex -> Maybe SMTCex -flattenBufs cex = do - bs <- mapM collapse cex.buffers - pure $ cex{ buffers = bs } - -- | Attempts to collapse a compressed buffer representation down to a flattened one collapse :: BufModel -> Maybe BufModel collapse model = case toBuf model of @@ -141,6 +92,7 @@ getVar :: SMTCex -> TS.Text -> W256 getVar cex name = fromJust $ Map.lookup (Var name) cex.vars +-- Props are ONLY for pretty printing the query Props data SMT2 = SMT2 [Builder] CexVars [Prop] deriving (Eq, Show) @@ -164,7 +116,7 @@ sorted = List.sortBy compareFst $ Map.toList $ encSs <> encBs decls <- mapM snd sorted let smt2 = (SMT2 [fromText "; intermediate buffers & stores"] mempty mempty):decls - pure $ foldr (<>) mempty smt2 + pure $ fold smt2 where compareFst (l, _) (r, _) = compare l r encodeBuf n expr = do @@ -178,20 +130,16 @@ storage <- exprToSMT expr pure $ SMT2 ["(define-fun store" <> (fromString . show $ n) <> " () Storage " <> storage <> ")"] mempty mempty -data AbstState = AbstState - { words :: Map (Expr EWord) Int - , count :: Int - } - deriving (Show) - smt2Line :: Builder -> SMT2 smt2Line txt = SMT2 [txt] mempty mempty -assertProps :: Config -> [Prop] -> Err SMT2 -- simplify to rewrite sload/sstore combos --- notice: it is VERY important not to concretize, because Keccak assumptions --- will be generated by assertPropsNoSimp, and that needs unconcretized Props -assertProps conf ps = assertPropsNoSimp (decompose . Expr.simplifyProps $ ps) +-- notice: it is VERY important not to concretize early, because Keccak assumptions +-- need unconcretized Props +assertProps :: Config -> [Prop] -> Err SMT2 +assertProps conf ps = + if not conf.simp then assertPropsHelper False ps + else assertPropsHelper True (decompose . Expr.simplifyProps $ ps) where decompose :: [Prop] -> [Prop] decompose props = if conf.decomposeStorage && safeExprs && safeProps @@ -202,13 +150,13 @@ safeExprs = all (isJust . mapPropM_ Expr.safeToDecompose) props safeProps = all Expr.safeToDecomposeProp props + -- Note: we need a version that does NOT call simplify, -- because we make use of it to verify the correctness of our simplification -- passes through property-based testing. -assertPropsNoSimp :: [Prop] -> Err SMT2 -assertPropsNoSimp psPreConc = do +assertPropsHelper :: Bool -> [Prop] -> Err SMT2 +assertPropsHelper simp psPreConc = do encs <- mapM propToSMT psElim - smt <- mapM propToSMT props intermediates <- declareIntermediates bufs stores readAssumes' <- readAssumes keccakAssertions' <- keccakAssertions @@ -217,7 +165,7 @@ pure $ prelude <> (declareAbstractStores abstractStores) <> smt2Line "" - <> (declareAddrs addresses) + <> declareConstrainAddrs addresses <> smt2Line "" <> (declareBufs toDeclarePsElim bufs stores) <> smt2Line "" @@ -231,40 +179,30 @@ <> smt2Line "" <> keccakAssertions' <> readAssumes' + <> gasOrder <> smt2Line "" - <> SMT2 (fmap (\p -> "(assert " <> p <> ")") encs) mempty mempty - <> SMT2 smt mempty mempty - <> SMT2 mempty mempty { storeReads = storageReads } mempty - <> SMT2 mempty mempty psPreConc + <> SMT2 (fmap (\p -> "(assert " <> p <> ")") encs) (cexInfo storageReads) ps where - ps = Expr.concKeccakProps psPreConc + ps = if simp then Expr.concKeccakSimpProps psPreConc else Expr.concKeccakProps psPreConc (psElim, bufs, stores) = eliminateProps ps - abst@(AbstState exprToInt _) = AbstState mempty 0 - props = map toProp (Map.toList exprToInt) - where - toProp :: (Expr EWord, Int) -> Prop - toProp (e, num) = PEq e (Var (TS.pack ("abst_" ++ (show num)))) - -- Props storing info that need declaration(s) toDeclarePs = ps <> keccAssump <> keccComp toDeclarePsElim = psElim <> keccAssump <> keccComp -- vars, frames, and block contexts in need of declaration - allVars = fmap referencedVars toDeclarePsElim <> fmap referencedVars bufVals <> fmap referencedVars storeVals <> [abstrVars abst] + allVars = fmap referencedVars toDeclarePsElim <> fmap referencedVars bufVals <> fmap referencedVars storeVals frameCtx = fmap referencedFrameContext toDeclarePsElim <> fmap referencedFrameContext bufVals <> fmap referencedFrameContext storeVals blockCtx = fmap referencedBlockContext toDeclarePsElim <> fmap referencedBlockContext bufVals <> fmap referencedBlockContext storeVals - - abstrVars :: AbstState -> [Builder] - abstrVars (AbstState b _) = map ((\v->fromString ("abst_" ++ show v)) . snd) (Map.toList b) + gasOrder = enforceGasOrder psPreConc -- Buf, Storage, etc. declarations needed bufVals = Map.elems bufs storeVals = Map.elems stores storageReads = Map.unionsWith (<>) $ fmap findStorageReads toDeclarePs abstractStores = Set.toList $ Set.unions (fmap referencedAbstractStores toDeclarePs) - addresses = Set.toList $ Set.unions (fmap referencedWAddrs toDeclarePs) + addresses = Set.toList $ Set.unions (fmap referencedAddrs toDeclarePs) -- Keccak assertions: concrete values, distance between pairs, injectivity, etc. -- This will make sure concrete values of Keccak are asserted, if they can be computed (i.e. can be concretized) @@ -283,6 +221,10 @@ assumps <- mapM assertSMT $ assertReads psElim bufs stores pure $ smt2Line "; read assumptions" <> SMT2 assumps mempty mempty + cexInfo :: Map (Expr 'EAddr, Maybe W256) (Set (Expr 'EWord)) -> CexVars + cexInfo a = mempty { storeReads = a } + + referencedAbstractStores :: TraversableTerm a => a -> Set Builder referencedAbstractStores term = foldTerm go mempty term where @@ -290,11 +232,11 @@ AbstractStore s idx -> Set.singleton (storeName s idx) _ -> mempty -referencedWAddrs :: TraversableTerm a => a -> Set Builder -referencedWAddrs term = foldTerm go mempty term +referencedAddrs :: TraversableTerm a => a -> Set Builder +referencedAddrs term = foldTerm go mempty term where go = \case - WAddr(a@(SymAddr _)) -> Set.singleton (formatEAddr a) + SymAddr a -> Set.singleton (formatEAddr (SymAddr a)) _ -> mempty referencedBufs :: TraversableTerm a => a -> [Builder] @@ -318,9 +260,10 @@ where go :: Expr a -> [(Builder, [Prop])] go = \case - TxValue -> [(fromString "txvalue", [])] - v@(Balance a) -> [(fromString "balance_" <> formatEAddr a, [PLT v (Lit $ 2 ^ (96 :: Int))])] - Gas {} -> internalError "TODO: GAS" + o@TxValue -> [(fromRight' $ exprToSMT o, [])] + o@(Balance _) -> [(fromRight' $ exprToSMT o, [PLT o (Lit $ 2 ^ (96 :: Int))])] + o@(Gas _ _) -> [(fromRight' $ exprToSMT o, [])] + o@(CodeHash (LitAddr _)) -> [(fromRight' $ exprToSMT o, [])] _ -> [] referencedBlockContext :: TraversableTerm a => a -> [(Builder, [Prop])] @@ -370,11 +313,10 @@ -- to zero. Looks for buffer reads in the a list of given predicates -- and the buffer and storage environments. assertReads :: [Prop] -> BufEnv -> StoreEnv -> [Prop] -assertReads props benv senv = concatMap assertRead allReads +assertReads props benv senv = nubOrd $ concatMap assertRead allReads where assertRead :: (Expr EWord, Expr EWord, Expr Buf) -> [Prop] assertRead (_, Lit 0, _) = [] - assertRead (idx, Lit 32, buf) = [PImpl (PGEq idx (bufLength buf)) (PEq (ReadWord idx buf) (Lit 0))] assertRead (idx, Lit sz, buf) = [PImpl (PGEq (Expr.add idx $ Lit offset) (bufLength buf)) (PEq (ReadByte (Expr.add idx $ Lit offset) buf) (LitByte 0)) | offset <- [(0::W256).. sz-1]] assertRead (_, _, _) = internalError "Cannot generate assertions for accesses of symbolic size" @@ -431,12 +373,36 @@ cexvars = (mempty :: CexVars){ calldata = fmap toLazyText names } -- Given a list of variable names, create an SMT2 object with the variables declared -declareAddrs :: [Builder] -> SMT2 -declareAddrs names = SMT2 (["; symbolic addresseses"] <> fmap declare names) cexvars mempty +declareConstrainAddrs :: [Builder] -> SMT2 +declareConstrainAddrs names = SMT2 (["; concrete and symbolic addresses"] <> fmap declare names <> fmap assume names) cexvars mempty where declare n = "(declare-fun " <> n <> " () Addr)" + -- assume that symbolic addresses do not collide with the zero address or precompiles + assume n = "(assert (bvugt " <> n <> " (_ bv9 160)))" cexvars = (mempty :: CexVars){ addrs = fmap toLazyText names } +-- The gas is a tuple of (prefix, index). Within each prefix, the gas is strictly decreasing as the +-- index increases. This function gets a map of Prefix -> [Int], and for each prefix, +-- enforces the order +enforceGasOrder :: [Prop] -> SMT2 +enforceGasOrder ps = SMT2 (["; gas ordering"] <> (concatMap (uncurry order) indices)) mempty mempty + where + order :: TS.Text -> [Int] -> [Builder] + order prefix n = consecutivePairs (nubInt n) >>= \(x, y)-> + -- The GAS instruction itself costs gas, so it's strictly decreasing + ["(assert (bvugt " <> fromRight' (exprToSMT (Gas prefix x)) <> " " <> + fromRight' ((exprToSMT (Gas prefix y))) <> "))"] + consecutivePairs :: [Int] -> [(Int, Int)] + consecutivePairs [] = [] + consecutivePairs l@(_:t) = zip l t + indices = Map.toList $ toMapOfLists $ concatMap (foldProp go mempty) ps + toMapOfLists :: [(TS.Text, Int)] -> Map.Map TS.Text [Int] + toMapOfLists = foldr (\(k, v) acc -> Map.insertWith (++) k [v] acc) Map.empty + go :: Expr a -> [(TS.Text, Int)] + go e = case e of + Gas prefix v -> [(prefix, v)] + _ -> [] + declareFrameContext :: [(Builder, [Prop])] -> Err SMT2 declareFrameContext names = do decls <- concatMapM declare names @@ -704,9 +670,14 @@ Add a b -> op2 "bvadd" a b Sub a b -> op2 "bvsub" a b Mul a b -> op2 "bvmul" a b - Exp a b -> case b of - Lit b' -> expandExp a b' - _ -> Left "cannot encode symbolic exponentiation into SMT" + Exp a b -> case a of + -- Lit 1 has already been handled via Expr.simplify + Lit 0 -> do + benc <- exprToSMT b + pure $ "(ite (= " <> benc `sp` zero <> " ) " <> one `sp` zero <> ")" + _ -> case b of + Lit b' -> expandExp a b' + _ -> Left $ "Cannot encode symbolic exponent into SMT. Offending symbolic value: " <> show b Min a b -> do aenc <- exprToSMT a benc <- exprToSMT b @@ -756,18 +727,18 @@ aExp <- exprToSMT a bExp <- exprToSMT b cExp <- exprToSMT c - let aLift = "(concat (_ bv0 256) " <> aExp <> ")" - bLift = "(concat (_ bv0 256) " <> bExp <> ")" - cLift = "(concat (_ bv0 256) " <> cExp <> ")" - pure $ "((_ extract 255 0) (ite (= " <> cExp <> " (_ bv0 256)) (_ bv0 512) (bvurem (bvmul " <> aLift `sp` bLift <> ")" <> cLift <> ")))" + let aLift = "((_ zero_extend 256) " <> aExp <> ")" + bLift = "((_ zero_extend 256) " <> bExp <> ")" + cLift = "((_ zero_extend 256) " <> cExp <> ")" + pure $ "(ite (= " <> cExp <> " (_ bv0 256)) (_ bv0 256) ((_ extract 255 0) (bvurem (bvmul " <> aLift `sp` bLift <> ")" <> cLift <> ")))" AddMod a b c -> do aExp <- exprToSMT a bExp <- exprToSMT b cExp <- exprToSMT c - let aLift = "(concat (_ bv0 256) " <> aExp <> ")" - bLift = "(concat (_ bv0 256) " <> bExp <> ")" - cLift = "(concat (_ bv0 256) " <> cExp <> ")" - pure $ "((_ extract 255 0) (ite (= " <> cExp <> " (_ bv0 256)) (_ bv0 512) (bvurem (bvadd " <> aLift `sp` bLift <> ")" <> cLift <> ")))" + let aLift = "((_ zero_extend 1) " <> aExp <> ")" + bLift = "((_ zero_extend 1) " <> bExp <> ")" + cLift = "((_ zero_extend 1) " <> cExp <> ")" + pure $ "(ite (= " <> cExp <> " (_ bv0 256)) (_ bv0 256) ((_ extract 255 0) (bvurem (bvadd " <> aLift `sp` bLift <> ")" <> cLift <> ")))" EqByte a b -> do cond <- op2 "=" a b pure $ "(ite " <> cond `sp` one `sp` zero <> ")" @@ -844,6 +815,9 @@ encPrev <- exprToSMT prev pure $ "(store" `sp` encPrev `sp` encIdx `sp` encVal <> ")" SLoad idx store -> op2 "select" store idx + LitAddr n -> pure $ fromLazyText $ "(_ bv" <> T.pack (show (into n :: Integer)) <> " 160)" + CodeHash a@(LitAddr _) -> pure $ fromLazyText "codehash_" <> formatEAddr a + Gas prefix var -> pure $ fromLazyText $ "gas_" <> T.pack (TS.unpack prefix) <> T.pack (show var) a -> internalError $ "TODO: implement: " <> show a where @@ -920,6 +894,8 @@ -- | Unrolls an exponentiation into a series of multiplications expandExp :: Expr EWord -> W256 -> Err Builder expandExp base expnt + -- in EVM, anything (including 0) to the power of 0 is 1 + | expnt == 0 = pure one | expnt == 1 = exprToSMT base | otherwise = do b <- exprToSMT base @@ -929,9 +905,11 @@ -- | Concatenates a list of bytes into a larger bitvector concatBytes :: [Expr Byte] -> Err Builder concatBytes bytes = do - let bytesRev = reverse bytes - a2 <- exprToSMT (head bytesRev) - foldM wrap a2 $ tail bytesRev + case List.uncons $ reverse bytes of + Nothing -> Left "unexpected empty bytes" + Just (h, t) -> do + a2 <- exprToSMT h + foldM wrap a2 t where wrap :: Builder -> Expr a -> Err Builder wrap inner byte = do @@ -990,9 +968,14 @@ parseW8 :: SpecConstant -> Word8 parseW8 = parseSC +readOrError :: (Num a, Eq a) => ReadS a -> TS.Text -> a +readOrError reader val = fst . headErr . reader . T.unpack . T.fromStrict $ val + where + headErr x = fromMaybe (internalError "error reading empty result") $ listToMaybe x + parseSC :: (Num a, Eq a) => SpecConstant -> a -parseSC (SCHexadecimal a) = fst . head . Numeric.readHex . T.unpack . T.fromStrict $ a -parseSC (SCBinary a) = fst . head . Numeric.readBin . T.unpack . T.fromStrict $ a +parseSC (SCHexadecimal a) = readOrError Numeric.readHex a +parseSC (SCBinary a) = readOrError Numeric.readBin a parseSC sc = internalError $ "cannot parse: " <> show sc parseErr :: (Show a) => a -> b @@ -1007,6 +990,11 @@ | Just a <- TS.stripPrefix "symaddr_" name = SymAddr a | otherwise = internalError $ "cannot parse: " <> show name +textToInt :: TS.Text -> Int +textToInt text = case decimal text of + Right (value, _) -> value + Left _ -> internalError $ "cannot parse '" <> (TS.unpack text) <> "' into an Int" + parseBlockCtx :: TS.Text -> Expr EWord parseBlockCtx "origin" = Origin parseBlockCtx "coinbase" = Coinbase @@ -1016,12 +1004,13 @@ parseBlockCtx "gaslimit" = GasLimit parseBlockCtx "chainid" = ChainId parseBlockCtx "basefee" = BaseFee -parseBlockCtx t = internalError $ "cannot parse " <> (TS.unpack t) <> " into an Expr" +parseBlockCtx val = internalError $ "cannot parse '" <> (TS.unpack val) <> "' into an Expr" parseTxCtx :: TS.Text -> Expr EWord parseTxCtx name | name == "txvalue" = TxValue | Just a <- TS.stripPrefix "balance_" name = Balance (parseEAddr a) + | Just a <- TS.stripPrefix "codehash_" name = CodeHash (parseEAddr a) | otherwise = internalError $ "cannot parse " <> (TS.unpack name) <> " into an Expr" getAddrs :: (TS.Text -> Expr EAddr) -> (Text -> IO Text) -> [TS.Text] -> IO (Map (Expr EAddr) Addr) @@ -1095,9 +1084,7 @@ :| [SortSymbol (IdIndexed "BitVec" (IxNumeral "8" :| []))] ) )) ((TermSpecConstant val :| []))) - -> case val of - SCHexadecimal "00" -> Base 0 0 - v -> Base (parseW8 v) len + -> Base (parseW8 val) len -- writing a byte over some array (TermApplication diff --git a/src/EVM/Solidity.hs b/src/EVM/Solidity.hs --- a/src/EVM/Solidity.hs +++ b/src/EVM/Solidity.hs @@ -4,6 +4,7 @@ module EVM.Solidity ( solidity , solcRuntime + , solcRuntime' , yul , yulRuntime , JumpType (..) @@ -20,6 +21,7 @@ , Reference(..) , Mutability(..) , readBuildOutput + , readFilteredBuildOutput , functionAbi , makeSrcMaps , readSolc @@ -44,12 +46,13 @@ import Optics.Core import Optics.Operators.Unsafe -import EVM.Effects; +import EVM.Effects +import EVM.Expr (maybeLitByteSimp) import Control.Applicative import Control.Monad import Control.Monad.IO.Unlift -import Data.Aeson hiding (json) +import Data.Aeson (encode) import Data.Aeson.Types import Data.Aeson.Optics import Data.Aeson.Key qualified as Key @@ -84,7 +87,7 @@ import System.Process import Text.Read (readMaybe) import Witch (unsafeInto) - +import Data.Either.Extra (maybeToEither) data StorageItem = StorageItem { slotType :: SlotType @@ -284,17 +287,22 @@ go c (xs, state, p) = (xs, internalError ("srcmap: y u " ++ show c ++ " in state" ++ show state ++ "?!?"), p) -- | Reads all solc output json files found under the provided filepath and returns them merged into a BuildOutput -readBuildOutput :: App m => FilePath -> ProjectType -> m (Either String BuildOutput) -readBuildOutput root CombinedJSON = do +readBuildOutput :: App m => FilePath -> ProjectType -> m (Err BuildOutput) +readBuildOutput root projectType = readFilteredBuildOutput root (const True) projectType + +readFilteredBuildOutput :: App m => FilePath -> (FilePath -> Bool) -> ProjectType -> m (Err BuildOutput) +readFilteredBuildOutput root jsonFilter CombinedJSON = do let outDir = root "out" - jsons <- liftIO $ findJsonFiles outDir + allJsons <- liftIO $ findJsonFiles outDir + let jsons = filter jsonFilter allJsons case jsons of [x] -> readSolc CombinedJSON root (outDir x) [] -> pure . Left $ "no json files found in: " <> outDir _ -> pure . Left $ "multiple json files found in: " <> outDir -readBuildOutput root _ = do +readFilteredBuildOutput root jsonFilter _ = do let outDir = root "out" - jsons <- liftIO $ findJsonFiles outDir + allJsons <- liftIO $ findJsonFiles outDir + let jsons = filter jsonFilter allJsons case (filterMetadata jsons) of [] -> pure . Left $ "no json files found in: " <> outDir js -> do @@ -341,7 +349,7 @@ then Nothing else Just (s1 - s2, min (s2 + n2 - s1) n1) -readSolc :: App m => ProjectType -> FilePath -> FilePath -> m (Either String BuildOutput) +readSolc :: App m => ProjectType -> FilePath -> FilePath -> m (Err BuildOutput) readSolc pt root fp = do -- NOTE: we cannot and must not use Data.Text.IO.readFile because that takes the locale -- and may fail with very strange errors when the JSON it's reading @@ -349,16 +357,17 @@ fileContents <- liftIO $ fmap Data.Text.Encoding.decodeUtf8 $ Data.ByteString.readFile fp let contractName = T.pack $ takeBaseName fp case readJSON pt contractName fileContents of - Nothing -> pure . Left $ "unable to parse " <> show pt <> " project JSON: " <> fp <> " Contract: " <> show contractName - Just (contracts, asts, sources) -> do + Left err -> pure . Left $ "unable to parse " <> show pt <> " project JSON: " <> fp + <> " Contract: " <> show contractName <> "\nError: " <> err + Right (contracts, asts, sources) -> do conf <- readConfig - when (conf.debug) $ liftIO $ putStrLn $ "Parsed constract: " <> show contractName <> " file: " <> fp + when (conf.debug) $ liftIO $ putStrLn $ "Parsed contract: " <> show contractName <> " file: " <> fp sourceCache <- liftIO $ makeSourceCache root sources asts pure (Right (BuildOutput contracts sourceCache)) yul :: Text -> Text -> IO (Maybe ByteString) yul contractName src = do - json <- solc Yul src + json <- solc Yul src False let f = (json ^?! key "contracts") ^?! key (Key.fromText "hevm.sol") c = f ^?! key (Key.fromText $ if T.null contractName then "object" else contractName) bytecode = c ^?! key "evm" ^?! key "bytecode" ^?! key "object" % _String @@ -366,7 +375,7 @@ yulRuntime :: Text -> Text -> IO (Maybe ByteString) yulRuntime contractName src = do - json <- solc Yul src + json <- solc Yul src False let f = (json ^?! key "contracts") ^?! key (Key.fromText "hevm.sol") c = f ^?! key (Key.fromText $ if T.null contractName then "object" else contractName) bytecode = c ^?! key "evm" ^?! key "deployedBytecode" ^?! key "object" % _String @@ -376,28 +385,34 @@ :: (MonadUnliftIO m) => Text -> Text -> m (Maybe ByteString) solidity contract src = liftIO $ do - json <- solc Solidity src + json <- solc Solidity src False let (Contracts sol, _, _) = fromJust $ readStdJSON json pure $ Map.lookup ("hevm.sol:" <> contract) sol <&> (.creationCode) -solcRuntime +solcRuntime' :: App m - => Text -> Text -> m (Maybe ByteString) -solcRuntime contract src = do + => Text -> Text -> Bool -> m (Maybe ByteString) +solcRuntime' contract src viaIR = do conf <- readConfig liftIO $ do - json <- solc Solidity src + json <- solc Solidity src viaIR when conf.dumpExprs $ liftIO $ Data.Text.IO.writeFile "compiled_code.json" json case readStdJSON json of Just (Contracts sol, _, _) -> pure $ Map.lookup ("hevm.sol:" <> contract) sol <&> (.runtimeCode) Nothing -> internalError $ "unable to parse solidity output:\n" <> (T.unpack json) +solcRuntime + :: App m + => Text -> Text -> m (Maybe ByteString) +solcRuntime contract src = solcRuntime' contract src False + functionAbi :: Text -> IO Method functionAbi f = do - json <- solc Solidity ("contract ABI { function " <> f <> " public {}}") + json <- solc Solidity ("contract ABI { function " <> f <> " public {}}") False let (Contracts sol, _, _) = fromMaybe - (internalError . T.unpack $ "unable to parse solc output:\n" <> json) - (readStdJSON json) + (internalError . T.unpack $ "while trying to parse function signature `" + <> f <> "`, unable to parse solc output:\n" <> json) + (readStdJSON json) case Map.toList (fromJust (Map.lookup "hevm.sol:ABI" sol)).abiMap of [(_,b)] -> pure b _ -> internalError "unexpected abi format" @@ -405,31 +420,31 @@ force :: String -> Maybe a -> a force s = fromMaybe (internalError s) -readJSON :: ProjectType -> Text -> Text -> Maybe (Contracts, Asts, Sources) +readJSON :: ProjectType -> Text -> Text -> Err (Contracts, Asts, Sources) readJSON CombinedJSON _ json = readCombinedJSON json readJSON _ contractName json = readFoundryJSON contractName json -- | Reads a foundry json output -readFoundryJSON :: Text -> Text -> Maybe (Contracts, Asts, Sources) +readFoundryJSON :: Text -> Text -> Err (Contracts, Asts, Sources) readFoundryJSON contractName json = do - runtime <- json ^? key "deployedBytecode" - runtimeCode <- (toCode contractName) . strip0x'' <$> runtime ^? key "object" % _String + runtime <- maybeToEither "missing 'deployedBytecode' field" $ json ^? key "deployedBytecode" + runtimeCode <- maybeToEither "missing 'deployedBytecode.object' field" $ + (toCode contractName) . strip0x'' <$> runtime ^? key "object" % _String runtimeSrcMap <- case runtime ^? key "sourceMap" % _String of - Nothing -> makeSrcMaps "" - smap -> makeSrcMaps =<< smap + Nothing -> Right $ force "Source map creation error" $ makeSrcMaps "" -- sourceMap is optional + Just smap -> maybeToEither "invalid sourceMap format" $ makeSrcMaps smap - creation <- json ^? key "bytecode" - creationCode <- (toCode contractName) . strip0x'' <$> creation ^? key "object" % _String + creation <- maybeToEither "missing 'bytecode' field" $ json ^? key "bytecode" + creationCode <- maybeToEither "missing 'bytecode.object' field" $ + (toCode contractName) . strip0x'' <$> creation ^? key "object" % _String creationSrcMap <- case creation ^? key "sourceMap" % _String of - Nothing -> makeSrcMaps "" - smap -> makeSrcMaps =<< smap - - ast <- json ^? key "ast" - path <- ast ^? key "absolutePath" % _String - - abi <- toList <$> json ^? key "abi" % _Array + Nothing -> Right $ force "Source map creation error" $ makeSrcMaps "" -- sourceMap is optional + Just smap -> maybeToEither "invalid sourceMap format" $ makeSrcMaps smap - id' <- unsafeInto <$> json ^? key "id" % _Integer + ast <- maybeToEither "missing 'ast' field. Recompile with `forge clean && forge build --ast`" $ json ^? key "ast" + path <- maybeToEither "missing 'ast.absolutePath' field" $ ast ^? key "absolutePath" % _String + abi <- maybeToEither "missing or invalid 'abi' array" $ toList <$> json ^? key "abi" % _Array + id' <- maybeToEither "missing or invalid 'id' field" $ unsafeInto <$> json ^? key "id" % _Integer let contract = SolcContract { runtimeCodehash = keccak' (stripBytecodeMetadata runtimeCode) @@ -446,10 +461,10 @@ , storageLayout = mkStorageLayout $ json ^? key "storageLayout" , immutableReferences = mempty -- TODO: foundry doesn't expose this? } - pure ( Contracts $ Map.singleton (path <> ":" <> contractName) contract - , Asts $ Map.singleton path ast - , Sources $ Map.singleton (SrcFile id' (T.unpack path)) Nothing - ) + Right ( Contracts $ Map.singleton (path <> ":" <> contractName) contract + , Asts $ Map.singleton path ast + , Sources $ Map.singleton (SrcFile id' (T.unpack path)) Nothing + ) -- | Parses the standard json output from solc readStdJSON :: Text -> Maybe (Contracts, Asts, Sources) @@ -507,18 +522,18 @@ }, fromMaybe mempty srcContents)) -- deprecate me soon -readCombinedJSON :: Text -> Maybe (Contracts, Asts, Sources) +readCombinedJSON :: Text -> Err (Contracts, Asts, Sources) readCombinedJSON json = do - contracts <- f . KeyMap.toHashMapText <$> (json ^? key "contracts" % _Object) - sources <- toList . fmap (preview _String) <$> json ^? key "sourceList" % _Array + contracts <- maybeToEither "missing or invalid 'contracts' field" $ f . KeyMap.toHashMapText <$> (json ^? key "contracts" % _Object) + sources <- maybeToEither "missing or invalid 'sourceList' field" $ toList . fmap (preview _String) <$> json ^? key "sourceList" % _Array + astsPre <- maybeToEither "JSON lacks abstract syntax trees (ast). Recompile with `forge clean && forge build --ast`" $ json ^? key "sources" % _Object pure ( Contracts contracts - , Asts (Map.fromList (HMap.toList asts)) + , Asts (Map.fromList (HMap.toList (KeyMap.toHashMapText astsPre))) , Sources $ Map.fromList $ (\(path, id') -> (SrcFile id' (T.unpack path), Nothing)) <$> zip (catMaybes sources) [0..] ) where - 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 @@ -667,21 +682,22 @@ then error $ T.unpack ("Error toCode: unlinked libraries detected in bytecode, in " <> contractName) else error $ T.unpack ("Error toCode:" <> e <> ", in " <> contractName) -solc :: Language -> Text -> IO Text -solc lang src = T.pack <$> readProcess "solc" ["--standard-json"] (T.unpack $ stdjson lang src) +solc :: Language -> Text -> Bool -> IO Text +solc lang src viaIR = T.pack <$> readProcess "solc" ["--standard-json"] (T.unpack $ stdjson lang src viaIR) data Language = Solidity | Yul deriving (Show) -data StandardJSON = StandardJSON Language Text +data StandardJSON = StandardJSON Language Text Bool -- more options later perhaps instance ToJSON StandardJSON where - toJSON (StandardJSON lang src) = + toJSON (StandardJSON lang src viaIR) = object [ "language" .= show lang , "sources" .= object ["hevm.sol" .= object ["content" .= src]] , "settings" .= - object [ "outputSelection" .= + object [ "viaIR" .= viaIR + , "outputSelection" .= object ["*" .= object ["*" .= (toJSON ["metadata" :: String, @@ -703,8 +719,8 @@ ] ] -stdjson :: Language -> Text -> Text -stdjson lang src = decodeUtf8 $ toStrict $ encode $ StandardJSON lang src +stdjson :: Language -> Text -> Bool -> Text +stdjson lang src viaIR = decodeUtf8 $ toStrict $ encode $ StandardJSON lang src viaIR -- | When doing CREATE and passing constructor arguments, Solidity loads -- the argument data via the creation bytecode, since there is no "calldata" @@ -729,7 +745,7 @@ stripBytecodeMetadataSym b = let concretes :: [Maybe Word8] - concretes = maybeLitByte <$> b + concretes = maybeLitByteSimp <$> b bzzrs :: [[Maybe Word8]] bzzrs = fmap (Just) . BS.unpack <$> knownBzzrPrefixes candidates = (flip Data.List.isInfixOf concretes) <$> bzzrs diff --git a/src/EVM/Solvers.hs b/src/EVM/Solvers.hs --- a/src/EVM/Solvers.hs +++ b/src/EVM/Solvers.hs @@ -10,14 +10,17 @@ import GHC.IO.Handle (Handle, hFlush, hSetBuffering, BufferMode(..)) import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan) import Control.Concurrent (forkIO, killThread) +import Control.Concurrent.STM (writeTChan, newTChan, TChan, tryReadTChan, atomically) import Control.Monad import Control.Monad.State.Strict import Control.Monad.IO.Unlift import Data.Char (isSpace) import Data.Map (Map) import Data.Map qualified as Map +import Data.Set (Set, isSubsetOf, fromList) import Data.Maybe (fromMaybe, isJust, fromJust) import Data.Either (isLeft) +import Data.Text qualified as TStrict import Data.Text.Lazy (Text) import Data.Text.Lazy qualified as T import Data.Text.Lazy.IO qualified as T @@ -26,9 +29,12 @@ import Witch (into) import EVM.Effects import EVM.Fuzz (tryCexFuzz) +import Data.Bits ((.&.)) +import Numeric (showHex) +import EVM.Expr (simplifyProps) import EVM.SMT -import EVM.Types (W256, Expr(AbstractBuf), internalError, Err, getError, getNonError) +import EVM.Types -- | Supported solvers data Solver @@ -55,117 +61,229 @@ -- | A channel representing a group of solvers newtype SolverGroup = SolverGroup (Chan Task) --- | A script to be executed, a list of models to be extracted in the case of a sat result, and a channel where the result should be written -data Task = Task - { script :: SMT2 - , resultChan :: Chan CheckSatResult +data MultiSol = MultiSol + { maxSols :: Int + , numBytes :: Int + , var :: String } --- | The result of a call to (check-sat) -data CheckSatResult - = Sat SMTCex - | Unsat - | Unknown String - | Error String +-- | A script to be executed, a list of models to be extracted in the case of a sat result, and a channel where the result should be written +data Task = TaskSingle SingleData | TaskMulti MultiData + +newtype CacheEntry = CacheEntry [Prop] deriving (Show, Eq) -isSat :: CheckSatResult -> Bool -isSat (Sat _) = True -isSat _ = False +data MultiData = MultiData + { smt2 :: SMT2 + , multiSol :: MultiSol + , resultChan :: Chan (Maybe [W256]) + } -isUnsat :: CheckSatResult -> Bool -isUnsat Unsat = True -isUnsat _ = False +data SingleData = SingleData + { smt2 :: SMT2 + , props :: Maybe [Prop] + , resultChan :: Chan SMTResult + } -checkSat :: SolverGroup -> Err SMT2 -> IO CheckSatResult -checkSat (SolverGroup taskQueue) script = do - if isLeft script then pure $ Error $ getError script +-- returns True if a is a superset of any of the sets in bs +supersetAny :: Set Prop -> [Set Prop] -> Bool +supersetAny a bs = any (`isSubsetOf` a) bs + +checkMulti :: SolverGroup -> Err SMT2 -> MultiSol -> IO (Maybe [W256]) +checkMulti (SolverGroup taskq) smt2 multiSol = do + if isLeft smt2 then pure Nothing else do -- prepare result channel resChan <- newChan -- send task to solver group - writeChan taskQueue (Task (getNonError script) resChan) + writeChan taskq (TaskMulti (MultiData (getNonError smt2) multiSol resChan)) -- collect result readChan resChan -writeSMT2File :: SMT2 -> Int -> IO () -writeSMT2File smt2 count = +checkSatWithProps :: App m => SolverGroup -> [Prop] -> m (SMTResult, Err SMT2) +checkSatWithProps sg props = do + conf <- readConfig + let psSimp = if conf.simp then simplifyProps props else props + if psSimp == [PBool False] then pure (Qed, Right mempty) + else do + let smt2 = assertProps conf psSimp + if isLeft smt2 then + let err = getError smt2 in pure (Error err, Left err) + else do + res <- liftIO $ checkSat sg (Just props) smt2 + pure (res, Right (getNonError smt2)) + +-- When props is Nothing, the cache will not be filled or used +checkSat :: SolverGroup -> Maybe [Prop] -> Err SMT2 -> IO SMTResult +checkSat (SolverGroup taskq) props smt2 = do + if isLeft smt2 then pure $ Error $ getError smt2 + else do + -- prepare result channel + resChan <- newChan + -- send task to solver group + writeChan taskq (TaskSingle (SingleData (getNonError smt2) props resChan)) + -- collect result + readChan resChan + +writeSMT2File :: SMT2 -> String -> IO () +writeSMT2File smt2 postfix = do let content = formatSMT2 smt2 <> "\n\n(check-sat)" - in T.writeFile ("query-" <> (show count) <> ".smt2") content + T.writeFile ("query-" <> postfix <> ".smt2") content withSolvers :: App m => Solver -> Natural -> Natural -> Maybe Natural -> (SolverGroup -> m a) -> m a withSolvers solver count threads timeout cont = do -- spawn solvers instances <- mapM (const $ liftIO $ spawnSolver solver threads timeout) [1..count] -- spawn orchestration thread - taskQueue <- liftIO newChan + taskq <- liftIO newChan + cacheq <- liftIO . atomically $ newTChan availableInstances <- liftIO newChan liftIO $ forM_ instances (writeChan availableInstances) - orchestrate' <- toIO $ orchestrate taskQueue availableInstances 0 + orchestrate' <- toIO $ orchestrate taskq cacheq availableInstances [] 0 orchestrateId <- liftIO $ forkIO orchestrate' -- run continuation with task queue - res <- cont (SolverGroup taskQueue) + res <- cont (SolverGroup taskq) -- cleanup and return results liftIO $ mapM_ (stopSolver) instances liftIO $ killThread orchestrateId pure res where - orchestrate :: App m => Chan Task -> Chan SolverInstance -> Int -> m b - orchestrate queue avail fileCounter = do - task <- liftIO $ readChan queue - inst <- liftIO $ readChan avail - runTask' <- toIO $ runTask task inst avail fileCounter - _ <- liftIO $ forkIO runTask' - orchestrate queue avail (fileCounter + 1) + orchestrate :: App m => Chan Task -> TChan CacheEntry -> Chan SolverInstance -> [Set Prop] -> Int -> m b + orchestrate taskq cacheq avail knownUnsat fileCounter = do + conf <- readConfig + mx <- liftIO . atomically $ tryReadTChan cacheq + case mx of + Just (CacheEntry props) -> do + let knownUnsat' = (fromList props):knownUnsat + when conf.debug $ liftIO $ putStrLn " adding UNSAT cache" + orchestrate taskq cacheq avail knownUnsat' fileCounter + Nothing -> do + task <- liftIO $ readChan taskq + case task of + TaskSingle (SingleData _ props r) | isJust props && supersetAny (fromList (fromJust props)) knownUnsat -> do + liftIO $ writeChan r Qed + when conf.debug $ liftIO $ putStrLn " Qed found via cache!" + orchestrate taskq cacheq avail knownUnsat fileCounter + _ -> do + inst <- liftIO $ readChan avail + runTask' <- case task of + TaskSingle (SingleData smt2 props r) -> toIO $ getOneSol smt2 props r cacheq inst avail fileCounter + TaskMulti (MultiData smt2 multiSol r) -> toIO $ getMultiSol smt2 multiSol r inst avail fileCounter + _ <- liftIO $ forkIO runTask' + orchestrate taskq cacheq avail knownUnsat (fileCounter + 1) - runTask :: (MonadIO m, ReadConfig m) => Task -> SolverInstance -> Chan SolverInstance -> Int -> m () - runTask (Task smt2@(SMT2 cmds cexvars ps) r) inst availableInstances fileCounter = do +getMultiSol :: forall m. (MonadIO m, ReadConfig m) => SMT2 -> MultiSol -> (Chan (Maybe [W256])) -> SolverInstance -> Chan SolverInstance -> Int -> m () +getMultiSol smt2@(SMT2 cmds cexvars _) multiSol r inst availableInstances fileCounter = do + conf <- readConfig + when conf.dumpQueries $ liftIO $ writeSMT2File smt2 (show fileCounter) + -- reset solver and send all lines of provided script + out <- liftIO $ sendScript inst ("(reset)" : cmds) + case out of + Left err -> liftIO $ do + when conf.debug $ putStrLn $ "Unable to write SMT to solver: " <> (T.unpack err) + writeChan r Nothing + Right _ -> do + sat <- liftIO $ sendLine inst "(check-sat)" + when conf.dumpQueries $ liftIO $ writeSMT2File smt2 (show fileCounter <> "-origquery") + subRun [] smt2 sat + -- put the instance back in the list of available instances + liftIO $ writeChan availableInstances inst + where + maskFromBytesCount k + | k <= 32 = (2 ^ (8 * k) - 1) + | otherwise = internalError "Byte length exceeds 256-bit capacity" + subRun :: (MonadIO m, ReadConfig m) => [W256] -> SMT2 -> Text -> m () + subRun vals fullSmt sat = do conf <- readConfig - let fuzzResult = tryCexFuzz ps conf.numCexFuzz - liftIO $ do - when (conf.dumpQueries) $ writeSMT2File smt2 fileCounter - if (isJust fuzzResult) - then do - when (conf.debug) $ putStrLn $ " Cex found via fuzzing:" <> (show fuzzResult) - writeChan r (Sat $ fromJust fuzzResult) - else if not conf.onlyCexFuzz then do - when (conf.debug) $ putStrLn " Fuzzing failed to find a Cex" - -- reset solver and send all lines of provided script - out <- sendScript inst (SMT2 ("(reset)" : cmds) mempty ps) - case out of - -- if we got an error then return it - Left e -> writeChan r (Error $ "Error while writing SMT to solver: " <> T.unpack e) - -- otherwise call (check-sat), parse the result, and send it down the result channel - Right () -> do - sat <- sendLine inst "(check-sat)" - res <- do - case sat of - "unsat" -> pure Unsat - "timeout" -> pure $ Unknown "Result timeout by SMT solver" - "unknown" -> pure $ Unknown "Result unknown by SMT solver" - "sat" -> Sat <$> getModel inst cexvars - _ -> pure . Error $ "Unable to parse SMT solver output: " <> T.unpack sat - writeChan r res + case sat of + "unsat" -> liftIO $ do + when conf.debug $ putStrLn $ "No more solutions to query, returning: " <> show vals + liftIO $ writeChan r (Just vals) + "timeout" -> liftIO $ do + when conf.debug $ putStrLn "Timeout inside SMT solver." + writeChan r Nothing + "unknown" -> liftIO $ do + when conf.debug $ putStrLn "Unknown result by SMT solver." + writeChan r Nothing + "sat" -> do + if length vals >= multiSol.maxSols then liftIO $ do + when conf.debug $ putStrLn "Too many solutions to symbolic query." + writeChan r Nothing else do - when (conf.debug) $ putStrLn "Fuzzing failed to find a Cex, not trying SMT due to onlyCexFuzz" - writeChan r $ Error "Option onlyCexFuzz enabled, not running SMT" + cex <- liftIO $ getModel inst cexvars + case Map.lookup (Var (TStrict.pack multiSol.var)) cex.vars of + Just v -> do + let hexMask = maskFromBytesCount multiSol.numBytes + maskedVal = v .&. hexMask + toSMT n = show (into n :: Integer) + maskedVar = "(bvand " <> multiSol.var <> " (_ bv" <> toSMT hexMask <> " 256))" + restrict = "(assert (not (= " <> maskedVar <> " (_ bv" <> toSMT maskedVal <> " 256))))" + newSmt = fullSmt <> SMT2 [(fromString restrict)] mempty mempty + when conf.debug $ liftIO $ putStrLn $ "Got one solution to symbolic query, val: 0x" <> (showHex maskedVal "") <> + " now have " <> show (length vals + 1) <> " solution(s), max is: " <> show multiSol.maxSols + when conf.dumpQueries $ liftIO $ writeSMT2File newSmt (show fileCounter <> "-sol" <> show (length vals)) + out <- liftIO $ sendLine inst (T.pack restrict) + case out of + "success" -> do + out2 <- liftIO $ sendLine inst (T.pack "(check-sat)") + subRun (maskedVal:vals) newSmt out2 + err -> liftIO $ do + when conf.debug $ putStrLn $ "Unable to write SMT to solver: " <> (T.unpack err) + writeChan r Nothing + Nothing -> internalError $ "variable " <> multiSol.var <> " not part of model (i.e. cex) ... that's not possible" + err -> liftIO $ do + when conf.debug $ putStrLn $ "Unable to write SMT to solver: " <> (T.unpack err) + writeChan r Nothing - -- put the instance back in the list of available instances - writeChan availableInstances inst +getOneSol :: (MonadIO m, ReadConfig m) => SMT2 -> Maybe [Prop] -> Chan SMTResult -> TChan CacheEntry -> SolverInstance -> Chan SolverInstance -> Int -> m () +getOneSol smt2@(SMT2 cmds cexvars ps) props r cacheq inst availableInstances fileCounter = do + conf <- readConfig + let fuzzResult = tryCexFuzz ps conf.numCexFuzz + liftIO $ do + when (conf.dumpQueries) $ writeSMT2File smt2 (show fileCounter) + if (isJust fuzzResult) + then do + when (conf.debug) $ putStrLn $ " Cex found via fuzzing:" <> (show fuzzResult) + writeChan r (Cex $ fromJust fuzzResult) + else if Prelude.not conf.onlyCexFuzz then do + -- reset solver and send all lines of provided script + out <- sendScript inst ("(reset)" : cmds) + case out of + -- if we got an error then return it + Left e -> writeChan r (Error $ "Error while writing SMT to solver: " <> T.unpack e) + -- otherwise call (check-sat), parse the result, and send it down the result channel + Right () -> do + sat <- sendLine inst "(check-sat)" + res <- do + case sat of + "unsat" -> do + when (isJust props) $ liftIO . atomically $ writeTChan cacheq (CacheEntry (fromJust props)) + pure Qed + "timeout" -> pure $ Unknown "Result timeout by SMT solver" + "unknown" -> pure $ Unknown "Result unknown by SMT solver" + "sat" -> Cex <$> getModel inst cexvars + _ -> pure . Error $ "Unable to parse SMT solver output: " <> T.unpack sat + writeChan r res + else do + when (conf.debug) $ putStrLn "Fuzzing failed to find a Cex, not trying SMT due to onlyCexFuzz" + writeChan r $ Error "Option onlyCexFuzz enabled, not running SMT" + -- put the instance back in the list of available instances + writeChan availableInstances inst + getModel :: SolverInstance -> CexVars -> IO SMTCex getModel inst cexvars = do -- 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.buffers -- check the sizes of buffer models and shrink if needed if bufsUsable initialModel - then do - pure (mkConcrete initialModel) - else mkConcrete . snd <$> runStateT (shrinkModel hints) initialModel + then pure initialModel + else do + -- get concrete values for each buffers max read index + hints <- capHints <$> queryMaxReads (getValue inst) cexvars.buffers + snd <$> runStateT (shrinkModel hints) initialModel where getRaw :: IO SMTCex getRaw = do @@ -205,24 +323,24 @@ shrinkBuf :: Text -> W256 -> StateT SMTCex IO () shrinkBuf buf hint = do let encBound = "(_ bv" <> (T.pack $ show (into hint :: Integer)) <> " 256)" - sat <- liftIO $ do + answer <- liftIO $ do checkCommand inst "(push 1)" checkCommand inst $ "(assert (bvule " <> buf <> "_length " <> encBound <> "))" sendLine inst "(check-sat)" - case sat of + case answer of "sat" -> do model <- liftIO getRaw put model "unsat" -> do liftIO $ checkCommand inst "(pop 1)" - shrinkBuf buf (if hint == 0 then hint + 1 else hint * 2) - e -> internalError $ "Unexpected solver output: " <> (T.unpack e) + let nextHint = if hint == 0 then 1 else hint * 2 + if nextHint < hint || nextHint > 1_073_741_824 + then pure () -- overflow or over 1GB + else shrinkBuf buf nextHint + _ -> do -- unexpected answer -> clean up and do not change the model + liftIO $ checkCommand inst "(pop 1)" + pure () - -- Collapses the abstract description of a models buffers down to a bytestring - mkConcrete :: SMTCex -> SMTCex - mkConcrete c = fromMaybe - (internalError $ "counterexample contains buffers that are too large to be represented as a ByteString: " <> show c) - (flattenBufs c) -- we set a pretty arbitrary upper limit (of 1024) to decide if we need to do some shrinking bufsUsable :: SMTCex -> Bool @@ -259,6 +377,7 @@ , "--interactive" , "--incremental" , "--tlimit-per=" <> mkTimeout timeout + , "--arrays-exp" ] Custom _ -> [] @@ -292,8 +411,8 @@ stopSolver (SolverInstance _ stdin stdout process) = cleanupProcess (Just stdin, Just stdout, Nothing, process) -- | Sends a list of commands to the solver. Returns the first error, if there was one. -sendScript :: SolverInstance -> SMT2 -> IO (Either Text ()) -sendScript solver (SMT2 cmds _ _) = do +sendScript :: SolverInstance -> [Builder] -> IO (Either Text ()) +sendScript solver cmds = do let sexprs = splitSExpr $ fmap toLazyText cmds go sexprs where diff --git a/src/EVM/Stepper.hs b/src/EVM/Stepper.hs --- a/src/EVM/Stepper.hs +++ b/src/EVM/Stepper.hs @@ -8,9 +8,8 @@ , run , runFully , wait - , ask + , fork , evm - , evmIO , enter , interpret ) @@ -36,21 +35,16 @@ -- | The instruction type of the operational monad data Action t s a where - -- | Keep executing until an intermediate result is reached Exec :: Action t s (VMResult t s) - - -- | Wait for a query to be resolved - Wait :: Query t s -> Action t s () - - -- | Multiple things can happen - Ask :: Choose s -> Action Symbolic s () - -- | Embed a VM state transformation EVM :: EVM t s a -> Action t s a - - -- | Perform an IO action - IOAct :: IO a -> Action t s a + -- | Wait for a query to be resolved + Wait :: Query t s -> Action t s () + -- | Two things can happen + Fork :: RunBoth s -> Action Symbolic s () + -- | Many (>2) things can happen + ForkMany :: RunAll s -> Action Symbolic s () -- | Type alias for an operational monad of @Action@ type Stepper t s a = Program (Action t s) a @@ -66,15 +60,15 @@ wait :: Query t s -> Stepper t s () wait = singleton . Wait -ask :: Choose s -> Stepper Symbolic s () -ask = singleton . Ask +fork :: RunBoth s -> Stepper Symbolic s () +fork = singleton . Fork +forkMany :: RunAll s -> Stepper Symbolic s () +forkMany = singleton . ForkMany + evm :: EVM t s a -> Stepper t s a evm = singleton . EVM -evmIO :: IO a -> Stepper t s a -evmIO = singleton . IOAct - -- | Run the VM until final result, resolving all queries execFully :: Stepper Concrete s (Either EvmError (Expr Buf)) execFully = @@ -94,8 +88,10 @@ Nothing -> internalError "should not occur" Just (HandleEffect (Query q)) -> wait q >> runFully - Just (HandleEffect (Choose q)) -> - ask q >> runFully + Just (HandleEffect (RunBoth q)) -> + fork q >> runFully + Just (HandleEffect (RunAll q)) -> + forkMany q >> runFully Just _ -> pure vm @@ -115,15 +111,13 @@ eval (action :>>= k) = case action of Exec -> do - (r, vm') <- liftIO $ stToIO $ runStateT EVM.Exec.exec vm + conf <- readConfig + (r, vm') <- liftIO $ stToIO $ runStateT (EVM.Exec.exec conf) vm interpret fetcher vm' (k r) Wait q -> do m <- fetcher q vm' <- liftIO $ stToIO $ execStateT m vm interpret fetcher vm' (k ()) - IOAct m -> do - r <- liftIO m - interpret fetcher vm (k r) EVM m -> do (r, vm') <- liftIO $ stToIO $ runStateT m vm interpret fetcher vm' (k r) diff --git a/src/EVM/SymExec.hs b/src/EVM/SymExec.hs --- a/src/EVM/SymExec.hs +++ b/src/EVM/SymExec.hs @@ -1,26 +1,27 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} module EVM.SymExec where 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 (when, forM_, forM) import Control.Monad.IO.Unlift import Control.Monad.Operational qualified as Operational import Control.Monad.ST (RealWorld, stToIO, ST) import Control.Monad.State.Strict (runStateT) -import Data.Bifunctor (second, first) +import Data.Bifunctor (second) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Containers.ListUtils (nubOrd) import Data.DoubleWord (Word256) -import Data.List (foldl', sortBy, sort, group) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.List (foldl', sortBy, sort) +import Data.List.NonEmpty qualified as NE +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Map.Merge.Strict qualified as Map -import Data.Set (Set, isSubsetOf, size) +import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T @@ -28,7 +29,8 @@ import Data.Tree.Zipper qualified as Zipper import Data.Tuple (swap) import Data.Vector qualified as V -import Data.Vector.Unboxed qualified as VUnboxed +import Data.Vector.Storable qualified as VS +import Data.Vector.Storable.ByteString (vectorToByteString) import EVM (makeVm, abstractContract, initialContract, getCodeLocation, isValidJumpDest) import EVM.Exec import EVM.Fetch qualified as Fetch @@ -36,14 +38,15 @@ import EVM.Effects import EVM.Expr qualified as Expr import EVM.FeeSchedule (feeSchedule) -import EVM.Format (formatExpr, formatPartial, showVal, bsToHex, indent, formatBinary) -import EVM.SMT (SMTCex(..), SMT2(..), assertProps) +import EVM.Format (formatExpr, formatPartial, formatPartialShort, showVal, indent, formatBinary, formatProp, formatState, formatError) import EVM.SMT qualified as SMT import EVM.Solvers import EVM.Stepper (Stepper) import EVM.Stepper qualified as Stepper import EVM.Traversals -import EVM.Types +import EVM.Types hiding (Comp) +import EVM.Types qualified +import EVM.Expr (maybeConcStoreSimp) import GHC.Conc (getNumProcessors) import GHC.Generics (Generic) import Optics.Core @@ -56,52 +59,46 @@ | StackBased deriving (Eq, Show, Read, ParseField, ParseFields, ParseRecord, Generic) -data ProofResult a b c d = Qed a | Cex b | Unknown c | Error d - deriving (Show, Eq) -type VerifyResult = ProofResult () (Expr End, SMTCex) (Expr End) String -type EquivResult = ProofResult () (SMTCex) () String - -isUnknown :: ProofResult a b c d -> Bool -isUnknown (EVM.SymExec.Unknown _) = True -isUnknown _ = False - -isError :: ProofResult a b c d -> Bool -isError (EVM.SymExec.Error _) = True -isError _ = False - -isCex :: ProofResult a b c d -> Bool -isCex (Cex _) = True -isCex _ = False - -isQed :: ProofResult a b c d -> Bool -isQed (Qed _) = True -isQed _ = False +groupIssues :: forall a b . GetUnknownStr b => [ProofResult a b] -> [(Integer, String)] +groupIssues results = map (\g -> (into (length g), NE.head g)) grouped + where + getIssue :: ProofResult a b -> Maybe String + getIssue (Error k) = Just k + getIssue (Unknown reason) = Just $ "SMT solver says: " <> getUnknownStr reason + getIssue _ = Nothing + grouped = NE.group $ sort $ mapMaybe getIssue results -groupIssues :: [ProofResult a b c String] -> [(Integer, String)] -groupIssues results = map (\g -> (into (length g), head g)) grouped +groupPartials :: [Expr End] -> [(Integer, String)] +groupPartials e = map (\g -> (into (length g), NE.head g)) grouped where - getErr :: ProofResult a b c String -> String - getErr (EVM.SymExec.Error k) = k - getErr (EVM.SymExec.Unknown _) = "SMT result timeout/unknown" - getErr _ = internalError "shouldn't happen" - sorted = sort $ map getErr results - grouped = group sorted + getPartial :: Expr End -> Maybe String + getPartial (Partial _ _ reason) = Just $ T.unpack $ formatPartialShort reason + getPartial _ = Nothing + grouped = NE.group $ sort $ mapMaybe getPartial e -data VeriOpts = VeriOpts - { simp :: Bool - , maxIter :: Maybe Integer +data IterConfig = IterConfig + { maxIter :: Maybe Integer , askSmtIters :: Integer , loopHeuristic :: LoopHeuristic + } + deriving (Eq, Show) + +defaultIterConf :: IterConfig +defaultIterConf = IterConfig + { maxIter = Nothing + , askSmtIters = 1 + , loopHeuristic = StackBased + } + +data VeriOpts = VeriOpts + { iterConf :: IterConfig , rpcInfo :: Fetch.RpcInfo } deriving (Eq, Show) defaultVeriOpts :: VeriOpts defaultVeriOpts = VeriOpts - { simp = True - , maxIter = Nothing - , askSmtIters = 1 - , loopHeuristic = StackBased + { iterConf = defaultIterConf , rpcInfo = Nothing } @@ -125,7 +122,7 @@ AbiIntType n -> if n `mod` 8 == 0 && n <= 256 -- TODO: is this correct? - then St [Expr.inRange n v] v + then St [Expr.inRangeSigned n v] v else internalError "bad type" AbiBoolType -> St [bool v] v AbiAddressType -> St [] (WAddr (SymAddr name)) @@ -151,8 +148,9 @@ -- with concrete arguments. -- Any argument given as "" or omitted at the tail of the list are -- kept symbolic. -symCalldata :: Text -> [AbiType] -> [String] -> Expr Buf -> (Expr Buf, [Prop]) -symCalldata sig typesignature concreteArgs base = +symCalldata :: App m => Text -> [AbiType] -> [String] -> Expr Buf -> m (Expr Buf, [Prop]) +symCalldata sig typesignature concreteArgs base = do + conf <- readConfig let args = concreteArgs <> replicate (length typesignature - length concreteArgs) "" mkArg :: AbiType -> String -> Int -> CalldataFragment @@ -169,8 +167,8 @@ withSelector = writeSelector cdBuf sig sizeConstraints = (Expr.bufLength withSelector .>= cdLen calldatas) - .&& (Expr.bufLength withSelector .< (Lit (2 ^ (64 :: Integer)))) - in (withSelector, sizeConstraints : props) + .&& (Expr.bufLength withSelector .< (Lit (2 ^ conf.maxBufSize))) + pure (withSelector, sizeConstraints : props) cdLen :: [CalldataFragment] -> Expr EWord cdLen = go (Lit 4) @@ -224,6 +222,43 @@ Just p -> [p vm] pure $ vm & over #constraints (<> precond) +-- Creates symbolic VM with empty storage, not symbolic storage like loadSymVM +loadEmptySymVM + :: ContractCode + -> Expr EWord + -> (Expr Buf, [Prop]) + -> ST s (VM Symbolic s) +loadEmptySymVM x callvalue cd = + (makeVm $ VMOpts + { contract = initialContract x + , otherContracts = [] + , calldata = cd + , value = callvalue + , baseState = EmptyBase + , address = SymAddr "entrypoint" + , caller = SymAddr "caller" + , origin = SymAddr "origin" + , coinbase = SymAddr "coinbase" + , number = Lit 0 + , timestamp = Lit 0 + , blockGaslimit = 0 + , gasprice = 0 + , prevRandao = 42069 + , gas = () + , gaslimit = 0xffffffffffffffff + , baseFee = 0 + , priorityFee = 0 + , maxCodeSize = 0xffffffff + , schedule = feeSchedule + , chainId = 1 + , create = False + , txAccessList = mempty + , allowFFI = False + , freshAddresses = 0 + , beaconRoot = 0 + }) + +-- Creates a symbolic VM that has symbolic storage, unlike loadEmptySymVM loadSymVM :: ContractCode -> Expr EWord @@ -241,7 +276,7 @@ , caller = SymAddr "caller" , origin = SymAddr "origin" , coinbase = SymAddr "coinbase" - , number = 0 + , number = Lit 0 , timestamp = Lit 0 , blockGaslimit = 0 , gasprice = 0 @@ -276,7 +311,7 @@ } where freeze = \case - ConcreteMemory m -> SymbolicMemory . ConcreteBuf . BS.pack . VUnboxed.toList <$> VUnboxed.freeze m + ConcreteMemory m -> SymbolicMemory . ConcreteBuf . vectorToByteString <$> VS.freeze m m@(SymbolicMemory _) -> pure m -- | Interpreter which explores all paths at branching points. Returns an @@ -284,91 +319,95 @@ interpret :: forall m . App m => Fetch.Fetcher Symbolic m RealWorld - -> Maybe Integer -- max iterations - -> Integer -- ask smt iterations - -> LoopHeuristic + -> IterConfig -> VM Symbolic RealWorld -> Stepper Symbolic RealWorld (Expr End) -> m (Expr End) -interpret fetcher maxIter askSmtIters heuristic vm = +interpret fetcher iterConf vm = eval . Operational.view where - eval - :: Operational.ProgramView (Stepper.Action Symbolic RealWorld) (Expr End) - -> m (Expr End) - + eval :: Operational.ProgramView (Stepper.Action Symbolic RealWorld) (Expr End) -> m (Expr End) eval (Operational.Return x) = pure x - eval (action Operational.:>>= k) = case action of Stepper.Exec -> do - (r, vm') <- liftIO $ stToIO $ runStateT exec vm - interpret fetcher maxIter askSmtIters heuristic vm' (k r) - Stepper.IOAct q -> do - r <- liftIO q - interpret fetcher maxIter askSmtIters heuristic vm (k r) - Stepper.Ask (PleaseChoosePath cond continue) -> do + conf <- readConfig + (r, vm') <- liftIO $ stToIO $ runStateT (exec conf) vm + interpret fetcher iterConf vm' (k r) + Stepper.EVM m -> do + (r, vm') <- liftIO $ stToIO $ runStateT m vm + interpret fetcher iterConf vm' (k r) + Stepper.ForkMany (PleaseRunAll expr vals continue) -> do + when (length vals < 2) $ internalError "PleaseRunAll requires at least 2 branches" frozen <- liftIO $ stToIO $ freezeVM vm + let newDepth = vm.exploreDepth+1 + ends <- withRunInIO $ \runInIO -> mapConcurrently (runInIO . runOne frozen newDepth) vals + pure $ goITE (zip vals ends) + where + goITE :: [(W256, Expr End)] -> Expr End + goITE [] = internalError "goITE: empty list" + goITE [(_, end)] = end + goITE ((val,end):ps) = ITE (Eq expr (Lit val)) end (goITE ps) + runOne :: App m => VM 'Symbolic RealWorld -> Int -> W256 -> m (Expr 'End) + runOne frozen newDepth v = do + (ra, vma) <- liftIO $ stToIO $ runStateT (continue v) frozen { result = Nothing, exploreDepth = newDepth } + interpret fetcher iterConf vma (k ra) + Stepper.Fork (PleaseRunBoth cond continue) -> do + frozen <- liftIO $ stToIO $ freezeVM vm + let newDepth = vm.exploreDepth+1 evalLeft <- toIO $ do - (ra, vma) <- liftIO $ stToIO $ runStateT (continue True) frozen { result = Nothing } - interpret fetcher maxIter askSmtIters heuristic vma (k ra) + (ra, vma) <- liftIO $ stToIO $ runStateT (continue True) frozen { result = Nothing, exploreDepth = newDepth } + interpret fetcher iterConf vma (k ra) evalRight <- toIO $ do - (rb, vmb) <- liftIO $ stToIO $ runStateT (continue False) frozen { result = Nothing } - interpret fetcher maxIter askSmtIters heuristic vmb (k rb) + (rb, vmb) <- liftIO $ stToIO $ runStateT (continue False) frozen { result = Nothing, exploreDepth = newDepth } + interpret fetcher iterConf vmb (k rb) (a, b) <- liftIO $ concurrently evalLeft evalRight pure $ ITE cond a b Stepper.Wait q -> do let performQuery = do m <- fetcher q (r, vm') <- liftIO$ stToIO $ runStateT m vm - interpret fetcher maxIter askSmtIters heuristic vm' (k r) + interpret fetcher iterConf vm' (k r) case q of PleaseAskSMT cond preconds continue -> do - let - -- no concretiziation here, or we may lose information - simpProps = Expr.simplifyProps ((cond ./= Lit 0):preconds) case Expr.concKeccakSimpExpr cond of -- is the condition concrete? Lit c -> -- have we reached max iterations, are we inside a loop? - case (maxIterationsReached vm maxIter, isLoopHead heuristic vm) of + case (maxIterationsReached vm iterConf.maxIter, isLoopHead iterConf.loopHeuristic vm) of -- Yes. return a partial leaf (Just _, Just True) -> pure $ Partial [] (TraceContext (Zipper.toForest vm.traces) vm.env.contracts vm.labels) $ MaxIterationsReached vm.state.pc vm.state.contract -- No. keep executing _ -> do (r, vm') <- liftIO $ stToIO $ runStateT (continue (Case (c > 0))) vm - interpret fetcher maxIter askSmtIters heuristic vm' (k r) + interpret fetcher iterConf vm' (k r) -- the condition is symbolic _ -> -- are in we a loop, have we hit maxIters, have we hit askSmtIters? - case (isLoopHead heuristic vm, askSmtItersReached vm askSmtIters, maxIterationsReached vm maxIter) of + case (isLoopHead iterConf.loopHeuristic vm, askSmtItersReached vm iterConf.askSmtIters, maxIterationsReached vm iterConf.maxIter) of -- we're in a loop and maxIters has been reached (Just True, _, Just n) -> do -- continue execution down the opposite branch than the one that -- got us to this point and return a partial leaf for the other side (r, vm') <- liftIO $ stToIO $ runStateT (continue (Case $ not n)) vm - a <- interpret fetcher maxIter askSmtIters heuristic vm' (k r) + a <- interpret fetcher iterConf vm' (k r) pure $ ITE cond a (Partial [] (TraceContext (Zipper.toForest vm.traces) vm.env.contracts vm.labels) (MaxIterationsReached vm.state.pc vm.state.contract)) -- we're in a loop and askSmtIters has been reached (Just True, True, _) -> -- ask the smt solver about the loop condition performQuery _ -> do + let simpProps = Expr.concKeccakSimpProps ((cond ./= Lit 0):preconds) (r, vm') <- case simpProps of - -- if we can statically determine unsatisfiability then we skip exploring the jump [PBool False] -> liftIO $ stToIO $ runStateT (continue (Case False)) vm - -- otherwise we explore both branches - _ -> liftIO $ stToIO $ runStateT (continue EVM.Types.Unknown) vm - interpret fetcher maxIter askSmtIters heuristic vm' (k r) + [] -> liftIO $ stToIO $ runStateT (continue (Case True)) vm + _ -> liftIO $ stToIO $ runStateT (continue UnknownBranch) vm {exploreDepth = vm.exploreDepth+1} + interpret fetcher iterConf vm' (k r) _ -> performQuery - Stepper.EVM m -> do - (r, vm') <- liftIO $ stToIO $ runStateT m vm - interpret fetcher maxIter askSmtIters heuristic vm' (k r) - maxIterationsReached :: VM Symbolic s -> Maybe Integer -> Maybe Bool maxIterationsReached _ Nothing = Nothing maxIterationsReached vm (Just maxIter) = @@ -418,6 +457,21 @@ checkAssert solvers errs c signature' concreteArgs opts = verifyContract solvers c signature' concreteArgs opts Nothing (Just $ checkAssertions errs) +getExprEmptyStore + :: App m + => SolverGroup + -> ByteString + -> Maybe Sig + -> [String] + -> VeriOpts + -> m (Expr End) +getExprEmptyStore solvers c signature' concreteArgs opts = do + conf <- readConfig + calldata <- mkCalldata signature' concreteArgs + preState <- liftIO $ stToIO $ loadEmptySymVM (RuntimeCode (ConcreteRuntimeCode c)) (Lit 0) calldata + exprInter <- interpret (Fetch.oracle solvers opts.rpcInfo) opts.iterConf preState runExpr + if conf.simp then (pure $ Expr.simplify exprInter) else pure exprInter + getExpr :: App m => SolverGroup @@ -427,9 +481,11 @@ -> VeriOpts -> m (Expr End) getExpr solvers c signature' concreteArgs opts = do - preState <- liftIO $ stToIO $ abstractVM (mkCalldata signature' concreteArgs) c Nothing False - exprInter <- interpret (Fetch.oracle solvers opts.rpcInfo) opts.maxIter opts.askSmtIters opts.loopHeuristic preState runExpr - if opts.simp then (pure $ Expr.simplify exprInter) else pure exprInter + conf <- readConfig + calldata <- mkCalldata signature' concreteArgs + preState <- liftIO $ stToIO $ abstractVM calldata c Nothing False + exprInter <- interpret (Fetch.oracle solvers opts.rpcInfo) opts.iterConf preState runExpr + if conf.simp then (pure $ Expr.simplify exprInter) else pure exprInter {- | Checks if an assertion violation has been encountered @@ -449,6 +505,7 @@ - 0x51: If you call a zero-initialized variable of internal function type. see: https://docs.soliditylang.org/en/v0.8.6/control-structures.html?highlight=Panic#panic-via-assert-and-error-via-require + NOTE: does not deal with e.g. `assertEq()` -} checkAssertions :: [Word256] -> Postcondition s checkAssertions errs _ = \case @@ -469,15 +526,16 @@ -- | 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 :: App m => Maybe Sig -> [String] -> m (Expr Buf, [Prop]) +mkCalldata Nothing _ = do + conf <- readConfig + pure ( 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 ^ conf.maxBufSize))] + ) mkCalldata (Just (Sig name types)) args = symCalldata name types args (AbstractBuf "txdata") @@ -492,7 +550,8 @@ -> Maybe (Postcondition RealWorld) -> m (Expr End, [VerifyResult]) verifyContract solvers theCode signature' concreteArgs opts maybepre maybepost = do - preState <- liftIO $ stToIO $ abstractVM (mkCalldata signature' concreteArgs) theCode maybepre False + calldata <- mkCalldata signature' concreteArgs + preState <- liftIO $ stToIO $ abstractVM calldata theCode maybepre False verify solvers opts preState maybepost -- | Stepper that parses the result of Stepper.runFully into an Expr End @@ -502,8 +561,8 @@ let traces = TraceContext (Zipper.toForest vm.traces) vm.env.contracts vm.labels pure $ case vm.result of Just (VMSuccess buf) -> Success vm.constraints traces buf (fmap toEContract vm.env.contracts) - Just (VMFailure e) -> Failure vm.constraints traces e - Just (Unfinished p) -> Partial vm.constraints traces p + Just (VMFailure e) -> Failure vm.constraints traces e + Just (Unfinished p) -> Partial vm.constraints traces p _ -> internalError "vm in intermediate state after call to runFully" toEContract :: Contract -> Expr EContract @@ -531,10 +590,9 @@ -- the incremental nature of the task at hand. Introducing support for -- incremental queries might let us go even faster here. -- TODO: handle errors properly -reachable :: App m => SolverGroup -> Expr End -> m ([SMT2], Expr End) +reachable :: App m => SolverGroup -> Expr End -> m ([SMT.SMT2], Expr End) reachable solvers e = do - conf <- readConfig - res <- liftIO $ go conf [] e + res <- go [] e pure $ second (fromMaybe (internalError "no reachable paths found")) res where {- @@ -543,12 +601,12 @@ If reachable return the expr wrapped in a Just. If not return Nothing. When walking back up the tree drop unreachable subbranches. -} - go :: Config -> [Prop] -> Expr End -> IO ([SMT2], Maybe (Expr End)) - go conf pcs = \case + go :: (App m, MonadUnliftIO m) => [Prop] -> Expr End -> m ([SMT.SMT2], Maybe (Expr End)) + go pcs = \case ITE c t f -> do - (tres, fres) <- concurrently - (go conf (PEq (Lit 1) c : pcs) t) - (go conf (PEq (Lit 0) c : pcs) f) + (tres, fres) <- withRunInIO $ \env -> concurrently + (env $ go (PEq (Lit 1) c : pcs) t) + (env $ go (PEq (Lit 0) c : pcs) f) let subexpr = case (snd tres, snd fres) of (Just t', Just f') -> Just $ ITE c t' f' (Just t', Nothing) -> Just t' @@ -556,12 +614,13 @@ (Nothing, Nothing) -> Nothing pure (fst tres <> fst fres, subexpr) leaf -> do - let query = assertProps conf pcs - res <- checkSat solvers query + (res, smt2) <- checkSatWithProps solvers pcs case res of - Sat _ -> pure ([getNonError query], Just leaf) - Unsat -> pure ([getNonError query], Nothing) - r -> internalError $ "Invalid solver result: " <> show r + Qed -> pure ([getNonError smt2], Nothing) + Cex _ -> pure ([getNonError smt2], Just leaf) + -- if we get an error, we don't know if the leaf is reachable or not, so + -- we assume it could be reachable + _ -> pure ([], Just leaf) -- | Extract constraints stored in Expr End nodes extractProps :: Expr End -> [Prop] @@ -572,10 +631,25 @@ Partial asserts _ _ -> asserts GVar _ -> internalError "cannot extract props from a GVar" +extractEndStates :: Expr End -> Map (Expr EAddr) (Expr EContract) +extractEndStates = \case + ITE {} -> mempty + Success _ _ _ contr -> contr + Failure {} -> mempty + Partial {} -> mempty + GVar _ -> internalError "cannot extract props from a GVar" + isPartial :: Expr a -> Bool isPartial (Partial _ _ _) = True isPartial _ = False +printPartialIssues :: [Expr End] -> String -> IO () +printPartialIssues flattened call = + when (any isPartial flattened) $ do + T.putStrLn $ indent 3 "\x1b[33m[WARNING]\x1b[0m: hevm was only able to partially explore " + <> T.pack call <> " due to the following issue(s):" + T.putStr . T.unlines . fmap (indent 5 . ("- " <>)) . fmap formatPartial . getPartials $ flattened + getPartials :: [Expr End] -> [PartialExec] getPartials = mapMaybe go where @@ -594,73 +668,100 @@ -> Maybe (Postcondition RealWorld) -> m (Expr End, [VerifyResult]) verify solvers opts preState maybepost = do + (expr, res, _) <- verifyInputs solvers opts (Fetch.oracle solvers opts.rpcInfo) preState maybepost + pure $ verifyResults preState expr res + +verifyResults :: VM Symbolic RealWorld -> Expr End -> [(SMTResult, Expr End)] -> (Expr End, [VerifyResult]) +verifyResults preState expr cexs = if Prelude.null cexs then (expr, [Qed]) else (expr, fmap toVRes cexs) + where + toVRes :: (SMTResult, Expr End) -> VerifyResult + toVRes (res, leaf) = case res of + Cex model -> Cex (leaf, expandCex preState model) + Unknown reason -> Unknown (reason, leaf) + Error e -> Error e + Qed -> Qed + +-- | Symbolically execute the VM and find possible inputs given the +-- postcondition, if available. +verifyInputs + :: App m + => SolverGroup + -> VeriOpts + -> Fetch.Fetcher Symbolic m RealWorld + -> VM Symbolic RealWorld + -> Maybe (Postcondition RealWorld) + -> m (Expr End, [(SMTResult, Expr End)], [PartialExec]) +verifyInputs solvers opts fetcher preState maybepost = do conf <- readConfig let call = mconcat ["prefix 0x", getCallPrefix preState.state.calldata] when conf.debug $ liftIO $ putStrLn $ " Exploring call " <> call - exprInter <- interpret (Fetch.oracle solvers opts.rpcInfo) opts.maxIter opts.askSmtIters opts.loopHeuristic preState runExpr + exprInter <- interpret fetcher opts.iterConf preState runExpr when conf.dumpExprs $ liftIO $ T.writeFile "unsimplified.expr" (formatExpr exprInter) - liftIO $ do - when conf.debug $ putStrLn " Simplifying expression" - let expr = if opts.simp then (Expr.simplify exprInter) else exprInter - when conf.dumpExprs $ T.writeFile "simplified.expr" (formatExpr expr) - - when conf.debug $ putStrLn $ " Exploration finished, " <> show (Expr.numBranches expr) <> " branch(es) to check in call " <> call + let expr = if conf.simp then (Expr.simplify exprInter) else exprInter + flattened = flattenExpr expr + when conf.dumpExprs $ liftIO $ do + T.writeFile "simplified.expr" (formatExpr expr) + T.writeFile "simplified-conc.expr" (formatExpr $ Expr.simplify $ mapExpr Expr.concKeccakOnePass expr) - let flattened = flattenExpr expr - when (any isPartial flattened) $ do - T.putStrLn $ indent 3 "\x1b[33mWARNING\x1b[0m: hevm was only able to partially explore the call " - <> T.pack call <> " due to the following issue(s):" - T.putStr . T.unlines . fmap (indent 5 . ("- " <>)) . fmap formatPartial . getPartials $ flattened + let partials = getPartials flattened + when conf.debug $ liftIO $ do + putStrLn " Flattening expression" + printPartialIssues flattened ("the call " <> call) + putStrLn $ " Exploration finished, " <> show (Expr.numBranches expr) <> " branch(es) to check in call " <> call - case maybepost of - Nothing -> pure (expr, [Qed ()]) - Just post -> liftIO $ do - let - -- Filter out any leaves from `flattened` that can be statically shown to be safe - tocheck = flip map flattened $ \leaf -> (toPropsFinal leaf preState.constraints post, leaf) - withQueries = filter canBeSat tocheck <&> first (assertProps conf) - when conf.debug $ - putStrLn $ " Checking for reachability of " <> show (length withQueries) - <> " potential property violation(s) in call " <> call + case maybepost of + Nothing -> pure (expr, [(Qed, expr)], partials) + Just post -> do + let + -- Filter out any leaves from `flattened` that can be statically shown to be safe + tocheck = flip map flattened $ \leaf -> (toPropsFinal conf leaf preState.constraints post, leaf) + withQueries = filter canBeSat tocheck + when conf.debug $ liftIO $ putStrLn $ " Checking for reachability of " <> show (length withQueries) + <> " potential property violation(s) in call " <> call - -- Dispatch the remaining branches to the solver to check for violations - results <- flip mapConcurrently withQueries $ \(query, leaf) -> do - res <- checkSat solvers query - when conf.debug $ putStrLn $ " SMT result: " <> show res - pure (res, leaf) - let cexs = filter (\(res, _) -> not . isUnsat $ res) results - when conf.debug $ putStrLn $ " Found " <> show (length cexs) <> " potential counterexample(s) in call " <> call - pure $ if Prelude.null cexs then (expr, [Qed ()]) else (expr, fmap toVRes cexs) + -- Dispatch the remaining branches to the solver to check for violations + results <- withRunInIO $ \env -> flip mapConcurrently withQueries $ \(query, leaf) -> do + res <- env $ checkSatWithProps solvers query + when conf.debug $ putStrLn $ " SMT result: " <> show (fst res) + pure (fst res, leaf) + let cexs = filter (\(res, _) -> not . isQed $ res) results + when conf.debug $ liftIO $ + putStrLn $ " Found " <> show (length cexs) <> " potential counterexample(s) in call " <> call + pure (expr, cexs, partials) where getCallPrefix :: Expr Buf -> String getCallPrefix (WriteByte (Lit 0) (LitByte a) (WriteByte (Lit 1) (LitByte b) (WriteByte (Lit 2) (LitByte c) (WriteByte (Lit 3) (LitByte d) _)))) = mconcat $ map (printf "%02x") [a,b,c,d] getCallPrefix _ = "unknown" toProps leaf constr post = PNeg (post preState leaf) : constr <> extractProps leaf - toPropsFinal leaf constr post = if opts.simp then Expr.simplifyProps $ toProps leaf constr post + toPropsFinal conf leaf constr post = if conf.simp then Expr.simplifyProps $ toProps leaf constr post else toProps leaf constr post canBeSat (a, _) = case a of [PBool False] -> False _ -> True - toVRes :: (CheckSatResult, Expr End) -> VerifyResult - toVRes (res, leaf) = case res of - Sat model -> Cex (leaf, expandCex preState model) - EVM.Solvers.Unknown _ -> EVM.SymExec.Unknown leaf - EVM.Solvers.Error e -> EVM.SymExec.Error e - Unsat -> Qed () expandCex :: VM Symbolic s -> SMTCex -> SMTCex expandCex prestate c = c { store = Map.union c.store concretePreStore } where - concretePreStore = Map.mapMaybe (maybeConcreteStore . (.storage)) + concretePreStore = Map.mapMaybe (maybeConcStoreSimp . (.storage)) . Map.filter (\v -> Expr.containsNode isConcreteStore v.storage) $ (prestate.env.contracts) isConcreteStore = \case ConcreteStore _ -> True _ -> False -type UnsatCache = TVar [Set Prop] +data EqIssues = EqIssues + { res :: [(EquivResult, String)] + , partials :: [Expr End] + } + deriving (Show, Eq) +instance Monoid EqIssues where + mempty = EqIssues mempty mempty + +instance Semigroup EqIssues where + EqIssues a1 b1 <> EqIssues a2 b2 = EqIssues (a1 <> a2) (b1 <> b2) + -- | Compares two contract runtimes for trace equivalence by running two VMs -- and comparing the end states. -- @@ -676,149 +777,207 @@ -> ByteString -> VeriOpts -> (Expr Buf, [Prop]) - -> m [EquivResult] -equivalenceCheck solvers bytecodeA bytecodeB opts calldata = do + -> Bool + -> m EqIssues +equivalenceCheck solvers bytecodeA bytecodeB opts calldata create = do + conf <- readConfig case bytecodeA == bytecodeB of True -> liftIO $ do putStrLn "bytecodeA and bytecodeB are identical" - pure [Qed ()] + pure mempty False -> do - branchesA <- getBranches bytecodeA - branchesB <- getBranches bytecodeB - equivalenceCheck' solvers branchesA branchesB + when conf.debug $ liftIO $ do + putStrLn "bytecodeA and bytecodeB are different, checking for equivalence" + branchesAorig <- getBranches bytecodeA + branchesBorig <- getBranches bytecodeB + when conf.debug $ liftIO $ do + liftIO $ putStrLn $ "branchesA props: " <> show (map extractProps branchesAorig) + liftIO $ putStrLn $ "branchesB props: " <> show (map extractProps branchesBorig) + liftIO $ putStrLn "" + liftIO $ putStrLn $ "branchesA endstates: " <> show (map extractEndStates branchesAorig) + + liftIO $ putStrLn $ "branchesB endstates: " <> show (map extractEndStates branchesBorig) + let branchesA = rewriteFresh "A-" branchesAorig + branchesB = rewriteFresh "B-" branchesBorig + let partialIssues = EqIssues mempty (filter isPartial branchesA <> filter isPartial branchesB) + issues <- equivalenceCheck' solvers branchesA branchesB create + pure $ oneQedOrNoQed issues <> partialIssues where -- decompiles the given bytecode into a list of branches - getBranches :: ByteString -> m [Expr End] + getBranches :: App m => ByteString -> m [Expr End] getBranches bs = do + conf <- readConfig let bytecode = if BS.null bs then BS.pack [0] else bs - prestate <- liftIO $ stToIO $ abstractVM calldata bytecode Nothing False - expr <- interpret (Fetch.oracle solvers Nothing) opts.maxIter opts.askSmtIters opts.loopHeuristic prestate runExpr - let simpl = if opts.simp then (Expr.simplify expr) else expr + prestate <- liftIO $ stToIO $ abstractVM calldata bytecode Nothing create + expr <- interpret (Fetch.oracle solvers Nothing) opts.iterConf prestate runExpr + let simpl = if conf.simp then Expr.simplify expr else expr pure $ flattenExpr simpl + oneQedOrNoQed :: EqIssues -> EqIssues + oneQedOrNoQed (EqIssues res partials) = + let allQed = all (\(r, _) -> isQed r) res + in if allQed then EqIssues [(Qed, "")] partials + else EqIssues (filter (\(r, _) -> not $ isQed r) res) partials +rewriteFresh :: Text -> [Expr a] -> [Expr a] +rewriteFresh prefix exprs = fmap (mapExpr mymap) exprs + where + mymap :: Expr a -> Expr a + mymap = \case + Gas p x -> Gas (prefix <> p) x + Var name | ("-fresh-" `T.isInfixOf` name) -> Var $ prefix <> name + AbstractBuf name | ("-fresh-" `T.isInfixOf` name) -> AbstractBuf $ prefix <> name + x -> x + equivalenceCheck' :: forall m . App m - => SolverGroup -> [Expr End] -> [Expr End] -> m [EquivResult] -equivalenceCheck' solvers branchesA branchesB = do - when (any isPartial branchesA || any isPartial branchesB) $ liftIO $ do - putStrLn "\x1b[33mWARNING\x1b[0m: hevm was only able to partially explore the given contract due to the following issue(s):" - T.putStr . T.unlines . fmap (indent 2 . ("- " <>)) . fmap formatPartial . nubOrd $ ((getPartials branchesA) <> (getPartials branchesB)) + => SolverGroup -> [Expr End] -> [Expr End] -> Bool -> m EqIssues +equivalenceCheck' solvers branchesA branchesB create = do + conf <- readConfig + when conf.debug $ do + liftIO $ printPartialIssues branchesA "codeA" + liftIO $ printPartialIssues branchesB "codeB" let allPairs = [(a,b) | a <- branchesA, b <- branchesB] liftIO $ putStrLn $ "Found " <> show (length allPairs) <> " total pairs of endstates" - conf <- readConfig when conf.dumpEndStates $ liftIO $ putStrLn $ "endstates in bytecodeA: " <> show (length branchesA) <> "\nendstates in bytecodeB: " <> show (length branchesB) - let differingEndStates = sortBySize (mapMaybe (uncurry distinct) allPairs) + ps <- forM allPairs $ uncurry distinct + let differingEndStates = sortBySize $ mapMaybe (view _1) ps + let knownIssues = foldr ((<>) . (view _2)) mempty ps liftIO $ putStrLn $ "Asking the SMT solver for " <> (show $ length differingEndStates) <> " pairs" when conf.dumpEndStates $ forM_ (zip differingEndStates [(1::Integer)..]) (\(x, i) -> liftIO $ T.writeFile ("prop-checked-" <> show i <> ".prop") (T.pack $ show x)) - knownUnsat <- liftIO $ newTVarIO [] procs <- liftIO getNumProcessors - results <- checkAll differingEndStates knownUnsat procs + newDifferences <- checkAll differingEndStates procs + let additionalIssues = EqIssues newDifferences mempty + pure $ knownIssues <> additionalIssues - let useful = foldr (\(_, b) n -> if b then n+1 else n) (0::Integer) results - liftIO $ putStrLn $ "Reuse of previous queries was Useful in " <> (show useful) <> " cases" - case all (isQed . fst) results of - True -> pure [Qed ()] - False -> pure $ filter (/= Qed ()) . fmap fst $ results where - -- we order the sets by size because this gives us more cache hits when + -- we order the sets by size because this gives us more UNSAT cache hits when -- running our queries later on (since we rely on a subset check) - sortBySize :: [Set a] -> [Set a] - sortBySize = sortBy (\a b -> if size a > size b then Prelude.LT else Prelude.GT) - - -- returns True if a is a subset of any of the sets in b - subsetAny :: Set Prop -> [Set Prop] -> Bool - subsetAny a b = foldr (\bp acc -> acc || isSubsetOf a bp) False b - - -- checks for satisfiability of all the props in the provided set. skips - -- the solver if we can determine unsatisfiability from the cache already - -- the last element of the returned tuple indicates whether the cache was - -- used or not - check :: Config -> UnsatCache -> (Set Prop) -> IO (EquivResult, Bool) - check conf knownUnsat props = do - let smt = assertProps conf (Set.toList props) - ku <- readTVarIO knownUnsat - res <- if subsetAny props ku - then pure (True, Unsat) - 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) - (_, EVM.Solvers.Unknown _) -> pure (EVM.SymExec.Unknown (), False) - (_, EVM.Solvers.Error txt) -> pure (EVM.SymExec.Error txt, False) + sortBySize :: [(Set a, b)] -> [(Set a, b)] + sortBySize = sortBy (\(a, _) (b, _) -> compare (Set.size a) (Set.size b)) - -- Allows us to run it in parallel. Note that this (seems to) run it + -- Allows us to run the queries in parallel. Note that this (seems to) run it -- from left-to-right, and with a max of K threads. This is in contrast to -- mapConcurrently which would spawn as many threads as there are jobs, and -- run them in a random order. We ordered them correctly, though so that'd be bad - checkAll :: App m => [(Set Prop)] -> UnsatCache -> Int -> m [(EquivResult, Bool)] - checkAll input cache numproc = do - conf <- readConfig - wrap <- liftIO $ pool numproc - liftIO $ parMapIO (wrap . (check conf cache)) input - + checkAll :: (App m, MonadUnliftIO m) => [(Set Prop, String)] -> Int -> m [(EquivResult, String)] + checkAll input numproc = withRunInIO $ \env -> do + wrap <- pool numproc + parMapIO (runOne env wrap) input + where + runOne env wrap (props, meaning) = do + res <- wrap (env $ fst <$> checkSatWithProps solvers (Set.toList props)) + pure (res, meaning) -- Takes two branches and returns a set of props that will need to be -- satisfied for the two branches to violate the equivalence check. i.e. -- 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 :: Expr End -> Expr End -> Maybe (Set Prop) - distinct aEnd bEnd = - case resultsDiffer aEnd bEnd of - -- if the end states are the same, then they can never produce a - -- different result under any circumstances - PBool False -> Nothing - -- 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 $ 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 $ resultsDiffer aEnd bEnd : extractProps aEnd <> extractProps bEnd + distinct :: App m => Expr End -> Expr End -> m (Maybe (Set Prop, String), EqIssues) + distinct aEnd bEnd = do + (requireToDiff, issues) <- resultsDiffer aEnd bEnd + let newIssues = EqIssues [] (filter isPartial [aEnd, bEnd]) + pure (collectReqs requireToDiff, issues <> newIssues) + where + collectReqs (Just (reqToDiff, meaning)) = Just (Set.fromList $ Expr.simplifyProps (reqToDiff : extractProps aEnd <> extractProps bEnd), meaning) + collectReqs Nothing = Nothing - resultsDiffer :: Expr End -> Expr End -> Prop - resultsDiffer aEnd bEnd = case (aEnd, bEnd) of - (Success _ _ aOut aState, Success _ _ bOut bState) -> - case (aOut == bOut, aState == bState) of - (True, True) -> PBool False - (False, True) -> aOut ./= bOut - (True, False) -> statesDiffer aState bState - (False, False) -> statesDiffer aState bState .|| aOut ./= bOut - (Failure _ _ (Revert a), Failure _ _ (Revert b)) -> if a == b then PBool False else a ./= b - (Failure _ _ a, Failure _ _ b) -> if a == b then PBool False else PBool True - -- partial end states can't be compared to actual end states, so we always ignore them - (Partial {}, _) -> PBool False - (_, Partial {}) -> PBool False - (ITE _ _ _, _) -> internalError "Expressions must be flattened" - (_, ITE _ _ _) -> internalError "Expressions must be flattened" - (a, b) -> if a == b - then PBool False - else PBool True + -- Note that the a==b and similar checks are ONLY syntactic checks. If they are true, + -- then they are surely equivalent. But if not, we need to check via SMT + resultsDiffer :: App m => Expr End -> Expr End -> m (Maybe (Prop, String), EqIssues) + resultsDiffer aEnd bEnd = do + let deployText :: String = if create then "Undeployed contracts. " else "Deployed contracts. " + case (aEnd, bEnd) of + (Success aProps _ aOut aState, Success bProps _ bOut bState) -> + case (aOut == bOut, aState == bState, create) of + (True, True, _) -> pure (Nothing, mempty) + (_, _, True) -> do + -- Either the deployed code doesn't behave the same, or they start with a different + -- starting state + deployedContractIssues <- deployedCodeDiffer aOut bOut aProps bProps + let deployedStateDiffer = (statesDiffer aState bState, + deployText <> "Both end in Successful code deployment, but starting states differ. " <> + "\nRet of A: " <> T.unpack (formatExpr aOut) <> + "\nState of A: " <> T.unpack (formatState aState) <> + "\nRet of B: " <> T.unpack (formatExpr bOut) <> + "\nState of B: " <> T.unpack (formatState bState)) + pure (Just deployedStateDiffer, deployedContractIssues) + (_, _, False) -> do + pure (Just ((aOut ./= bOut) .|| (statesDiffer aState bState), + deployText <> "Both end in Success, but return values or end state differ. " <> + "\nRet of A: " <> T.unpack (formatExpr aOut) <> + "\nState of A: " <> T.unpack (formatState aState) <> + "\nRet of B: " <> T.unpack (formatExpr bOut) <> + "\nState of B: " <> T.unpack (formatState bState)), mempty) + (Failure _ _ a, Failure _ _ b) -> pure (Just (differentError a b, + deployText <> "Both end in Failure but different EVM error." <> + "\nA err: " <> T.unpack (formatError a) <> + "\nB err: " <> T.unpack (formatError b)), mempty) + ((Failure _ _ a), (Success _ _ b _)) -> pure (Just (PBool True, + deployText <> "Failure vs Success end states" <> + "\nA err: " <> T.unpack (formatError a) <> + "\nB ret: " <> T.unpack (formatExpr b)), mempty) + ((Success _ _ a _), (Failure _ _ b)) -> pure (Just (PBool True, + deployText <> "Success vs Failure end states" <> + "\nA ret: " <> T.unpack (formatExpr a) <> + "\nB err: " <> T.unpack (formatError b)), mempty) + -- partial end states can't be compared to actual end states, so we always ignore them + (Partial {}, _) -> pure (Nothing, mempty) + (_, Partial {}) -> pure (Nothing, mempty) + (ITE _ _ _, _) -> internalError "Expressions must be flattened" + (_, ITE _ _ _) -> internalError "Expressions must be flattened" + (GVar _, _) -> internalError "GVar in equivalence check" + (_, GVar _) -> internalError "GVar in equivalence check" + where + -- All EVM errors that cannot be syntactically compared are compared semantically: BalanceTooLow, Revert, and MaxInitCodeSizeExceeded + differentError :: EvmError ->EvmError -> Prop + differentError a b = case (a, b) of + (BalanceTooLow a1Word a2Word, BalanceTooLow b1Word b2Word) -> (a1Word ./= b1Word) .|| (a2Word ./= b2Word) + (Revert aBuf, Revert bBuf) -> aBuf ./= bBuf + (MaxInitCodeSizeExceeded l1 aWord, MaxInitCodeSizeExceeded l2 bWord) -> (PBool (l1 /= l2)) .|| (aWord ./= bWord) + (x, y) | x == y -> PBool False + | otherwise -> PBool True + + -- If the original check was for create (i.e. undeployed code), then we must also check that the deployed + -- code is equivalent. The constraints from the undeployed code (aProps,bProps) influence this check. + deployedCodeDiffer :: Expr Buf -> Expr Buf -> [Prop] -> [Prop] -> m EqIssues + deployedCodeDiffer aOut bOut aProps bProps = do + let simpA = Expr.simplify aOut + simpB = Expr.simplify bOut + conf <- readConfig + case (simpA, simpB) of + (ConcreteBuf codeA, ConcreteBuf codeB) -> do + -- TODO: use aProps/bProps to constrain the deployed code + -- since symbolic code (with constructors taking arguments) is not supported, + -- this is currently not necessary + when conf.debug $ liftIO $ do + liftIO $ putStrLn $ "create deployed code A: " <> bsToHex codeA + <> " with constraints: " <> (T.unpack . T.unlines $ map formatProp aProps) + liftIO $ putStrLn $ "create deployed code B: " <> bsToHex codeB + <> " with constraints: " <> (T.unpack . T.unlines $ map formatProp bProps) + calldata <- mkCalldata Nothing [] + equivalenceCheck solvers codeA codeB defaultVeriOpts calldata False + _ -> internalError $ "Symbolic code returned from constructor." <> " A: " <> show simpA <> " B: " <> show simpB + statesDiffer :: Map (Expr EAddr) (Expr EContract) -> Map (Expr EAddr) (Expr EContract) -> Prop - statesDiffer aState bState - = if Set.fromList (Map.keys aState) /= Set.fromList (Map.keys bState) - -- TODO: consider possibility of aliased symbolic addresses - then PBool True - else let - merged = (Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched (\_ x y -> (x,y))) aState bState) - in Map.foldl' (\a (ac, bc) -> a .|| contractsDiffer ac bc) (PBool False) merged + statesDiffer aState bState = + case aState == bState of + True -> PBool False + False -> if Set.fromList (Map.keys aState) /= Set.fromList (Map.keys bState) + -- TODO: consider possibility of aliased symbolic addresses + then PBool True + else let + merged = (Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched (\_ x y -> (x,y))) aState bState) + in Map.foldl' (\a (ac, bc) -> a .|| contractsDiffer ac bc) (PBool False) merged contractsDiffer :: Expr EContract -> Expr EContract -> Prop contractsDiffer ac bc = let @@ -828,7 +987,7 @@ -- TODO: is this sound? do we need a more sophisticated nonce representation? noncesDiffer = PBool (ac.nonce /= bc.nonce) storesDiffer = case (ac.storage, bc.storage) of - (ConcreteStore as, ConcreteStore bs) -> PBool $ as /= bs + (ConcreteStore as, ConcreteStore bs) | not (as == Map.empty || bs == Map.empty) -> PBool $ as /= bs (as, bs) -> if as == bs then PBool False else as ./= bs in balsDiffer .|| storesDiffer .|| noncesDiffer @@ -836,31 +995,30 @@ both' :: (a -> b) -> (a, a) -> (b, b) both' f (x, y) = (f x, f y) -produceModels :: App m => SolverGroup -> Expr End -> m [(Expr End, CheckSatResult)] +produceModels :: App m => SolverGroup -> Expr End -> m [(Expr End, SMTResult)] produceModels solvers expr = do let flattened = flattenExpr expr - withQueries conf = fmap (\e -> ((assertProps conf) . extractProps $ e, e)) flattened - conf <- readConfig - results <- liftIO $ (flip mapConcurrently) (withQueries conf) $ \(query, leaf) -> do - res <- checkSat solvers query + withQueries = fmap (\e -> (extractProps e, e)) flattened + results <- withRunInIO $ \runInIO -> (flip mapConcurrently) withQueries $ \(query, leaf) -> do + (res, _) <- runInIO $ checkSatWithProps solvers query pure (res, leaf) - pure $ fmap swap $ filter (\(res, _) -> not . isUnsat $ res) results + pure $ fmap swap $ filter (\(res, _) -> not . isQed $ res) results -showModel :: Expr Buf -> (Expr End, CheckSatResult) -> IO () +showModel :: Expr Buf -> (Expr End, SMTResult) -> IO () showModel cd (expr, res) = do case res of - EVM.Solvers.Unsat -> pure () -- ignore unreachable branches - EVM.Solvers.Error e -> do + Qed -> pure () -- ignore unreachable branches + Error e -> do putStrLn "" putStrLn "--- Branch ---" putStrLn $ "Error during SMT solving, cannot check branch " <> e - EVM.Solvers.Unknown reason -> do + Unknown reason -> do putStrLn "" putStrLn "--- Branch ---" putStrLn $ "Unable to produce a model for the following end state due to '" <> reason <> "' :" T.putStrLn $ indent 2 $ formatExpr expr putStrLn "" - Sat cex -> do + Cex cex -> do putStrLn "" putStrLn "--- Branch ---" putStrLn "Inputs:" @@ -868,12 +1026,17 @@ putStrLn "End State:" T.putStrLn $ indent 2 $ formatExpr expr +showBuffer :: (Expr Buf) -> SMTCex -> Text +showBuffer buf cex = case Map.lookup buf cex.buffers of + Nothing -> internalError "buffer missing in the counterexample" + Just buffer -> case SMT.collapse buffer of + Nothing -> T.pack $ show buffer + Just (Flat bs) -> T.pack $ show bs + Just (EVM.Types.Comp _) -> internalError "CompressedBuf returned from collapse" formatCex :: Expr Buf -> Maybe Sig -> SMTCex -> Text formatCex cd sig m@(SMTCex _ addrs _ store blockContext txContext) = T.unlines $ - [ "Calldata:" - , indent 2 cd' - ] + [ "Calldata:", indent 2 cd' ] <> storeCex <> txCtx <> blockCtx @@ -887,7 +1050,9 @@ -- callvalue check inserted by solidity in contracts that don't have any -- payable functions). cd' = case sig of - Nothing -> prettyBuf . Expr.concKeccakSimpExpr . defaultSymbolicValues $ subModel m cd + Nothing -> case (defaultSymbolicValues $ subModel m cd) of + Right k -> prettyBuf $ Expr.concKeccakSimpExpr k + Left err -> T.pack err Just (Sig n ts) -> prettyCalldata m cd n ts storeCex :: [Text] @@ -946,22 +1111,29 @@ ) mempty txContext ] - prettyBuf :: Expr Buf -> Text - prettyBuf (ConcreteBuf "") = "Empty" - prettyBuf (ConcreteBuf bs) = formatBinary bs - prettyBuf b = internalError $ "Unexpected symbolic buffer:\n" <> T.unpack (formatExpr b) +prettyBuf :: Expr Buf -> Text +prettyBuf (ConcreteBuf "") = "Empty" +prettyBuf (ConcreteBuf bs) = formatBinary bs +prettyBuf b = internalError $ "Unexpected symbolic buffer:\n" <> T.unpack (formatExpr b) prettyCalldata :: SMTCex -> Expr Buf -> Text -> [AbiType] -> Text -prettyCalldata cex buf sig types = head (T.splitOn "(" sig) <> "(" <> body <> ")" +prettyCalldata cex buf sig types = headErr errSig (T.splitOn "(" sig) <> "(" <> body <> ")" where - argdata = Expr.drop 4 . Expr.simplify . defaultSymbolicValues $ subModel cex buf - body = case decodeBuf types argdata of - CAbi v -> T.intercalate "," (fmap showVal v) - NoVals -> case argdata of - ConcreteBuf c -> T.pack (bsToHex c) - _ -> err - SAbi _ -> err - err = internalError $ "unable to produce a concrete model for calldata: " <> show buf + cd = defaultSymbolicValues $ subModel cex buf + argdata :: Err (Expr Buf) = case cd of + Right cd' -> Right $ Expr.drop 4 (Expr.simplify cd') + Left e -> Left e + body = case argdata of + Right argdata' -> case decodeBuf types argdata' of + CAbi v -> T.intercalate "," (fmap showVal v) + NoVals -> case argdata' of + ConcreteBuf c -> T.pack (bsToHex c) + _ -> T.pack err + SAbi _ -> T.pack err + Left e -> T.pack e + headErr e l = fromMaybe (T.pack e) $ listToMaybe l + err = "Error: unable to produce a concrete model for calldata: " <> show buf + errSig = "Error unable to split sig: " <> show sig -- | If the expression contains any symbolic values, default them to some -- concrete value The intuition here is that if we still have symbolic values @@ -969,18 +1141,20 @@ -- any value and we can safely pick a random value. This is a bit unsatisfying, -- we should really be doing smth like: https://github.com/ethereum/hevm/issues/334 -- but it's probably good enough for now -defaultSymbolicValues :: Expr a -> Expr a -defaultSymbolicValues e = subBufs (foldTerm symbufs mempty e) - . subVars (foldTerm symwords mempty e) - . subAddrs (foldTerm symaddrs mempty e) $ e +defaultSymbolicValues :: Err (Expr a) -> Err (Expr a) +defaultSymbolicValues = \case + Right e -> subBufs (foldTerm symbufs mempty e) + . subVars (foldTerm symwords mempty e) + . subAddrs (foldTerm symaddrs mempty e) $ e + Left err -> Left err where symaddrs :: Expr a -> Map (Expr EAddr) Addr symaddrs = \case a@(SymAddr _) -> Map.singleton a (Addr 0x1312) _ -> mempty - symbufs :: Expr a -> Map (Expr Buf) ByteString + symbufs :: Expr a -> Map (Expr Buf) BufModel symbufs = \case - a@(AbstractBuf _) -> Map.singleton a "" + a@(AbstractBuf _) -> Map.singleton a (Flat BS.empty) _ -> mempty symwords :: Expr a -> Map (Expr EWord) W256 symwords = \case @@ -997,19 +1171,14 @@ -- | Takes an expression and a Cex and replaces all abstract values in the buf with -- concrete ones from the Cex. -subModel :: SMTCex -> Expr a -> Expr a +subModel :: SMTCex -> Expr a -> Err (Expr a) subModel c - = subBufs (fmap forceFlattened c.buffers) + = subBufs c.buffers . subStores c.store . subVars c.vars . subVars c.blockContext . subVars c.txContext . subAddrs c.addrs - where - forceFlattened (SMT.Flat bs) = bs - forceFlattened b@(SMT.Comp _) = forceFlattened $ - fromMaybe (internalError $ "cannot flatten buffer: " <> show b) - (SMT.collapse b) subVars :: Map (Expr EWord) W256 -> Expr a -> Expr a subVars model b = Map.foldlWithKey subVar b model @@ -1037,18 +1206,27 @@ else v e -> e -subBufs :: Map (Expr Buf) ByteString -> Expr a -> Expr a -subBufs model b = Map.foldlWithKey subBuf b model +subBufs :: Map (Expr Buf) BufModel -> Expr a -> Err (Expr a) +subBufs model b = Map.foldlWithKey subBuf (Right b) model where - subBuf :: Expr a -> Expr Buf -> ByteString -> Expr a - subBuf x var val = mapExpr go x + subBuf :: Err (Expr a) -> Expr Buf -> BufModel -> Err (Expr a) + subBuf x var val = case x of + Right x' -> mapExprM go x' + Left err -> Left err where - go :: Expr a -> Expr a + go :: Expr a -> Err (Expr a) go = \case - a@(AbstractBuf _) -> if a == var - then ConcreteBuf val - else a - e -> e + c@(AbstractBuf _) -> case c == var of + True -> case forceFlattened val of + Right bs -> Right $ ConcreteBuf bs + Left err -> Left $ show c <> " --- cannot flatten buffer: " <> err + False -> Right c + e -> Right e + forceFlattened :: BufModel -> Err ByteString + forceFlattened (Flat bs) = Right bs + forceFlattened buf@(EVM.Types.Comp _) = case SMT.collapse buf of + Just k -> forceFlattened k + Nothing -> Left $ show buf subStores :: Map (Expr EAddr) (Map W256 W256) -> Expr a -> Expr a subStores model b = Map.foldlWithKey subStore b model @@ -1064,10 +1242,6 @@ else v e -> e -getCex :: ProofResult a b c d -> Maybe b +getCex :: ProofResult a b -> Maybe a getCex (Cex c) = Just c getCex _ = Nothing - -getUnknown :: ProofResult a b c d-> Maybe c -getUnknown (EVM.SymExec.Unknown c) = Just c -getUnknown _ = Nothing diff --git a/src/EVM/Traversals.hs b/src/EVM/Traversals.hs --- a/src/EVM/Traversals.hs +++ b/src/EVM/Traversals.hs @@ -158,7 +158,7 @@ -- frame context - e@(Gas _) -> f e + e@(Gas _ _) -> f e e@(Balance {}) -> f e -- code @@ -516,7 +516,7 @@ -- frame context - Gas a -> f (Gas a) + Gas a b -> f (Gas a b) Balance a -> do a' <- mapExprM f a f (Balance a') diff --git a/src/EVM/Types.hs b/src/EVM/Types.hs --- a/src/EVM/Types.hs +++ b/src/EVM/Types.hs @@ -2,6 +2,10 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} {-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} @@ -13,7 +17,6 @@ import Control.Monad.ST (ST) import Control.Monad.State.Strict (StateT) import Crypto.Hash (hash, Keccak_256, Digest) -import Data.Aeson import Data.Aeson qualified as JSON import Data.Aeson.Types qualified as JSON import Data.Bifunctor (first) @@ -45,12 +48,13 @@ import Data.Tree (Forest) import Data.Tree.Zipper qualified as Zipper import Data.Vector qualified as V -import Data.Vector.Storable qualified as SV -import Data.Vector.Unboxed.Mutable (STVector) +import Data.Vector.Storable qualified as VS +import Data.Vector.Storable.Mutable (STVector) import Numeric (readHex, showHex) import Options.Generic import Optics.TH import EVM.FeeSchedule (FeeSchedule (..)) +import Data.Kind (Type) import Text.Regex.TDFA qualified as Regex import Text.Read qualified @@ -286,7 +290,8 @@ Balance :: Expr EAddr -> Expr EWord - Gas :: Int -- frame idx + Gas :: Text -- prefix needed to distinguish during equivalence checking + -> Int -- fresh gas variable -> Expr EWord -- code @@ -481,33 +486,33 @@ _ == _ = False instance Ord Prop where - PBool a <= PBool b = a <= b - PEq (a :: Expr x) (b :: Expr x) <= PEq (c :: Expr y) (d :: Expr y) - = case eqT @x @y of - Just Refl -> a <= c || b <= d - Nothing -> toNum a <= toNum c - PLT a b <= PLT c d = a <= c || b <= d - PGT a b <= PGT c d = a <= c || b <= d - PGEq a b <= PGEq c d = a <= c || b <= d - PLEq a b <= PLEq c d = a <= c || b <= d - PNeg a <= PNeg b = a <= b - PAnd a b <= PAnd c d = a <= c || b <= d - POr a b <= POr c d = a <= c || b <= d - PImpl a b <= PImpl c d = a <= c || b <= d - a <= b = asNum a <= asNum b - where - asNum :: Prop -> Int - asNum (PBool {}) = 0 - asNum (PEq {}) = 1 - asNum (PLT {}) = 2 - asNum (PGT {}) = 3 - asNum (PGEq {}) = 4 - asNum (PLEq {}) = 5 - asNum (PNeg {}) = 6 - asNum (PAnd {}) = 7 - asNum (POr {}) = 8 - asNum (PImpl {}) = 9 + compare (PBool a) (PBool b) = compare a b + compare (PEq (a :: Expr x) (b :: Expr x)) (PEq (c :: Expr y) (d :: Expr y)) = + case eqT @x @y of + Just Refl -> compare (a, b) (c, d) + Nothing -> compare (typeRep a) (typeRep c) + compare (PNeg a) (PNeg b) = compare a b + compare (PLT a1 b1) (PLT a2 b2) = compare (a1, b1) (a2, b2) + compare (PGT a1 b1) (PGT a2 b2) = compare (a1, b1) (a2, b2) + compare (PGEq a1 b1) (PGEq a2 b2) = compare (a1, b1) (a2, b2) + compare (PLEq a1 b1) (PLEq a2 b2) = compare (a1, b1) (a2, b2) + compare (PAnd a1 b1) (PAnd a2 b2) = compare (a1, b1) (a2, b2) + compare (POr a1 b1) (POr a2 b2) = compare (a1, b1) (a2, b2) + compare (PImpl a1 b1) (PImpl a2 b2) = compare (a1, b1) (a2, b2) + compare a b = compare (tag a) (tag b) + where + tag :: Prop -> Int + tag PBool{} = 0 + tag PEq{} = 1 + tag PLT{} = 2 + tag PGT{} = 3 + tag PGEq{} = 4 + tag PLEq{} = 5 + tag PNeg{} = 6 + tag PAnd{} = 7 + tag POr{} = 8 + tag PImpl{} = 9 isPBool :: Prop -> Bool @@ -581,12 +586,15 @@ = UnexpectedSymbolicArg { pc :: Int, opcode :: String, msg :: String, args :: [SomeExpr] } | MaxIterationsReached { pc :: Int, addr :: Expr EAddr } | JumpIntoSymbolicCode { pc :: Int, jumpDst :: Int } + | CheatCodeMissing { pc :: Int, selector :: FunctionSelector } + | BranchTooDeep { pc :: Int} deriving (Show, Eq, Ord) -- | Effect types used by the vm implementation for side effects & control flow data Effect t s where Query :: Query t s -> Effect t s - Choose :: Choose s -> Effect Symbolic s + RunBoth :: RunBoth s -> Effect Symbolic s + RunAll :: RunAll s -> Effect Symbolic s deriving instance Show (Effect t s) -- | Queries halt execution until resolved through RPC calls or SMT queries @@ -594,15 +602,20 @@ PleaseFetchContract :: Addr -> BaseState -> (Contract -> EVM t s ()) -> Query t s PleaseFetchSlot :: Addr -> W256 -> (W256 -> EVM t s ()) -> Query t s PleaseAskSMT :: Expr EWord -> [Prop] -> (BranchCondition -> EVM Symbolic s ()) -> Query Symbolic s + PleaseGetSols :: Expr EWord -> Int -> [Prop] -> (Maybe [W256] -> EVM Symbolic s ()) -> Query Symbolic s PleaseDoFFI :: [String] -> Map String String -> (ByteString -> EVM t s ()) -> Query t s PleaseReadEnv :: String -> (String -> EVM t s ()) -> Query t s -- | Execution could proceed down one of two branches -data Choose s where - PleaseChoosePath :: Expr EWord -> (Bool -> EVM Symbolic s ()) -> Choose s +data RunBoth s where + PleaseRunBoth :: Expr EWord -> (Bool -> EVM Symbolic s ()) -> RunBoth s +-- | Execution could proceed down one of several branches +data RunAll s where + PleaseRunAll :: Expr EWord -> [W256] -> (W256 -> EVM Symbolic s ()) -> RunAll s + -- | The possible return values of a SMT query -data BranchCondition = Case Bool | Unknown +data BranchCondition = Case Bool | UnknownBranch deriving Show instance Show (Query t s) where @@ -617,16 +630,27 @@ (("") ++) + PleaseGetSols expr numBytes constraints _ -> + (("") ++) PleaseDoFFI cmd env _ -> ((" ((" - ((" + ((" + ((" VMResult Symbolic s -- ^ Execution could not continue further @@ -665,6 +689,10 @@ , currentFork :: Int , labels :: Map Addr Text , osEnv :: Map String String + , freshVar :: Int + -- ^ used to generate fresh symbolic variable names for overapproximations + -- during symbolic execution. See e.g. OpStaticcall + , exploreDepth :: Int } deriving (Generic) @@ -797,7 +825,7 @@ data Block = Block { coinbase :: Expr EAddr , timestamp :: Expr EWord - , number :: W256 + , number :: Expr EWord , prevRandao :: W256 , gaslimit :: Word64 , baseFee :: W256 @@ -814,7 +842,7 @@ , balance :: Expr EWord , nonce :: Maybe W64 , codehash :: Expr EWord - , opIxMap :: SV.Vector Int + , opIxMap :: VS.Vector Int , codeOps :: V.Vector (Int, Op) , external :: Bool } @@ -853,7 +881,8 @@ whenSymbolicElse :: EVM t s a -> EVM t s a -> EVM t s a partial :: PartialExec -> EVM t s () - branch :: Expr EWord -> (Bool -> EVM t s ()) -> EVM t s () + branch :: Maybe Int -> Expr EWord -> (Bool -> EVM t s ()) -> EVM t s () + manySolutions :: Maybe Int -> Expr EWord -> Int -> (Maybe W256 -> EVM t s ()) -> EVM t s () -- Bytecode Representations ------------------------------------------------------------------------ @@ -919,7 +948,12 @@ data RuntimeCode = ConcreteRuntimeCode ByteString | SymbolicRuntimeCode (V.Vector (Expr Byte)) - deriving (Show, Eq, Ord) + deriving (Eq, Ord) +instance Show RuntimeCode + where + show = \case + ConcreteRuntimeCode e -> "ConcreteRuntimeCode 0x" <> bsToHex e + SymbolicRuntimeCode e -> show e -- Execution Traces -------------------------------------------------------------------------------- @@ -969,7 +1003,7 @@ , origin :: Expr EAddr , gas :: Gas t , gaslimit :: Word64 - , number :: W256 + , number :: Expr EWord , timestamp :: Expr EWord , coinbase :: Expr EAddr , prevRandao :: W256 @@ -1083,9 +1117,115 @@ deriving (Show, Eq, Ord, Functor) --- Function Selectors ------------------------------------------------------------------------------ +-- | A model for a buffer, either in it's compressed form (for storing parsed +-- models from a solver), or as a bytestring (for presentation to users) +data BufModel + = Comp CompressedBuf + | Flat ByteString + deriving (Eq) +instance Show BufModel where + show (Comp c) = "Comp " <> show c + show (Flat b) = "Flat 0x" <> bsToHex b +-- | This representation lets us store buffers of arbitrary length without +-- exhausting the available memory, it closely matches the format used by +-- smt-lib when returning models for arrays +data CompressedBuf + = Base { byte :: Word8, length :: W256} + | Write { byte :: Word8, idx :: W256, next :: CompressedBuf } + deriving (Eq, Show) +-- | a final post shrinking cex, buffers here are all represented as concrete bytestrings +data SMTCex = SMTCex + { vars :: Map (Expr EWord) W256 + , addrs :: Map (Expr EAddr) Addr + , buffers :: Map (Expr Buf) BufModel + , store :: Map (Expr EAddr) (Map W256 W256) + , blockContext :: Map (Expr EWord) W256 + , txContext :: Map (Expr EWord) W256 + } + deriving (Eq, Show) + +instance Semigroup SMTCex where + a <> b = SMTCex + { vars = a.vars <> b.vars + , addrs = a.addrs <> b.addrs + , buffers = a.buffers <> b.buffers + , store = a.store <> b.store + , blockContext = a.blockContext <> b.blockContext + , txContext = a.txContext <> b.txContext + } + +instance Monoid SMTCex where + mempty = SMTCex + { vars = mempty + , addrs = mempty + , buffers = mempty + , store = mempty + , blockContext = mempty + , txContext = mempty + } + +class GetUnknownStr a where + getUnknownStr :: a -> String + +instance GetUnknownStr String where + getUnknownStr = id + +instance GetUnknownStr (String, Expr End) where + getUnknownStr (s, _) = s + +data ProofResult a (b :: Type) where + Qed :: ProofResult a b + Cex :: a -> ProofResult a b + Unknown :: GetUnknownStr b => b -> ProofResult a b + Error :: String -> ProofResult a b + +instance (Show a, Show b) => Show (ProofResult a b) where + show Qed = "Qed" + show (Cex c) = "Cex " <> show c + show (Unknown u) = "Unknown " <> show u + show (Error e) = "Error: " <> e + +instance (Eq a, Eq b) => Eq (ProofResult a b) where + x == y = case (x, y) of + (Unknown u1, Unknown u2) -> u1 == u2 + (Error a, Error b) -> a == b + (Cex a, Cex b) -> a == b + (Qed, Qed) -> True + _ -> False + +type VerifyResult = ProofResult (Expr End, SMTCex) (String, Expr End) +type EquivResult = ProofResult SMTCex String +type SMTResult = ProofResult SMTCex String + +getUnknown :: ProofResult a b -> Maybe b +getUnknown (Unknown a) = Just a +getUnknown _ = Nothing + +isUnknown :: ProofResult a b -> Bool +isUnknown (Unknown _) = True +isUnknown _ = False + +isError :: ProofResult a b -> Bool +isError (Error _) = True +isError _ = False + +getResError :: ProofResult a b -> Maybe String +getResError (Error e) = Just e +getResError _ = Nothing + +isCex :: ProofResult a b -> Bool +isCex (Cex _) = True +isCex _ = False + +isQed :: ProofResult a b -> Bool +isQed Qed = True +isQed _ = False + + +-- Function Selectors ------------------------------------------------------------------------------ + -- | https://docs.soliditylang.org/en/v0.8.19/abi-spec.html#function-selector newtype FunctionSelector = FunctionSelector { unFunctionSelector :: Word32 } deriving (Bits, Num, Eq, Ord, Real, Enum, Integral) @@ -1137,22 +1277,22 @@ cutshow = drop 2 $ show x pad = replicate (64 - length (cutshow)) '0' -instance FromJSON W256 where +instance JSON.FromJSON W256 where parseJSON v = do - s <- T.unpack <$> parseJSON v + s <- T.unpack <$> JSON.parseJSON v case reads s of [(x, "")] -> pure x _ -> fail $ "invalid hex word (" ++ s ++ ")" -instance FromJSONKey W256 where - fromJSONKey = FromJSONKeyTextParser $ \s -> +instance JSON.FromJSONKey W256 where + fromJSONKey = JSON.FromJSONKeyTextParser $ \s -> case reads (T.unpack s) of [(x, "")] -> pure x _ -> fail $ "invalid word (" ++ T.unpack s ++ ")" -wordField :: JSON.Object -> Key -> JSON.Parser W256 +wordField :: JSON.Object -> JSON.Key -> JSON.Parser W256 wordField x f = ((readNull 0) . T.unpack) - <$> (x .: f) + <$> (x JSON..: f) instance ParseField W256 instance ParseFields W256 @@ -1179,17 +1319,17 @@ instance JSON.ToJSON W64 where toJSON x = JSON.String $ T.pack $ show x -instance FromJSON W64 where +instance JSON.FromJSON W64 where parseJSON v = do - s <- T.unpack <$> parseJSON v + s <- T.unpack <$> JSON.parseJSON v case reads s of [(x, "")] -> pure x _ -> fail $ "invalid hex word (" ++ s ++ ")" -word64Field :: JSON.Object -> Key -> JSON.Parser Word64 +word64Field :: JSON.Object -> JSON.Key -> JSON.Parser Word64 word64Field x f = ((readNull 0) . T.unpack) - <$> (x .: f) + <$> (x JSON..: f) -- Addresses --------------------------------------------------------------------------------------- @@ -1221,9 +1361,9 @@ instance JSON.ToJSON Addr where toJSON = JSON.String . T.pack . show -instance FromJSON Addr where +instance JSON.FromJSON Addr where parseJSON v = do - s <- T.unpack <$> parseJSON v + s <- T.unpack <$> JSON.parseJSON v case reads s of [(x, "")] -> pure x _ -> fail $ "invalid address (" ++ s ++ ")" @@ -1236,17 +1376,17 @@ where hex = show addr -instance FromJSONKey Addr where - fromJSONKey = FromJSONKeyTextParser $ \s -> +instance JSON.FromJSONKey Addr where + fromJSONKey = JSON.FromJSONKeyTextParser $ \s -> case reads (T.unpack s) of [(x, "")] -> pure x _ -> fail $ "invalid word (" ++ T.unpack s ++ ")" -addrField :: JSON.Object -> Key -> JSON.Parser Addr -addrField x f = (read . T.unpack) <$> (x .: f) +addrField :: JSON.Object -> JSON.Key -> JSON.Parser Addr +addrField x f = (read . T.unpack) <$> (x JSON..: f) -addrFieldMaybe :: JSON.Object -> Key -> JSON.Parser (Maybe Addr) -addrFieldMaybe x f = (Text.Read.readMaybe . T.unpack) <$> (x .: f) +addrFieldMaybe :: JSON.Object -> JSON.Key -> JSON.Parser (Maybe Addr) +addrFieldMaybe x f = (Text.Read.readMaybe . T.unpack) <$> (x JSON..: f) instance ParseField Addr instance ParseFields Addr @@ -1266,24 +1406,6 @@ -- Conversions ------------------------------------------------------------------------------------- -maybeLitByte :: Expr Byte -> Maybe Word8 -maybeLitByte (LitByte x) = Just x -maybeLitByte _ = Nothing - -maybeLitWord :: Expr EWord -> Maybe W256 -maybeLitWord (Lit w) = Just w -maybeLitWord (WAddr (LitAddr w)) = Just (into w) -maybeLitWord _ = Nothing - -maybeLitAddr :: Expr EAddr -> Maybe Addr -maybeLitAddr (LitAddr a) = Just a -maybeLitAddr _ = Nothing - -maybeConcreteStore :: Expr Storage -> Maybe (Map W256 W256) -maybeConcreteStore (ConcreteStore s) = Just s -maybeConcreteStore _ = Nothing - - word256 :: ByteString -> Word256 word256 xs | BS.length xs == 1 = -- optimize one byte pushes @@ -1347,6 +1469,20 @@ bssToBs (ByteStringS bs) = bs +-- Function to construct a W256 from a list of 32 Word8 values +constructWord256 :: [Word8] -> W256 +constructWord256 bytes + | length bytes == 32 = W256 (Word256 (Word128 w256hi w256m1) (Word128 w256m0 w256lo)) + | otherwise = internalError "List must contain exactly 32 Word8 values" + where + w256hi = word8sToWord64 (take 8 bytes) + w256m1 = word8sToWord64 (take 8 (drop 8 bytes)) + w256m0 = word8sToWord64 (take 8 (drop 16 bytes)) + w256lo = word8sToWord64 (take 8 (drop 24 bytes)) + word8sToWord64 :: [Word8] -> Word64 + word8sToWord64 = foldl (\acc byte -> (acc `shiftL` 8) .|. fromIntegral byte) 0 + + -- Keccak hashing ---------------------------------------------------------------------------------- @@ -1426,9 +1562,14 @@ pad = replicate (w - length str) '0' untilFixpoint :: Eq a => (a -> a) -> a -> a -untilFixpoint f a = if f a == a - then a - else untilFixpoint f (f a) +untilFixpoint f a = + let a' = f a in + if a' == a + then a + else untilFixpoint f a' + +bsToHex :: ByteString -> String +bsToHex bs = concatMap (paddedShowHex 2) (BS.unpack bs) -- Optics ------------------------------------------------------------------------------------------ diff --git a/src/EVM/UnitTest.hs b/src/EVM/UnitTest.hs --- a/src/EVM/UnitTest.hs +++ b/src/EVM/UnitTest.hs @@ -4,7 +4,6 @@ import EVM import EVM.ABI -import EVM.SMT import EVM.Solvers import EVM.Dapp import EVM.Effects @@ -14,11 +13,13 @@ import EVM.Fetch qualified as Fetch import EVM.Format import EVM.Solidity -import EVM.SymExec (defaultVeriOpts, symCalldata, verify, isQed, extractCex, prettyCalldata, panicMsg, VeriOpts(..), flattenExpr, isUnknown, isError, groupIssues) +import EVM.SymExec (defaultVeriOpts, symCalldata, verify, extractCex, prettyCalldata, panicMsg, VeriOpts(..), flattenExpr, groupIssues, groupPartials, IterConfig(..), defaultIterConf) import EVM.Types import EVM.Transaction (initTx) import EVM.Stepper (Stepper) import EVM.Stepper qualified as Stepper +import EVM.Expr (maybeLitWordSimp) +import Data.List (foldl') import Control.Monad (void, when, forM, forM_) import Control.Monad.ST (RealWorld, ST, stToIO) @@ -29,6 +30,7 @@ import Data.Binary.Get (runGet) import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Internal (c2w) import Data.ByteString.Lazy qualified as BSLazy import Data.Decimal (DecimalRaw(..)) import Data.Foldable (toList) @@ -43,16 +45,17 @@ import GHC.Natural import System.IO (hFlush, stdout) import Witch (unsafeInto, into) +import Data.Vector qualified as V +import Data.Char (ord) data UnitTestOptions s = UnitTestOptions { rpcInfo :: Fetch.RpcInfo , solvers :: SolverGroup - , verbose :: Maybe Int , maxIter :: Maybe Integer , askSmtIters :: Integer , smtTimeout :: Maybe Natural - , solver :: Maybe Text , match :: Text + , prefix :: Text , dapp :: DappInfo , testParams :: TestVMParams , ffiAllowed :: Bool @@ -106,22 +109,24 @@ -- | Generate VeriOpts from UnitTestOptions makeVeriOpts :: UnitTestOptions s -> VeriOpts makeVeriOpts opts = - defaultVeriOpts { maxIter = opts.maxIter - , askSmtIters = opts.askSmtIters + defaultVeriOpts { iterConf = defaultIterConf {maxIter = opts.maxIter, askSmtIters = opts.askSmtIters } , rpcInfo = opts.rpcInfo } -- | Top level CLI endpoint for hevm test -unitTest :: App m => UnitTestOptions RealWorld -> Contracts -> m Bool +-- | Returns tuple of (No Cex, No warnings) +unitTest :: App m => UnitTestOptions RealWorld -> Contracts -> m (Bool, Bool) unitTest opts (Contracts cs) = do - let unitTestContrs = findUnitTests opts.match $ Map.elems cs + let unitTestContrs = findUnitTests opts.prefix opts.match $ Map.elems cs conf <- readConfig when conf.debug $ liftIO $ do putStrLn $ "Found " ++ show (length unitTestContrs) ++ " unit test contract(s) to test:" let x = map (\(a,b) -> " --> " <> a <> " --- functions: " <> (Text.pack $ show b)) unitTestContrs putStrLn $ unlines $ map Text.unpack x results <- concatMapM (runUnitTestContract opts cs) unitTestContrs - pure $ and results + when conf.debug $ liftIO $ putStrLn $ "unitTest individual results: " <> show results + let (firsts, seconds) = unzip results + pure (and firsts, and seconds) -- | Assuming a constructor is loaded, this stepper will run the constructor -- to create the test contract, give it an initial balance, and run `setUp()'. @@ -154,24 +159,20 @@ Left e -> pushTrace (ErrorTrace e) _ -> popTrace +-- Returns tuple of (No Cex, No warnings) runUnitTestContract :: App m => UnitTestOptions RealWorld -> Map Text SolcContract -> (Text, [Sig]) - -> m [Bool] + -> m [(Bool, Bool)] runUnitTestContract opts@(UnitTestOptions {..}) contractMap (name, testSigs) = do - - -- Print a header liftIO $ putStrLn $ "Checking " ++ show (length testSigs) ++ " function(s) in contract " ++ unpack name -- Look for the wanted contract by name from the Solidity info case Map.lookup name contractMap of - Nothing -> - -- Fail if there's no such contract - internalError $ "Contract " ++ unpack name ++ " not found" - + Nothing -> internalError $ "Contract " ++ unpack name ++ " not found" Just theContract -> do -- Construct the initial VM and begin the contract's constructor vm0 :: VM Concrete RealWorld <- liftIO $ stToIO $ initialUnitTestVm opts theContract @@ -181,22 +182,24 @@ Stepper.evm get writeTraceDapp dapp vm1 + failOut <- failOutput vm1 opts "setUp()" case vm1.result of Just (VMFailure _) -> liftIO $ do - Text.putStrLn "\x1b[31m[BAIL]\x1b[0m setUp() " - tick $ failOutput vm1 opts "setUp()" - pure [False] + Text.putStrLn " \x1b[31m[BAIL]\x1b[0m setUp() " + tick $ indentLines 3 failOut + pure [(True, False)] Just (VMSuccess _) -> do forM testSigs $ \s -> symRun opts vm1 s _ -> internalError "setUp() did not end with a result" --- | Define the thread spawner for symbolic tests -symRun :: App m => UnitTestOptions RealWorld -> VM Concrete RealWorld -> Sig -> m Bool +-- Define the thread spawner for symbolic tests +-- Returns tuple of (No Cex, No warnings) +symRun :: App m => UnitTestOptions RealWorld -> VM Concrete RealWorld -> Sig -> m (Bool, Bool) symRun opts@UnitTestOptions{..} vm (Sig testName types) = do let callSig = testName <> "(" <> (Text.intercalate "," (map abiTypeSolidity types)) <> ")" liftIO $ putStrLn $ "\x1b[96m[RUNNING]\x1b[0m " <> Text.unpack callSig - let cd = symCalldata callSig types [] (AbstractBuf "txdata") - shouldFail = "proveFail" `isPrefixOf` callSig + cd <- symCalldata callSig types [] (AbstractBuf "txdata") + let shouldFail = "proveFail" `isPrefixOf` callSig -- define postcondition depending on `shouldFail` let testContract store = fromMaybe (internalError "test contract not found in state") (Map.lookup vm.state.contract store) @@ -209,11 +212,15 @@ _ -> PBool True False -> \(_, post) -> case post of Success _ _ _ store -> if opts.checkFailBit then PNeg (failed store) else PBool True + Failure _ _ (UnrecognizedOpcode 0xfe) -> PBool False Failure _ _ (Revert msg) -> case msg of ConcreteBuf b -> - if (BS.isPrefixOf (selector "Error(string)") b) || b == panicMsg 0x01 then PBool False + -- NOTE: assertTrue/assertFalse does not have the double colon after "assertion failed" + let assertFail = (selector "Error(string)" `BS.isPrefixOf` b) && + ("assertion failed" `BS.isPrefixOf` (BS.drop txtOffset b)) + in if assertFail || b == panicMsg 0x01 then PBool False else PBool True - b -> b ./= ConcreteBuf (panicMsg 0x01) + _ -> symbolicFail msg Failure _ _ _ -> PBool True Partial _ _ _ -> PBool True _ -> internalError "Invalid leaf node" @@ -226,48 +233,81 @@ writeTraceDapp dapp vm' -- check postconditions against vm - (e, results) <- verify solvers (makeVeriOpts opts) (symbolify vm') (Just postcondition) - let allReverts = not . (any Expr.isSuccess) . flattenExpr $ e - + (end, results) <- verify solvers (makeVeriOpts opts) (symbolify vm') (Just postcondition) + let ends = flattenExpr end conf <- readConfig - when conf.debug $ liftIO $ forM_ (filter Expr.isFailure (flattenExpr e)) $ \case + when conf.debug $ liftIO $ forM_ (filter Expr.isFailure ends) $ \case (Failure _ _ a) -> putStrLn $ " -> debug of func: " <> Text.unpack testName <> " Failure at the end of expr: " <> show a; _ -> internalError "cannot be, filtered for failure" - when (any isUnknown results || any isError results) $ liftIO $ do - putStrLn $ " \x1b[33mWARNING\x1b[0m: hevm was only able to partially explore the test " <> Text.unpack testName <> " due to: "; - forM_ (groupIssues (filter isError results)) $ \(num, str) -> putStrLn $ " " <> show num <> "x -> " <> str - forM_ (groupIssues (filter isUnknown results)) $ \(num, str) -> putStrLn $ " " <> show num <> "x -> " <> str -- display results - if all isQed results - then if allReverts && (not shouldFail) - then do - liftIO $ putStr $ " \x1b[31m[FAIL]\x1b[0m " <> Text.unpack testName <> "\n" <> Text.unpack allBranchRev - pure False - else do - liftIO $ putStr $ " \x1b[32m[PASS]\x1b[0m " <> Text.unpack testName <> "\n" - pure True - else do - -- not all is Qed - let x = mapMaybe extractCex results - let y = symFailure opts testName (fst cd) types x - liftIO $ putStr $ " \x1b[31m[FAIL]\x1b[0m " <> Text.unpack testName <> "\n" <> Text.unpack y - pure False - -allBranchRev :: Text -allBranchRev = intercalate "\n" - [ Text.concat $ indentLines 3 <$> - [ "Reason:" - , " No reachable assertion violations, but all branches reverted" - , " Prefix this testname with `proveFail` if this is expected" - ] - ] -symFailure :: UnitTestOptions RealWorld -> Text -> Expr Buf -> [AbiType] -> [(Expr End, SMTCex)] -> Text -symFailure UnitTestOptions {..} testName cd types failures' = - mconcat - [ Text.concat $ indentLines 3 . mkMsg <$> failures' - ] + let t = "the test " <> Text.unpack testName + let warnings = any Expr.isPartial ends || any isUnknown results || any isError results + let allReverts = not . (any Expr.isSuccess) $ ends + let unexpectedAllRevert = allReverts && not shouldFail + when conf.debug $ liftIO $ putStrLn $ "symRun -- (cex,warnings,unexpectedAllRevert): " <> show (any isCex results, warnings, unexpectedAllRevert) + txtResult <- case (any isCex results, warnings, unexpectedAllRevert) of + (False, False, False) -> do + -- happy case + pure $ " \x1b[32m[PASS]\x1b[0m " <> Text.unpack testName <> "\n" + (True, _, _) -> do + -- there are counterexamples (and maybe other things, but Cex is most important) + let x = mapMaybe extractCex results + y <- symFailure opts testName (fst cd) types x + pure $ " \x1b[31m[FAIL]\x1b[0m " <> Text.unpack testName <> "\n" <> Text.unpack y + (_, True, _) -> do + -- There are errors/unknowns/partials, we fail them + pure $ " \x1b[31m[FAIL]\x1b[0m " <> Text.unpack testName <> "\n" + (_, _, True) -> do + -- No cexes/errors/unknowns/partials, but all branches reverted + pure $ " \x1b[31m[FAIL]\x1b[0m " <> Text.unpack testName <> "\n" + <> " No reachable assertion violations, but all branches reverted\n" + liftIO $ putStr txtResult + when (unexpectedAllRevert && (warnings || (any isCex results))) $ do + -- if we display a FAILED due to Cex/warnings, we should also mention everything reverted + liftIO $ putStrLn $ " \x1b[33m[WARNING]\x1b[0m " <> Text.unpack testName <> " all branches reverted\n" + liftIO $ printWarnings ends results t + pure (not (any isCex results), not (warnings || unexpectedAllRevert)) where + -- The offset of the text is: the selector (4B), the offset value (aligned to 32B), and the length of the string (aligned to 32B) + txtOffset = 4+32+32 + symbolicFail :: Expr Buf -> Prop + symbolicFail e = + let origTxt = "assertion failed" + txtLen = length origTxt + w8Txt = V.fromList $ map (fromIntegral . ord) origTxt + panic = e == ConcreteBuf (panicMsg 0x01) + concretePrefix = Expr.concretePrefix e + assertFail = + if (length concretePrefix < txtOffset+txtLen) + then PAnd (symBytesEq 0 e (BS.unpack $ selector "Error(string)")) (symBytesEq txtOffset e origTxt) + else PBool (V.drop txtOffset (V.take (txtLen+txtOffset) concretePrefix) == w8Txt) + in PBool (not panic) .&& PNeg assertFail + symBytesEq :: Int -> Expr Buf -> String -> Prop + symBytesEq off buf str = let acc = go str buf off [] + in foldl' PAnd (PBool True) acc + where + go :: String -> Expr Buf -> Int -> [Prop] -> [Prop] + go "" _ _ acc = acc + go (a:ax) b n acc = go ax b (n+1) (PEq lhs rhs:acc) + where + lhs = LitByte (c2w a) + rhs = Expr.readByte (Lit (fromIntegral n)) b +-- +printWarnings :: GetUnknownStr b => [Expr 'End] -> [ProofResult a b] -> String -> IO () +printWarnings e results testName = do + when (any isUnknown results || any isError results || any Expr.isPartial e) $ do + putStrLn $ " \x1b[33m[WARNING]\x1b[0m hevm was only able to partially explore " <> testName <> " due to: "; + forM_ (groupIssues (filter isError results)) $ \(num, str) -> putStrLn $ " " <> show num <> "x -> " <> str + forM_ (groupIssues (filter isUnknown results)) $ \(num, str) -> putStrLn $ " " <> show num <> "x -> " <> str + forM_ (groupPartials e) $ \(num, str) -> putStrLn $ " " <> show num <> "x -> " <> str + putStrLn "" + +symFailure :: App m => UnitTestOptions RealWorld -> Text -> Expr Buf -> [AbiType] -> [(Expr End, SMTCex)] -> m Text +symFailure UnitTestOptions {..} testName cd types failures' = do + conf <- readConfig + pure $ mconcat [ Text.concat $ indentLines 3 . mkMsg conf <$> failures' ] + where showRes = \case Success _ _ _ _ -> if "proveFail" `isPrefixOf` testName then "Successful execution" @@ -275,15 +315,14 @@ res -> let ?context = dappContext (traceContext res) in Text.pack $ prettyvmresult res - mkMsg (leaf, cex) = intercalate "\n" $ + mkMsg conf (leaf, cex) = intercalate "\n" $ ["Counterexample:" - ," result: " <> showRes leaf ," calldata: " <> let ?context = dappContext (traceContext leaf) in prettyCalldata cex cd testName types - ] <> verbText leaf - verbText leaf = case verbose of - Just _ -> [Text.unlines [ indentLines 2 (showTraceTree' dapp leaf)]] - _ -> mempty + ," result: " <> showRes leaf + ] <> verbText conf leaf + verbText conf leaf = if conf.verb <= 1 then mempty + else [Text.unlines [ indentLines 2 (showTraceTree' dapp leaf)]] dappContext TraceContext { contracts, labels } = DappContext { info = dapp, contracts, labels } @@ -292,38 +331,20 @@ let p = Text.replicate n " " in Text.unlines (map (p <>) (Text.lines s)) -passOutput :: VM t s -> UnitTestOptions s -> Text -> Text -passOutput vm UnitTestOptions { .. } testName = - let ?context = DappContext { info = dapp - , contracts = vm.env.contracts - , labels = vm.labels } - in let v = fromMaybe 0 verbose - in if (v > 1) then - mconcat - [ "Success: " - , fromMaybe "" (stripSuffix "()" testName) - , "\n" - , if (v > 2) then indentLines 2 (showTraceTree dapp vm) else "" - , indentLines 2 (formatTestLogs dapp.eventMap vm.logs) - , "\n" - ] - else "" - -failOutput :: VM t s -> UnitTestOptions s -> Text -> Text -failOutput vm UnitTestOptions { .. } testName = +failOutput :: App m => VM t s -> UnitTestOptions s -> Text -> m Text +failOutput vm UnitTestOptions { .. } testName = do + conf <- readConfig let ?context = DappContext { info = dapp , contracts = vm.env.contracts , labels = vm.labels } - in mconcat - [ "Failure: " - , fromMaybe "" (stripSuffix "()" testName) - , "\n" - , case verbose of - Just _ -> indentLines 2 (showTraceTree dapp vm) - _ -> "" - , indentLines 2 (formatTestLogs dapp.eventMap vm.logs) - , "\n" - ] + pure $ mconcat + [ "Failure: " + , fromMaybe "" (stripSuffix "()" testName) + , "\n" + , if conf.verb <= 1 then "" + else indentLines 2 (showTraceTree dapp vm) + , indentLines 2 (formatTestLogs dapp.eventMap vm.logs) + ] formatTestLogs :: (?context :: DappContext) => Map W256 Event -> [Expr Log] -> Text formatTestLogs events xs = @@ -338,7 +359,7 @@ formatTestLog _ (LogEntry _ _ []) = Nothing formatTestLog _ (GVar _) = internalError "unexpected global variable" formatTestLog events (LogEntry _ args (topic:_)) = - case maybeLitWord topic >>= \t1 -> (Map.lookup t1 events) of + case maybeLitWordSimp topic >>= \t1 -> (Map.lookup t1 events) of Nothing -> Nothing Just (Event name _ argInfos) -> case (name <> parenthesise (abiTypeSolidity <$> argTypes)) of @@ -374,10 +395,11 @@ _ -> Nothing where + headErr l = fromMaybe (internalError "shouldn't happen") $ listToMaybe l argTypes = [argType | (_, argType, NotIndexed) <- argInfos] unquote = Text.dropAround (\c -> c == '"' || c == '«' || c == '»') log_unnamed = - Just $ showValue (head argTypes) args + Just $ showValue (headErr argTypes) args log_named = let (key, val) = case take 2 (textValues argTypes args) of [k, v] -> (k, v) @@ -413,7 +435,7 @@ assign (#state % #caller) params.caller assign (#state % #gas) (toGas params.gasCall) origin <- fromMaybe (initialContract (RuntimeCode (ConcreteRuntimeCode ""))) <$> use (#env % #contracts % at params.origin) - let insufficientBal = maybe False (\b -> b < params.gasprice * (into params.gasCall)) (maybeLitWord origin.balance) + let insufficientBal = maybe False (\b -> b < params.gasprice * (into params.gasCall)) (maybeLitWordSimp origin.balance) when insufficientBal $ internalError "insufficient balance for gas cost" vm <- get put $ initTx vm @@ -431,7 +453,7 @@ , gas = toGas testParams.gasCreate , gaslimit = testParams.gasCreate , coinbase = testParams.coinbase - , number = testParams.number + , number = Lit testParams.number , timestamp = Lit testParams.timestamp , blockGaslimit = testParams.gaslimit , gasprice = testParams.gasprice @@ -457,7 +479,7 @@ paramsFromRpc :: Fetch.RpcInfo -> IO TestVMParams paramsFromRpc rpcinfo = do (miner,ts,blockNum,ran,limit,base) <- case rpcinfo of - Nothing -> pure (SymAddr "miner", Lit 0, 0, 0, 0, 0) + Nothing -> pure (SymAddr "miner", Lit 0, Lit 0, 0, 0, 0) Just (block, url) -> Fetch.fetchBlockFrom block url >>= \case Nothing -> internalError "Could not fetch block" Just Block{..} -> pure ( coinbase @@ -467,7 +489,7 @@ , gaslimit , baseFee ) - let ts' = fromMaybe (internalError "received unexpected symbolic timestamp via rpc") (maybeLitWord ts) + let ts' = fromMaybe (internalError "received unexpected symbolic timestamp via rpc") (maybeLitWordSimp ts) pure $ TestVMParams -- TODO: make this symbolic! It needs some tweaking to the way that our -- symbolic interpreters work to allow us to symbolically exec constructor initialization @@ -480,7 +502,7 @@ , priorityFee = 0 , balanceCreate = defaultBalanceForTestContract , coinbase = miner - , number = blockNum + , number = forceLit blockNum , timestamp = ts' , gaslimit = limit , gasprice = 0 diff --git a/test/EVM/Test/BlockchainTests.hs b/test/EVM/Test/BlockchainTests.hs --- a/test/EVM/Test/BlockchainTests.hs +++ b/test/EVM/Test/BlockchainTests.hs @@ -10,6 +10,7 @@ import EVM.UnitTest (writeTrace) import EVM.Types hiding (Block, Case, Env) import EVM.Test.Tracing (interpretWithTrace, VMTrace, compareTraces, EVMToolTraceOutput(..), decodeTraceOutputHelper) +import EVM.Expr (maybeLitWordSimp, maybeLitAddrSimp) import Optics.Core import Control.Arrow ((***), (&&&)) @@ -32,6 +33,8 @@ import System.Environment (lookupEnv, getEnv) import System.FilePath.Find qualified as Find import System.FilePath.Posix (makeRelative, ()) +import System.IO (hPutStr, hClose) +import System.IO.Temp (withSystemTempFile) import System.Process (readProcessWithExitCode) import GHC.IO.Exception (ExitCode(ExitSuccess)) import Witch (into, unsafeInto) @@ -207,8 +210,10 @@ putStrLn $ "evmtool stderr output:" <> show evmtoolStderr putStrLn $ "evmtool stdout output:" <> show evmtoolStdout hevm <- traceVMTest x - liftIO $ writeFile "trace.jsonl" $ filterInfoLines evmtoolStderr - decodedContents <- liftIO $ decodeTraceOutputHelper "trace.jsonl" + decodedContents <- liftIO $ withSystemTempFile "trace.jsonl" $ \traceFile hdl -> do + hPutStr hdl $ filterInfoLines evmtoolStderr + hClose hdl + decodeTraceOutputHelper traceFile let EVMToolTraceOutput ts _ = fromJust decodedContents liftIO $ putStrLn "Comparing traces." _ <- liftIO $ compareTraces hevm ts @@ -235,7 +240,7 @@ printContracts cs = putStrLn $ Map.foldrWithKey (\k c acc -> acc ++ "-->" <> show k ++ " : " ++ (show $ fromJust c.nonce) ++ " " - ++ (show $ fromJust $ maybeLitWord c.balance) ++ " " + ++ (show $ fromJust $ maybeLitWordSimp c.balance) ++ " " ++ (show $ fromConcrete c.storage) ++ (show $ fromConcrete c.tStorage) ++ "\n") "" cs @@ -439,7 +444,7 @@ , baseFee = block.baseFee , priorityFee = priorityFee tx block.baseFee , gaslimit = tx.gasLimit - , number = block.number + , number = Lit block.number , timestamp = Lit block.timestamp , coinbase = LitAddr block.coinbase , prevRandao = block.mixHash @@ -533,5 +538,5 @@ forceConcreteAddrs :: Map (Expr EAddr) Contract -> Map Addr Contract forceConcreteAddrs cs = Map.mapKeys - (fromMaybe (internalError "Internal Error: unexpected symbolic address") . maybeLitAddr) + (fromMaybe (internalError "Internal Error: unexpected symbolic address") . maybeLitAddrSimp) cs diff --git a/test/EVM/Test/Tracing.hs b/test/EVM/Test/Tracing.hs --- a/test/EVM/Test/Tracing.hs +++ b/test/EVM/Test/Tracing.hs @@ -17,13 +17,13 @@ import Control.Monad.ST (RealWorld, ST, stToIO) import Control.Monad.State.Strict (StateT(..)) import Control.Monad.State.Strict qualified as State -import Control.Monad.Reader (ReaderT) +import Control.Monad.Reader (ReaderT, lift) import Data.Aeson ((.:), (.:?)) import Data.Aeson qualified as JSON import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Char8 qualified as Char8 -import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) +import Data.Maybe (fromJust, isJust, isNothing) import Data.Map.Strict qualified as Map import Data.Text.IO qualified as T import Data.Vector qualified as Vector @@ -31,10 +31,10 @@ import GHC.Generics (Generic) import GHC.IO.Exception (ExitCode(ExitSuccess)) import Numeric (showHex) -import Paths_hevm qualified as Paths -import System.Directory (removeFile) -import System.Environment (lookupEnv) -import System.Process (readProcessWithExitCode) +import System.Directory (removeDirectoryRecursive) +import System.FilePath (()) +import System.IO.Temp (getCanonicalTemporaryDirectory, createTempDirectory) +import System.Process (readCreateProcessWithExitCode, proc, CreateProcess(..)) import Test.QuickCheck (elements) import Test.QuickCheck.Instances.Text() import Test.QuickCheck.Instances.Natural() @@ -53,7 +53,7 @@ import EVM.Concrete qualified as Concrete import EVM.Exec (ethrunAddress) import EVM.Fetch qualified as Fetch -import EVM.Format (bsToHex, formatBinary) +import EVM.Format (formatBinary) import EVM.FeeSchedule import EVM.Op (intToOpName) import EVM.Sign (deriveAddr) @@ -144,7 +144,7 @@ data EVMToolEnv = EVMToolEnv { coinbase :: Addr , timestamp :: Expr EWord - , number :: W256 + , number :: Expr EWord , gasLimit :: Data.Word.Word64 , baseFee :: W256 , maxCodeSize :: W256 @@ -158,7 +158,7 @@ instance JSON.ToJSON EVMToolEnv where toJSON b = JSON.object [ ("currentCoinBase" , (JSON.toJSON b.coinbase)) , ("currentGasLimit" , (JSON.toJSON ("0x" ++ showHex (into @Integer b.gasLimit) ""))) - , ("currentNumber" , (JSON.toJSON b.number)) + , ("currentNumber" , (JSON.toJSON number)) , ("currentTimestamp" , (JSON.toJSON tstamp)) , ("currentBaseFee" , (JSON.toJSON b.baseFee)) , ("blockHashes" , (JSON.toJSON b.blockHashes)) @@ -171,11 +171,15 @@ tstamp = case (b.timestamp) of Lit a -> a _ -> internalError "Timestamp needs to be a Lit" + number :: W256 + number = case (b.number) of + Lit a -> a + _ -> internalError "Timestamp needs to be a Lit" emptyEvmToolEnv :: EVMToolEnv emptyEvmToolEnv = EVMToolEnv { coinbase = 0 , timestamp = Lit 0 - , number = 0 + , number = Lit 0 , gasLimit = 0xffffffffffffffff , baseFee = 0 , maxCodeSize= 0xffffffff @@ -244,7 +248,7 @@ 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)) + , ("nonce", (JSON.toJSON b.nonce)) ] emptyEVMToolAlloc :: EVMToolAlloc @@ -287,7 +291,7 @@ } evmEnv = EVMToolEnv { coinbase = 0xff , timestamp = Lit 0x3e8 - , number = 0x0 + , number = Lit 0 , gasLimit = unsafeInto gaslimitExec , baseFee = 0x0 , maxCodeSize = 0xfffff @@ -308,8 +312,8 @@ let (txn, evmEnv, contrAlloc, fromAddress, toAddress, _) = evmSetup contr txData gaslimitExec runCodeWithTrace Nothing evmEnv contrAlloc txn (LitAddr fromAddress) (LitAddr toAddress) -getEVMToolRet :: OpContract -> ByteString -> Int -> IO (Maybe EVMToolResult) -getEVMToolRet contr txData gaslimitExec = do +getEVMToolRet :: FilePath -> OpContract -> ByteString -> Int -> IO (Maybe EVMToolResult) +getEVMToolRet evmDir 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 @@ -318,24 +322,25 @@ } 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" - , "--state.fork", "Cancun" - , "--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" - ] "" + JSON.encodeFile (evmDir "txs.json") txs + JSON.encodeFile (evmDir "alloc.json") alloc + JSON.encodeFile (evmDir "env.json") evmEnv + let cmd = (proc "evm" [ "transition" + , "--state.fork", "Cancun" + , "--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" + ]) { cwd = Just evmDir } + (exitCode, evmtoolStdout, evmtoolStderr) <- readCreateProcessWithExitCode cmd "" when (exitCode /= ExitSuccess) $ do putStrLn $ "evmtool exited with code " <> show exitCode putStrLn $ "evmtool stderr output:" <> show evmtoolStderr putStrLn $ "evmtool stdout output:" <> show evmtoolStdout - JSON.decodeFileStrict "result.json" :: IO (Maybe EVMToolResult) + JSON.decodeFileStrict (evmDir "result.json") :: IO (Maybe EVMToolResult) -- Compares traces of evmtool (from go-ethereum) and HEVM compareTraces :: [VMTrace] -> [EVMToolTrace] -> IO (Bool) @@ -389,45 +394,34 @@ putStrLn $ "Traces don't match. evmtool's trace is longer by:" <> (show b) pure False -getTraceFileName :: EVMToolResult -> String -getTraceFileName evmtoolResult = traceFileName +getTraceFileName :: FilePath -> EVMToolResult -> String +getTraceFileName evmDir evmtoolResult = evmDir traceFileName where txName = ((evmtoolResult.receipts) !! 0).transactionHash traceFileName = "trace-0-" ++ txName ++ ".jsonl" -getTraceOutput :: Maybe EVMToolResult -> IO (Maybe EVMToolTraceOutput) -getTraceOutput evmtoolResult = +getTraceOutput :: FilePath -> Maybe EVMToolResult -> IO (Maybe EVMToolTraceOutput) +getTraceOutput evmDir evmtoolResult = case evmtoolResult of Nothing -> pure Nothing Just res -> do - let traceFileName = getTraceFileName res + let traceFileName = getTraceFileName evmDir res decodeTraceOutputHelper traceFileName decodeTraceOutputHelper :: String -> IO (Maybe EVMToolTraceOutput) decodeTraceOutputHelper traceFileName = do - convertPath <- Paths.getDataFileName "test/scripts/convert_trace_to_json.sh" - maybeShellPath <- (fromMaybe "bash") <$> (lookupEnv "HEVM_SYSTEM_SHELL") - let shellPath = if maybeShellPath == "" then "bash" else maybeShellPath - (exitcode, stdout, stderr) <- readProcessWithExitCode shellPath [convertPath, traceFileName] "" - case exitcode of - ExitSuccess -> do - -- putStrLn $ "Successfully converted trace to JSON: " <> (show stdout) <> " " <> - -- (show stderr) <> " " <> (show exitcode) <> " " <> (show traceFileName) - JSON.decodeFileStrict (traceFileName ++ ".json") :: IO (Maybe EVMToolTraceOutput) - _ -> do - putStrLn $ "Error converting trace! exit code:" <> (show exitcode) - putStrLn $ "stdout: " <> (show stdout) - putStrLn $ "stderr: " <> (show stderr) - pure Nothing - -deleteTraceOutputFiles :: Maybe EVMToolResult -> IO () -deleteTraceOutputFiles evmtoolResult = - case evmtoolResult of - Nothing -> pure () - Just res -> do - let traceFileName = getTraceFileName res - System.Directory.removeFile traceFileName - System.Directory.removeFile (traceFileName ++ ".json") + traceContents <- readFile traceFileName + let traceLines = lines traceContents + let (traces, outputLines) = splitAt (length traceLines - 1) traceLines + let parsedTraces = map decodeString traces :: [Maybe EVMToolTrace] + let parsedOutput = decodeString (outputLines !! 0) :: Maybe EVMToolOutput + if all isJust parsedTraces && isJust parsedOutput then + pure $ Just $ EVMToolTraceOutput (map fromJust parsedTraces) (fromJust parsedOutput) + else + pure Nothing + where + decodeString :: (JSON.FromJSON a) => String -> Maybe a + decodeString = JSON.decodeStrict . Char8.pack -- | Takes a runtime code and calls it with the provided calldata -- Uses evmtool's alloc and transaction to set up the VM correctly @@ -438,7 +432,8 @@ runCodeWithTrace rpcinfo evmEnv alloc txn fromAddr toAddress = withSolvers Z3 0 1 Nothing $ \solvers -> do let calldata' = ConcreteBuf txn.txdata code' = alloc.code - buildExpr s vm = interpret (Fetch.oracle s Nothing) Nothing 1 Naive vm runExpr + iterConf = IterConfig { maxIter = Nothing, askSmtIters = 1, loopHeuristic = Naive } + buildExpr s vm = interpret (Fetch.oracle s Nothing) iterConf vm runExpr origVM <- liftIO $ stToIO $ vmForRuntimeCode code' calldata' evmEnv alloc txn fromAddr toAddress expr <- buildExpr solvers $ symbolify origVM @@ -542,11 +537,12 @@ runWithTrace = do -- This is just like `exec` except for every instruction evaluated, -- we also increment a counter indexed by the current code location. + conf <- lift readConfig vm0 <- use _1 case vm0.result of Nothing -> do State.modify' (\(a, b) -> (a, b ++ [vmtrace vm0])) - vm' <- liftIO $ stToIO $ State.execStateT exec1 vm0 + vm' <- liftIO $ stToIO $ State.execStateT (exec1 conf) vm0 assign _1 vm' runWithTrace Just (VMFailure _) -> do @@ -581,8 +577,6 @@ vm' <- liftIO $ stToIO $ State.execStateT m vm assign _1 vm' interpretWithTrace fetcher (k ()) - Stepper.IOAct q -> - liftIO q >>= interpretWithTrace fetcher . k Stepper.EVM m -> do vm <- use _1 (r, vm') <- liftIO $ stToIO $ State.runStateT m vm @@ -877,9 +871,11 @@ checkTraceAndOutputs :: App m => OpContract -> Int -> ByteString -> m () checkTraceAndOutputs contract gasLimit txData = do - evmtoolResult <- liftIO $ getEVMToolRet contract txData gasLimit + tmpDir <- liftIO getCanonicalTemporaryDirectory + evmDir <- liftIO $ createTempDirectory tmpDir "evm-trace" + evmtoolResult <- liftIO $ getEVMToolRet evmDir contract txData gasLimit hevmRun <- getHEVMRet contract txData gasLimit - evmtoolTraceOutput <- fmap fromJust $ liftIO $ getTraceOutput evmtoolResult + evmtoolTraceOutput <- fmap fromJust $ liftIO $ getTraceOutput evmDir evmtoolResult case hevmRun of (Right (expr, hevmTrace, hevmTraceResult)) -> liftIO $ do let @@ -917,7 +913,7 @@ putStrLn $ "ret value computed via symb+conc : " <> (bsToHex (fromJust simplConcrExprRetval)) assertEqual "Simplified, concretized expression must match evmtool's output." True False else do - putStrLn $ "Name of trace file: " <> (getTraceFileName $ fromJust evmtoolResult) + putStrLn $ "Name of trace file: " <> (getTraceFileName evmDir $ fromJust evmtoolResult) putStrLn $ "HEVM result :" <> (show hevmTraceResult) T.putStrLn $ "HEVM result: " <> (formatBinary $ bssToBs hevmTraceResult.out) T.putStrLn $ "evm result : " <> (formatBinary $ bssToBs evmtoolTraceOutput.output.output) @@ -930,13 +926,7 @@ -- putStrLn $ "output by evmtool is: '" <> bsToHex evmtoolTraceOutput.toOutput.output <> "'" traceOK <- compareTraces hevmTrace (evmtoolTraceOutput.trace) assertEqual "Traces and gas must match" traceOK True - liftIO $ do - 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 + liftIO $ removeDirectoryRecursive evmDir -- GasLimitInt newtype GasLimitInt = GasLimitInt (Int) diff --git a/test/EVM/Test/Utils.hs b/test/EVM/Test/Utils.hs --- a/test/EVM/Test/Utils.hs +++ b/test/EVM/Test/Utils.hs @@ -1,6 +1,7 @@ module EVM.Test.Utils where import Data.Text (Text) +import Data.List (isInfixOf) import GHC.IO.Exception (IOErrorType(..)) import GHC.Natural import Paths_hevm qualified as Paths @@ -24,9 +25,10 @@ import EVM.Types (internalError) import System.Environment (lookupEnv) +-- Returns tuple of (No cex, No warnings) runSolidityTestCustom :: (MonadMask m, App m) - => FilePath -> Text -> Maybe Natural -> Maybe Integer -> Bool -> RpcInfo -> ProjectType -> m Bool + => FilePath -> Text -> Maybe Natural -> Maybe Integer -> Bool -> RpcInfo -> ProjectType -> m (Bool, Bool) runSolidityTestCustom testFile match timeout maxIter ffiAllowed rpcinfo projectType = do withSystemTempDirectory "dapp-test" $ \root -> do (compile projectType root testFile) >>= \case @@ -35,13 +37,14 @@ internalError $ "Error compiling test file " <> show testFile <> " in directory " <> show root <> " using project type " <> show projectType Right bo@(BuildOutput contracts _) -> do - withSolvers Z3 1 1 timeout $ \solvers -> do + withSolvers Bitwuzla 3 1 timeout $ \solvers -> do opts <- liftIO $ testOpts solvers root (Just bo) match maxIter ffiAllowed rpcinfo unitTest opts contracts +-- Returns tuple of (No cex, No warnings) runSolidityTest :: (MonadMask m, App m) - => FilePath -> Text -> m Bool + => FilePath -> Text -> m (Bool, Bool) runSolidityTest testFile match = runSolidityTestCustom testFile match Nothing Nothing True Nothing Foundry testOpts :: SolverGroup -> FilePath -> Maybe BuildOutput -> Text -> Maybe Integer -> Bool -> RpcInfo -> IO (UnitTestOptions RealWorld) @@ -56,9 +59,8 @@ , maxIter = maxIter , askSmtIters = 1 , smtTimeout = Nothing - , solver = Nothing - , verbose = Just 1 , match = match + , prefix = "prove" , testParams = params , dapp = srcInfo , ffiAllowed = allowFFI @@ -90,7 +92,7 @@ (res,out,err) <- liftIO $ readProcessWithExitCode "forge" ["build", "--ast", "--root", root] "" case res of ExitFailure _ -> pure . Left $ "compilation failed: " <> "exit code: " <> show res <> "\n\nstdout:\n" <> out <> "\n\nstderr:\n" <> err - ExitSuccess -> readBuildOutput root Foundry + ExitSuccess -> readFilteredBuildOutput root (\path -> "unit-tests.t.sol" `Data.List.isInfixOf` path) Foundry where initStdForgeDir :: FilePath -> IO () initStdForgeDir tld = do @@ -102,9 +104,4 @@ initLib tld srcFile dstFile = do createDirectoryIfMissing True (tld "src") writeFile (tld "src" dstFile) =<< readFile =<< Paths.getDataFileName srcFile - _ <- readProcessWithExitCode "git" ["init", tld] "" - callProcess "git" ["config", "--file", tld ".git" "config", "user.name", "'hevm'"] - callProcess "git" ["config", "--file", tld ".git" "config", "user.email", "'hevm@hevm.dev'"] - callProcessCwd "git" ["add", "."] tld - callProcessCwd "git" ["commit", "-m", "", "--allow-empty-message", "--no-gpg-sign"] tld pure () diff --git a/test/clitest.hs b/test/clitest.hs new file mode 100644 --- /dev/null +++ b/test/clitest.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +{-| +Description : CLI tests + +This module contains simple CLI test cases to make sure we don't accidentally +break the hevm CLI interface. + +-} + +import Test.Hspec +import System.Process (readProcess, readProcessWithExitCode) +import System.FilePath (()) +import System.Exit (ExitCode(..)) +import Data.List.Split (splitOn) +import Data.Text qualified as T +import Data.String.Here + +import EVM.Solidity +import EVM.Effects +import EVM.Types + + +main :: IO () +main = do + hspec $ + describe "CLI" $ do + it "hevm help works" $ do + (exitCode, stdout, stderr) <- readProcessWithExitCode "cabal" ["run", "exe:hevm", "--", "--help"] "" + stdout `shouldContain` "Usage: hevm" + stdout `shouldContain` "test" + stdout `shouldContain` "equivalence" + stdout `shouldContain` "symbolic" + stdout `shouldContain` "exec" + stdout `shouldContain` "version" + + it "hevm symbolic tutorial works -- FAIL" $ do + Just symbBin <- runApp $ solcRuntime (T.pack "MyContract") (T.pack [i| + contract MyContract { + function simple_symb() public pure { + uint i; + i = 1; + assert(i == 2); + } + } + |]) + let symbHex = bsToHex symbBin + (exitCode, stdout, stderr) <- readProcessWithExitCode "cabal" ["run", "exe:hevm", "--", "symbolic", "--code", symbHex] "" + stdout `shouldContain` "Discovered the following" + exitCode `shouldBe` ExitFailure 1 + + (exitCode, stdout, stderr) <- readProcessWithExitCode "cabal" ["run", "exe:hevm", "--", "symbolic", "--code", symbHex, "--sig", "nonexistent()"] "" + stdout `shouldContain` "QED" + exitCode `shouldBe` ExitSuccess + + it "hevm equivalence tutorial works -- FAIL" $ do + let torun = splitOn " " "equivalence --code-a 60003560000260005260016000f3 --code-b 7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff60005260016000f3" + (exitCode, stdout, stderr) <- readProcessWithExitCode "cabal" (["run", "exe:hevm", "--" ] ++ torun) "" + stdout `shouldContain` "Not equivalent" + stdout `shouldContain` "FAIL" + exitCode `shouldBe` ExitFailure 1 + + it "hevm equivalence tutorial works -- PASS" $ do + Just a <- runApp $ solcRuntime (T.pack "MyContract") (T.pack [i| + contract MyContract { + mapping (address => uint) balances; + function my_adder(address recv, uint amt) public { + if (balances[recv] + amt >= 100) { revert(); } + balances[recv] += amt; + } + } + |]) + let aHex = bsToHex a + Just b <- runApp $ solcRuntime (T.pack "MyContract") (T.pack [i| + contract MyContract { + mapping (address => uint) balances; + function my_adder(address recv, uint amt) public { + if (balances[recv] + amt >= 100) { revert(); } + balances[recv] += amt/2; + balances[recv] += amt/2; + if (amt % 2 != 0) balances[recv]++; + } + } + |]) + let bHex = bsToHex b + (exitCode, stdout, stderr) <- readProcessWithExitCode "cabal" (["run", "exe:hevm", "--", "equivalence" , "--code-a", aHex, "--code-b", bHex ]) "" + stdout `shouldContain` "No discrepancies found" + stdout `shouldContain` "PASS" + exitCode `shouldBe` ExitSuccess + + it "hevm concrete tutorial works" $ do + let torun = splitOn " " "exec --code 0x647175696e6550383480393834f3 --gas 0xff" + (exitCode, stdout, stderr) <- readProcessWithExitCode "cabal" (["run", "exe:hevm", "--" ] ++ torun) "" + stdout `shouldContain` "Return: 0x64" + exitCode `shouldBe` ExitSuccess + + it "warning on zero address" $ do + Just c <- runApp $ solcRuntime (T.pack "C") (T.pack [i| + contract Target { + function get() external view returns (uint256) { + return 55; + } + } + contract C { + Target mm; + function retFor() public returns (uint256) { + Target target = Target(address(0)); + uint256 ret = target.get(); + assert(ret == 4); + return ret; + } + } + |]) + let hexStr = bsToHex c + (exitCode, stdout, stderr) <- readProcessWithExitCode "cabal" ["run", "exe:hevm", "--", "symbolic", "--code", hexStr] "" + stdout `shouldContain` "Warning: fetching contract at address 0" + + -- file "devcon_example.yul" from "eq-all-yul-optimization-tests" in test.hs + -- we check that at least one UNSAT cache hit happens, i.e. the unsat cache is not + -- completely broken + it "unsat-cache" $ do + let a = [i| { + calldatacopy(0,0,1024) + sstore(0, array_sum(calldataload(0))) + function array_sum(x) -> sum { + let length := calldataload(x) + for { let i := 0 } lt(i, length) { i := add(i, 1) } { + sum := add(sum, array_load(x, i)) + } + } + function array_load(x, i) -> v { + let len := calldataload(x) + if iszero(lt(i, len)) { revert(0, 0) } + let data := add(x, 0x20) + v := calldataload(add(data, mul(i, 0x20))) + } + } |] + let b = [i| { + calldatacopy(0,0,1024) + { + let _1 := calldataload(0) + let sum := 0 + let length := calldataload(_1) + let i := 0 + for { } true { i := add(i, 1) } + { + let _2 := iszero(lt(i, length)) + if _2 { break } + _2 := 0 + sum := add(sum, calldataload(add(add(_1, shl(5, i)), 0x20))) + } + sstore(0, sum) + } + } |] + Just aPrgm <- yul (T.pack "") $ T.pack a + Just bPrgm <- yul (T.pack "") $ T.pack b + let hexStrA = bsToHex aPrgm + hexStrB = bsToHex bPrgm + (exitCode, stdout, stderr) <- readProcessWithExitCode "cabal" ["run", "exe:hevm", "--", "equivalence", "--num-solvers", "1", "--debug", "--code-a", hexStrA, "--code-b", hexStrB] "" + stdout `shouldContain` "Qed found via cache" + it "crash-of-hevm" $ do + let hexStrA = "608060405234801561001057600080fd5b506004361061002b5760003560e01c8063efa2978514610030575b600080fd5b61004361003e3660046102ad565b610045565b005b60006100508561007a565b9050600061005d866100a8565b905080821461006e5761006e61034c565b50505050505050505050565b600061008761032e6103aa565b8261009457610197610098565b61013e5b6100a291906103e2565b92915050565b60006100b561032e6103aa565b6100be906103aa565b6100c7906103aa565b82806100d1575060005b806100da575060005b61013157605a6100ea60006103aa565b6100f3906103aa565b6100ff6001605a610404565b61010b6001605a610404565b61011891166101976103e2565b6101229190610493565b61012c9190610493565b610149565b604061013f8161013e6103e2565b6101499190610493565b61015391906103e2565b61016061032e60006103e2565b83801561016b575060015b15801590610177575060015b80156101a05750831515801561018b575060015b15158015610197575060015b806101a0575060005b610251576101976101b3605a602d610493565b602d60006101c2600182610493565b6101cd906001610404565b6101d8906001610404565b6101e1906103aa565b6101ea906103aa565b6101f491906103e2565b6101ff90605a610404565b604e61020c8160016103e2565b6102169190610493565b61022490600116605a610404565b1661022e906103aa565b61023891906103e2565b6102429190610493565b61024c9190610493565b610283565b604561025f8161013e6103e2565b6102699190610493565b60456102778161013e6103e2565b6102819190610493565b165b61028d91906103e2565b1692915050565b80358015155b81146100a257600080fd5b80358061029a565b600080600080600080600080610100898b0312156102ca57600080fd5b6102d48a8a610294565b97506102e38a60208b01610294565b96506102f28a60408b016102a5565b95506103018a60608b016102a5565b94506103108a60808b01610294565b935061031f8a60a08b016102a5565b925061032e8a60c08b01610294565b915061033d8a60e08b016102a5565b90509295985092959890939650565b7f4e487b7100000000000000000000000000000000000000000000000000000000600052600160045260246000fd5b7f4e487b7100000000000000000000000000000000000000000000000000000000600052601160045260246000fd5b60007f800000000000000000000000000000000000000000000000000000000000000082036103db576103db61037b565b5060000390565b818103600083128015838313168383129190911617156100a2576100a261037b565b60008261043a577f4e487b7100000000000000000000000000000000000000000000000000000000600052601260045260246000fd5b7f800000000000000000000000000000000000000000000000000000000000000082147fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff8414161561048e5761048e61037b565b500590565b80820160008212801584831290811690159190911617156100a2576100a261037b56fea26469706673582212200a37769e5bf4b8b890caac8ab643126d55feb821a0201d2f674203f23fa666ad64736f6c634300081e0033" + + (exitCode, stdout, stderr) <- readProcessWithExitCode "cabal" ["run", "exe:hevm", "--", "symbolic", "--code", hexStrA] "" + stderr `shouldNotContain` "CallStack" + exitCode `shouldBe` ExitSuccess diff --git a/test/rpc.hs b/test/rpc.hs --- a/test/rpc.hs +++ b/test/rpc.hs @@ -11,7 +11,7 @@ import Data.Vector qualified as V import Optics.Core -import EVM (makeVm, symbolify) +import EVM (makeVm, symbolify, forceLit) import EVM.ABI import EVM.Fetch import EVM.SMT @@ -42,28 +42,28 @@ let block = BlockNumber 15537392 (cb, numb, basefee, prevRan) <- fetchBlockFrom block testRpc >>= \case Nothing -> internalError "Could not fetch block" - Just Block{..} -> return ( coinbase + Just Block{..} -> pure ( coinbase , number , baseFee , prevRandao ) assertEqual "coinbase" (LitAddr 0xea674fdde714fd979de3edf0f56aa9716b898ec8) cb - assertEqual "number" (BlockNumber numb) block + assertEqual "number" (BlockNumber (forceLit 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 Nothing -> internalError "Could not fetch block" - Just Block{..} -> return ( coinbase + Just Block{..} -> pure ( coinbase , number , baseFee , prevRandao ) assertEqual "coinbase" (LitAddr 0x690b9a9e9aa1c9db991c7721a92d351db4fac990) cb - assertEqual "number" (BlockNumber numb) block + assertEqual "number" (BlockNumber (forceLit numb)) block assertEqual "basefee" 22163046690 basefee assertEqual "prevRan" 0x2267531ab030ed32fd5f2ef51f81427332d0becbd74fe7f4cd5684ddf4b287e0 prevRan ] @@ -72,7 +72,7 @@ [ test "dapp-test" $ do let testFile = "test/contracts/pass/rpc.sol" res <- runSolidityTestCustom testFile ".*" Nothing Nothing False testRpcInfo Foundry - liftIO $ assertEqual "test result" True res + liftIO $ assertEqual "test result" (True, True) res -- concretely exec "transfer" on WETH9 using remote rpc -- https://etherscan.io/token/0xc02aaa39b223fe8d0a0e5c4f27ead9083c756cc2#code @@ -100,9 +100,9 @@ -- symbolically exec "transfer" on WETH9 using remote rpc -- https://etherscan.io/token/0xc02aaa39b223fe8d0a0e5c4f27ead9083c756cc2#code , test "weth-sym" $ do + calldata' <- symCalldata "transfer(address,uint256)" [AbiAddressType, AbiUIntType 256] ["0xdead"] (AbstractBuf "txdata") let blockNum = 16198552 - calldata' = symCalldata "transfer(address,uint256)" [AbiAddressType, AbiUIntType 256] ["0xdead"] (AbstractBuf "txdata") postc _ (Failure _ _ (Revert _)) = PBool False postc _ _ = PBool True vm <- liftIO $ weth9VM blockNum calldata' @@ -125,7 +125,7 @@ vmFromRpc blockNum calldata callvalue caller address = do ctrct <- fetchContractFrom (BlockNumber blockNum) testRpc address >>= \case Nothing -> internalError $ "contract not found: " <> show address - Just contract' -> return contract' + Just contract' -> pure contract' blk <- fetchBlockFrom (BlockNumber blockNum) testRpc >>= \case Nothing -> internalError "could not fetch block" diff --git a/test/scripts/convert_trace_to_json.sh b/test/scripts/convert_trace_to_json.sh --- a/test/scripts/convert_trace_to_json.sh +++ b/test/scripts/convert_trace_to_json.sh @@ -1,4 +1,5 @@ #!/usr/bin/env bash +set -euxo pipefail -num=$(wc -l "$1" | cut -d " " -f 1) +num=$(awk 'END{print NR}' "$1") awk -v ll="$num" 'BEGIN {print "{\"trace\": [" } {if (NR!=ll) {print $0; if (NR!=ll-1) {print ","}} else {print "], \"output\":" $0}} END{print "}"}' "$1" > "$1.json" diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,4599 +1,6353 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE QuasiQuotes #-} - -module Main where - -import Prelude hiding (LT, GT) - -import GHC.TypeLits -import Data.Proxy -import Control.Monad -import Control.Monad.ST (RealWorld, stToIO) -import Control.Monad.State.Strict -import Control.Monad.IO.Unlift -import Control.Monad.Reader (ReaderT) -import Data.Bits hiding (And, Xor) -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Base16 qualified as BS16 -import Data.Binary.Put (runPut) -import Data.Binary.Get (runGetOrFail) -import Data.DoubleWord -import Data.Either -import Data.List qualified as List -import Data.Map.Strict qualified as Map -import Data.Maybe -import Data.String.Here -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.IO qualified as T -import Data.Time (diffUTCTime, getCurrentTime) -import Data.Tuple.Extra -import Data.Tree (flatten) -import Data.Typeable -import Data.Vector qualified as V -import Data.Word (Word8, Word64) -import GHC.Conc (getNumProcessors) -import System.Directory -import System.Environment -import Test.Tasty -import Test.Tasty.QuickCheck hiding (Failure, Success) -import Test.QuickCheck.Instances.Text() -import Test.QuickCheck.Instances.Natural() -import Test.QuickCheck.Instances.ByteString() -import Test.Tasty.HUnit -import Test.Tasty.Runners hiding (Failure, Success) -import Test.Tasty.ExpectedFailure -import Text.RE.TDFA.String -import Text.RE.Replace -import Witch (unsafeInto, into) -import Data.Containers.ListUtils (nubOrd) - -import Optics.Core hiding (pre, re, elements) -import Optics.State - -import EVM hiding (choose) -import EVM.ABI -import EVM.Assembler -import EVM.Exec -import EVM.Expr qualified as Expr -import EVM.Fetch qualified as Fetch -import EVM.Format (hexText, formatExpr) -import EVM.Precompiled -import EVM.RLP -import EVM.SMT hiding (one) -import EVM.Solidity -import EVM.Solvers -import EVM.Stepper qualified as Stepper -import EVM.SymExec -import EVM.Test.Tracing qualified as Tracing -import EVM.Test.Utils -import EVM.Traversals -import EVM.Types hiding (Env) -import EVM.Effects -import EVM.UnitTest (writeTrace) - -testEnv :: Env -testEnv = Env { config = defaultConfig { - dumpQueries = False - , dumpExprs = False - , dumpEndStates = False - , debug = False - , dumpTrace = False - , decomposeStorage = True - } } - -putStrLnM :: (MonadUnliftIO m) => String -> m () -putStrLnM a = liftIO $ putStrLn a - -assertEqualM :: (App m, Eq a, Show a, HasCallStack) => String -> a -> a -> m () -assertEqualM a b c = liftIO $ assertEqual a b c - -assertBoolM - :: (MonadUnliftIO m, HasCallStack) - => String -> Bool -> m () -assertBoolM a b = liftIO $ assertBool a b - -test :: TestName -> ReaderT Env IO () -> TestTree -test a b = testCase a $ runEnv testEnv b - -testFuzz :: TestName -> ReaderT Env IO () -> TestTree -testFuzz a b = testCase a $ runEnv (testEnv {config = testEnv.config {numCexFuzz = 100, onlyCexFuzz = True}}) b - -prop :: Testable prop => ReaderT Env IO prop -> Property -prop a = ioProperty $ runEnv testEnv a - -withDefaultSolver :: App m => (SolverGroup -> m a) -> m a -withDefaultSolver = withSolvers Z3 1 1 Nothing - -withCVC5Solver :: App m => (SolverGroup -> m a) -> m a -withCVC5Solver = withSolvers CVC5 1 1 Nothing - -main :: IO () -main = defaultMain tests - --- | run a subset of tests in the repl. p is a tasty pattern: --- https://github.com/UnkindPartition/tasty/tree/ee6fe7136fbcc6312da51d7f1b396e1a2d16b98a#patterns -runSubSet :: String -> IO () -runSubSet p = defaultMain . applyPattern p $ tests - -tests :: TestTree -tests = testGroup "hevm" - [ Tracing.tests - , testGroup "simplify-storage" - [ test "simplify-storage-array-only-static" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - uint[] a; - function transfer(uint acct, uint val1, uint val2) public { - unchecked { - a[0] = val1 + 1; - a[1] = val2 + 2; - assert(a[0]+a[1] == val1 + val2 + 3); - } - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - assertEqualM "Expression is not clean." (badStoresInExpr expr) False - -- This case is somewhat artificial. We can't simplify this using only - -- static rewrite rules, because acct is totally abstract and acct + 1 - -- could overflow back to zero. we may be able to do better if we have some - -- smt assisted simplification that can take branch conditions into account. - , expectFail $ test "simplify-storage-array-symbolic-index" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - uint b; - uint[] a; - function transfer(uint acct, uint val1) public { - unchecked { - a[acct] = val1; - assert(a[acct] == val1); - } - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - -- T.writeFile "symbolic-index.expr" $ formatExpr expr - assertEqualM "Expression is not clean." (badStoresInExpr expr) False - , expectFail $ test "simplify-storage-array-of-struct-symbolic-index" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - struct MyStruct { - uint a; - uint b; - } - MyStruct[] arr; - function transfer(uint acct, uint val1, uint val2) public { - unchecked { - arr[acct].a = val1+1; - arr[acct].b = val1+2; - assert(arr[acct].a + arr[acct].b == val1+val2+3); - } - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - assertEqualM "Expression is not clean." (badStoresInExpr expr) False - , test "simplify-storage-array-loop-nonstruct" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - uint[] a; - function transfer(uint v) public { - for (uint i = 0; i < a.length; i++) { - a[i] = v; - assert(a[i] == v); - } - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256)" [AbiUIntType 256])) [] (defaultVeriOpts { maxIter = Just 5 }) - assertEqualM "Expression is not clean." (badStoresInExpr expr) False - , test "simplify-storage-map-newtest1" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - mapping (uint => uint) a; - mapping (uint => uint) b; - function fun(uint v, uint i) public { - require(i < 1000); - require(v < 1000); - b[i+v] = v+1; - a[i] = v; - b[i+1] = v+1; - assert(a[i] == v); - assert(b[i+1] == v+1); - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - assertEqualM "Expression is not clean." (badStoresInExpr expr) False - (_, [(Qed _)]) <- withDefaultSolver $ \s -> checkAssert s [0x11] c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - liftIO $ putStrLn "OK" - , ignoreTest $ test "simplify-storage-map-todo" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - mapping (uint => uint) a; - mapping (uint => uint) b; - function fun(uint v, uint i) public { - require(i < 1000); - require(v < 1000); - a[i] = v; - b[i+1] = v+1; - b[i+v] = 55; // note: this can overwrite b[i+1], hence assert below can fail - assert(a[i] == v); - assert(b[i+1] == v+1); - } - } - |] - -- TODO: expression below contains (load idx1 (store idx1 (store idx1 (store idx0)))), and the idx0 - -- is not stripped. This is due to us not doing all we can in this case, see - -- note above readStorage. Decompose remedies this (when it can be decomposed) - -- expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - -- putStrLnM $ T.unpack $ formatExpr expr - (_, [Cex _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - liftIO $ putStrLn "OK" - , test "simplify-storage-array-loop-struct" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - struct MyStruct { - uint a; - uint b; - } - MyStruct[] arr; - function transfer(uint v1, uint v2) public { - for (uint i = 0; i < arr.length; i++) { - arr[i].a = v1+1; - arr[i].b = v2+2; - assert(arr[i].a + arr[i].b == v1 + v2 + 3); - } - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] (defaultVeriOpts { maxIter = Just 5 }) - assertEqualM "Expression is not clean." (badStoresInExpr expr) False - , test "decompose-1" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - mapping (address => uint) balances; - function prove_mapping_access(address x, address y) public { - require(x != y); - balances[x] = 1; - balances[y] = 2; - assert(balances[x] != balances[y]); - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "prove_mapping_access(address,address)" [AbiAddressType, AbiAddressType])) [] defaultVeriOpts - putStrLnM $ T.unpack $ formatExpr expr - let simpExpr = mapExprM Expr.decomposeStorage expr - -- putStrLnM $ T.unpack $ formatExpr (fromJust simpExpr) - assertEqualM "Decompose did not succeed." (isJust simpExpr) True - , test "decompose-2" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - mapping (address => uint) balances; - function prove_mixed_symoblic_concrete_writes(address x, uint v) public { - balances[x] = v; - balances[address(0)] = balances[x]; - assert(balances[address(0)] == v); - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "prove_mixed_symoblic_concrete_writes(address,uint256)" [AbiAddressType, AbiUIntType 256])) [] defaultVeriOpts - let simpExpr = mapExprM Expr.decomposeStorage expr - -- putStrLnM $ T.unpack $ formatExpr (fromJust simpExpr) - assertEqualM "Decompose did not succeed." (isJust simpExpr) True - , test "decompose-3" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - uint[] a; - function prove_array(uint x, uint v1, uint y, uint v2) public { - require(v1 != v2); - a[x] = v1; - a[y] = v2; - assert(a[x] == a[y]); - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "prove_array(uint256,uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - let simpExpr = mapExprM Expr.decomposeStorage expr - assertEqualM "Decompose did not succeed." (isJust simpExpr) True - , test "decompose-4-mixed" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - uint[] a; - mapping( uint => uint) balances; - function prove_array(uint x, uint v1, uint y, uint v2) public { - require(v1 != v2); - balances[x] = v1+1; - balances[y] = v1+2; - a[x] = v1; - assert(balances[x] != balances[y]); - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "prove_array(uint256,uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - let simpExpr = mapExprM Expr.decomposeStorage expr - -- putStrLnM $ T.unpack $ formatExpr (fromJust simpExpr) - assertEqualM "Decompose did not succeed." (isJust simpExpr) True - , test "decompose-5-mixed" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - mapping (address => uint) balances; - mapping (uint => bool) auth; - uint[] arr; - uint a; - uint b; - function prove_mixed(address x, address y, uint val) public { - b = val+1; - require(x != y); - balances[x] = val; - a = val; - arr[val] = 5; - auth[val+1] = true; - balances[y] = val+2; - if (balances[y] == balances[y]) { - assert(balances[y] == val); - } - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "prove_mixed(address,address,uint256)" [AbiAddressType, AbiAddressType, AbiUIntType 256])) [] defaultVeriOpts - let simpExpr = mapExprM Expr.decomposeStorage expr - -- putStrLnM $ T.unpack $ formatExpr (fromJust simpExpr) - assertEqualM "Decompose did not succeed." (isJust simpExpr) True - -- TODO check what's going on here. Likely the "arbitrary write through array" is the reason why we fail - , expectFail $ test "decompose-6-fail" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - uint[] arr; - function prove_mixed(uint val) public { - arr[val] = 5; - arr[val+1] = val+5; - assert(arr[val] == arr[val+1]); - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "prove_mixed(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - let simpExpr = mapExprM Expr.decomposeStorage expr - -- putStrLnM $ T.unpack $ formatExpr (fromJust simpExpr) - assertEqualM "Decompose did not succeed." (isJust simpExpr) True - , test "simplify-storage-map-only-static" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - mapping(uint => uint) items1; - function transfer(uint acct, uint val1, uint val2) public { - unchecked { - items1[0] = val1+1; - items1[1] = val2+2; - assert(items1[0]+items1[1] == val1 + val2 + 3); - } - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - assertEqualM "Expression is not clean." (badStoresInExpr expr) False - , test "simplify-storage-map-only-2" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - mapping(uint => uint) items1; - function transfer(uint acct, uint val1, uint val2) public { - unchecked { - items1[acct] = val1+1; - items1[acct+1] = val2+2; - assert(items1[acct]+items1[acct+1] == val1 + val2 + 3); - } - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - -- putStrLnM $ T.unpack $ formatExpr expr - assertEqualM "Expression is not clean." (badStoresInExpr expr) False - , test "simplify-storage-map-with-struct" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - struct MyStruct { - uint a; - uint b; - } - mapping(uint => MyStruct) items1; - function transfer(uint acct, uint val1, uint val2) public { - unchecked { - items1[acct].a = val1+1; - items1[acct].b = val2+2; - assert(items1[acct].a+items1[acct].b == val1 + val2 + 3); - } - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - assertEqualM "Expression is not clean." (badStoresInExpr expr) False - , test "simplify-storage-map-and-array" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - uint[] a; - mapping(uint => uint) items1; - mapping(uint => uint) items2; - function transfer(uint acct, uint val1, uint val2) public { - uint beforeVal1 = items1[acct]; - uint beforeVal2 = items2[acct]; - unchecked { - items1[acct] = val1+1; - items2[acct] = val2+2; - a[0] = val1 + val2 + 1; - a[1] = val1 + val2 + 2; - assert(items1[acct]+items2[acct]+a[0]+a[1] > beforeVal1 + beforeVal2); - } - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - -- putStrLnM $ T.unpack $ formatExpr expr - assertEqualM "Expression is not clean." (badStoresInExpr expr) False - ] - , testGroup "StorageTests" - [ test "read-from-sstore" $ assertEqualM "" - (Lit 0xab) - (Expr.readStorage' (Lit 0x0) (SStore (Lit 0x0) (Lit 0xab) (AbstractStore (LitAddr 0x0) Nothing))) - , test "read-from-concrete" $ assertEqualM "" - (Lit 0xab) - (Expr.readStorage' (Lit 0x0) (ConcreteStore $ Map.fromList [(0x0, 0xab)])) - , test "read-past-write" $ assertEqualM "" - (Lit 0xab) - (Expr.readStorage' (Lit 0x0) (SStore (Lit 0x1) (Var "b") (ConcreteStore $ Map.fromList [(0x0, 0xab)]))) - , test "accessStorage uses fetchedStorage" $ do - let dummyContract = - (initialContract (RuntimeCode (ConcreteRuntimeCode mempty))) - { external = True } - vm :: VM Concrete RealWorld <- liftIO $ stToIO $ vmForEthrunCreation "" - -- perform the initial access - vm1 <- liftIO $ stToIO $ execStateT (EVM.accessStorage (LitAddr 0) (Lit 0) (pure . pure ())) vm - -- it should fetch the contract first - vm2 <- case vm1.result of - Just (HandleEffect (Query (PleaseFetchContract _addr _ continue))) -> - liftIO $ stToIO $ execStateT (continue dummyContract) vm1 - _ -> internalError "unexpected result" - -- then it should fetch the slow - vm3 <- case vm2.result of - Just (HandleEffect (Query (PleaseFetchSlot _addr _slot continue))) -> - liftIO $ stToIO $ execStateT (continue 1337) vm2 - _ -> internalError "unexpected result" - -- perform the same access as for vm1 - vm4 <- liftIO $ stToIO $ execStateT (EVM.accessStorage (LitAddr 0) (Lit 0) (pure . pure ())) vm3 - - -- there won't be query now as accessStorage uses fetch cache - assertBoolM (show vm4.result) (isNothing vm4.result) - ] - , testGroup "SimplifierUnitTests" - -- common overflow cases that the simplifier was getting wrong - [ test "writeWord-overflow" $ do - let e = ReadByte (Lit 0x0) (WriteWord (Lit 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffd) (Lit 0x0) (ConcreteBuf "\255\255\255\255")) - b <- checkEquiv e (Expr.simplify e) - assertBoolM "Simplifier failed" b - , test "buffer-length-copy-slice-beyond-source1" $ do - let e = BufLength (CopySlice (Lit 0x2) (Lit 0x2) (Lit 0x1) (ConcreteBuf "a") (ConcreteBuf "")) - b <- checkEquiv e (Expr.simplify e) - assertBoolM "Simplifier failed" b - , test "buffer-length-copy-slice-beyond-source2" $ do - let e = BufLength (CopySlice (Lit 0x2) (Lit 0x2) (Lit 0x1) (ConcreteBuf "") (ConcreteBuf "")) - b <- checkEquiv e (Expr.simplify e) - assertBoolM "Simplifier failed" b - , test "simp-max-buflength" $ do - let simp = Expr.simplify $ Max (Lit 0) (BufLength (AbstractBuf "txdata")) - assertEqualM "max-buflength rules" simp $ BufLength (AbstractBuf "txdata") - , test "simp-PLT-max" $ do - let simp = Expr.simplifyProp $ PLT (Max (Lit 5) (BufLength (AbstractBuf "txdata"))) (Lit 99) - assertEqualM "max-buflength rules" simp $ PLT (BufLength (AbstractBuf "txdata")) (Lit 99) - , test "simp-assoc-add1" $ do - let simp = Expr.simplify $ Add (Var "a") (Add (Var "b") (Var "c")) - assertEqualM "assoc rules" simp $ Add (Add (Var "a") (Var "b")) (Var "c") - , test "simp-assoc-add2" $ do - let simp = Expr.simplify $ Add (Lit 1) (Add (Var "b") (Var "c")) - assertEqualM "assoc rules" simp $ Add (Add (Lit 1) (Var "b")) (Var "c") - , test "simp-assoc-add3" $ do - let simp = Expr.simplify $ Add (Lit 1) (Add (Lit 2) (Var "c")) - assertEqualM "assoc rules" simp $ Add (Lit 3) (Var "c") - , test "simp-assoc-add4" $ do - let simp = Expr.simplify $ Add (Lit 1) (Add (Var "b") (Lit 2)) - assertEqualM "assoc rules" simp $ Add (Lit 3) (Var "b") - , test "simp-assoc-add5" $ do - let simp = Expr.simplify $ Add (Var "a") (Add (Lit 1) (Lit 2)) - assertEqualM "assoc rules" simp $ Add (Lit 3) (Var "a") - , test "simp-assoc-add6" $ do - let simp = Expr.simplify $ Add (Lit 7) (Add (Lit 1) (Lit 2)) - assertEqualM "assoc rules" simp $ Lit 10 - , test "simp-assoc-add-7" $ do - let simp = Expr.simplify $ Add (Var "a") (Add (Var "b") (Lit 2)) - assertEqualM "assoc rules" simp $ Add (Add (Lit 2) (Var "a")) (Var "b") - , test "simp-assoc-add8" $ do - let simp = Expr.simplify $ Add (Add (Var "a") (Add (Lit 0x2) (Var "b"))) (Add (Var "c") (Add (Lit 0x2) (Var "d"))) - assertEqualM "assoc rules" simp $ Add (Add (Add (Add (Lit 0x4) (Var "a")) (Var "b")) (Var "c")) (Var "d") - , test "simp-assoc-mul1" $ do - let simp = Expr.simplify $ Mul (Var "a") (Mul (Var "b") (Var "c")) - assertEqualM "assoc rules" simp $ Mul (Mul (Var "a") (Var "b")) (Var "c") - , test "simp-assoc-mul2" $ do - let simp = Expr.simplify $ Mul (Lit 2) (Mul (Var "a") (Lit 3)) - assertEqualM "assoc rules" simp $ Mul (Lit 6) (Var "a") - , test "simp-zero-write-extend-buffer-len" $ do - let - expr = BufLength $ CopySlice (Lit 0) (Lit 0x10) (Lit 0) (AbstractBuf "buffer") (ConcreteBuf "bimm") - simp = Expr.simplify expr - ret <- checkEquiv expr simp - assertEqualM "Must be equivalent" True ret - , test "bufLength-simp" $ do - let - a = BufLength (ConcreteBuf "ab") - simp = Expr.simplify a - assertEqualM "Must be simplified down to a Lit" simp (Lit 2) - , test "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) - assertBoolM "Simplifier failed" b - , test "stripWrites-overflow" $ do - -- below eventually boils down to - -- unsafeInto (0xf0000000000000000000000000000000000000000000000000000000000000+1) :: Int - -- which failed before - let - a = ReadByte (Lit 0xf0000000000000000000000000000000000000000000000000000000000000) (WriteByte (And (SHA256 (ConcreteBuf "")) (Lit 0x1)) (LitByte 0) (ConcreteBuf "")) - b = Expr.simplify a - ret <- checkEquiv a b - assertBoolM "must be equivalent" ret - , test "read-beyond-bound (negative-test)" $ do - let - e1 = CopySlice (Lit 1) (Lit 0) (Lit 2) (ConcreteBuf "a") (ConcreteBuf "") - e2 = ConcreteBuf "Definitely not the same!" - equal <- checkEquiv e1 e2 - assertBoolM "Should not be equivalent!" $ not equal - ] - -- 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 - -- unsimplified one - , adjustOption (\(Test.Tasty.QuickCheck.QuickCheckTests n) -> Test.Tasty.QuickCheck.QuickCheckTests (div n 2)) $ testGroup "SimplifierTests" - [ testProperty "buffer-simplification" $ \(expr :: Expr Buf) -> prop $ do - let simplified = Expr.simplify expr - checkEquivAndLHS expr simplified - , testProperty "buffer-simplification-len" $ \(expr :: Expr Buf) -> prop $ do - let simplified = Expr.simplify (BufLength expr) - checkEquivAndLHS (BufLength expr) simplified - , testProperty "store-simplification" $ \(expr :: Expr Storage) -> prop $ do - let simplified = Expr.simplify expr - checkEquivAndLHS expr simplified - , testProperty "load-simplification" $ \(GenWriteStorageLoad expr) -> prop $ do - let simplified = Expr.simplify expr - checkEquivAndLHS expr simplified - , ignoreTest $ testProperty "load-decompose" $ \(GenWriteStorageLoad expr) -> prop $ do - putStrLnM $ T.unpack $ formatExpr expr - let simp = Expr.simplify expr - let decomposed = fromMaybe simp $ mapExprM Expr.decomposeStorage simp - -- putStrLnM $ "-----------------------------------------" - -- putStrLnM $ T.unpack $ formatExpr decomposed - -- putStrLnM $ "\n\n\n\n" - checkEquiv expr decomposed - , testProperty "byte-simplification" $ \(expr :: Expr Byte) -> prop $ do - let simplified = Expr.simplify expr - checkEquivAndLHS expr simplified - , testProperty "word-simplification" $ \(ZeroDepthWord expr) -> prop $ do - let simplified = Expr.simplify expr - checkEquivAndLHS expr simplified - , testProperty "readStorage-equivalance" $ \(store, slot) -> prop $ do - let simplified = Expr.readStorage' slot store - full = SLoad slot store - checkEquiv full simplified - , testProperty "writeStorage-equivalance" $ \(val, GenWriteStorageExpr (slot, store)) -> prop $ do - let simplified = Expr.writeStorage slot val store - full = SStore slot val store - checkEquiv full simplified - , testProperty "readWord-equivalance" $ \(buf, idx) -> prop $ do - let simplified = Expr.readWord idx buf - full = ReadWord idx buf - checkEquiv full simplified - , testProperty "writeWord-equivalance" $ \(idx, val, WriteWordBuf buf) -> prop $ do - let simplified = Expr.writeWord idx val buf - full = WriteWord idx val buf - checkEquiv full simplified - , testProperty "arith-simplification" $ \(_ :: Int) -> prop $ do - expr <- liftIO $ generate . sized $ genWordArith 15 - let simplified = Expr.simplify expr - checkEquivAndLHS expr simplified - , testProperty "readByte-equivalance" $ \(buf, idx) -> prop $ do - let simplified = Expr.readByte idx buf - full = ReadByte idx buf - checkEquiv full simplified - -- we currently only simplify concrete writes over concrete buffers so that's what we test here - , testProperty "writeByte-equivalance" $ \(LitOnly val, LitOnly buf, GenWriteByteIdx idx) -> prop $ do - let simplified = Expr.writeByte idx val buf - full = WriteByte idx val buf - checkEquiv full simplified - , testProperty "copySlice-equivalance" $ \(srcOff, GenCopySliceBuf src, GenCopySliceBuf dst, LitWord @300 size) -> prop $ do - -- we bias buffers to be concrete more often than not - dstOff <- liftIO $ generate (maybeBoundedLit 100_000) - let simplified = Expr.copySlice srcOff dstOff size src dst - full = CopySlice srcOff dstOff size src dst - checkEquiv full simplified - , testProperty "indexWord-equivalence" $ \(src, LitWord @50 idx) -> prop $ do - let simplified = Expr.indexWord idx src - full = IndexWord idx src - checkEquiv full simplified - , testProperty "indexWord-mask-equivalence" $ \(src :: Expr EWord, LitWord @35 idx) -> prop $ do - mask <- liftIO $ generate $ do - pow <- arbitrary :: Gen Int - frequency - [ (1, pure $ Lit $ (shiftL 1 (pow `mod` 256)) - 1) -- potentially non byte aligned - , (1, pure $ Lit $ (shiftL 1 ((pow * 8) `mod` 256)) - 1) -- byte aligned - ] - let - input = And mask src - simplified = Expr.indexWord idx input - full = IndexWord idx input - checkEquiv full simplified - , testProperty "toList-equivalance" $ \buf -> prop $ do - let - -- transforms the input buffer to give it a known length - fixLength :: Expr Buf -> Gen (Expr Buf) - fixLength = mapExprM go - where - go :: Expr a -> Gen (Expr a) - go = \case - WriteWord _ val b -> liftM3 WriteWord idx (pure val) (pure b) - WriteByte _ val b -> liftM3 WriteByte idx (pure val) (pure b) - CopySlice so _ sz src dst -> liftM5 CopySlice (pure so) idx (pure sz) (pure src) (pure dst) - AbstractBuf _ -> cbuf - e -> pure e - cbuf = do - bs <- arbitrary - pure $ ConcreteBuf bs - idx = do - w <- arbitrary - -- we use 100_000 as an upper bound for indices to keep tests reasonably fast here - pure $ Lit (w `mod` 100_000) - - input <- liftIO $ generate $ fixLength buf - case Expr.toList input of - Nothing -> do - putStrLnM "skip" - pure True -- ignore cases where the buf cannot be represented as a list - Just asList -> do - let asBuf = Expr.fromList asList - checkEquiv asBuf input - , testProperty "simplifyProp-equivalence-lit" $ \(LitProp p) -> prop $ do - let simplified = Expr.simplifyProps [p] - case simplified of - [] -> checkEquivProp (PBool True) p - [val@(PBool _)] -> checkEquivProp val p - _ -> liftIO $ assertFailure "must evaluate down to a literal bool" - , testProperty "simplifyProp-equivalence-sym" $ \(p) -> prop $ do - let simplified = Expr.simplifyProp p - checkEquivPropAndLHS p simplified - , testProperty "simpProp-equivalence-sym-Prop" $ \(ps :: [Prop]) -> prop $ do - let simplified = pand (Expr.simplifyProps ps) - checkEquivPropAndLHS (pand ps) simplified - , testProperty "simpProp-equivalence-sym-LitProp" $ \(LitProp p) -> prop $ do - let simplified = pand (Expr.simplifyProps [p]) - checkEquivPropAndLHS p simplified - , testProperty "storage-slot-simp-property" $ \(StorageExp s) -> prop $ do - -- we have to run `Expr.structureArraySlots` on the unsimplified system, or - -- we'd need some form of minimal simplifier for things to work out. As long as - -- we trust the structureArraySlots, this is fine, as that function is standalone, - -- and quite minimal - let s2 = Expr.structureArraySlots s - let simplified = Expr.simplify s2 - checkEquivAndLHS s2 simplified - , test "storage-slot-single" $ do - -- this tests that "" and "0"x32 is not equivalent in Keccak - let x = SLoad (Add (Keccak (ConcreteBuf "")) (Lit 1)) (SStore (Keccak (ConcreteBuf "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL")) (Lit 0) (AbstractStore (SymAddr "stuff") Nothing)) - let simplified = Expr.simplify x - y <- checkEquivAndLHS x simplified - assertBoolM "Must be equal" y - , test "word-eq-bug" $ do - -- This test is actually OK because the simplified takes into account that it's impossible to find a - -- near-collision in the keccak hash - let x = (SLoad (Keccak (AbstractBuf "es")) (SStore (Add (Keccak (ConcreteBuf "")) (Lit 0x1)) (Lit 0xacab) (ConcreteStore (Map.empty)))) - let simplified = Expr.simplify x - y <- checkEquiv x simplified - assertBoolM "Must be equal, given keccak distance axiom" y - ] - {- NOTE: These tests were designed to test behaviour on reading from a buffer such that the indices overflow 2^256. - However, such scenarios are impossible in the real world (the operation would run out of gas). The problem - is that the behaviour of bytecode interpreters does not match the semantics of SMT. Intrepreters just - return all zeroes for any read beyond buffer size, while in SMT reading multiple bytes may lead to overflow - on indices and subsequently to reading from the beginning of the buffer (wrap-around semantics). - , testGroup "concrete-buffer-simplification-large-index" [ - test "copy-slice-large-index-nooverflow" $ do - let - e = CopySlice (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Lit 0x0) (Lit 0x1) (ConcreteBuf "a") (ConcreteBuf "") - s = Expr.simplify e - equal <- checkEquiv e s - assertEqualM "Must be equal" True equal - , test "copy-slice-overflow-back-into-source" $ do - let - e = CopySlice (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Lit 0x0) (Lit 0x2) (ConcreteBuf "a") (ConcreteBuf "") - s = Expr.simplify e - equal <- checkEquiv e s - assertEqualM "Must be equal" True equal - , test "copy-slice-overflow-beyond-source" $ do - let - e = CopySlice (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Lit 0x0) (Lit 0x3) (ConcreteBuf "a") (ConcreteBuf "") - s = Expr.simplify e - equal <- checkEquiv e s - assertEqualM "Must be equal" True equal - , test "copy-slice-overflow-beyond-source-into-nonempty" $ do - let - e = CopySlice (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Lit 0x0) (Lit 0x3) (ConcreteBuf "a") (ConcreteBuf "b") - s = Expr.simplify e - equal <- checkEquiv e s - assertEqualM "Must be equal" True equal - , test "read-word-overflow-back-into-source" $ do - let - e = ReadWord (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (ConcreteBuf "kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk") - s = Expr.simplify e - equal <- checkEquiv e s - assertEqualM "Must be equal" True equal - ] - -} - , testGroup "isUnsat-concrete-tests" [ - test "disjunction-left-false" $ do - let - t = [PEq (Var "x") (Lit 1), POr (PEq (Var "x") (Lit 0)) (PEq (Var "y") (Lit 1)), PEq (Var "y") (Lit 2)] - cannotBeSat = Expr.isUnsat t - assertEqualM "Must be equal" cannotBeSat True - , test "disjunction-right-false" $ do - let - t = [PEq (Var "x") (Lit 1), POr (PEq (Var "y") (Lit 1)) (PEq (Var "x") (Lit 0)), PEq (Var "y") (Lit 2)] - cannotBeSat = Expr.isUnsat t - assertEqualM "Must be equal" cannotBeSat True - , test "disjunction-both-false" $ do - let - t = [PEq (Var "x") (Lit 1), POr (PEq (Var "x") (Lit 2)) (PEq (Var "x") (Lit 0)), PEq (Var "y") (Lit 2)] - cannotBeSat = Expr.isUnsat t - assertEqualM "Must be equal" cannotBeSat True - , ignoreTest $ test "disequality-and-equality" $ do - let - t = [PNeg (PEq (Lit 1) (Var "arg1")), PEq (Lit 1) (Var "arg1")] - cannotBeSat = Expr.isUnsat t - assertEqualM "Must be equal" cannotBeSat True - , test "equality-and-disequality" $ do - let - t = [PEq (Lit 1) (Var "arg1"), PNeg (PEq (Lit 1) (Var "arg1"))] - cannotBeSat = Expr.isUnsat t - assertEqualM "Must be equal" cannotBeSat True - ] - , testGroup "simpProp-concrete-tests" [ - test "simpProp-concrete-trues" $ do - let - t = [PBool True, PBool True] - simplified = Expr.simplifyProps t - assertEqualM "Must be equal" [] simplified - , test "simpProp-concrete-false1" $ do - let - t = [PBool True, PBool False] - simplified = Expr.simplifyProps t - assertEqualM "Must be equal" [PBool False] simplified - , test "simpProp-concrete-false2" $ do - let - t = [PBool False, PBool False] - simplified = Expr.simplifyProps t - assertEqualM "Must be equal" [PBool False] simplified - , test "simpProp-concrete-or-1" $ do - let - -- a = 5 && (a=4 || a=3) -> False - t = [PEq (Lit 5) (Var "a"), POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 3))] - simplified = Expr.simplifyProps t - assertEqualM "Must be equal" [PBool False] simplified - , ignoreTest $ test "simpProp-concrete-or-2" $ do - let - -- Currently does not work, because we don't do simplification inside - -- POr/PAnd using canBeSat - -- a = 5 && (a=4 || a=5) -> a=5 - t = [PEq (Lit 5) (Var "a"), POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 5))] - simplified = Expr.simplifyProps t - assertEqualM "Must be equal" [] simplified - , test "simpProp-concrete-and-1" $ do - let - -- a = 5 && (a=4 && a=3) -> False - t = [PEq (Lit 5) (Var "a"), PAnd (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 3))] - simplified = Expr.simplifyProps t - assertEqualM "Must be equal" [PBool False] simplified - , test "simpProp-concrete-or-of-or" $ do - let - -- a = 5 && ((a=4 || a=6) || a=3) -> False - t = [PEq (Lit 5) (Var "a"), POr (POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 6))) (PEq (Var "a") (Lit 3))] - simplified = Expr.simplifyProps t - assertEqualM "Must be equal" [PBool False] simplified - , test "simpProp-inner-expr-simp" $ do - let - -- 5+1 = 6 - t = [PEq (Add (Lit 5) (Lit 1)) (Var "a")] - simplified = Expr.simplifyProps t - assertEqualM "Must be equal" [PEq (Lit 6) (Var "a")] simplified - , test "simpProp-inner-expr-simp-with-canBeSat" $ do - let - -- 5+1 = 6, 6 != 7 - t = [PAnd (PEq (Add (Lit 5) (Lit 1)) (Var "a")) (PEq (Var "a") (Lit 7))] - simplified = Expr.simplifyProps t - assertEqualM "Must be equal" [PBool False] simplified - , test "simpProp-inner-expr-bitwise-and" $ do - let - -- 1 & 2 != 2 - t = [PEq (And (Lit 1) (Lit 2)) (Lit 2)] - simplified = Expr.simplifyProps t - assertEqualM "Must be equal" [PBool False] simplified - , test "simpProp-inner-expr-bitwise-or" $ do - let - -- 2 | 4 == 6 - t = [PEq (Or (Lit 2) (Lit 4)) (Lit 6)] - simplified = Expr.simplifyProps t - assertEqualM "Must be equal" [] simplified - ] - , testGroup "MemoryTests" - [ test "read-write-same-byte" $ assertEqualM "" - (LitByte 0x12) - (Expr.readByte (Lit 0x20) (WriteByte (Lit 0x20) (LitByte 0x12) mempty)) - , test "read-write-same-word" $ assertEqualM "" - (Lit 0x12) - (Expr.readWord (Lit 0x20) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) - , test "read-byte-write-word" $ assertEqualM "" - -- reading at byte 31 a word that's been written should return LSB - (LitByte 0x12) - (Expr.readByte (Lit 0x1f) (WriteWord (Lit 0x0) (Lit 0x12) mempty)) - , test "read-byte-write-word2" $ assertEqualM "" - -- Same as above, but offset not 0 - (LitByte 0x12) - (Expr.readByte (Lit 0x20) (WriteWord (Lit 0x1) (Lit 0x12) mempty)) - ,test "read-write-with-offset" $ assertEqualM "" - -- 0x3F = 63 decimal, 0x20 = 32. 0x12 = 18 - -- We write 128bits (32 Bytes), representing 18 at offset 32. - -- Hence, when reading out the 63rd byte, we should read out the LSB 8 bits - -- which is 0x12 - (LitByte 0x12) - (Expr.readByte (Lit 0x3F) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) - ,test "read-write-with-offset2" $ assertEqualM "" - -- 0x20 = 32, 0x3D = 61 - -- we write 128 bits (32 Bytes) representing 0x10012, at offset 32. - -- we then read out a byte at offset 61. - -- So, at 63 we'd read 0x12, at 62 we'd read 0x00, at 61 we should read 0x1 - (LitByte 0x1) - (Expr.readByte (Lit 0x3D) (WriteWord (Lit 0x20) (Lit 0x10012) mempty)) - , test "read-write-with-extension-to-zero" $ assertEqualM "" - -- write word and read it at the same place (i.e. 0 offset) - (Lit 0x12) - (Expr.readWord (Lit 0x0) (WriteWord (Lit 0x0) (Lit 0x12) mempty)) - , test "read-write-with-extension-to-zero-with-offset" $ assertEqualM "" - -- write word and read it at the same offset of 4 - (Lit 0x12) - (Expr.readWord (Lit 0x4) (WriteWord (Lit 0x4) (Lit 0x12) mempty)) - , test "read-write-with-extension-to-zero-with-offset2" $ assertEqualM "" - -- write word and read it at the same offset of 16 - (Lit 0x12) - (Expr.readWord (Lit 0x20) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) - , test "read-word-copySlice-overlap" $ assertEqualM "" - -- we should not recurse into a copySlice if the read index + 32 overlaps the sliced region - (ReadWord (Lit 40) (CopySlice (Lit 0) (Lit 30) (Lit 12) (WriteWord (Lit 10) (Lit 0x64) (AbstractBuf "hi")) (AbstractBuf "hi"))) - (Expr.readWord (Lit 40) (CopySlice (Lit 0) (Lit 30) (Lit 12) (WriteWord (Lit 10) (Lit 0x64) (AbstractBuf "hi")) (AbstractBuf "hi"))) - , test "indexword-MSB" $ assertEqualM "" - -- 31st is the LSB byte (of 32) - (LitByte 0x78) - (Expr.indexWord (Lit 31) (Lit 0x12345678)) - , test "indexword-LSB" $ assertEqualM "" - -- 0th is the MSB byte (of 32), Lit 0xff22bb... is exactly 32 Bytes. - (LitByte 0xff) - (Expr.indexWord (Lit 0) (Lit 0xff22bb4455667788990011223344556677889900112233445566778899001122)) - , test "indexword-LSB2" $ assertEqualM "" - -- same as above, but with offset 2 - (LitByte 0xbb) - (Expr.indexWord (Lit 2) (Lit 0xff22bb4455667788990011223344556677889900112233445566778899001122)) - , test "encodeConcreteStore-overwrite" $ - assertEqualM "" - (pure "(store (store ((as const Storage) #x0000000000000000000000000000000000000000000000000000000000000000) (_ bv1 256) (_ bv2 256)) (_ bv3 256) (_ bv4 256))") - (EVM.SMT.encodeConcreteStore $ Map.fromList [(W256 1, W256 2), (W256 3, W256 4)]) - , test "indexword-oob-sym" $ assertEqualM "" - -- indexWord should return 0 for oob access - (LitByte 0x0) - (Expr.indexWord (Lit 100) (JoinBytes - (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) - (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) - (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) - (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0))) - , test "stripbytes-concrete-bug" $ assertEqualM "" - (Expr.simplifyReads (ReadByte (Lit 0) (ConcreteBuf "5"))) - (LitByte 53) - ] - , testGroup "ABI" - [ testProperty "Put/get inverse" $ \x -> - case runGetOrFail (getAbi (abiValueType x)) (runPut (putAbi x)) of - Right ("", _, x') -> x' == x - _ -> False - ] - , testGroup "Solidity-Expressions" - [ test "Trivial" $ - SolidityCall "x = 3;" [] - ===> AbiUInt 256 3 - , test "Arithmetic" $ do - SolidityCall "x = a + 1;" - [AbiUInt 256 1] ===> AbiUInt 256 2 - SolidityCall "unchecked { x = a - 1; }" - [AbiUInt 8 0] ===> AbiUInt 8 255 - - , test "keccak256()" $ - SolidityCall "x = uint(keccak256(abi.encodePacked(a)));" - [AbiString ""] ===> AbiUInt 256 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470 - - , testProperty "symbolic-abi-enc-vs-solidity" $ \(SymbolicAbiVal y) -> prop $ do - Just encoded <- runStatements [i| x = abi.encode(a);|] [y] AbiBytesDynamicType - let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of - AbiTuple (V.toList -> [e]) -> e - _ -> internalError "AbiTuple expected" - let - frag = [symAbiArg "y" (AbiTupleType $ V.fromList [abiValueType y])] - (hevmEncoded, _) = first (Expr.drop 4) $ combineFragments frag (ConcreteBuf "") - expectedVals = expectedConcVals "y" (AbiTuple . V.fromList $ [y]) - hevmConcretePre = subModel expectedVals hevmEncoded - hevmConcrete = case Expr.simplify hevmConcretePre of - ConcreteBuf b -> b - buf -> internalError ("valMap: " <> show expectedVals <> "\ny:" <> show y <> "\n" <> "buf: " <> show buf) - -- putStrLnM $ "frag: " <> show frag - -- putStrLnM $ "expectedVals: " <> show expectedVals - -- putStrLnM $ "frag: " <> show frag - -- putStrLnM $ "hevmEncoded: " <> show hevmEncoded - -- putStrLnM $ "solidity encoded: " <> show solidityEncoded - -- putStrLnM $ "our encoded : " <> show (AbiBytesDynamic hevmConcrete) - -- putStrLnM $ "y : " <> show y - -- putStrLnM $ "y type: " <> showAlter y - -- putStrLnM $ "hevmConcretePre: " <> show hevmConcretePre - assertEqualM "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmConcrete) - , testProperty "symbolic-abi encoding-vs-solidity-2-args" $ \(SymbolicAbiVal x', SymbolicAbiVal y') -> prop $ do - Just encoded <- runStatements [i| x = abi.encode(a, b);|] [x', y'] AbiBytesDynamicType - let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of - AbiTuple (V.toList -> [e]) -> e - _ -> internalError "AbiTuple expected" - let hevmEncoded = encodeAbiValue (AbiTuple $ V.fromList [x',y']) - assertEqualM "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) - , testProperty "abi-encoding-vs-solidity" $ forAll (arbitrary >>= genAbiValue) $ - \y -> prop $ do - Just encoded <- runStatements [i| x = abi.encode(a);|] - [y] AbiBytesDynamicType - let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of - AbiTuple (V.toList -> [e]) -> e - _ -> internalError "AbiTuple expected" - let hevmEncoded = encodeAbiValue (AbiTuple $ V.fromList [y]) - assertEqualM "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) - - , testProperty "abi-encoding-vs-solidity-2-args" $ forAll (arbitrary >>= bothM genAbiValue) $ - \(x', y') -> prop $ do - Just encoded <- runStatements [i| x = abi.encode(a, b);|] - [x', y'] AbiBytesDynamicType - let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of - AbiTuple (V.toList -> [e]) -> e - _ -> internalError "AbiTuple expected" - let hevmEncoded = encodeAbiValue (AbiTuple $ V.fromList [x',y']) - assertEqualM "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) - - -- we need a separate test for this because the type of a function is "function() external" in solidity but just "function" in the abi: - , askOption $ \(QuickCheckTests n) -> testProperty "abi-encoding-vs-solidity-function-pointer" $ withMaxSuccess (min n 20) $ forAll (genAbiValue AbiFunctionType) $ - \y -> prop $ do - Just encoded <- runFunction [i| - function foo(function() external a) public pure returns (bytes memory x) { - x = abi.encode(a); - } - |] (abiMethod "foo(function)" (AbiTuple (V.singleton y))) - let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of - AbiTuple (V.toList -> [e]) -> e - _ -> internalError "AbiTuple expected" - let hevmEncoded = encodeAbiValue (AbiTuple $ V.fromList [y]) - assertEqualM "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) - ] - - , testGroup "Precompiled contracts" - [ testGroup "Example (reverse)" - [ test "success" $ - assertEqualM "example contract reverses" - (execute 0xdeadbeef "foobar" 6) (Just "raboof") - , test "failure" $ - assertEqualM "example contract fails on length mismatch" - (execute 0xdeadbeef "foobar" 5) Nothing - ] - - , testGroup "ECRECOVER" - [ test "success" $ do - let - r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4732" - s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" - v = hex "000000000000000000000000000000000000000000000000000000000000001c" - h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31" - a = hex "0000000000000000000000002d5e56d45c63150d937f2182538a0f18510cb11f" - assertEqualM "successful recovery" - (Just a) - (execute 1 (h <> v <> r <> s) 32) - , test "fail on made up values" $ do - let - r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4731" - s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" - v = hex "000000000000000000000000000000000000000000000000000000000000001c" - h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31" - assertEqualM "fail because bit flip" - Nothing - (execute 1 (h <> v <> r <> s) 32) - ] - ] - , testGroup "Byte/word manipulations" - [ testProperty "padLeft length" $ \n (Bytes bs) -> - BS.length (padLeft n bs) == max n (BS.length bs) - , testProperty "padLeft identity" $ \(Bytes bs) -> - padLeft (BS.length bs) bs == bs - , testProperty "padRight length" $ \n (Bytes bs) -> - BS.length (padLeft n bs) == max n (BS.length bs) - , testProperty "padRight identity" $ \(Bytes bs) -> - padLeft (BS.length bs) bs == bs - , testProperty "padLeft zeroing" $ \(NonNegative n) (Bytes bs) -> - let x = BS.take n (padLeft (BS.length bs + n) bs) - y = BS.replicate n 0 - in x == y - ] - - , testGroup "Unresolved link detection" - [ test "holes detected" $ do - let code' = "608060405234801561001057600080fd5b5060405161040f38038061040f83398181016040528101906100329190610172565b73__$f3cbc3eb14e5bd0705af404abcf6f741ec$__63ab5c1ffe826040518263ffffffff1660e01b81526004016100699190610217565b60206040518083038186803b15801561008157600080fd5b505af4158015610095573d6000803e3d6000fd5b505050506040513d601f19601f820116820180604052508101906100b99190610145565b50506103c2565b60006100d36100ce84610271565b61024c565b9050828152602081018484840111156100ef576100ee610362565b5b6100fa8482856102ca565b509392505050565b600081519050610111816103ab565b92915050565b600082601f83011261012c5761012b61035d565b5b815161013c8482602086016100c0565b91505092915050565b60006020828403121561015b5761015a61036c565b5b600061016984828501610102565b91505092915050565b6000602082840312156101885761018761036c565b5b600082015167ffffffffffffffff8111156101a6576101a5610367565b5b6101b284828501610117565b91505092915050565b60006101c6826102a2565b6101d081856102ad565b93506101e08185602086016102ca565b6101e981610371565b840191505092915050565b60006102016003836102ad565b915061020c82610382565b602082019050919050565b6000604082019050818103600083015261023181846101bb565b90508181036020830152610244816101f4565b905092915050565b6000610256610267565b905061026282826102fd565b919050565b6000604051905090565b600067ffffffffffffffff82111561028c5761028b61032e565b5b61029582610371565b9050602081019050919050565b600081519050919050565b600082825260208201905092915050565b60008115159050919050565b60005b838110156102e85780820151818401526020810190506102cd565b838111156102f7576000848401525b50505050565b61030682610371565b810181811067ffffffffffffffff821117156103255761032461032e565b5b80604052505050565b7f4e487b7100000000000000000000000000000000000000000000000000000000600052604160045260246000fd5b600080fd5b600080fd5b600080fd5b600080fd5b6000601f19601f8301169050919050565b7f6261720000000000000000000000000000000000000000000000000000000000600082015250565b6103b4816102be565b81146103bf57600080fd5b50565b603f806103d06000396000f3fe6080604052600080fdfea26469706673582212207d03b26e43dc3d116b0021ddc9817bde3762a3b14315351f11fc4be384fd14a664736f6c63430008060033" - assertBoolM "linker hole not detected" (containsLinkerHole code'), - test "no false positives" $ do - let code' = "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fea265627a7a723158205d775f914dcb471365a430b5f5b2cfe819e615cbbb5b2f1ccc7da1fd802e43c364736f6c634300050b0032" - assertBoolM "false positive" (not . containsLinkerHole $ code') - ] - - , testGroup "metadata stripper" - [ test "it strips the metadata for solc => 0.6" $ do - let code' = hexText "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fea265627a7a723158205d775f914dcb471365a430b5f5b2cfe819e615cbbb5b2f1ccc7da1fd802e43c364736f6c634300050b0032" - stripped = stripBytecodeMetadata code' - assertEqualM "failed to strip metadata" (show (ByteStringS stripped)) "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fe" - , - testCase "it strips the metadata and constructor args" $ do - let srccode = - [i| - contract A { - uint y; - constructor(uint x) public { - y = x; - } - } - |] - - Just initCode <- solidity "A" srccode - assertEqual "constructor args screwed up metadata stripping" (stripBytecodeMetadata (initCode <> encodeAbiValue (AbiUInt 256 1))) (stripBytecodeMetadata initCode) - ] - - , testGroup "RLP encodings" - [ testProperty "rlp decode is a retraction (bytes)" $ \(Bytes bs) -> - rlpdecode (rlpencode (BS bs)) == Just (BS bs) - , testProperty "rlp encode is a partial inverse (bytes)" $ \(Bytes bs) -> - case rlpdecode bs of - Just r -> rlpencode r == bs - Nothing -> True - , testProperty "rlp decode is a retraction (RLP)" $ \(RLPData r) -> - rlpdecode (rlpencode r) == Just r - ] - , testGroup "Panic code tests via symbolic execution" - [ - test "assert-fail" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a) external pure { - assert(a != 0); - } - } - |] - (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s [0x01] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - assertEqualM "Must be 0" 0 $ getVar ctr "arg1" - putStrLnM $ "expected counterexample found, and it's correct: " <> (show $ getVar ctr "arg1") - , - test "safeAdd-fail" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a, uint256 b) external pure returns (uint256 c) { - c = a+b; - } - } - |] - (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s [0x11] c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - let x = getVar ctr "arg1" - let y = getVar ctr "arg2" - - let maxUint = 2 ^ (256 :: Integer) :: Integer - assertBoolM "Overflow must occur" (toInteger x + toInteger y >= maxUint) - putStrLnM "expected counterexample found" - , - test "div-by-zero-fail" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a, uint256 b) external pure returns (uint256 c) { - c = a/b; - } - } - |] - (_, [Cex (_, ctr)]) <- withSolvers Bitwuzla 1 1 Nothing $ \s -> checkAssert s [0x12] c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - assertEqualM "Division by 0 needs b=0" (getVar ctr "arg2") 0 - putStrLnM "expected counterexample found" - , - test "unused-args-fail" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun(uint256 a) public pure { - assert(false); - } - } - |] - (_, [Cex _]) <- withSolvers Bitwuzla 1 1 Nothing $ \s -> checkAssert s [0x1] c Nothing [] defaultVeriOpts - putStrLnM "expected counterexample found" - , - test "enum-conversion-fail" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - enum MyEnum { ONE, TWO } - function fun(uint256 a) external pure returns (MyEnum b) { - b = MyEnum(a); - } - } - |] - (_, [Cex (_, ctr)]) <- withSolvers Bitwuzla 1 1 Nothing $ \s -> checkAssert s [0x21] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - assertBoolM "Enum is only defined for 0 and 1" $ (getVar ctr "arg1") > 1 - putStrLnM "expected counterexample found" - , - -- TODO 0x22 is missing: "0x22: If you access a storage byte array that is incorrectly encoded." - -- TODO below should NOT fail - -- TODO this has a loop that depends on a symbolic value and currently causes interpret to loop - ignoreTest $ test "pop-empty-array" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - uint[] private arr; - function fun(uint8 a) external { - arr.push(1); - arr.push(2); - for (uint i = 0; i < a; i++) { - arr.pop(); - } - } - } - |] - a <- withDefaultSolver $ \s -> checkAssert s [0x31] c (Just (Sig "fun(uint8)" [AbiUIntType 8])) [] defaultVeriOpts - liftIO $ do - print $ length a - print $ show a - putStrLnM "expected counterexample found" - , - test "access-out-of-bounds-array" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - uint[] private arr; - function fun(uint8 a) external returns (uint x){ - arr.push(1); - arr.push(2); - x = arr[a]; - } - } - |] - (_, [Cex (_, _)]) <- withDefaultSolver $ \s -> checkAssert s [0x32] c (Just (Sig "fun(uint8)" [AbiUIntType 8])) [] defaultVeriOpts - -- assertBoolM "Access must be beyond element 2" $ (getVar ctr "arg1") > 1 - putStrLnM "expected counterexample found" - , - -- Note: we catch the assertion here, even though we are only able to explore partially - test "alloc-too-much" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a) external { - uint[] memory arr = new uint[](a); - } - } - |] - (_, [Cex _]) <- withDefaultSolver $ \s -> - checkAssert s [0x41] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "expected counterexample found" - , - test "vm.deal unknown address" $ do - Just c <- solcRuntime "C" - [i| - interface Vm { - function deal(address,uint256) external; - } - contract C { - // this is not supported yet due to restrictions around symbolic address aliasing... - function f(address e, uint val) external { - Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); - vm.deal(e, val); - assert(e.balance == val); - } - } - |] - Right e <- reachableUserAsserts c (Just $ Sig "f(address,uint256)" [AbiAddressType, AbiUIntType 256]) - assertBoolM "The expression is not partial" $ Expr.containsNode isPartial e - , - test "vm.prank-create" $ do - Just c <- solcRuntime "C" - [i| - interface Vm { - function prank(address) external; - } - contract Owned { - address public owner; - constructor() { - owner = msg.sender; - } - } - contract C { - function f() external { - Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); - - Owned target = new Owned(); - assert(target.owner() == address(this)); - - address usr = address(1312); - vm.prank(usr); - target = new Owned(); - assert(target.owner() == usr); - target = new Owned(); - assert(target.owner() == address(this)); - } - } - |] - Right _ <- reachableUserAsserts c (Just $ Sig "f()" []) - liftIO $ putStrLn "no reachable assertion violations" - , - test "vm.prank underflow" $ do - Just c <- solcRuntime "C" - [i| - interface Vm { - function prank(address) external; - } - contract Payable { - function hi() public payable {} - } - contract C { - function f() external { - Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); - - uint amt = 10; - address from = address(0xacab); - require(from.balance < amt); - - Payable target = new Payable(); - vm.prank(from); - target.hi{value : amt}(); - } - } - |] - r <- allBranchesFail c Nothing - assertBoolM "all branches must fail" (isRight r) - , - test "call ffi when disabled" $ do - Just c <- solcRuntime "C" - [i| - interface Vm { - function ffi(string[] calldata) external; - } - contract C { - function f() external { - Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); - - string[] memory inputs = new string[](2); - inputs[0] = "echo"; - inputs[1] = "acab"; - - // should fail to explore this branch - vm.ffi(inputs); - } - } - |] - Right e <- reachableUserAsserts c Nothing - liftIO $ T.putStrLn $ formatExpr e - assertBoolM "The expression is not partial" $ Expr.containsNode isPartial e - , - -- TODO: we can't deal with symbolic jump conditions - expectFail $ test "call-zero-inited-var-thats-a-function" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function (uint256) internal returns (uint) funvar; - function fun2(uint256 a) internal returns (uint){ - return a; - } - function fun(uint256 a) external returns (uint) { - if (a != 44) { - funvar = fun2; - } - return funvar(a); - } - } - |] - (_, [Cex (_, cex)]) <- withDefaultSolver $ - \s -> checkAssert s [0x51] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - let a = fromJust $ Map.lookup (Var "arg1") cex.vars - assertEqualM "unexpected cex value" a 44 - putStrLnM "expected counterexample found" - , - test "symbolic-mcopy" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a, uint256 s) external returns (uint) { - require(a < 5); - assembly { - mcopy(0x2, 0, s) - a:=mload(s) - } - assert(a < 5); - return a; - } - } - |] - let sig = Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) - (_, k) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts - putStrLnM $ "Ret: " <> (show k) - , - test "symbolic-copyslice" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a, uint256 s) external returns (uint) { - require(a < 10); - if (a >= 8) { - assembly { - calldatacopy(0x5, s, s) - a:=mload(s) - } - } else { - assembly { - calldatacopy(0x2, 0x2, 5) - a:=mload(s) - } - } - assert(a < 9); - return a; - } - } - |] - let sig = Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) - (_, k) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts - putStrLnM $ "Ret: " <> (show k) - ] - , testGroup "Symbolic-Constructor-Args" - -- this produced some hard to debug failures. keeping it around since it seemed to exercise the contract creation code in interesting ways... - [ test "multiple-symbolic-constructor-calls" $ do - Just initCode <- solidity "C" - [i| - contract A { - uint public x; - constructor (uint z) {} - } - - contract B { - constructor (uint i) {} - - } - - contract C { - constructor(uint u) { - new A(u); - new B(u); - } - } - |] - withSolvers Bitwuzla 1 1 Nothing $ \s -> do - let calldata = (WriteWord (Lit 0x0) (Var "u") (ConcreteBuf ""), []) - initVM <- liftIO $ stToIO $ abstractVM calldata initCode Nothing True - expr <- Expr.simplify <$> interpret (Fetch.oracle s Nothing) Nothing 1 StackBased initVM runExpr - assertBoolM "unexptected partial execution" (not $ Expr.containsNode isPartial expr) - , test "mixed-concrete-symbolic-args" $ do - Just c <- solcRuntime "C" - [i| - contract B { - uint public x; - uint public y; - constructor (uint i, uint j) { - x = i; - y = j; - } - - } - - contract C { - function foo(uint i) public { - B b = new B(10, i); - assert(b.x() == 10); - assert(b.y() == i); - } - } - |] - Right expr <- reachableUserAsserts c (Just $ Sig "foo(uint256)" [AbiUIntType 256]) - assertBoolM "unexptected partial execution" (not $ Expr.containsNode isPartial expr) - , test "jump-into-symbolic-region" $ do - let - -- our initCode just jumps directly to the end - code = BS.pack . mapMaybe maybeLitByte $ V.toList $ assemble - [ OpPush (Lit 0x85) - , OpJump - , OpPush (Lit 1) - , OpPush (Lit 1) - , OpPush (Lit 1) - , OpJumpdest - ] - -- we write a symbolic word to the middle, so the jump above should - -- fail since the target is not in the concrete region - initCode = (WriteWord (Lit 0x43) (Var "HI") (ConcreteBuf code), []) - - -- we pass in the above initCode buffer as calldata, and then copy - -- it into memory before calling Create - runtimecode = RuntimeCode (SymbolicRuntimeCode $ assemble - [ OpPush (Lit 0x85) - , OpPush (Lit 0x0) - , OpPush (Lit 0x0) - , OpCalldatacopy - , OpPush (Lit 0x85) - , OpPush (Lit 0x0) - , OpPush (Lit 0x0) - , OpCreate - ]) - withDefaultSolver $ \s -> do - vm <- liftIO $ stToIO $ loadSymVM runtimecode (Lit 0) initCode False - expr <- Expr.simplify <$> interpret (Fetch.oracle s Nothing) Nothing 1 StackBased vm runExpr - case expr of - Partial _ _ (JumpIntoSymbolicCode _ _) -> assertBoolM "" True - _ -> assertBoolM "did not encounter expected partial node" False - ] - , testGroup "Dapp-Tests" - [ test "Trivial-Pass" $ do - let testFile = "test/contracts/pass/trivial.sol" - runSolidityTest testFile ".*" >>= assertEqualM "test result" True - , test "Foundry" $ do - -- quick smokecheck to make sure that we can parse ForgeStdLib style build outputs - let cases = - [ ("test/contracts/pass/trivial.sol", ".*", True) - , ("test/contracts/pass/dsProvePass.sol", "proveEasy", True) - , ("test/contracts/fail/trivial.sol", ".*", False) - , ("test/contracts/fail/dsProveFail.sol", "prove_add", False) - ] - results <- forM cases $ \(testFile, match, expected) -> do - actual <- runSolidityTestCustom testFile match Nothing Nothing False Nothing Foundry - pure (actual == expected) - assertBoolM "test result" (and results) - , test "Trivial-Fail" $ do - let testFile = "test/contracts/fail/trivial.sol" - runSolidityTest testFile "prove_false" >>= assertEqualM "test result" False - , test "Abstract" $ do - let testFile = "test/contracts/pass/abstract.sol" - runSolidityTest testFile ".*" >>= assertEqualM "test result" True - , test "Constantinople" $ do - let testFile = "test/contracts/pass/constantinople.sol" - runSolidityTest testFile ".*" >>= assertEqualM "test result" True - , test "ConstantinopleMin" $ do - let testFile = "test/contracts/pass/constantinople_min.sol" - runSolidityTest testFile ".*" >>= assertEqualM "test result" True - , test "Prove-Tests-Pass" $ do - let testFile = "test/contracts/pass/dsProvePass.sol" - runSolidityTest testFile ".*" >>= assertEqualM "test result" True - , test "prefix-check-for-dapp" $ do - let testFile = "test/contracts/fail/check-prefix.sol" - runSolidityTest testFile "check_trivial" >>= assertEqualM "test result" False - , test "transfer-dapp" $ do - let testFile = "test/contracts/pass/transfer.sol" - runSolidityTest testFile "prove_transfer" >>= assertEqualM "should prove transfer" True - , test "badvault-sym-branch" $ do - let testFile = "test/contracts/fail/10_BadVault.sol" - runSolidityTestCustom testFile "prove_BadVault_usingExploitLaunchPad" Nothing Nothing True Nothing Foundry >>= assertEqualM "Must find counterexample" False - , test "Prove-Tests-Fail" $ do - let testFile = "test/contracts/fail/dsProveFail.sol" - runSolidityTest testFile "prove_trivial" >>= assertEqualM "test result" False - runSolidityTest testFile "prove_trivial_dstest" >>= assertEqualM "test result" False - runSolidityTest testFile "prove_add" >>= assertEqualM "test result" False - runSolidityTestCustom testFile "prove_smtTimeout" (Just 1) Nothing False Nothing Foundry >>= assertEqualM "test result" False - runSolidityTest testFile "prove_multi" >>= assertEqualM "test result" False - runSolidityTest testFile "prove_distributivity" >>= assertEqualM "test result" False - , test "Loop-Tests" $ do - let testFile = "test/contracts/pass/loops.sol" - runSolidityTestCustom testFile "prove_loop" Nothing (Just 10) False Nothing Foundry >>= assertEqualM "test result" True - runSolidityTestCustom testFile "prove_loop" Nothing (Just 100) False Nothing Foundry >>= assertEqualM "test result" False - , test "Cheat-Codes-Pass" $ do - let testFile = "test/contracts/pass/cheatCodes.sol" - runSolidityTest testFile ".*" >>= assertEqualM "test result" True - , test "Cheat-Codes-Fork-Pass" $ do - let testFile = "test/contracts/pass/cheatCodesFork.sol" - runSolidityTest testFile ".*" >>= assertEqualM "test result" True - , test "Unwind" $ do - let testFile = "test/contracts/pass/unwind.sol" - runSolidityTest testFile ".*" >>= assertEqualM "test result" True - ] - , testGroup "max-iterations" - [ test "concrete-loops-reached" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun() external payable returns (uint) { - uint count = 0; - for (uint i = 0; i < 5; i++) count++; - return count; - } - } - |] - let sig = Just $ Sig "fun()" [] - opts = defaultVeriOpts{ maxIter = Just 3 } - (e, [Qed _]) <- withDefaultSolver $ - \s -> checkAssert s defaultPanicCodes c sig [] opts - assertBoolM "The expression is not partial" $ isPartial e - , test "concrete-loops-not-reached" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun() external payable returns (uint) { - uint count = 0; - for (uint i = 0; i < 5; i++) count++; - return count; - } - } - |] - - let sig = Just $ Sig "fun()" [] - opts = defaultVeriOpts{ maxIter = Just 6 } - (e, [Qed _]) <- withDefaultSolver $ - \s -> checkAssert s defaultPanicCodes c sig [] opts - assertBoolM "The expression is partial" $ not $ isPartial e - , test "symbolic-loops-reached" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun(uint j) external payable returns (uint) { - uint count = 0; - for (uint i = 0; i < j; i++) count++; - return count; - } - } - |] - (e, [Qed _]) <- withDefaultSolver $ - \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] (defaultVeriOpts{ maxIter = Just 5 }) - assertBoolM "The expression is not partial" $ Expr.containsNode isPartial e - , test "inconsistent-paths" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun(uint j) external payable returns (uint) { - require(j <= 3); - uint count = 0; - for (uint i = 0; i < j; i++) count++; - return count; - } - } - |] - let sig = Just $ Sig "fun(uint256)" [AbiUIntType 256] - -- we don't ask the solver about the loop condition until we're - -- already in an inconsistent path (i == 5, j <= 3, i < j), so we - -- will continue looping here until we hit max iterations - opts = defaultVeriOpts{ maxIter = Just 10, askSmtIters = 5 } - (e, [Qed _]) <- withDefaultSolver $ - \s -> checkAssert s defaultPanicCodes c sig [] opts - assertBoolM "The expression is not partial" $ Expr.containsNode isPartial e - , test "mem-tuple" $ do - Just c <- solcRuntime "C" - [i| - contract C { - struct Pair { - uint x; - uint y; - } - function prove_tuple_pass(Pair memory p) public pure { - uint256 f = p.x; - uint256 g = p.y; - unchecked { - p.x+=p.y; - assert(p.x == (f + g)); - } - } - } - |] - let opts = defaultVeriOpts - let sig = Just $ Sig "prove_tuple_pass((uint256,uint256))" [AbiTupleType (V.fromList [AbiUIntType 256, AbiUIntType 256])] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] opts - putStrLnM "Qed, memory tuple is good" - , test "symbolic-loops-not-reached" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun(uint j) external payable returns (uint) { - require(j <= 3); - uint count = 0; - for (uint i = 0; i < j; i++) count++; - return count; - } - } - |] - let sig = Just $ Sig "fun(uint256)" [AbiUIntType 256] - -- askSmtIters is low enough here to avoid the inconsistent path - -- conditions, so we never hit maxIters - opts = defaultVeriOpts{ maxIter = Just 5, askSmtIters = 1 } - (e, [Qed _]) <- withDefaultSolver $ - \s -> checkAssert s defaultPanicCodes c sig [] opts - assertBoolM "The expression is partial" $ not (Expr.containsNode isPartial e) - ] - , testGroup "Symbolic Addresses" - [ test "symbolic-address-create" $ do - let src = [i| - contract A { - constructor() payable {} - } - contract C { - function fun(uint256 a) external{ - require(address(this).balance > a); - new A{value:a}(); - } - } - |] - Just a <- solcRuntime "A" src - Just c <- solcRuntime "C" src - let sig = Sig "fun(uint256)" [AbiUIntType 256] - (expr, [Qed _]) <- withDefaultSolver $ \s -> - verifyContract s c (Just sig) [] defaultVeriOpts Nothing Nothing - let isSuc (Success {}) = True - isSuc _ = False - case filter isSuc (flattenExpr expr) of - [Success _ _ _ store] -> do - let ca = fromJust (Map.lookup (SymAddr "freshSymAddr1") store) - let code = case ca.code of - RuntimeCode (ConcreteRuntimeCode c') -> c' - _ -> internalError "expected concrete code" - assertEqualM "balance mismatch" (Var "arg1") ca.balance - assertEqualM "code mismatch" (stripBytecodeMetadata a) (stripBytecodeMetadata code) - assertEqualM "nonce mismatch" (Just 1) ca.nonce - _ -> assertBoolM "too many success nodes!" False - , test "symbolic-balance-call" $ do - let src = [i| - contract A { - function f() public payable returns (uint) { - return msg.value; - } - } - contract C { - function fun(uint256 x) external { - require(address(this).balance > x); - A a = new A(); - uint res = a.f{value:x}(); - assert(res == x); - } - } - |] - Just c <- solcRuntime "C" src - res <- reachableUserAsserts c Nothing - assertBoolM "unexpected cex" (isRight res) - -- TODO: implement missing aliasing rules - , expectFail $ test "deployed-contract-addresses-cannot-alias" $ do - Just c <- solcRuntime "C" - [i| - contract A {} - contract C { - function f() external { - A a = new A(); - if (address(a) == address(this)) assert(false); - } - } - |] - res <- reachableUserAsserts c Nothing - assertBoolM "should not be able to alias" (isRight res) - , test "addresses-in-args-can-alias-anything" $ do - let addrs :: [Text] - addrs = ["address(this)", "tx.origin", "block.coinbase", "msg.sender"] - sig = Just $ Sig "f(address)" [AbiAddressType] - checkVs vs = [i| - contract C { - function f(address a) external { - if (${vs} == a) assert(false); - } - } - |] - - [self, origin, coinbase, caller] <- forM addrs $ \addr -> do - Just c <- solcRuntime "C" (checkVs addr) - Left [cex] <- reachableUserAsserts c sig - pure cex.addrs - - liftIO $ do - let check as a = (Map.lookup (SymAddr "arg1") as) @?= (Map.lookup a as) - check self (SymAddr "entrypoint") - check origin (SymAddr "origin") - check coinbase (SymAddr "coinbase") - check caller (SymAddr "caller") - , test "addresses-in-args-can-alias-themselves" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function f(address a, address b) external { - if (a == b) assert(false); - } - } - |] - let sig = Just $ Sig "f(address,address)" [AbiAddressType,AbiAddressType] - Left [cex] <- reachableUserAsserts c sig - let arg1 = fromJust $ Map.lookup (SymAddr "arg1") cex.addrs - arg2 = fromJust $ Map.lookup (SymAddr "arg1") cex.addrs - assertEqualM "should match" arg1 arg2 - -- TODO: fails due to missing aliasing rules - , expectFail $ test "tx.origin cannot alias deployed contracts" $ do - Just c <- solcRuntime "C" - [i| - contract A {} - contract C { - function f() external { - address a = address(new A()); - if (tx.origin == a) assert(false); - } - } - |] - cexs <- reachableUserAsserts c Nothing - assertBoolM "unexpected cex" (isRight cexs) - , test "tx.origin can alias everything else" $ do - let addrs = ["address(this)", "block.coinbase", "msg.sender", "arg"] :: [Text] - sig = Just $ Sig "f(address)" [AbiAddressType] - checkVs vs = [i| - contract C { - function f(address arg) external { - if (${vs} == tx.origin) assert(false); - } - } - |] - - [self, coinbase, caller, arg] <- forM addrs $ \addr -> do - Just c <- solcRuntime "C" (checkVs addr) - Left [cex] <- reachableUserAsserts c sig - pure cex.addrs - - liftIO $ do - let check as a = (Map.lookup (SymAddr "origin") as) @?= (Map.lookup a as) - check self (SymAddr "entrypoint") - check coinbase (SymAddr "coinbase") - check caller (SymAddr "caller") - check arg (SymAddr "arg1") - , test "coinbase can alias anything" $ do - let addrs = ["address(this)", "tx.origin", "msg.sender", "a", "arg"] :: [Text] - sig = Just $ Sig "f(address)" [AbiAddressType] - checkVs vs = [i| - contract A {} - contract C { - function f(address arg) external { - address a = address(new A()); - if (${vs} == block.coinbase) assert(false); - } - } - |] - - [self, origin, caller, a, arg] <- forM addrs $ \addr -> do - Just c <- solcRuntime "C" (checkVs addr) - Left [cex] <- reachableUserAsserts c sig - pure cex.addrs - - liftIO $ do - let check as a' = (Map.lookup (SymAddr "coinbase") as) @?= (Map.lookup a' as) - check self (SymAddr "entrypoint") - check origin (SymAddr "origin") - check caller (SymAddr "caller") - check a (SymAddr "freshSymAddr1") - check arg (SymAddr "arg1") - , test "caller can alias anything" $ do - let addrs = ["address(this)", "tx.origin", "block.coinbase", "a", "arg"] :: [Text] - sig = Just $ Sig "f(address)" [AbiAddressType] - checkVs vs = [i| - contract A {} - contract C { - function f(address arg) external { - address a = address(new A()); - if (${vs} == msg.sender) assert(false); - } - } - |] - - [self, origin, coinbase, a, arg] <- forM addrs $ \addr -> do - Just c <- solcRuntime "C" (checkVs addr) - Left [cex] <- reachableUserAsserts c sig - pure cex.addrs - - liftIO $ do - let check as a' = (Map.lookup (SymAddr "caller") as) @?= (Map.lookup a' as) - check self (SymAddr "entrypoint") - check origin (SymAddr "origin") - check coinbase (SymAddr "coinbase") - check a (SymAddr "freshSymAddr1") - check arg (SymAddr "arg1") - , test "vm.load fails for a potentially aliased address" $ do - Just c <- solcRuntime "C" - [i| - interface Vm { - function load(address,bytes32) external returns (bytes32); - } - contract C { - function f() external { - Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); - vm.load(msg.sender, 0x0); - } - } - |] - -- NOTE: we have a postcondition here, not just a regular verification - (_, [Cex _]) <- withDefaultSolver $ \s -> - verifyContract s c Nothing [] defaultVeriOpts Nothing (Just $ checkBadCheatCode "load(address,bytes32)") - pure () - , test "vm.store fails for a potentially aliased address" $ do - Just c <- solcRuntime "C" - [i| - interface Vm { - function store(address,bytes32,bytes32) external; - } - contract C { - function f() external { - Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); - vm.store(msg.sender, 0x0, 0x0); - } - } - |] - -- NOTE: we have a postcondition here, not just a regular verification - (_, [Cex _]) <- withDefaultSolver $ \s -> - verifyContract s c Nothing [] defaultVeriOpts Nothing (Just $ checkBadCheatCode "store(address,bytes32,bytes32)") - pure () - -- TODO: make this work properly - , test "transfering-eth-does-not-dealias" $ do - Just c <- solcRuntime "C" - [i| - // we can't do calls to unknown code yet so we use selfdestruct - contract Send { - constructor(address payable dst) payable { - selfdestruct(dst); - } - } - contract C { - function f() external { - uint preSender = msg.sender.balance; - uint preOrigin = tx.origin.balance; - - new Send{value:10}(payable(msg.sender)); - new Send{value:5}(payable(tx.origin)); - - if (msg.sender == tx.origin) { - assert(preSender == preOrigin - && msg.sender.balance == preOrigin + 15 - && tx.origin.balance == preSender + 15); - } else { - assert(msg.sender.balance == preSender + 10 - && tx.origin.balance == preOrigin + 5); - } - } - } - |] - Right e <- reachableUserAsserts c Nothing - -- TODO: this should work one day - assertBoolM "should be partial" (Expr.containsNode isPartial e) - , test "addresses-in-context-are-symbolic" $ do - Just a <- solcRuntime "A" - [i| - contract A { - function f() external { - assert(msg.sender != address(0x0)); - } - } - |] - Just b <- solcRuntime "B" - [i| - contract B { - function f() external { - assert(block.coinbase != address(0x1)); - } - } - |] - Just c <- solcRuntime "C" - [i| - contract C { - function f() external { - assert(tx.origin != address(0x2)); - } - } - |] - Just d <- solcRuntime "D" - [i| - contract D { - function f() external { - assert(address(this) != address(0x3)); - } - } - |] - [acex,bcex,ccex,dcex] <- forM [a,b,c,d] $ \con -> do - Left [cex] <- reachableUserAsserts con Nothing - assertEqualM "wrong number of addresses" 1 (length (Map.keys cex.addrs)) - pure cex - - assertEqualM "wrong model for a" (Addr 0) (fromJust $ Map.lookup (SymAddr "caller") acex.addrs) - assertEqualM "wrong model for b" (Addr 1) (fromJust $ Map.lookup (SymAddr "coinbase") bcex.addrs) - assertEqualM "wrong model for c" (Addr 2) (fromJust $ Map.lookup (SymAddr "origin") ccex.addrs) - assertEqualM "wrong model for d" (Addr 3) (fromJust $ Map.lookup (SymAddr "entrypoint") dcex.addrs) - ] - , testGroup "Symbolic execution" - [ - test "require-test" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(int256 a) external pure { - require(a <= 0); - assert (a <= 0); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256)" [AbiIntType 256])) [] defaultVeriOpts - putStrLnM "Require works as expected" - , - -- here test - test "ITE-with-bitwise-AND" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function f(uint256 x) public pure { - require(x > 0); - uint256 a = (x & 8); - bool w; - // assembly is needed here, because solidity doesn't allow uint->bool conversion - assembly { - w:=a - } - if (!w) assert(false); //we should get a CEX: when x has a 0 at bit 3 - } - } - |] - -- should find a counterexample - (_, [Cex _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "expected counterexample found" - , - test "ITE-with-bitwise-OR" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function f(uint256 x) public pure { - uint256 a = (x | 8); - bool w; - // assembly is needed here, because solidity doesn't allow uint->bool conversion - assembly { - w:=a - } - assert(w); // due to bitwise OR with positive value, this must always be true - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "this should always be true, due to bitwise OR with positive value" - , - test "abstract-returndata-size" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function f(uint256 x) public pure { - assembly { - return(0, x) - } - } - } - |] - expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "f(uint256)" [])) [] defaultVeriOpts - assertBoolM "The expression is partial" $ not $ Expr.containsNode isPartial expr - , - -- CopySlice check - -- uses identity precompiled contract (0x4) to copy memory - -- checks 9af114613075a2cd350633940475f8b6699064de (readByte + CopySlice had src/dest mixed up) - -- without 9af114613 it dies with: `Exception: UnexpectedSymbolicArg 296 "MSTORE index"` - -- TODO: check 9e734b9da90e3e0765128b1f20ce1371f3a66085 (bufLength + copySlice was off by 1) - test "copyslice-check" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function checkval(uint8 a) public { - bytes memory data = new bytes(5); - for(uint i = 0; i < 5; i++) data[i] = bytes1(a); - bytes memory ret = new bytes(data.length); - assembly { - let len := mload(data) - if iszero(call(0xff, 0x04, 0, add(data, 0x20), len, add(ret,0x20), len)) { - invalid() - } - } - for(uint i = 0; i < 5; i++) assert(ret[i] == data[i]); - } - } - |] - let sig = Just (Sig "checkval(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) - (res, [Qed _]) <- withDefaultSolver $ \s -> - checkAssert s defaultPanicCodes c sig [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "opcode-mul-assoc" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(int256 a, int256 b, int256 c) external pure { - int256 tmp1; - int256 out1; - int256 tmp2; - int256 out2; - assembly { - tmp1 := mul(a, b) - out1 := mul(tmp1,c) - tmp2 := mul(b, c) - out2 := mul(a, tmp2) - } - assert (out1 == out2); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256,int256)" [AbiIntType 256, AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts - putStrLnM "MUL is associative" - , - -- TODO look at tests here for SAR: https://github.com/dapphub/dapptools/blob/01ef8ea418c3fe49089a44d56013d8fcc34a1ec2/src/dapp-tests/pass/constantinople.sol#L250 - test "opcode-sar-neg" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(int256 shift_by, int256 val) external pure returns (int256 out) { - require(shift_by >= 0); - require(val <= 0); - assembly { - out := sar(shift_by,val) - } - assert (out <= 0); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts - putStrLnM "SAR works as expected" - , - test "opcode-sar-pos" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(int256 shift_by, int256 val) external pure returns (int256 out) { - require(shift_by >= 0); - require(val >= 0); - assembly { - out := sar(shift_by,val) - } - assert (out >= 0); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts - putStrLnM "SAR works as expected" - , - test "opcode-sar-fixedval-pos" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(int256 shift_by, int256 val) external pure returns (int256 out) { - require(shift_by == 1); - require(val == 64); - assembly { - out := sar(shift_by,val) - } - assert (out == 32); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts - putStrLnM "SAR works as expected" - , - test "opcode-sar-fixedval-neg" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(int256 shift_by, int256 val) external pure returns (int256 out) { - require(shift_by == 1); - require(val == -64); - assembly { - out := sar(shift_by,val) - } - assert (out == -32); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts - putStrLnM "SAR works as expected" - , - test "opcode-div-zero-1" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val) external pure { - uint out; - assembly { - out := div(val, 0) - } - assert(out == 0); - - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "sdiv works as expected" - , - test "opcode-sdiv-zero-1" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val) external pure { - uint out; - assembly { - out := sdiv(val, 0) - } - assert(out == 0); - - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "sdiv works as expected" - , - test "opcode-sdiv-zero-2" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val) external pure { - uint out; - assembly { - out := sdiv(0, val) - } - assert(out == 0); - - } - } - |] - (_, [Qed _]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "sdiv works as expected" - , - test "signed-overflow-checks" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun(int256 a) external returns (int256) { - return a + a; - } - } - |] - (_, [Cex (_, _)]) <- withDefaultSolver $ \s -> checkAssert s [0x11] c (Just (Sig "fun(int256)" [AbiIntType 256])) [] defaultVeriOpts - putStrLnM "expected cex discovered" - , - test "opcode-signextend-neg" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val, uint8 b) external pure { - require(b <= 31); - require(b >= 0); - require(val < (1 <<(b*8))); - require(val & (1 <<(b*8-1)) != 0); // MSbit set, i.e. negative - uint256 out; - assembly { - out := signextend(b, val) - } - if (b == 31) assert(out == val); - else assert(out > val); - assert(out & (1<<254) != 0); // MSbit set, i.e. negative - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "signextend works as expected" - , - test "opcode-signextend-pos-nochop" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val, uint8 b) external pure { - require(val < (1 <<(b*8))); - require(val & (1 <<(b*8-1)) == 0); // MSbit not set, i.e. positive - uint256 out; - assembly { - out := signextend(b, val) - } - assert (out == val); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts - putStrLnM "signextend works as expected" - , - test "opcode-signextend-pos-chopped" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val, uint8 b) external pure { - require(b == 0); // 1-byte - require(val == 514); // but we set higher bits - uint256 out; - assembly { - out := signextend(b, val) - } - assert (out == 2); // chopped - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts - putStrLnM "signextend works as expected" - , - -- when b is too large, value is unchanged - test "opcode-signextend-pos-b-toolarge" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val, uint8 b) external pure { - require(b >= 31); - uint256 out; - assembly { - out := signextend(b, val) - } - assert (out == val); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts - putStrLnM "signextend works as expected" - , - test "opcode-shl" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 shift_by, uint256 val) external pure { - require(val < (1<<16)); - require(shift_by < 16); - uint256 out; - assembly { - out := shl(shift_by,val) - } - assert (out >= val); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "SAR works as expected" - , - test "opcode-xor-cancel" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a, uint256 b) external pure { - require(a == b); - uint256 c; - assembly { - c := xor(a,b) - } - assert (c == 0); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "XOR works as expected" - , - test "opcode-xor-reimplement" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a, uint256 b) external pure { - uint256 c; - assembly { - c := xor(a,b) - } - assert (c == (~(a & b)) & (a | b)); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "XOR works as expected" - , - test "opcode-add-commutative" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a, uint256 b) external pure { - uint256 res1; - uint256 res2; - assembly { - res1 := add(a,b) - res2 := add(b,a) - } - assert (res1 == res2); - } - } - |] - a <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - case a of - (_, [Cex (_, ctr)]) -> do - let x = getVar ctr "arg1" - let y = getVar ctr "arg2" - putStrLnM $ "y:" <> show y - putStrLnM $ "x:" <> show x - assertEqualM "Addition is not commutative... that's wrong" False True - (_, [Qed _]) -> do - putStrLnM "adding is commutative" - _ -> internalError "Unexpected" - , - test "opcode-div-res-zero-on-div-by-zero" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint16 a) external pure { - uint16 b = 0; - uint16 res; - assembly { - res := div(a,b) - } - assert (res == 0); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint16)" [AbiUIntType 16])) [] defaultVeriOpts - putStrLnM "DIV by zero is zero" - , - -- Somewhat tautological since we are asserting the precondition - -- on the same form as the actual "requires" clause. - test "SafeAdd success case" $ do - Just safeAdd <- solcRuntime "SafeAdd" - [i| - contract SafeAdd { - function add(uint x, uint y) public pure returns (uint z) { - require((z = x + y) >= x); - } - } - |] - let pre preVM = let (x, y) = case getStaticAbiArgs 2 preVM of - [x', y'] -> (x', y') - _ -> internalError "expected 2 args" - in (x .<= Expr.add x y) - -- TODO check if it's needed - .&& preVM.state.callvalue .== Lit 0 - post prestate leaf = - let (x, y) = case getStaticAbiArgs 2 prestate of - [x', y'] -> (x', y') - _ -> internalError "expected 2 args" - in case leaf of - Success _ _ b _ -> (ReadWord (Lit 0) b) .== (Add x y) - _ -> PBool True - sig = Just (Sig "add(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) - (res, [Qed _]) <- withDefaultSolver $ \s -> - verifyContract s safeAdd sig [] defaultVeriOpts (Just pre) (Just post) - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - - test "x == y => x + y == 2 * y" $ do - Just safeAdd <- solcRuntime "SafeAdd" - [i| - contract SafeAdd { - function add(uint x, uint y) public pure returns (uint z) { - require((z = x + y) >= x); - } - } - |] - let pre preVM = let (x, y) = case getStaticAbiArgs 2 preVM of - [x', y'] -> (x', y') - _ -> internalError "expected 2 args" - in (x .<= Expr.add x y) - .&& (x .== y) - .&& preVM.state.callvalue .== Lit 0 - post prestate leaf = - let (_, y) = case getStaticAbiArgs 2 prestate of - [x', y'] -> (x', y') - _ -> internalError "expected 2 args" - in case leaf of - Success _ _ b _ -> (ReadWord (Lit 0) b) .== (Mul (Lit 2) y) - _ -> PBool True - (res, [Qed _]) <- withDefaultSolver $ \s -> - verifyContract s safeAdd (Just (Sig "add(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts (Just pre) (Just post) - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "summary storage writes" $ do - Just c <- solcRuntime "A" - [i| - contract A { - uint x; - function f(uint256 y) public { - unchecked { - x += y; - x += y; - } - } - } - |] - let pre vm = Lit 0 .== vm.state.callvalue - post prestate leaf = - let y = case getStaticAbiArgs 1 prestate of - [y'] -> y' - _ -> internalError "expected 1 arg" - this = prestate.state.codeContract - prestore = (fromJust (Map.lookup this prestate.env.contracts)).storage - prex = Expr.readStorage' (Lit 0) prestore - in case leaf of - Success _ _ _ postState -> let - poststore = (fromJust (Map.lookup this postState)).storage - in Expr.add prex (Expr.mul (Lit 2) y) .== (Expr.readStorage' (Lit 0) poststore) - _ -> PBool True - sig = Just (Sig "f(uint256)" [AbiUIntType 256]) - (res, [Qed _]) <- withDefaultSolver $ \s -> - verifyContract s c sig [] defaultVeriOpts (Just pre) (Just post) - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - -- tests how whiffValue handles Neg via application of the triple IsZero simplification rule - -- regression test for: https://github.com/dapphub/dapptools/pull/698 - test "Neg" $ do - let src = - [i| - object "Neg" { - code { - // Deploy the contract - datacopy(0, dataoffset("runtime"), datasize("runtime")) - return(0, datasize("runtime")) - } - object "runtime" { - code { - let v := calldataload(4) - if iszero(iszero(and(v, not(0xffffffffffffffffffffffffffffffffffffffff)))) { - invalid() - } - } - } - } - |] - Just c <- liftIO $ yulRuntime "Neg" src - (res, [Qed _]) <- withSolvers Z3 4 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "hello(address)" [AbiAddressType])) [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "catch-storage-collisions-noproblem" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y) public { - if (x != y) { - assembly { - let newx := sub(sload(x), 1) - let newy := add(sload(y), 1) - sstore(x,newx) - sstore(y,newy) - } - } - } - } - |] - 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 = prestate.state.codeContract - prestore = (fromJust (Map.lookup this prestate.env.contracts)).storage - prex = Expr.readStorage' x prestore - prey = Expr.readStorage' y prestore - in case poststate of - Success _ _ _ postcs -> let - poststore = (fromJust (Map.lookup this postcs)).storage - postx = Expr.readStorage' x poststore - posty = Expr.readStorage' y poststore - in Expr.add prex prey .== Expr.add postx posty - _ -> PBool True - sig = Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) - (_, [Qed _]) <- withDefaultSolver $ \s -> - verifyContract s c sig [] defaultVeriOpts (Just pre) (Just post) - putStrLnM "Correct, this can never fail" - , - -- Inspired by these `msg.sender == to` token bugs - -- which break linearity of totalSupply. - test "catch-storage-collisions-good" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y) public { - assembly { - let newx := sub(sload(x), 1) - let newy := add(sload(y), 1) - sstore(x,newx) - sstore(y,newy) - } - } - } - |] - let pre vm = (Lit 0) .== vm.state.callvalue - post prestate leaf = - let (x,y) = case getStaticAbiArgs 2 prestate of - [x',y'] -> (x',y') - _ -> error "expected 2 args" - this = prestate.state.codeContract - prestore = (fromJust (Map.lookup this prestate.env.contracts)).storage - prex = Expr.readStorage' x prestore - prey = Expr.readStorage' y prestore - in case leaf of - Success _ _ _ poststate -> let - poststore = (fromJust (Map.lookup this poststate)).storage - postx = Expr.readStorage' x poststore - posty = Expr.readStorage' y poststore - in Expr.add prex prey .== Expr.add postx posty - _ -> PBool True - sig = Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) - (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> - verifyContract s c sig [] defaultVeriOpts (Just pre) (Just post) - let x = getVar ctr "arg1" - let y = getVar ctr "arg2" - putStrLnM $ "y:" <> show y - putStrLnM $ "x:" <> show x - assertEqualM "Catch storage collisions" x y - putStrLnM "expected counterexample found" - , - test "simple-assert" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo() external pure { - assert(false); - } - } - |] - (_, [Cex (Failure _ _ (Revert msg), _)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo()" [])) [] defaultVeriOpts - assertEqualM "incorrect revert msg" msg (ConcreteBuf $ panicMsg 0x01) - , - test "simple-assert-2" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - assert(x != 10); - } - } - |] - (_, [(Cex (_, ctr))]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - assertEqualM "Must be 10" 10 $ getVar ctr "arg1" - putStrLnM "Got 10 Cex, as expected" - , - test "assert-fail-equal" $ do - Just c <- solcRuntime "AssertFailEqual" - [i| - contract AssertFailEqual { - function fun(uint256 deposit_count) external pure { - assert(deposit_count == 0); - assert(deposit_count == 11); - } - } - |] - (_, [Cex (_, a), Cex (_, b)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - let ints = map (flip getVar "arg1") [a,b] - assertBoolM "0 must be one of the Cex-es" $ isJust $ List.elemIndex 0 ints - putStrLnM "expected 2 counterexamples found, one Cex is the 0 value" - , - test "assert-fail-notequal" $ do - Just c <- solcRuntime "AssertFailNotEqual" - [i| - contract AssertFailNotEqual { - function fun(uint256 deposit_count) external pure { - assert(deposit_count != 0); - assert(deposit_count != 11); - } - } - |] - (_, [Cex (_, a), Cex (_, b)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - let x = getVar a "arg1" - let y = getVar b "arg1" - assertBoolM "At least one has to be 0, to go through the first assert" (x == 0 || y == 0) - putStrLnM "expected 2 counterexamples found." - , - test "assert-fail-twoargs" $ do - Just c <- solcRuntime "AssertFailTwoParams" - [i| - contract AssertFailTwoParams { - function fun(uint256 deposit_count1, uint256 deposit_count2) external pure { - assert(deposit_count1 != 0); - assert(deposit_count2 != 11); - } - } - |] - (_, [Cex _, Cex _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "expected 2 counterexamples found" - , - test "assert-2nd-arg" $ do - Just c <- solcRuntime "AssertFailTwoParams" - [i| - contract AssertFailTwoParams { - function fun(uint256 deposit_count1, uint256 deposit_count2) external pure { - assert(deposit_count2 != 666); - } - } - |] - (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - assertEqualM "Must be 666" 666 $ getVar ctr "arg2" - putStrLnM "Found arg2 Ctx to be 666" - , - -- LSB is zeroed out, byte(31,x) takes LSB, so y==0 always holds - test "check-lsb-msb1" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - x &= 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff00; - uint8 y; - assembly { y := byte(31,x) } - assert(y == 0); - } - } - |] - (res, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - -- We zero out everything but the LSB byte. However, byte(31,x) takes the LSB byte - -- so there is a counterexamle, where LSB of x is not zero - test "check-lsb-msb2" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - x &= 0x00000000000000000000000000000000000000000000000000000000000000ff; - uint8 y; - assembly { y := byte(31,x) } - assert(y == 0); - } - } - |] - (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - assertBoolM "last byte must be non-zero" $ ((Data.Bits..&.) (getVar ctr "arg1") 0xff) > 0 - putStrLnM "Expected counterexample found" - , - -- We zero out everything but the 2nd LSB byte. However, byte(31,x) takes the 2nd LSB byte - -- so there is a counterexamle, where 2nd LSB of x is not zero - test "check-lsb-msb3 -- 2nd byte" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - x &= 0x000000000000000000000000000000000000000000000000000000000000ff00; - uint8 y; - assembly { y := byte(30,x) } - assert(y == 0); - } - } - |] - (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - assertBoolM "second to last byte must be non-zero" $ ((Data.Bits..&.) (getVar ctr "arg1") 0xff00) > 0 - putStrLnM "Expected counterexample found" - , - -- Reverse of test above - test "check-lsb-msb4 2nd byte rev" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - x &= 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff00ff; - uint8 y; - assembly { - y := byte(30,x) - } - assert(y == 0); - } - } - |] - (res, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - -- Bitwise OR operation test - test "opcode-bitwise-or-full-1s" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - uint256 y; - uint256 z = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff; - assembly { y := or(x, z) } - assert(y == 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "When OR-ing with full 1's we should get back full 1's" - , - -- Bitwise OR operation test - test "opcode-bitwise-or-byte-of-1s" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - uint256 y; - uint256 z = 0x000000000000000000000000000000000000000000000000000000000000ff00; - assembly { y := or(x, z) } - assert((y & 0x000000000000000000000000000000000000000000000000000000000000ff00) == - 0x000000000000000000000000000000000000000000000000000000000000ff00); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "When OR-ing with a byte of 1's, we should get 1's back there" - , - test "Deposit contract loop (z3)" $ do - Just c <- solcRuntime "Deposit" - [i| - contract Deposit { - function deposit(uint256 deposit_count) external pure { - require(deposit_count < 2**32 - 1); - ++deposit_count; - bool found = false; - for (uint height = 0; height < 32; height++) { - if ((deposit_count & 1) == 1) { - found = true; - break; - } - deposit_count = deposit_count >> 1; - } - assert(found); - } - } - |] - (res, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "deposit(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "Deposit-contract-loop-error-version" $ do - Just c <- solcRuntime "Deposit" - [i| - contract Deposit { - function deposit(uint8 deposit_count) external pure { - require(deposit_count < 2**32 - 1); - ++deposit_count; - bool found = false; - for (uint height = 0; height < 32; height++) { - if ((deposit_count & 1) == 1) { - found = true; - break; - } - deposit_count = deposit_count >> 1; - } - assert(found); - } - } - |] - (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s allPanicCodes c (Just (Sig "deposit(uint8)" [AbiUIntType 8])) [] defaultVeriOpts - assertEqualM "Must be 255" 255 $ getVar ctr "arg1" - putStrLnM $ "expected counterexample found, and it's correct: " <> (show $ getVar ctr "arg1") - , - test "explore function dispatch" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x) public pure returns (uint) { - return x; - } - } - |] - (res, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "check-asm-byte-in-bounds" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 idx, uint256 val) external pure { - uint256 actual; - uint256 expected; - require(idx < 32); - assembly { - actual := byte(idx,val) - expected := shr(248, shl(mul(idx, 8), val)) - } - assert(actual == expected); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts - putStrLnM "in bounds byte reads return the expected value" - , - test "check-div-mod-sdiv-smod-by-zero-constant-prop" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 e) external pure { - uint x = 0; - uint y = 55; - uint z; - assembly { z := div(y,x) } - assert(z == 0); - assembly { z := div(x,y) } - assert(z == 0); - assembly { z := sdiv(y,x) } - assert(z == 0); - assembly { z := sdiv(x,y) } - assert(z == 0); - assembly { z := mod(y,x) } - assert(z == 0); - assembly { z := mod(x,y) } - assert(z == 0); - assembly { z := smod(y,x) } - assert(z == 0); - assembly { z := smod(x,y) } - assert(z == 0); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "div/mod/sdiv/smod by zero works as expected during constant propagation" - , - test "check-asm-byte-oob" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x, uint256 y) external pure { - uint256 z; - require(x >= 32); - assembly { z := byte(x,y) } - assert(z == 0); - } - } - |] - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts - putStrLnM "oob byte reads always return 0" - , - test "injectivity of keccak (diff sizes)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint128 x, uint256 y) external pure { - assert( - keccak256(abi.encodePacked(x)) != - keccak256(abi.encodePacked(y)) - ); - } - } - |] - Right _ <- reachableUserAsserts c (Just $ Sig "f(uint128,uint256)" [AbiUIntType 128, AbiUIntType 256]) - pure () - , - test "injectivity of keccak (32 bytes)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y) public pure { - if (keccak256(abi.encodePacked(x)) == keccak256(abi.encodePacked(y))) assert(x == y); - } - } - |] - (res, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "injectivity of keccak contrapositive (32 bytes)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y) public pure { - require (x != y); - assert (keccak256(abi.encodePacked(x)) != keccak256(abi.encodePacked(y))); - } - } - |] - (res, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "injectivity of keccak (64 bytes)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y, uint w, uint z) public pure { - assert (keccak256(abi.encodePacked(x,y)) != keccak256(abi.encodePacked(w,z))); - } - } - |] - (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256,uint256,uint256,uint256)" (replicate 4 (AbiUIntType 256)))) [] defaultVeriOpts - let x = getVar ctr "arg1" - let y = getVar ctr "arg2" - let w = getVar ctr "arg3" - let z = getVar ctr "arg4" - assertEqualM "x==y for hash collision" x y - assertEqualM "w==z for hash collision" w z - putStrLnM "expected counterexample found" - , - test "calldata beyond calldatasize is 0 (symbolic calldata)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f() public pure { - uint y; - assembly { - let x := calldatasize() - y := calldataload(x) - } - assert(y == 0); - } - } - |] - (res, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "calldata beyond calldatasize is 0 (concrete dalldata prefix)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint256 z) public pure { - uint y; - assembly { - let x := calldatasize() - y := calldataload(x) - } - assert(y == 0); - } - } - |] - (res, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "calldata symbolic access" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint256 z) public pure { - uint x; uint y; - assembly { - y := calldatasize() - } - require(z >= y); - require(z < 2**64); // Accesses to larger indices are not supported - assembly { - x := calldataload(z) - } - assert(x == 0); - } - } - |] - (res, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "multiple-contracts" $ do - let code = - [i| - contract C { - uint x; - A constant a = A(0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B); - - function call_A() public view { - // should fail since x can be anything - assert(a.x() == x); - } - } - contract A { - uint public x; - } - |] - aAddr = LitAddr (Addr 0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B) - cAddr = SymAddr "entrypoint" - Just c <- solcRuntime "C" code - Just a <- solcRuntime "A" code - (_, [Cex (_, cex)]) <- withDefaultSolver $ \s -> do - vm <- liftIO $ stToIO $ abstractVM (mkCalldata (Just (Sig "call_A()" [])) []) c Nothing False - <&> set (#state % #callvalue) (Lit 0) - <&> over (#env % #contracts) - (Map.insert aAddr (initialContract (RuntimeCode (ConcreteRuntimeCode a)))) - verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) - - let storeCex = cex.store - testCex = case (Map.lookup cAddr storeCex, Map.lookup aAddr storeCex) of - (Just sC, Just sA) -> case (Map.lookup 0 sC, Map.lookup 0 sA) of - (Just x, Just y) -> x /= y - (Just x, Nothing) -> x /= 0 - _ -> False - _ -> False - assertBoolM "Did not find expected storage cex" testCex - putStrLnM "expected counterexample found" - , - expectFail $ test "calling unique contracts (read from storage)" $ do - Just c <- solcRuntime "C" - [i| - contract C { - uint x; - A a; - - function call_A() public { - a = new A(); - // should fail since x can be anything - assert(a.x() == x); - } - } - contract A { - uint public x; - } - |] - (_, [Cex _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "call_A()" [])) [] defaultVeriOpts - putStrLnM "expected counterexample found" - , - test "keccak-concrete-and-sym-agree" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function kecc(uint x) public pure { - if (x == 0) { - assert(keccak256(abi.encode(x)) == keccak256(abi.encode(0))); - } - } - } - |] - (res, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "kecc(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "keccak-concrete-and-sym-agree-nonzero" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function kecc(uint x) public pure { - if (x == 55) { - // Note: 3014... is the encode & keccak & uint256 conversion of 55 - assert(uint256(keccak256(abi.encode(x))) == 30148980456718914367279254941528755963179627010946392082519497346671089299886); - } - } - } - |] - (res, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "kecc(uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "keccak concrete and sym injectivity" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x) public pure { - if (x !=3) assert(keccak256(abi.encode(x)) != keccak256(abi.encode(3))); - } - } - |] - (res, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - test "safemath-distributivity-yul" $ do - let yulsafeDistributivity = hex "6355a79a6260003560e01c14156016576015601f565b5b60006000fd60a1565b603d602d604435600435607c565b6039602435600435607c565b605d565b6052604b604435602435605d565b600435607c565b141515605a57fe5b5b565b6000828201821115151560705760006000fd5b82820190505b92915050565b6000818384048302146000841417151560955760006000fd5b82820290505b92915050565b" - vm <- liftIO $ stToIO $ abstractVM (mkCalldata (Just (Sig "distributivity(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) []) yulsafeDistributivity Nothing False - (_, [Qed _]) <- withDefaultSolver $ \s -> verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) - putStrLnM "Proven" - , - test "safemath-distributivity-sol" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function distributivity(uint x, uint y, uint z) public { - assert(mul(x, add(y, z)) == add(mul(x, y), mul(x, z))); - } - - function add(uint x, uint y) internal pure returns (uint z) { - unchecked { - require((z = x + y) >= x, "ds-math-add-overflow"); - } - } - - function mul(uint x, uint y) internal pure returns (uint z) { - unchecked { - require(y == 0 || (z = x * y) / y == x, "ds-math-mul-overflow"); - } - } - } - |] - - (_, [Qed _]) <- withSolvers Bitwuzla 1 1 (Just 99999999) $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "distributivity(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLnM "Proven" - , - test "storage-cex-1" $ do - Just c <- solcRuntime "C" - [i| - contract C { - uint x; - uint y; - function fun(uint256 a) external{ - require(x != 0); - require(y != 0); - assert (x == y); - } - } - |] - (_, [(Cex (_, cex))]) <- withDefaultSolver $ \s -> checkAssert s [0x01] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - let addr = SymAddr "entrypoint" - testCex = Map.size cex.store == 1 && - case Map.lookup addr cex.store of - Just s -> Map.size s == 2 && - case (Map.lookup 0 s, Map.lookup 1 s) of - (Just x, Just y) -> x /= y - _ -> False - _ -> False - assertBoolM "Did not find expected storage cex" testCex - putStrLnM "Expected counterexample found" - , - test "storage-cex-2" $ do - Just c <- solcRuntime "C" - [i| - contract C { - uint[10] arr1; - uint[10] arr2; - function fun(uint256 a) external{ - assert (arr1[0] < arr2[a]); - } - } - |] - (_, [(Cex (_, cex))]) <- withDefaultSolver $ \s -> checkAssert s [0x01] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - let addr = SymAddr "entrypoint" - a = getVar cex "arg1" - testCex = Map.size cex.store == 1 && - case Map.lookup addr cex.store of - Just s -> case (Map.lookup 0 s, Map.lookup (10 + a) s) of - (Just x, Just y) -> x >= y - (Just x, Nothing) -> x > 0 -- arr1 can be Nothing, it'll then be zero - _ -> False - Nothing -> False -- arr2 must contain an element, or it'll be 0 - assertBoolM "Did not find expected storage cex" testCex - putStrLnM "Expected counterexample found" - , - test "storage-cex-concrete" $ do - Just c <- solcRuntime "C" - [i| - contract C { - uint x; - uint y; - function fun(uint256 a) external{ - require (x != 0); - require (y != 0); - assert (x != y); - } - } - |] - let sig = Just (Sig "fun(uint256)" [AbiUIntType 256]) - (_, [Cex (_, cex)]) <- withDefaultSolver $ - \s -> verifyContract s c sig [] defaultVeriOpts Nothing (Just $ checkAssertions [0x01]) - let addr = SymAddr "entrypoint" - testCex = Map.size cex.store == 1 && - case Map.lookup addr cex.store of - Just s -> Map.size s == 2 && - case (Map.lookup 0 s, Map.lookup 1 s) of - (Just x, Just y) -> x == y - _ -> False - _ -> False - assertBoolM "Did not find expected storage cex" testCex - putStrLnM "Expected counterexample found" - , test "temp-store-check" $ do - Just c <- solcRuntime "C" - [i| - pragma solidity ^0.8.25; - contract C { - mapping(address => bool) sentGifts; - function stuff(address k) public { - require(sentGifts[k] == false); - assembly { - if tload(0) { revert(0, 0) } - tstore(0, 1) - } - sentGifts[k] = true; - assembly { - tstore(0, 0) - } - assert(sentGifts[k]); - } - } - |] - let sig = (Just (Sig "stuff(address)" [AbiAddressType])) - (_, [Qed _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts - putStrLnM $ "Basic tstore check passed" - ] - , testGroup "concr-fuzz" - [ testFuzz "fuzz-complicated-mul" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function complicated(uint x, uint y, uint z) public { - uint a; - uint b; - unchecked { - a = x * x * x * y * y * y * z; - b = x * x * x * x * y * y * z * z; - } - assert(a == b); - } - } - |] - let sig = (Sig "complicated(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256]) - (_, [Cex (_, ctr)]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts - let - x = getVar ctr "arg1" - y = getVar ctr "arg2" - z = getVar ctr "arg3" - a = x * x * x * y * y * y * z; - b = x * x * x * x * y * y * z * z; - val = a == b - assertBoolM "Must fail" (not val) - putStrLnM $ "expected counterexample found, x: " <> (show x) <> " y: " <> (show y) <> " z: " <> (show z) - putStrLnM $ "cex a: " <> (show a) <> " b: " <> (show b) - , testFuzz "fuzz-stores" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - mapping(uint => uint) items; - function func() public { - assert(items[5] == 0); - } - } - |] - let sig = (Sig "func()" []) - (_, [Cex (_, ctr)]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts - putStrLnM $ "expected counterexample found. ctr: " <> (show ctr) - , testFuzz "fuzz-simple-fixed-value" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - mapping(uint => uint) items; - function func(uint a) public { - assert(a != 1337); - } - } - |] - let sig = (Sig "func(uint256)" [AbiUIntType 256]) - (_, [Cex (_, ctr)]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts - putStrLnM $ "expected counterexample found. ctr: " <> (show ctr) - , testFuzz "fuzz-simple-fixed-value2" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function func(uint a, uint b) public { - assert(!((a == 1337) && (b == 99))); - } - } - |] - let sig = (Sig "func(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) - (_, [Cex (_, ctr)]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts - putStrLnM $ "expected counterexample found. ctr: " <> (show ctr) - , testFuzz "fuzz-simple-fixed-value3" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function func(uint a, uint b) public { - assert(((a != 1337) && (b != 99))); - } - } - |] - let sig = (Sig "func(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) - (_, [Cex (_, ctr1), Cex (_, ctr2)]) <- withSolvers Bitwuzla 1 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts - putStrLnM $ "expected counterexamples found. ctr1: " <> (show ctr1) <> " ctr2: " <> (show ctr2) - , testFuzz "fuzz-simple-fixed-value-store1" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - mapping(uint => uint) items; - function func(uint a) public { - uint f = items[2]; - assert(a != f); - } - } - |] - let sig = (Sig "func(uint256)" [AbiUIntType 256, AbiUIntType 256]) - (_, [Cex _]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts - putStrLnM $ "expected counterexamples found" - , testFuzz "fuzz-simple-fixed-value-store2" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - mapping(uint => uint) items; - function func(uint a) public { - items[0] = 1337; - assert(a != items[0]); - } - } - |] - let sig = (Sig "func(uint256)" [AbiUIntType 256, AbiUIntType 256]) - (_, [Cex (_, ctr1)]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts - putStrLnM $ "expected counterexamples found: " <> show ctr1 - ] - , testGroup "simplification-working" - [ - test "PEq-and-PNot-PEq-1" $ do - let a = [PEq (Lit 0x539) (Var "arg1"),PNeg (PEq (Lit 0x539) (Var "arg1"))] - assertEqualM "Must simplify to PBool False" (Expr.simplifyProps a) ([PBool False]) - , test "PEq-and-PNot-PEq-2" $ do - let a = [PEq (Var "arg1") (Lit 0x539),PNeg (PEq (Lit 0x539) (Var "arg1"))] - assertEqualM "Must simplify to PBool False" (Expr.simplifyProps a) ([PBool False]) - , test "PEq-and-PNot-PEq-3" $ do - let a = [PEq (Var "arg1") (Lit 0x539),PNeg (PEq (Var "arg1") (Lit 0x539))] - assertEqualM "Must simplify to PBool False" (Expr.simplifyProps a) ([PBool False]) - , test "prop-simp-bool1" $ do - let - a = successGen [PAnd (PBool True) (PBool False)] - b = Expr.simplify a - assertEqualM "Must simplify down" (successGen [PBool False]) b - , test "prop-simp-bool2" $ do - let - a = successGen [POr (PBool True) (PBool False)] - b = Expr.simplify a - assertEqualM "Must simplify down" (successGen []) b - , test "prop-simp-LT" $ do - let - a = successGen [PLT (Lit 1) (Lit 2)] - b = Expr.simplify a - assertEqualM "Must simplify down" (successGen []) b - , test "prop-simp-GEq" $ do - let - a = successGen [PGEq (Lit 1) (Lit 2)] - b = Expr.simplify a - assertEqualM "Must simplify down" (successGen [PBool False]) b - , test "prop-simp-multiple" $ do - let - a = successGen [PBool False, PBool True] - b = Expr.simplify a - assertEqualM "Must simplify down" (successGen [PBool False]) b - , test "prop-simp-expr" $ do - let - a = successGen [PEq (Add (Lit 1) (Lit 2)) (Sub (Lit 4) (Lit 1))] - b = Expr.simplify a - assertEqualM "Must simplify down" (successGen []) b - , test "prop-simp-impl" $ do - let - a = successGen [PImpl (PBool False) (PEq (Var "abc") (Var "bcd"))] - b = Expr.simplify a - assertEqualM "Must simplify down" (successGen []) b - , test "propSimp-no-duplicate1" $ do - let a = [PAnd (PGEq (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x44)) (PLT (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x10000000000000000)), PAnd (PGEq (Var "arg1") (Lit 0x0)) (PLEq (Var "arg1") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PEq (Lit 0x63) (Var "arg2"),PEq (Lit 0x539) (Var "arg1"),PEq TxValue (Lit 0x0),PEq (IsZero (Eq (Lit 0x63) (Var "arg2"))) (Lit 0x0)] - let simp = Expr.simplifyProps a - assertEqualM "must not duplicate" simp (nubOrd simp) - assertEqualM "We must be able to remove all duplicates" (length $ nubOrd simp) (length $ List.nub simp) - , test "propSimp-no-duplicate2" $ do - let a = [PNeg (PBool False),PAnd (PGEq (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x44)) (PLT (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x10000000000000000)),PAnd (PGEq (Var "arg2") (Lit 0x0)) (PLEq (Var "arg2") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PAnd (PGEq (Var "arg1") (Lit 0x0)) (PLEq (Var "arg1") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PEq (Lit 0x539) (Var "arg1"),PNeg (PEq (Lit 0x539) (Var "arg1")),PEq TxValue (Lit 0x0),PLT (BufLength (AbstractBuf "txdata")) (Lit 0x10000000000000000),PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0),PNeg (PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0)),PNeg (PEq (IsZero TxValue) (Lit 0x0))] - let simp = Expr.simplifyProps a - assertEqualM "must not duplicate" simp (nubOrd simp) - assertEqualM "must not duplicate" (length simp) (length $ List.nub simp) - , test "full-order-prop1" $ do - let a = [PNeg (PBool False),PAnd (PGEq (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x44)) (PLT (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x10000000000000000)),PAnd (PGEq (Var "arg2") (Lit 0x0)) (PLEq (Var "arg2") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PAnd (PGEq (Var "arg1") (Lit 0x0)) (PLEq (Var "arg1") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PEq (Lit 0x539) (Var "arg1"),PNeg (PEq (Lit 0x539) (Var "arg1")),PEq TxValue (Lit 0x0),PLT (BufLength (AbstractBuf "txdata")) (Lit 0x10000000000000000),PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0),PNeg (PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0)),PNeg (PEq (IsZero TxValue) (Lit 0x0))] - let simp = Expr.simplifyProps a - assertEqualM "We must be able to remove all duplicates" (length $ nubOrd simp) (length $ List.nub simp) - , test "full-order-prop2" $ do - let a =[PNeg (PBool False),PAnd (PGEq (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x44)) (PLT (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x10000000000000000)),PAnd (PGEq (Var "arg2") (Lit 0x0)) (PLEq (Var "arg2") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PAnd (PGEq (Var "arg1") (Lit 0x0)) (PLEq (Var "arg1") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PEq (Lit 0x63) (Var "arg2"),PEq (Lit 0x539) (Var "arg1"),PEq TxValue (Lit 0x0),PLT (BufLength (AbstractBuf "txdata")) (Lit 0x10000000000000000),PEq (IsZero (Eq (Lit 0x63) (Var "arg2"))) (Lit 0x0),PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0),PNeg (PEq (IsZero TxValue) (Lit 0x0))] - let simp = Expr.simplifyProps a - assertEqualM "must not duplicate" simp (nubOrd simp) - assertEqualM "We must be able to remove all duplicates" (length $ nubOrd simp) (length $ List.nub simp) - ] - , testGroup "equivalence-checking" - [ - test "eq-yul-simple-cex" $ do - Just aPrgm <- liftIO $ yul "" - [i| - { - calldatacopy(0, 0, 32) - switch mload(0) - case 0 { } - case 1 { } - default { invalid() } - } - |] - Just bPrgm <- liftIO $ yul "" - [i| - { - calldatacopy(0, 0, 32) - switch mload(0) - case 0 { } - case 2 { } - default { invalid() } - } - |] - withSolvers Z3 3 1 Nothing $ \s -> do - a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) - assertBoolM "Must have a difference" (any isCex a) - , - test "eq-sol-exp-qed" $ do - Just aPrgm <- solcRuntime "C" - [i| - contract C { - function a(uint8 x) public returns (uint8 b) { - unchecked { - b = x*2; - } - } - } - |] - Just bPrgm <- solcRuntime "C" - [i| - contract C { - function a(uint8 x) public returns (uint8 b) { - unchecked { - b = x<<1; - } - } - } - |] - withSolvers Z3 3 1 Nothing $ \s -> do - a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) - assertEqualM "Must have no difference" [Qed ()] a - , - test "eq-balance-differs" $ do - Just aPrgm <- solcRuntime "C" - [i| - contract Send { - constructor(address payable dst) payable { - selfdestruct(dst); - } - } - contract C { - function f() public { - new Send{value:2}(payable(address(0x0))); - } - } - |] - Just bPrgm <- solcRuntime "C" - [i| - contract Send { - constructor(address payable dst) payable { - selfdestruct(dst); - } - } - contract C { - function f() public { - new Send{value:1}(payable(address(0x0))); - } - } - |] - withSolvers Z3 3 1 Nothing $ \s -> do - a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) - assertBoolM "Must differ" (all isCex a) - , - -- TODO: this fails because we don't check equivalence of deployed contracts - expectFail $ test "eq-handles-contract-deployment" $ do - Just aPrgm <- solcRuntime "B" - [i| - contract Send { - constructor(address payable dst) payable { - selfdestruct(dst); - } - } - - contract A { - address parent; - constructor(address p) { - parent = p; - } - function evil() public { - parent.call(abi.encode(B.drain.selector)); - } - } - - contract B { - address child; - function a() public { - child = address(new A(address(this))); - } - function drain() public { - require(msg.sender == child); - new Send{value: address(this).balance}(payable(address(0x0))); - } - } - |] - Just bPrgm <- solcRuntime "D" - [i| - contract Send { - constructor(address payable dst) payable { - selfdestruct(dst); - } - } - - contract C { - address parent; - constructor(address p) { - parent = p; - } - } - - contract D { - address child; - function a() public { - child = address(new C(address(this))); - } - function drain() public { - require(msg.sender == child); - new Send{value: address(this).balance}(payable(address(0x0))); - } - } - |] - withSolvers Z3 3 1 Nothing $ \s -> do - a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) - assertBoolM "Must differ" (all isCex a) - , - test "eq-unknown-addr" $ do - Just aPrgm <- solcRuntime "C" - [i| - contract C { - address addr; - function a(address a, address b) public { - addr = a; - } - } - |] - Just bPrgm <- solcRuntime "C" - [i| - contract C { - address addr; - function a(address a, address b) public { - addr = b; - } - } - |] - withSolvers Z3 3 1 Nothing $ \s -> do - let cd = mkCalldata (Just (Sig "a(address,address)" [AbiAddressType, AbiAddressType])) [] - a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts cd - assertEqualM "Must be different" (any isCex a) True - , - test "eq-sol-exp-cex" $ do - Just aPrgm <- solcRuntime "C" - [i| - contract C { - function a(uint8 x) public returns (uint8 b) { - unchecked { - b = x*2+1; - } - } - } - |] - Just bPrgm <- solcRuntime "C" - [i| - contract C { - function a(uint8 x) public returns (uint8 b) { - unchecked { - b = x<<1; - } - } - } - |] - withSolvers Bitwuzla 3 1 Nothing $ \s -> do - a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) - assertEqualM "Must be different" (any isCex a) True - , test "eq-all-yul-optimization-tests" $ do - let opts = defaultVeriOpts{ maxIter = Just 5, askSmtIters = 20, loopHeuristic = Naive } - ignoredTests = - -- unbounded loop -- - [ "commonSubexpressionEliminator/branches_for.yul" - , "conditionalSimplifier/no_opt_if_break_is_not_last.yul" - , "conditionalUnsimplifier/no_opt_if_break_is_not_last.yul" - , "expressionSimplifier/inside_for.yul" - , "forLoopConditionIntoBody/cond_types.yul" - , "forLoopConditionIntoBody/simple.yul" - , "fullSimplify/inside_for.yul" - , "fullSuite/no_move_loop_orig.yul" - , "loopInvariantCodeMotion/multi.yul" - , "redundantAssignEliminator/for_deep_simple.yul" - , "unusedAssignEliminator/for_deep_noremove.yul" - , "unusedAssignEliminator/for_deep_simple.yul" - , "ssaTransform/for_def_in_init.yul" - , "loopInvariantCodeMotion/simple_state.yul" - , "loopInvariantCodeMotion/simple.yul" - , "loopInvariantCodeMotion/recursive.yul" - , "loopInvariantCodeMotion/no_move_staticall_returndatasize.yul" - , "loopInvariantCodeMotion/no_move_state_loop.yul" - , "loopInvariantCodeMotion/no_move_state.yul" -- not infinite, but rollaround on a large int - , "loopInvariantCodeMotion/no_move_loop.yul" - - -- infinite recursion - , "unusedStoreEliminator/function_side_effects_2.yul" - , "unusedStoreEliminator/write_before_recursion.yul" - , "fullInliner/multi_fun_callback.yul" - , "conditionalUnsimplifier/side_effects_of_functions.yul" - , "expressionInliner/double_recursive_calls.yul" - , "conditionalSimplifier/side_effects_of_functions.yul" - - -- Takes too long, would timeout on most test setups. - -- We could probably fix these by "bunching together" queries - , "reasoningBasedSimplifier/mulmod.yul" - , "loadResolver/multi_sload_loop.yul" - , "reasoningBasedSimplifier/mulcheck.yul" - , "reasoningBasedSimplifier/smod.yul" - , "fullSuite/abi_example1.yul" - , "yulOptimizerTests/fullInliner/large_function_multi_use.yul" - , "loadResolver/merge_known_write_with_distance.yul" - , "loadResolver/second_mstore_with_delta.yul" - , "rematerialiser/for_continue_2.yul" - , "rematerialiser/for_continue_with_assignment_in_post.yul" - - -- invalid test -- - -- https://github.com/ethereum/solidity/issues/9500 - , "commonSubexpressionEliminator/object_access.yul" - , "expressionSplitter/object_access.yul" - - -- stack too deep -- - , "fullSuite/abi2.yul" - , "fullSuite/aztec.yul" - , "stackCompressor/inlineInBlock.yul" - , "stackCompressor/inlineInFunction.yul" - , "stackCompressor/unusedPrunerWithMSize.yul" - , "wordSizeTransform/function_call.yul" - , "fullInliner/no_inline_into_big_function.yul" - , "controlFlowSimplifier/switch_only_default.yul" - , "stackLimitEvader" -- all that are in this subdirectory - - -- typed yul -- - , "conditionalSimplifier/add_correct_type_wasm.yul" - , "conditionalSimplifier/add_correct_type.yul" - , "disambiguator/for_statement.yul" - , "disambiguator/funtion_call.yul" - , "disambiguator/if_statement.yul" - , "disambiguator/long_names.yul" - , "disambiguator/switch_statement.yul" - , "disambiguator/variables_clash.yul" - , "disambiguator/variables_inside_functions.yul" - , "disambiguator/variables.yul" - , "expressionInliner/simple.yul" - , "expressionInliner/with_args.yul" - , "expressionSplitter/typed.yul" - , "fullInliner/multi_return_typed.yul" - , "functionGrouper/empty_block.yul" - , "functionGrouper/multi_fun_mixed.yul" - , "functionGrouper/nested_fun.yul" - , "functionGrouper/single_fun.yul" - , "functionHoister/empty_block.yul" - , "functionHoister/multi_mixed.yul" - , "functionHoister/nested.yul" - , "functionHoister/single.yul" - , "mainFunction/empty_block.yul" - , "mainFunction/multi_fun_mixed.yul" - , "mainFunction/nested_fun.yul" - , "mainFunction/single_fun.yul" - , "ssaTransform/typed_for.yul" - , "ssaTransform/typed_switch.yul" - , "ssaTransform/typed.yul" - , "varDeclInitializer/typed.yul" - - -- New: symbolic index on MSTORE/MLOAD/CopySlice/CallDataCopy/ExtCodeCopy/Revert, - -- or exponent is symbolic (requires symbolic gas) - -- or SHA3 offset symbolic - , "blockFlattener/basic.yul" - , "commonSubexpressionEliminator/case2.yul" - , "equalStoreEliminator/indirect_inferrence.yul" - , "expressionJoiner/reassignment.yul" - , "expressionSimplifier/exp_simplifications.yul" - , "expressionSimplifier/zero_length_read.yul" - , "expressionSimplifier/side_effects_in_for_condition.yul" - , "fullSuite/create_and_mask.yul" - , "fullSuite/unusedFunctionParameterPruner_return.yul" - , "fullSuite/unusedFunctionParameterPruner_simple.yul" - , "fullSuite/unusedFunctionParameterPruner.yul" - , "loadResolver/double_mload_with_other_reassignment.yul" - , "loadResolver/double_mload_with_reassignment.yul" - , "loadResolver/double_mload.yul" - , "loadResolver/keccak_reuse_basic.yul" - , "loadResolver/keccak_reuse_expr_mstore.yul" - , "loadResolver/keccak_reuse_msize.yul" - , "loadResolver/keccak_reuse_mstore.yul" - , "loadResolver/keccak_reuse_reassigned_branch.yul" - , "loadResolver/keccak_reuse_reassigned_value.yul" - , "loadResolver/keccak_symbolic_memory.yul" - , "loadResolver/merge_mload_with_known_distance.yul" - , "loadResolver/mload_self.yul" - , "loadResolver/keccak_reuse_in_expression.yul" - , "loopInvariantCodeMotion/complex_move.yul" - , "loopInvariantCodeMotion/move_memory_function.yul" - , "loopInvariantCodeMotion/move_state_function.yul" - , "loopInvariantCodeMotion/no_move_memory.yul" - , "loopInvariantCodeMotion/no_move_storage.yul" - , "loopInvariantCodeMotion/not_first.yul" - , "ssaAndBack/single_assign_if.yul" - , "ssaAndBack/single_assign_switch.yul" - , "structuralSimplifier/switch_inline_no_match.yul" - , "unusedFunctionParameterPruner/simple.yul" - , "unusedStoreEliminator/covering_calldatacopy.yul" - , "unusedStoreEliminator/remove_before_revert.yul" - , "unusedStoreEliminator/unknown_length2.yul" - , "unusedStoreEliminator/unrelated_relative.yul" - , "fullSuite/extcodelength.yul" - , "unusedStoreEliminator/create_inside_function.yul"-- "trying to reset symbolic storage with writes in create" - - -- Due to tstorage warnings treated as errors when running solc with --standard-json - -- these cannot be currently run. See: https://github.com/ethereum/solidity/issues/15397 - -- When that fix comes to upstream, we can re-enabled again - , "equalStoreEliminator/transient_storage.yul" - , "unusedStoreEliminator/tload.yul" - , "unusedStoreEliminator/tstore.yul" - , "yulOptimizerTests/fullSuite/transient_storage.yul" - , "yulOptimizerTests/unusedPruner/transient_storage.yul" - ] - - solcRepo <- liftIO $ fromMaybe (internalError "cannot find solidity repo") <$> (lookupEnv "HEVM_SOLIDITY_REPO") - let testDir = solcRepo <> "/test/libyul/yulOptimizerTests" - dircontents <- liftIO $ System.Directory.listDirectory testDir - let - fullpaths = map ((testDir ++ "/") ++) dircontents - recursiveList :: [FilePath] -> [FilePath] -> IO [FilePath] - recursiveList (a:ax) b = do - isdir <- doesDirectoryExist a - case isdir of - True -> do - fs <- System.Directory.listDirectory a - let fs2 = map ((a ++ "/") ++) fs - recursiveList (ax++fs2) b - False -> recursiveList ax (a:b) - recursiveList [] b = pure b - files <- liftIO $ recursiveList fullpaths [] - let filesFiltered = filter (\file -> not $ any (`List.isSubsequenceOf` file) ignoredTests) files - - -- Takes one file which follows the Solidity Yul optimizer unit tests format, - -- extracts both the nonoptimized and the optimized versions, and checks equivalence. - forM_ filesFiltered (\f-> do - liftIO $ print f - origcont <- liftIO $ readFile f - let - onlyAfter pattern (a:ax) = if a =~ pattern then (a:ax) else onlyAfter pattern ax - onlyAfter _ [] = [] - replaceOnce pat repl inp = go inp [] where - go (a:ax) b = if a =~ pat then let a2 = replaceAll repl $ a *=~ pat in b ++ a2:ax - else go ax (b ++ [a]) - go [] b = b - - -- takes a yul program and ensures memory is symbolic by prepending - -- `calldatacopy(0,0,1024)`. (calldata is symbolic, but memory starts empty). - -- This forces the exploration of more branches, and makes the test vectors a - -- little more thorough. - symbolicMem (a:ax) = if a =~ [re|"^ *object"|] then - let a2 = replaceAll "a calldatacopy(0,0,1024)" $ a *=~ [re|code {|] - in (a2:ax) - else replaceOnce [re|^ *{|] "{\ncalldatacopy(0,0,1024)" $ onlyAfter [re|^ *{|] (a:ax) - symbolicMem _ = internalError "Program too short" - - unfiltered = lines origcont - filteredASym = symbolicMem [ x | x <- unfiltered, (not $ x =~ [re|^//|]) && (not $ x =~ [re|^$|]) ] - filteredBSym = symbolicMem [ replaceAll "" $ x *=~[re|^//|] | x <- onlyAfter [re|^// step:|] unfiltered, not $ x =~ [re|^$|] ] - start <- liftIO $ getCurrentTime - putStrLnM $ "Checking file: " <> f - conf <- readConfig - when conf.debug $ liftIO $ do - putStrLnM "-------------Original Below-----------------" - mapM_ putStrLn unfiltered - putStrLnM "------------- Filtered A + Symb below-----------------" - mapM_ putStrLn filteredASym - putStrLnM "------------- Filtered B + Symb below-----------------" - mapM_ putStrLn filteredBSym - putStrLnM "------------- END -----------------" - Just aPrgm <- liftIO $ yul "" $ T.pack $ unlines filteredASym - Just bPrgm <- liftIO $ yul "" $ T.pack $ unlines filteredBSym - procs <- liftIO $ getNumProcessors - withSolvers CVC5 (unsafeInto procs) 1 (Just 100) $ \s -> do - res <- equivalenceCheck s aPrgm bPrgm opts (mkCalldata Nothing []) - end <- liftIO $ getCurrentTime - case any isCex res of - False -> liftIO $ do - print $ "OK. Took " <> (show $ diffUTCTime end start) <> " seconds" - let timeouts = filter isUnknown res - let errors = filter isError res - unless (null timeouts && null errors) $ do - putStrLnM $ "But " <> (show $ length timeouts) <> " timeout(s) and " <> (show $ length errors) <> " error(s) occurred" - internalError "Encountered timeout(s) and/or error(s)" - True -> liftIO $ do - putStrLnM $ "Not OK: " <> show f <> " Got: " <> show res - internalError "Was NOT equivalent" - ) - ] - ] - where - (===>) = assertSolidityComputation - -checkEquivProp :: App m => Prop -> Prop -> m Bool -checkEquivProp a b = fmap (fromMaybe True) $ checkEquivBase (\l r -> PNeg (PImpl l r .&& PImpl r l)) a b True - -checkEquivPropAndLHS :: App m => Prop -> Prop -> m Bool -checkEquivPropAndLHS orig simp = do - let lhsConst = Expr.checkLHSConstProp simp - equiv <- checkEquivProp orig simp - pure $ lhsConst && equiv - -checkEquiv :: (Typeable a, App m) => Expr a -> Expr a -> m Bool -checkEquiv a b = do - opts <- readConfig - if a == b then pure True else do - when (opts.debug) $ liftIO $ putStrLn $ "Checking equivalence of " <> show a <> " and " <> show b - x <- checkEquivBase (./=) a b True - when (opts.debug) $ liftIO $ putStrLn $ "UNSAT check, expect True: " <> show x - y <- checkEquivBase (.==) a b False - when (opts.debug) $ liftIO $ putStrLn $ "SAT check, expect False: " <> show y - pure $ (fromMaybe True x) && not (fromMaybe False y) - -checkEquivAndLHS :: (Typeable a, App m) => Expr a -> Expr a -> m Bool -checkEquivAndLHS orig simp = do - opts <- readConfig - let lhsConst = Expr.checkLHSConst simp - when (opts.debug) $ liftIO $ putStrLn $ "LHS const: " <> show lhsConst - equiv <- checkEquiv orig simp - pure $ lhsConst && equiv - -checkEquivBase :: (Eq a, App m) => (a -> a -> Prop) -> a -> a -> Bool -> m (Maybe Bool) -checkEquivBase mkprop l r expect = do - withSolvers Z3 1 1 (Just 1) $ \solvers -> liftIO $ do - let smt = assertPropsNoSimp [mkprop l r] - res <- checkSat solvers smt - let - ret = case res of - Unsat -> Just True - Sat _ -> Just False - EVM.Solvers.Error _ -> Just (not expect) - EVM.Solvers.Unknown _ -> Nothing - when (ret == Just (not expect)) $ print res - pure ret - --- | Takes a runtime code and calls it with the provided calldata - --- | Takes a creation code and some calldata, runs the creation code, and calls the resulting contract with the provided calldata -runSimpleVM :: App m => ByteString -> ByteString -> m (Maybe ByteString) -runSimpleVM x ins = do - loadVM x >>= \case - Nothing -> pure Nothing - Just vm -> do - let calldata = (ConcreteBuf ins) - vm' = set (#state % #calldata) calldata vm - res <- Stepper.interpret (Fetch.zero 0 Nothing) vm' Stepper.execFully - case res of - Right (ConcreteBuf bs) -> pure $ Just bs - s -> internalError $ show s - --- | Takes a creation code and returns a vm with the result of executing the creation code -loadVM :: App m => ByteString -> m (Maybe (VM Concrete RealWorld)) -loadVM x = do - vm <- liftIO $ stToIO $ vmForEthrunCreation x - vm1 <- Stepper.interpret (Fetch.zero 0 Nothing) vm Stepper.runFully - case vm1.result of - Just (VMSuccess (ConcreteBuf targetCode)) -> do - let target = vm1.state.contract - vm2 <- Stepper.interpret (Fetch.zero 0 Nothing) vm1 (prepVm target targetCode) - writeTrace vm2 - pure $ Just vm2 - _ -> pure Nothing - where - prepVm target targetCode = Stepper.evm $ do - replaceCodeOfSelf (RuntimeCode $ ConcreteRuntimeCode targetCode) - resetState - assign (#state % #gas) 0xffffffffffffffff -- kludge - execState (loadContract target) <$> get >>= put - get - -hex :: ByteString -> ByteString -hex s = - case BS16.decodeBase16Untyped s of - Right x -> x - Left e -> internalError $ T.unpack e - -singleContract :: Text -> Text -> IO (Maybe ByteString) -singleContract x s = - solidity x [i| - pragma experimental ABIEncoderV2; - contract ${x} { ${s} } - |] - -defaultDataLocation :: AbiType -> Text -defaultDataLocation t = - if (case t of - AbiBytesDynamicType -> True - AbiStringType -> True - AbiArrayDynamicType _ -> True - AbiArrayType _ _ -> True - _ -> False) - then "memory" - else "" - -runFunction :: App m => Text -> ByteString -> m (Maybe ByteString) -runFunction c input = do - x <- liftIO $ singleContract "X" c - runSimpleVM (fromJust x) input - -runStatements :: App m => Text -> [AbiValue] -> AbiType -> m (Maybe ByteString) -runStatements stmts args t = do - let params = - T.intercalate ", " - (map (\(x, c) -> abiTypeSolidity (abiValueType x) - <> " " <> defaultDataLocation (abiValueType x) - <> " " <> T.pack [c]) - (zip args "abcdefg")) - s = - "foo(" <> T.intercalate "," - (map (abiTypeSolidity . abiValueType) args) <> ")" - - runFunction [i| - function foo(${params}) public pure returns (${abiTypeSolidity t} ${defaultDataLocation t} x) { - ${stmts} - } - |] (abiMethod s (AbiTuple $ V.fromList args)) - -getStaticAbiArgs :: Int -> VM Symbolic s -> [Expr EWord] -getStaticAbiArgs n vm = - let cd = vm.state.calldata - in decodeStaticArgs 4 n cd - --- includes shaving off 4 byte function sig -decodeAbiValues :: [AbiType] -> ByteString -> [AbiValue] -decodeAbiValues types bs = - let xy = case decodeAbiValue (AbiTupleType $ V.fromList types) (BS.fromStrict (BS.drop 4 bs)) of - AbiTuple xy' -> xy' - _ -> internalError "AbiTuple expected" - in V.toList xy - --- abi types that are supported in the symbolic abi encoder -newtype SymbolicAbiType = SymbolicAbiType AbiType - deriving (Eq, Show) - -newtype SymbolicAbiVal = SymbolicAbiVal AbiValue - deriving (Eq, Show) - -instance Arbitrary SymbolicAbiVal where - arbitrary = do - SymbolicAbiType ty <- arbitrary - SymbolicAbiVal <$> genAbiValue ty - -instance Arbitrary SymbolicAbiType where - arbitrary = SymbolicAbiType <$> frequency - [ (5, (AbiUIntType . (* 8)) <$> choose (1, 32)) - , (5, (AbiIntType . (* 8)) <$> choose (1, 32)) - , (5, pure AbiAddressType) - , (5, pure AbiBoolType) - , (5, AbiBytesType <$> choose (1,32)) - , (1, do SymbolicAbiType ty <- scale (`div` 2) arbitrary - AbiArrayType <$> (choose (1, 30)) <*> pure ty - ) - ] - -newtype Bytes = Bytes ByteString - deriving Eq - -instance Show Bytes where - showsPrec _ (Bytes x) _ = show (BS.unpack x) - -instance Arbitrary Bytes where - arbitrary = fmap (Bytes . BS.pack) arbitrary - -newtype RLPData = RLPData RLP - deriving (Eq, Show) - --- bias towards bytestring to try to avoid infinite recursion -instance Arbitrary RLPData where - arbitrary = frequency - [(5, do - Bytes bytes <- arbitrary - return $ RLPData $ BS bytes) - , (1, do - k <- choose (0,10) - ls <- vectorOf k arbitrary - return $ RLPData $ List [r | RLPData r <- ls]) - ] - -instance Arbitrary Word128 where - arbitrary = liftM2 fromHiAndLo arbitrary arbitrary - -instance Arbitrary Word160 where - arbitrary = liftM2 fromHiAndLo arbitrary arbitrary - -instance Arbitrary Word256 where - arbitrary = liftM2 fromHiAndLo arbitrary arbitrary - -instance Arbitrary W64 where - arbitrary = fmap W64 arbitrary - -instance Arbitrary W256 where - arbitrary = fmap W256 arbitrary - -instance Arbitrary Addr where - arbitrary = fmap Addr arbitrary - -instance Arbitrary (Expr EAddr) where - arbitrary = oneof - [ fmap LitAddr arbitrary - , fmap SymAddr (genName "addr") - ] - -instance Arbitrary (Expr Storage) where - arbitrary = sized genStorage - -instance Arbitrary (Expr EWord) where - arbitrary = sized defaultWord - -instance Arbitrary (Expr Byte) where - arbitrary = sized genByte - -instance Arbitrary (Expr Buf) where - arbitrary = sized defaultBuf - -instance Arbitrary (Expr End) where - arbitrary = sized genEnd - -instance Arbitrary (ContractCode) where - arbitrary = oneof - [ fmap UnknownCode arbitrary - , liftM2 InitCode arbitrary arbitrary - , fmap RuntimeCode arbitrary - ] - -instance Arbitrary (RuntimeCode) where - arbitrary = oneof - [ fmap ConcreteRuntimeCode arbitrary - , fmap SymbolicRuntimeCode arbitrary - ] - -instance Arbitrary (V.Vector (Expr Byte)) where - arbitrary = fmap V.fromList (listOf1 arbitrary) - -instance Arbitrary (Expr EContract) where - arbitrary = sized genEContract - --- LitOnly -newtype LitOnly a = LitOnly a - deriving (Show, Eq) - -newtype LitWord (sz :: Nat) = LitWord (Expr EWord) - deriving (Show) - -instance (KnownNat sz) => Arbitrary (LitWord sz) where - arbitrary = LitWord <$> genLit (fromInteger v) - where - v = natVal (Proxy @sz) - -instance Arbitrary (LitOnly (Expr Byte)) where - arbitrary = LitOnly . LitByte <$> arbitrary - -instance Arbitrary (LitOnly (Expr EWord)) where - arbitrary = LitOnly . Lit <$> arbitrary - -instance Arbitrary (LitOnly (Expr Buf)) where - arbitrary = LitOnly . ConcreteBuf <$> arbitrary - -genEContract :: Int -> Gen (Expr EContract) -genEContract sz = do - c <- arbitrary - b <- defaultWord sz - n <- arbitrary - s <- genStorage sz - ts <- genStorage sz - pure $ C {code=c, storage=s, tStorage=ts, balance=b, nonce=n} - --- ZeroDepthWord -newtype ZeroDepthWord = ZeroDepthWord (Expr EWord) - deriving (Show, Eq) - -instance Arbitrary ZeroDepthWord where - arbitrary = do - fmap ZeroDepthWord . sized $ genWord 0 - --- WriteWordBuf -newtype WriteWordBuf = WriteWordBuf (Expr Buf) - deriving (Show, Eq) - -instance Arbitrary WriteWordBuf where - arbitrary = do - let mkBuf = oneof - [ pure $ ConcreteBuf "" -- empty - , fmap ConcreteBuf arbitrary -- concrete - , sized (genBuf 100) -- overlapping writes - , arbitrary -- sparse writes - ] - fmap WriteWordBuf mkBuf - --- GenCopySliceBuf -newtype GenCopySliceBuf = GenCopySliceBuf (Expr Buf) - deriving (Show, Eq) - -instance Arbitrary GenCopySliceBuf where - arbitrary = do - let mkBuf = oneof - [ pure $ ConcreteBuf "" - , fmap ConcreteBuf arbitrary - , arbitrary - ] - fmap GenCopySliceBuf mkBuf - --- GenWriteStorageExpr -newtype GenWriteStorageExpr = GenWriteStorageExpr (Expr EWord, Expr Storage) - deriving (Show, Eq) - -instance Arbitrary GenWriteStorageExpr where - arbitrary = do - slot <- arbitrary - let mkStore = oneof - [ pure $ ConcreteStore mempty - , fmap ConcreteStore arbitrary - , do - -- generate some write chains where we know that at least one - -- write matches either the input addr, or both the input - -- addr and slot - let addWrites :: Expr Storage -> Int -> Gen (Expr Storage) - addWrites b 0 = pure b - addWrites b n = liftM3 SStore arbitrary arbitrary (addWrites b (n - 1)) - s <- arbitrary - addMatch <- fmap (SStore slot) arbitrary - let withMatch = addMatch s - newWrites <- oneof [ pure 0, pure 1, fmap (`mod` 5) arbitrary ] - addWrites withMatch newWrites - , arbitrary - ] - store <- mkStore - pure $ GenWriteStorageExpr (slot, store) - --- GenWriteByteIdx -newtype GenWriteByteIdx = GenWriteByteIdx (Expr EWord) - deriving (Show, Eq) - -instance Arbitrary GenWriteByteIdx where - arbitrary = do - -- 1st: can never overflow an Int - -- 2nd: can overflow an Int - let mkIdx = frequency [ (10, genLit 1_000_000) , (1, fmap Lit arbitrary) ] - fmap GenWriteByteIdx mkIdx - -newtype LitProp = LitProp Prop - deriving (Show, Eq) - -instance Arbitrary LitProp where - arbitrary = LitProp <$> sized (genProp True) - - -newtype StorageExp = StorageExp (Expr EWord) - deriving (Show, Eq) - -instance Arbitrary StorageExp where - arbitrary = StorageExp <$> (genStorageExp) - -genStorageExp :: Gen (Expr EWord) -genStorageExp = do - fromPos <- genSlot - storage <- genStorageWrites - pure $ SLoad fromPos storage - -genSlot :: Gen (Expr EWord) -genSlot = frequency [ (1, do - buf <- genConcreteBufSlot 64 - case buf of - (ConcreteBuf b) -> do - key <- genLit 10 - pure $ Expr.MappingSlot b key - _ -> internalError "impossible" - ) - -- map element - ,(2, do - l <- genLit 10 - buf <- genConcreteBufSlot 64 - pure $ Add (Keccak buf) l) - -- Array element - ,(2, do - l <- genLit 10 - buf <- genConcreteBufSlot 32 - pure $ Add (Keccak buf) l) - -- member of the Contract - ,(2, pure $ Lit 20) - -- array element - ,(2, do - arrayNum :: Int <- arbitrary - offs :: W256 <- arbitrary - pure $ Lit $ fst (Expr.preImages !! (arrayNum `mod` 3)) + (offs `mod` 3)) - -- random stuff - ,(1, pure $ Lit (maxBound :: W256)) - ] - --- Generates an N-long buffer, all with the same value, at most 8 different ones -genConcreteBufSlot :: Int -> Gen (Expr Buf) -genConcreteBufSlot len = do - b :: Word8 <- arbitrary - pure $ ConcreteBuf $ BS.pack ([ 0 | _ <- [0..(len-2)]] ++ [b]) - -genStorageWrites :: Gen (Expr Storage) -genStorageWrites = do - toSlot <- genSlot - val <- genLit (maxBound :: W256) - store <- frequency [ (3, pure $ AbstractStore (SymAddr "") Nothing) - , (2, genStorageWrites) - ] - pure $ SStore toSlot val store - -instance Arbitrary Prop where - arbitrary = sized (genProp False) - -genProps :: Bool -> Int -> Gen [Prop] -genProps onlyLits sz2 = listOf $ genProp onlyLits sz2 - -genProp :: Bool -> Int -> Gen (Prop) -genProp _ 0 = PBool <$> arbitrary -genProp onlyLits sz = oneof - [ liftM2 PEq subWord subWord - , liftM2 PLT subWord subWord - , liftM2 PGT subWord subWord - , liftM2 PLEq subWord subWord - , liftM2 PGEq subWord subWord - , fmap PNeg subProp - , liftM2 PAnd subProp subProp - , liftM2 POr subProp subProp - , liftM2 PImpl subProp subProp - ] - where - subWord = if onlyLits then frequency [(2, Lit <$> arbitrary) - ,(1, pure $ Lit 0) - ,(1, pure $ Lit Expr.maxLit) - ] - else genWord 1 (sz `div` 2) - subProp = genProp onlyLits (sz `div` 2) - -genByte :: Int -> Gen (Expr Byte) -genByte 0 = fmap LitByte arbitrary -genByte sz = oneof - [ liftM2 IndexWord subWord subWord - , liftM2 ReadByte subWord subBuf - ] - where - subWord = defaultWord (sz `div` 10) - subBuf = defaultBuf (sz `div` 10) - -genLit :: W256 -> Gen (Expr EWord) -genLit bound = do - w <- arbitrary - pure $ Lit (w `mod` bound) - -genNat :: Gen Int -genNat = fmap unsafeInto (arbitrary :: Gen Natural) - -genName :: String -> Gen Text --- In order not to generate SMT reserved words, we prepend with "esc_" -genName ty = fmap (T.pack . (("esc_" <> ty <> "_") <> )) $ listOf1 (oneof . (fmap pure) $ ['a'..'z'] <> ['A'..'Z']) - -genEnd :: Int -> Gen (Expr End) -genEnd 0 = oneof - [ fmap (Failure mempty mempty . UnrecognizedOpcode) arbitrary - , pure $ Failure mempty mempty IllegalOverflow - , pure $ Failure mempty mempty SelfDestruction - ] -genEnd sz = oneof - [ liftM3 Failure subProp (pure mempty) (fmap Revert subBuf) - , liftM4 Success subProp (pure mempty) subBuf arbitrary - , liftM3 ITE subWord subEnd subEnd - -- TODO Partial - ] - where - subBuf = defaultBuf (sz `div` 2) - subWord = defaultWord (sz `div` 2) - subEnd = genEnd (sz `div` 2) - subProp = genProps False (sz `div` 2) - -genSmallLit :: W256 -> Gen (Expr EWord) -genSmallLit m = do - val :: W256 <- arbitrary - pure $ Lit (val `mod` m) - -genWord :: Int -> Int -> Gen (Expr EWord) -genWord litFreq 0 = frequency - [ (litFreq, do - val <- frequency - [ (10, fmap (`mod` 100) arbitrary) - , (1, pure 0) - , (1, pure Expr.maxLit) - , (1, arbitrary) - ] - pure $ Lit val - ) - , (1, oneof - [ pure Origin - , pure Coinbase - , pure Timestamp - , pure BlockNumber - , pure PrevRandao - , pure GasLimit - , pure ChainId - , pure BaseFee - --, liftM2 SelfBalance arbitrary arbitrary - --, liftM2 Gas arbitrary arbitrary - , fmap Lit arbitrary - , fmap Var (genName "word") - ] - ) - ] -genWord litFreq sz = frequency - [ (litFreq, do - val <- frequency - [ (10, fmap (`mod` 100) arbitrary) - , (1, arbitrary) - ] - pure $ Lit val - ) - , (1, oneof - [ liftM2 Add subWord subWord - , liftM2 Sub subWord subWord - , liftM2 Mul subWord subWord - , liftM2 Div subWord subWord - , liftM2 SDiv subWord subWord - , liftM2 Mod subWord subWord - , liftM2 SMod subWord subWord - --, liftM3 AddMod subWord subWord subWord - --, liftM3 MulMod subWord subWord subWord -- it works, but it's VERY SLOW - --, liftM2 Exp subWord litWord - , liftM2 SEx subWord subWord - , liftM2 Min subWord subWord - , liftM2 LT subWord subWord - , liftM2 GT subWord subWord - , liftM2 LEq subWord subWord - , liftM2 GEq subWord subWord - , liftM2 SLT subWord subWord - --, liftM2 SGT subWord subWord - , liftM2 Eq subWord subWord - , fmap IsZero subWord - , liftM2 And subWord subWord - , liftM2 Or subWord subWord - , liftM2 Xor subWord subWord - , fmap Not subWord - , liftM2 SHL subWord subWord - , liftM2 SHR subWord subWord - , liftM2 SAR subWord subWord - , fmap BlockHash subWord - --, liftM3 Balance arbitrary arbitrary subWord - --, fmap CodeSize subWord - --, fmap ExtCodeHash subWord - , fmap Keccak subBuf - , fmap SHA256 subBuf - , liftM2 SLoad subWord subStore - , liftM2 ReadWord genReadIndex subBuf - , fmap BufLength subBuf - , do - one <- subByte - two <- subByte - three <- subByte - four <- subByte - five <- subByte - six <- subByte - seven <- subByte - eight <- subByte - nine <- subByte - ten <- subByte - eleven <- subByte - twelve <- subByte - thirteen <- subByte - fourteen <- subByte - fifteen <- subByte - sixteen <- subByte - seventeen <- subByte - eighteen <- subByte - nineteen <- subByte - twenty <- subByte - twentyone <- subByte - twentytwo <- subByte - twentythree <- subByte - twentyfour <- subByte - twentyfive <- subByte - twentysix <- subByte - twentyseven <- subByte - twentyeight <- subByte - twentynine <- subByte - thirty <- subByte - thirtyone <- subByte - thirtytwo <- subByte - pure $ JoinBytes - one two three four five six seven eight nine ten - eleven twelve thirteen fourteen fifteen sixteen - seventeen eighteen nineteen twenty twentyone - twentytwo twentythree twentyfour twentyfive - twentysix twentyseven twentyeight twentynine - thirty thirtyone thirtytwo - ]) - ] - where - subWord = genWord litFreq (sz `div` 5) - subBuf = defaultBuf (sz `div` 10) - subStore = genStorage (sz `div` 10) - subByte = genByte (sz `div` 10) - genReadIndex = do - o :: (Expr EWord) <- subWord - pure $ case o of - Lit w -> Lit $ w `mod` into (maxBound :: Word64) - _ -> o - -genWordArith :: Int -> Int -> Gen (Expr EWord) -genWordArith litFreq 0 = frequency - [ (litFreq, fmap Lit arbitrary) - , (1, oneof [ fmap Lit arbitrary ]) - ] -genWordArith litFreq sz = frequency - [ (litFreq, fmap Lit arbitrary) - , (20, frequency - [ (20, liftM2 Add subWord subWord) - , (20, liftM2 Sub subWord subWord) - , (20, liftM2 Mul subWord subWord) - , (20, liftM2 SEx subWord subWord) - , (20, liftM2 Xor subWord subWord) - -- these reduce variability - , (3 , liftM2 Min subWord subWord) - , (3 , liftM2 Div subWord subWord) - , (3 , liftM2 SDiv subWord subWord) - , (3 , liftM2 Mod subWord subWord) - , (3 , liftM2 SMod subWord subWord) - , (3 , liftM2 SHL subWord subWord) - , (3 , liftM2 SHR subWord subWord) - , (3 , liftM2 SAR subWord subWord) - , (3 , liftM2 Or subWord subWord) - -- comparisons, reducing variability greatly - , (1 , liftM2 LEq subWord subWord) - , (1 , liftM2 GEq subWord subWord) - , (1 , liftM2 SLT subWord subWord) - --(1, , liftM2 SGT subWord subWord - , (1 , liftM2 Eq subWord subWord) - , (1 , liftM2 And subWord subWord) - , (1 , fmap IsZero subWord ) - -- Expensive below - --(1, liftM3 AddMod subWord subWord subWord - --(1, liftM3 MulMod subWord subWord subWord - --(1, liftM2 Exp subWord litWord - ]) - ] - where - subWord = genWordArith (litFreq `div` 2) (sz `div` 2) - --- Used to check for unsimplified expressions -newtype FoundBad = FoundBad { bad :: Bool } deriving (Show) -initFoundBad :: FoundBad -initFoundBad = FoundBad { bad = False } - --- Finds SLoad -> SStore. This should not occur in most scenarios --- as we can simplify them away -badStoresInExpr :: Expr a -> Bool -badStoresInExpr expr = bad - where - FoundBad bad = execState (mapExprM findBadStore expr) initFoundBad - findBadStore :: Expr a-> State FoundBad (Expr a) - findBadStore e = case e of - (SLoad _ (SStore _ _ _)) -> do - put (FoundBad { bad = True }) - pure e - _ -> pure e - -defaultBuf :: Int -> Gen (Expr Buf) -defaultBuf = genBuf (4_000_000) - -defaultWord :: Int -> Gen (Expr EWord) -defaultWord = genWord 10 - -maybeBoundedLit :: W256 -> Gen (Expr EWord) -maybeBoundedLit bound = do - o <- (arbitrary :: Gen (Expr EWord)) - pure $ case o of - Lit w -> Lit $ w `mod` bound - _ -> o - -genBuf :: W256 -> Int -> Gen (Expr Buf) -genBuf _ 0 = oneof - [ fmap AbstractBuf (genName "buf") - , fmap ConcreteBuf arbitrary - ] -genBuf bound sz = oneof - [ liftM3 WriteWord (maybeBoundedLit bound) subWord subBuf - , liftM3 WriteByte (maybeBoundedLit bound) subByte subBuf - -- we don't generate copyslice instances where: - -- - size is abstract - -- - size > 100 (due to unrolling in SMT.hs) - -- - literal dstOffsets are > 4,000,000 (due to unrolling in SMT.hs) - -- n.b. that 4,000,000 is the theoretical maximum memory size given a 30,000,000 block gas limit - , liftM5 CopySlice genReadIndex (maybeBoundedLit bound) smolLitWord subBuf subBuf - ] - where - -- copySlice gets unrolled in the generated SMT so we can't go too crazy here - smolLitWord = do - w <- arbitrary - pure $ Lit (w `mod` 100) - subWord = defaultWord (sz `div` 5) - subByte = genByte (sz `div` 10) - subBuf = genBuf bound (sz `div` 10) - genReadIndex = do - o :: (Expr EWord) <- subWord - pure $ case o of - Lit w -> Lit $ w `mod` into (maxBound :: Word64) - _ -> o - -genStorage :: Int -> Gen (Expr Storage) -genStorage 0 = oneof - [ liftM2 AbstractStore arbitrary (pure Nothing) - , fmap ConcreteStore arbitrary - ] -genStorage sz = liftM3 SStore key val subStore - where - subStore = genStorage (sz `div` 10) - val = defaultWord (sz `div` 5) - key = genStorageKey - -genStorageKey :: Gen (Expr EWord) -genStorageKey = frequency - -- array slot - [ (4, liftM2 Expr.ArraySlotWithOffs (genByteStringKey 32) (genSmallLit 5)) - , (4, fmap Expr.ArraySlotZero (genByteStringKey 32)) - -- mapping slot - , (8, liftM2 Expr.MappingSlot (genByteStringKey 64) (genSmallLit 5)) - -- small slot - , (4, genLit 20) - -- unrecognized slot type - , (1, genSmallLit 5) - ] - -genByteStringKey :: W256 -> Gen (ByteString) -genByteStringKey len = do - b :: Word8 <- arbitrary - pure $ BS.pack ([ 0 | _ <- [0..(len-2)]] ++ [b `mod` 5]) - --- GenWriteStorageLoad -newtype GenWriteStorageLoad = GenWriteStorageLoad (Expr EWord) - deriving (Show, Eq) - -instance Arbitrary GenWriteStorageLoad where - arbitrary = do - load <- genStorageLoad 10 - pure $ GenWriteStorageLoad load - - where - genStorageLoad :: Int -> Gen (Expr EWord) - genStorageLoad sz = liftM2 SLoad key subStore - where - subStore = genStorage (sz `div` 10) - key = genStorageKey - -data Invocation - = SolidityCall Text [AbiValue] - deriving Show - -assertSolidityComputation :: App m => Invocation -> AbiValue -> m () -assertSolidityComputation (SolidityCall s args) x = - do y <- runStatements s args (abiValueType x) - liftIO $ assertEqual (T.unpack s) - (fmap Bytes (Just (encodeAbiValue x))) - (fmap Bytes y) - -bothM :: (Monad m) => (a -> m b) -> (a, a) -> m (b, b) -bothM f (a, a') = do - b <- f a - b' <- f a' - return (b, b') - -applyPattern :: String -> TestTree -> TestTree -applyPattern p = localOption (TestPattern (parseExpr p)) - -checkBadCheatCode :: Text -> Postcondition s -checkBadCheatCode sig _ = \case - (Failure _ c (Revert _)) -> case mapMaybe findBadCheatCode (concatMap flatten c.traces) of - (s:_) -> (ConcreteBuf $ into s.unFunctionSelector) ./= (ConcreteBuf $ selector sig) - _ -> PBool True - _ -> PBool True - where - findBadCheatCode :: Trace -> Maybe FunctionSelector - findBadCheatCode Trace { tracedata = td } = case td of - ErrorTrace (BadCheatCode _ s) -> Just s - _ -> Nothing - -allBranchesFail :: App m => ByteString -> Maybe Sig -> m (Either [SMTCex] (Expr End)) -allBranchesFail = checkPost (Just p) - where - p _ = \case - Success _ _ _ _ -> PBool False - _ -> PBool True - -reachableUserAsserts :: App m => ByteString -> Maybe Sig -> m (Either [SMTCex] (Expr End)) -reachableUserAsserts = checkPost (Just $ checkAssertions [0x01]) - -checkPost :: App m => Maybe (Postcondition RealWorld) -> ByteString -> Maybe Sig -> m (Either [SMTCex] (Expr End)) -checkPost post c sig = do - (e, res) <- withDefaultSolver $ \s -> - verifyContract s c sig [] defaultVeriOpts Nothing post - let cexs = snd <$> mapMaybe getCex res - case cexs of - [] -> pure $ Right e - cs -> pure $ Left cs - -successGen :: [Prop] -> Expr End -successGen props = Success props mempty (ConcreteBuf "") mempty - --- gets the expected concrete values for symbolic abi testing -expectedConcVals :: Text -> AbiValue -> SMTCex -expectedConcVals nm val = case val of - AbiUInt {} -> mempty { vars = Map.fromList [(Var nm, mkWord val)] } - AbiInt {} -> mempty { vars = Map.fromList [(Var nm, mkWord val)] } - AbiAddress {} -> mempty { addrs = Map.fromList [(SymAddr nm, truncateToAddr (mkWord val))] } - AbiBool {} -> mempty { vars = Map.fromList [(Var nm, mkWord val)] } - AbiBytes {} -> mempty { vars = Map.fromList [(Var nm, mkWord val)] } - AbiArray _ _ vals -> mconcat . V.toList . V.imap (\(T.pack . show -> idx) v -> expectedConcVals (nm <> "-a-" <> idx) v) $ vals - AbiTuple vals -> mconcat . V.toList . V.imap (\(T.pack . show -> idx) v -> expectedConcVals (nm <> "-t-" <> idx) v) $ vals - _ -> internalError $ "unsupported Abi type " <> show nm <> " val: " <> show val <> " val type: " <> showAlter val - where - mkWord = word . encodeAbiValue +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE TypeAbstractions #-} + +module Main where + +import Prelude hiding (LT, GT) + +import GHC.TypeLits +import Data.Proxy +import Control.Monad +import Control.Monad.ST (RealWorld, stToIO) +import Control.Monad.State.Strict +import Control.Monad.IO.Unlift +import Control.Monad.Reader (ReaderT) +import Data.Bits hiding (And, Xor) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as BS16 +import Data.Binary.Put (runPut) +import Data.Binary.Get (runGetOrFail) +import Data.DoubleWord +import Data.Either +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Maybe +import Data.Monoid (Any(..)) +import Data.Set qualified as Set +import Data.String.Here +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (diffUTCTime, getCurrentTime) +import Data.Tuple.Extra +import Data.Tree (flatten) +import Data.Typeable +import Data.Vector qualified as V +import Data.Word (Word8, Word64) +import Data.Char (digitToInt) +import GHC.Conc (getNumProcessors) +import System.Directory +import System.Environment +import Test.Tasty +import Test.Tasty.QuickCheck hiding (Failure, Success) +import Test.QuickCheck.Instances.Text() +import Test.QuickCheck.Instances.Natural() +import Test.QuickCheck.Instances.ByteString() +import Test.Tasty.HUnit +import Test.Tasty.Runners hiding (Failure, Success) +import Test.Tasty.ExpectedFailure +import Text.RE.TDFA.String +import Text.RE.Replace +import Witch (unsafeInto, into) +import Data.Containers.ListUtils (nubOrd) + +import Optics.Core hiding (pre, re, elements) +import Optics.State + +import EVM +import EVM.ABI +import EVM.Assembler +import EVM.Exec +import EVM.Expr qualified as Expr +import EVM.Fetch qualified as Fetch +import EVM.Format (hexByteString, hexText, formatExpr) +import EVM.Precompiled +import EVM.RLP +import EVM.SMT hiding (one) +import EVM.Solidity +import EVM.Solvers +import EVM.Stepper qualified as Stepper +import EVM.SymExec +import EVM.Test.Tracing qualified as Tracing +import EVM.Test.Utils +import EVM.Traversals +import EVM.Types hiding (Env) +import EVM.Effects +import EVM.UnitTest (writeTrace, printWarnings) +import EVM.Expr (maybeLitByteSimp) +import Data.Text.Internal.Builder (toLazyText) + +testEnv :: Env +testEnv = Env { config = defaultConfig { + dumpQueries = False + , dumpExprs = False + , dumpEndStates = False + , debug = False + , dumpTrace = False + , decomposeStorage = True + , verb = 1 + } } + +putStrLnM :: (MonadUnliftIO m) => String -> m () +putStrLnM a = liftIO $ putStrLn a + +assertEqualM :: (App m, Eq a, Show a, HasCallStack) => String -> a -> a -> m () +assertEqualM a b c = liftIO $ assertEqual a b c + +assertBoolM + :: (MonadUnliftIO m, HasCallStack) + => String -> Bool -> m () +assertBoolM a b = liftIO $ assertBool a b + +test :: TestName -> ReaderT Env IO () -> TestTree +test a b = testCase a $ runEnv testEnv b + +testNoSimplify :: TestName -> ReaderT Env IO () -> TestTree +testNoSimplify a b = let testEnvNoSimp = Env { config = testEnv.config { simp = False } } + in testCase a $ runEnv testEnvNoSimp b + +testFuzz :: TestName -> ReaderT Env IO () -> TestTree +testFuzz a b = testCase a $ runEnv (testEnv {config = testEnv.config {numCexFuzz = 100, onlyCexFuzz = True}}) b + +prop :: Testable prop => ReaderT Env IO prop -> Property +prop a = ioProperty $ runEnv testEnv a + +propNoSimpNoFuzz :: Testable prop => ReaderT Env IO prop -> Property +propNoSimpNoFuzz a = let testEnvNoSimp = Env { config = testEnv.config { numCexFuzz = 0, simp = False } } + in ioProperty $ runEnv testEnvNoSimp a + +withDefaultSolver :: App m => (SolverGroup -> m a) -> m a +withDefaultSolver = withSolvers Z3 3 1 Nothing + +withCVC5Solver :: App m => (SolverGroup -> m a) -> m a +withCVC5Solver = withSolvers CVC5 3 1 Nothing + +withBitwuzlaSolver :: App m => (SolverGroup -> m a) -> m a +withBitwuzlaSolver = withSolvers Bitwuzla 3 1 Nothing + +main :: IO () +main = defaultMain tests + +-- | run a subset of tests in the repl. p is a tasty pattern: +-- https://github.com/UnkindPartition/tasty/tree/ee6fe7136fbcc6312da51d7f1b396e1a2d16b98a#patterns +runSubSet :: String -> IO () +runSubSet p = defaultMain . applyPattern p $ tests + +tests :: TestTree +tests = testGroup "hevm" + [ Tracing.tests + , testGroup "simplify-storage" + [ test "simplify-storage-array-only-static" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] a; + function transfer(uint acct, uint val1, uint val2) public { + unchecked { + a[0] = val1 + 1; + a[1] = val2 + 2; + assert(a[0]+a[1] == val1 + val2 + 3); + } + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + assertEqualM "Expression is not clean." (badStoresInExpr expr) False + -- This case is somewhat artificial. We can't simplify this using only + -- static rewrite rules, because acct is totally abstract and acct + 1 + -- could overflow back to zero. we may be able to do better if we have some + -- smt assisted simplification that can take branch conditions into account. + , expectFail $ test "simplify-storage-array-symbolic-index" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint b; + uint[] a; + function transfer(uint acct, uint val1) public { + unchecked { + a[acct] = val1; + assert(a[acct] == val1); + } + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + -- T.writeFile "symbolic-index.expr" $ formatExpr expr + assertEqualM "Expression is not clean." (badStoresInExpr expr) False + , expectFail $ test "simplify-storage-array-of-struct-symbolic-index" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + struct MyStruct { + uint a; + uint b; + } + MyStruct[] arr; + function transfer(uint acct, uint val1, uint val2) public { + unchecked { + arr[acct].a = val1+1; + arr[acct].b = val1+2; + assert(arr[acct].a + arr[acct].b == val1+val2+3); + } + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + assertEqualM "Expression is not clean." (badStoresInExpr expr) False + , test "simplify-storage-array-loop-nonstruct" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] a; + function transfer(uint v) public { + for (uint i = 0; i < a.length; i++) { + a[i] = v; + assert(a[i] == v); + } + } + } + |] + let veriOpts = defaultVeriOpts { iterConf = defaultIterConf { maxIter = Just 5 }} + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256)" [AbiUIntType 256])) [] veriOpts + assertEqualM "Expression is not clean." (badStoresInExpr expr) False + , test "simplify-storage-map-newtest1" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping (uint => uint) a; + mapping (uint => uint) b; + function fun(uint v, uint i) public { + require(i < 1000); + require(v < 1000); + b[i+v] = v+1; + a[i] = v; + b[i+1] = v+1; + assert(a[i] == v); + assert(b[i+1] == v+1); + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + assertEqualM "Expression is not clean." (badStoresInExpr expr) False + (_, [(Qed)]) <- withDefaultSolver $ \s -> checkAssert s [0x11] c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + liftIO $ putStrLn "OK" + , ignoreTest $ test "simplify-storage-map-todo" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping (uint => uint) a; + mapping (uint => uint) b; + function fun(uint v, uint i) public { + require(i < 1000); + require(v < 1000); + a[i] = v; + b[i+1] = v+1; + b[i+v] = 55; // note: this can overwrite b[i+1], hence assert below can fail + assert(a[i] == v); + assert(b[i+1] == v+1); + } + } + |] + -- TODO: expression below contains (load idx1 (store idx1 (store idx1 (store idx0)))), and the idx0 + -- is not stripped. This is due to us not doing all we can in this case, see + -- note above readStorage. Decompose remedies this (when it can be decomposed) + -- expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + -- putStrLnM $ T.unpack $ formatExpr expr + (_, [Cex _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + liftIO $ putStrLn "OK" + , test "simplify-storage-array-loop-struct" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + struct MyStruct { + uint a; + uint b; + } + MyStruct[] arr; + function transfer(uint v1, uint v2) public { + for (uint i = 0; i < arr.length; i++) { + arr[i].a = v1+1; + arr[i].b = v2+2; + assert(arr[i].a + arr[i].b == v1 + v2 + 3); + } + } + } + |] + let veriOpts = defaultVeriOpts { iterConf = defaultIterConf { maxIter = Just 5 }} + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] veriOpts + assertEqualM "Expression is not clean." (badStoresInExpr expr) False + , test "decompose-1" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping (address => uint) balances; + function prove_mapping_access(address x, address y) public { + require(x != y); + balances[x] = 1; + balances[y] = 2; + assert(balances[x] != balances[y]); + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "prove_mapping_access(address,address)" [AbiAddressType, AbiAddressType])) [] defaultVeriOpts + let simpExpr = mapExprM Expr.decomposeStorage expr + assertEqualM "Decompose did not succeed." (isJust simpExpr) True + , test "decompose-2" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping (address => uint) balances; + function prove_mixed_symoblic_concrete_writes(address x, uint v) public { + balances[x] = v; + balances[address(0)] = balances[x]; + assert(balances[address(0)] == v); + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "prove_mixed_symoblic_concrete_writes(address,uint256)" [AbiAddressType, AbiUIntType 256])) [] defaultVeriOpts + let simpExpr = mapExprM Expr.decomposeStorage expr + -- putStrLnM $ T.unpack $ formatExpr (fromJust simpExpr) + assertEqualM "Decompose did not succeed." (isJust simpExpr) True + , test "decompose-3" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] a; + function prove_array(uint x, uint v1, uint y, uint v2) public { + require(v1 != v2); + a[x] = v1; + a[y] = v2; + assert(a[x] == a[y]); + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "prove_array(uint256,uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + let simpExpr = mapExprM Expr.decomposeStorage expr + assertEqualM "Decompose did not succeed." (isJust simpExpr) True + , test "decompose-4-mixed" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] a; + mapping( uint => uint) balances; + function prove_array(uint x, uint v1, uint y, uint v2) public { + require(v1 != v2); + balances[x] = v1+1; + balances[y] = v1+2; + a[x] = v1; + assert(balances[x] != balances[y]); + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "prove_array(uint256,uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + let simpExpr = mapExprM Expr.decomposeStorage expr + -- putStrLnM $ T.unpack $ formatExpr (fromJust simpExpr) + assertEqualM "Decompose did not succeed." (isJust simpExpr) True + , test "decompose-5-mixed" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping (address => uint) balances; + mapping (uint => bool) auth; + uint[] arr; + uint a; + uint b; + function prove_mixed(address x, address y, uint val) public { + b = val+1; + require(x != y); + balances[x] = val; + a = val; + arr[val] = 5; + auth[val+1] = true; + balances[y] = val+2; + if (balances[y] == balances[y]) { + assert(balances[y] == val); + } + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "prove_mixed(address,address,uint256)" [AbiAddressType, AbiAddressType, AbiUIntType 256])) [] defaultVeriOpts + let simpExpr = mapExprM Expr.decomposeStorage expr + -- putStrLnM $ T.unpack $ formatExpr (fromJust simpExpr) + assertEqualM "Decompose did not succeed." (isJust simpExpr) True + , test "decompose-6" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] arr; + function prove_mixed(uint val) public { + arr[val] = 5; + arr[val+1] = val+5; + assert(arr[val] == arr[val+1]); + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "prove_mixed(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + let simpExpr = mapExprM Expr.decomposeStorage expr + -- putStrLnM $ T.unpack $ formatExpr (fromJust simpExpr) + assertEqualM "Decompose did not succeed." (isJust simpExpr) True + -- This test uses array.length, which is is concrete 0 only in case we start with an empty storage + -- otherwise (i.e. with getExpr) it's symbolic, and the exploration loops forever + , test "decompose-7-emtpy-storage" $ do + Just c <- solcRuntime "MyContract" [i| + contract MyContract { + uint[] arr; + function nested_append(uint v, uint w) public { + arr.push(w); + arr.push(); + arr.push(); + arr.push(arr[0]-1); + + arr[2] = v; + arr[1] = arr[0]-arr[2]; + + assert(arr.length == 4); + assert(arr[0] == w); + assert(arr[1] == w-v); + assert(arr[2] == v); + assert(arr[3] == w-1); + } + } |] + let sig = Just $ Sig "nested_append(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256] + expr <- withDefaultSolver $ \s -> getExprEmptyStore s c sig [] defaultVeriOpts + assertEqualM "Expression must be clean." (badStoresInExpr expr) False + , test "simplify-storage-map-only-static" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping(uint => uint) items1; + function transfer(uint acct, uint val1, uint val2) public { + unchecked { + items1[0] = val1+1; + items1[1] = val2+2; + assert(items1[0]+items1[1] == val1 + val2 + 3); + } + } + } + |] + let sig = (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) + expr <- withDefaultSolver $ \s -> getExpr s c sig [] defaultVeriOpts + assertEqualM "Expression is not clean." (badStoresInExpr expr) False + , test "simplify-storage-map-only-2" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping(uint => uint) items1; + function transfer(uint acct, uint val1, uint val2) public { + unchecked { + items1[acct] = val1+1; + items1[acct+1] = val2+2; + assert(items1[acct]+items1[acct+1] == val1 + val2 + 3); + } + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + -- putStrLnM $ T.unpack $ formatExpr expr + assertEqualM "Expression is not clean." (badStoresInExpr expr) False + , test "simplify-storage-map-with-struct" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + struct MyStruct { + uint a; + uint b; + } + mapping(uint => MyStruct) items1; + function transfer(uint acct, uint val1, uint val2) public { + unchecked { + items1[acct].a = val1+1; + items1[acct].b = val2+2; + assert(items1[acct].a+items1[acct].b == val1 + val2 + 3); + } + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + assertEqualM "Expression is not clean." (badStoresInExpr expr) False + , test "simplify-storage-map-and-array" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] a; + mapping(uint => uint) items1; + mapping(uint => uint) items2; + function transfer(uint acct, uint val1, uint val2) public { + uint beforeVal1 = items1[acct]; + uint beforeVal2 = items2[acct]; + unchecked { + items1[acct] = val1+1; + items2[acct] = val2+2; + a[0] = val1 + val2 + 1; + a[1] = val1 + val2 + 2; + assert(items1[acct]+items2[acct]+a[0]+a[1] > beforeVal1 + beforeVal2); + } + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + -- putStrLnM $ T.unpack $ formatExpr expr + assertEqualM "Expression is not clean." (badStoresInExpr expr) False + , test "simplify-storage-wordToAddr" $ do + let a = "000000000000000000000000d95322745865822719164b1fc167930754c248de000000000000000000000000000000000000000000000000000000000000004a" + store = ConcreteStore (Map.fromList[(W256 0xebd33f63ba5dda53a45af725baed5628cdad261db5319da5f5d921521fe1161d,W256 0x5842cf)]) + expr = SLoad (Keccak (ConcreteBuf (hexStringToByteString a))) store + simpExpr = Expr.wordToAddr expr + simpExpr2 = Expr.concKeccakSimpExpr expr + assertEqualM "Expression should simplify to value." simpExpr (Just $ LitAddr 0x5842cf) + assertEqualM "Expression should simplify to value." simpExpr2 (Lit 0x5842cf) + , test "simplify-storage-wordToAddr-complex" $ do + let a = "000000000000000000000000d95322745865822719164b1fc167930754c248de000000000000000000000000000000000000000000000000000000000000004a" + store = ConcreteStore (Map.fromList[(W256 0xebd33f63ba5dda53a45af725baed5628cdad261db5319da5f5d921521fe1161d,W256 0x5842cf)]) + expr = SLoad (Keccak (ConcreteBuf (hexStringToByteString a))) store + writeWChain = WriteWord (Lit 0x32) (Lit 0x72) (WriteWord (Lit 0x0) expr (ConcreteBuf "")) + kecc = Keccak (CopySlice (Lit 0x0) (Lit 0x0) (Lit 0x20) (WriteWord (Lit 0x0) expr (writeWChain)) (ConcreteBuf "")) + keccAnd = (And (Lit 1461501637330902918203684832716283019655932542975) kecc) + outer = And (Lit 1461501637330902918203684832716283019655932542975) (SLoad (keccAnd) (ConcreteStore (Map.fromList[(W256 1184450375068808042203882151692185743185288360635, W256 0xacab)]))) + simp = Expr.concKeccakSimpExpr outer + assertEqualM "Expression should simplify to value." simp (Lit 0xacab) + ] + , testGroup "StorageTests" + [ test "read-from-sstore" $ assertEqualM "" + (Lit 0xab) + (Expr.readStorage' (Lit 0x0) (SStore (Lit 0x0) (Lit 0xab) (AbstractStore (LitAddr 0x0) Nothing))) + , test "read-from-concrete" $ assertEqualM "" + (Lit 0xab) + (Expr.readStorage' (Lit 0x0) (ConcreteStore $ Map.fromList [(0x0, 0xab)])) + , test "read-past-write" $ assertEqualM "" + (Lit 0xab) + (Expr.readStorage' (Lit 0x0) (SStore (Lit 0x1) (Var "b") (ConcreteStore $ Map.fromList [(0x0, 0xab)]))) + , test "accessStorage uses fetchedStorage" $ do + let dummyContract = + (initialContract (RuntimeCode (ConcreteRuntimeCode mempty))) + { external = True } + vm :: VM Concrete RealWorld <- liftIO $ stToIO $ vmForEthrunCreation "" + -- perform the initial access + let ?conf = testEnv.config + vm1 <- liftIO $ stToIO $ execStateT (EVM.accessStorage (LitAddr 0) (Lit 0) (pure . pure ())) vm + -- it should fetch the contract first + vm2 <- case vm1.result of + Just (HandleEffect (Query (PleaseFetchContract _addr _ continue))) -> + liftIO $ stToIO $ execStateT (continue dummyContract) vm1 + _ -> internalError "unexpected result" + -- then it should fetch the slow + vm3 <- case vm2.result of + Just (HandleEffect (Query (PleaseFetchSlot _addr _slot continue))) -> + liftIO $ stToIO $ execStateT (continue 1337) vm2 + _ -> internalError "unexpected result" + -- perform the same access as for vm1 + vm4 <- liftIO $ stToIO $ execStateT (EVM.accessStorage (LitAddr 0) (Lit 0) (pure . pure ())) vm3 + + -- there won't be query now as accessStorage uses fetch cache + assertBoolM (show vm4.result) (isNothing vm4.result) + ] + , testGroup "SimplifierUnitTests" + -- common overflow cases that the simplifier was getting wrong + [ test "writeWord-overflow" $ do + let e = ReadByte (Lit 0x0) (WriteWord (Lit 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffd) (Lit 0x0) (ConcreteBuf "\255\255\255\255")) + b <- checkEquiv e (Expr.simplify e) + assertBoolM "Simplifier failed" b + , test "copyslice-simps" $ do + let e a b = CopySlice (Lit 0) (Lit 0) (BufLength (AbstractBuf "buff")) (CopySlice (Lit 0) (Lit 0) (BufLength (AbstractBuf "buff")) (AbstractBuf "buff") (ConcreteBuf a)) (ConcreteBuf b) + expr1 = e "" "" + expr2 = e "" "aasdfasdf" + expr3 = e "9832478932" "" + expr4 = e "9832478932" "aasdfasdf" + assertEqualM "Not full simp" (Expr.simplify expr1) (AbstractBuf "buff") + assertEqualM "Not full simp" (Expr.simplify expr2) $ CopySlice (Lit 0x0) (Lit 0x0) (BufLength (AbstractBuf "buff")) (AbstractBuf "buff") (ConcreteBuf "aasdfasdf") + assertEqualM "Not full simp" (Expr.simplify expr3) (AbstractBuf "buff") + assertEqualM "Not full simp" (Expr.simplify expr4) $ CopySlice (Lit 0x0) (Lit 0x0) (BufLength (AbstractBuf "buff")) (AbstractBuf "buff") (ConcreteBuf "aasdfasdf") + , test "buffer-length-copy-slice-beyond-source1" $ do + let e = BufLength (CopySlice (Lit 0x2) (Lit 0x2) (Lit 0x1) (ConcreteBuf "a") (ConcreteBuf "")) + b <- checkEquiv e (Expr.simplify e) + assertBoolM "Simplifier failed" b + , test "buffer-length-copy-slice-beyond-source2" $ do + let e = BufLength (CopySlice (Lit 0x2) (Lit 0x2) (Lit 0x1) (ConcreteBuf "") (ConcreteBuf "")) + b <- checkEquiv e (Expr.simplify e) + assertBoolM "Simplifier failed" b + , test "simp-readByte1" $ do + let srcOffset = (ReadWord (Lit 0x1) (AbstractBuf "stuff1")) + size = (ReadWord (Lit 0x1) (AbstractBuf "stuff2")) + src = (AbstractBuf "stuff2") + e = ReadByte (Lit 0x0) (CopySlice srcOffset (Lit 0x10) size src (AbstractBuf "dst")) + simp = Expr.simplify e + assertEqualM "readByte simplification" simp (ReadByte (Lit 0x0) (AbstractBuf "dst")) + , test "simp-readByte2" $ do + let srcOffset = (ReadWord (Lit 0x1) (AbstractBuf "stuff1")) + size = (Lit 0x1) + src = (AbstractBuf "stuff2") + e = ReadByte (Lit 0x0) (CopySlice srcOffset (Lit 0x10) size src (AbstractBuf "dst")) + simp = Expr.simplify e + res <- checkEquiv e simp + assertEqualM "readByte simplification" res True + , test "simp-readWord1" $ do + let srcOffset = (ReadWord (Lit 0x1) (AbstractBuf "stuff1")) + size = (ReadWord (Lit 0x1) (AbstractBuf "stuff2")) + src = (AbstractBuf "stuff2") + e = ReadWord (Lit 0x1) (CopySlice srcOffset (Lit 0x40) size src (AbstractBuf "dst")) + simp = Expr.simplify e + assertEqualM "readWord simplification" simp (ReadWord (Lit 0x1) (AbstractBuf "dst")) + , test "simp-readWord2" $ do + let srcOffset = (ReadWord (Lit 0x12) (AbstractBuf "stuff1")) + size = (Lit 0x1) + src = (AbstractBuf "stuff2") + e = ReadWord (Lit 0x12) (CopySlice srcOffset (Lit 0x50) size src (AbstractBuf "dst")) + simp = Expr.simplify e + res <- checkEquiv e simp + assertEqualM "readWord simplification" res True + , test "simp-max-buflength" $ do + let simp = Expr.simplify $ Max (Lit 0) (BufLength (AbstractBuf "txdata")) + assertEqualM "max-buflength rules" simp $ BufLength (AbstractBuf "txdata") + , test "simp-PLT-max" $ do + let simp = Expr.simplifyProp $ PLT (Max (Lit 5) (BufLength (AbstractBuf "txdata"))) (Lit 99) + assertEqualM "max-buflength rules" simp $ PLT (BufLength (AbstractBuf "txdata")) (Lit 99) + , test "simp-assoc-add1" $ do + let simp = Expr.simplify $ Add (Add (Var "c") (Var "a")) (Var "b") + assertEqualM "assoc rules" simp $ Add (Var "a") (Add (Var "b") (Var "c")) + , test "simp-assoc-add2" $ do + let simp = Expr.simplify $ Add (Add (Lit 1) (Var "c")) (Var "b") + assertEqualM "assoc rules" simp $ Add (Lit 1) (Add (Var "b") (Var "c")) + , test "simp-assoc-add3" $ do + let simp = Expr.simplify $ Add (Lit 1) (Add (Lit 2) (Var "c")) + assertEqualM "assoc rules" simp $ Add (Lit 3) (Var "c") + , test "simp-assoc-add4" $ do + let simp = Expr.simplify $ Add (Lit 1) (Add (Var "b") (Lit 2)) + assertEqualM "assoc rules" simp $ Add (Lit 3) (Var "b") + , test "simp-assoc-add5" $ do + let simp = Expr.simplify $ Add (Var "a") (Add (Lit 1) (Lit 2)) + assertEqualM "assoc rules" simp $ Add (Lit 3) (Var "a") + , test "simp-assoc-add6" $ do + let simp = Expr.simplify $ Add (Lit 7) (Add (Lit 1) (Lit 2)) + assertEqualM "assoc rules" simp $ Lit 10 + , test "simp-assoc-add-7" $ do + let simp = Expr.simplify $ Add (Var "a") (Add (Var "b") (Lit 2)) + assertEqualM "assoc rules" simp $ Add (Lit 2) (Add (Var "a") (Var "b")) + , test "simp-assoc-add8" $ do + let simp = Expr.simplify $ Add (Add (Var "a") (Add (Lit 0x2) (Var "b"))) (Add (Var "c") (Add (Lit 0x2) (Var "d"))) + assertEqualM "assoc rules" simp $ Add (Lit 4) (Add (Var "a") (Add (Var "b") (Add (Var "c") (Var "d")))) + , test "simp-assoc-mul1" $ do + let simp = Expr.simplify $ Mul (Mul (Var "b") (Var "a")) (Var "c") + assertEqualM "assoc rules" simp $ Mul (Var "a") (Mul (Var "b") (Var "c")) + , test "simp-assoc-mul2" $ do + let simp = Expr.simplify $ Mul (Lit 2) (Mul (Var "a") (Lit 3)) + assertEqualM "assoc rules" simp $ Mul (Lit 6) (Var "a") + , test "simp-assoc-xor1" $ do + let simp = Expr.simplify $ Xor (Lit 2) (Xor (Var "a") (Lit 3)) + assertEqualM "assoc rules" simp $ Xor (Lit 1) (Var "a") + , test "simp-assoc-xor2" $ do + let simp = Expr.simplify $ Xor (Lit 2) (Xor (Var "b") (Xor (Var "a") (Lit 3))) + assertEqualM "assoc rules" simp $ Xor (Lit 1) (Xor (Var "a") (Var "b")) + , test "simp-zero-write-extend-buffer-len" $ do + let + expr = BufLength $ CopySlice (Lit 0) (Lit 0x10) (Lit 0) (AbstractBuf "buffer") (ConcreteBuf "bimm") + simp = Expr.simplify expr + ret <- checkEquiv expr simp + assertEqualM "Must be equivalent" True ret + , test "bufLength-simp" $ do + let + a = BufLength (ConcreteBuf "ab") + simp = Expr.simplify a + assertEqualM "Must be simplified down to a Lit" simp (Lit 2) + , test "stripWrites-overflow" $ do + -- below eventually boils down to + -- unsafeInto (0xf0000000000000000000000000000000000000000000000000000000000000+1) :: Int + -- which failed before + let + a = ReadByte (Lit 0xf0000000000000000000000000000000000000000000000000000000000000) (WriteByte (And (SHA256 (ConcreteBuf "")) (Lit 0x1)) (LitByte 0) (ConcreteBuf "")) + b = Expr.simplify a + ret <- checkEquiv a b + assertBoolM "must be equivalent" ret + , test "read-beyond-bound (negative-test)" $ do + let + e1 = CopySlice (Lit 1) (Lit 0) (Lit 2) (ConcreteBuf "a") (ConcreteBuf "") + e2 = ConcreteBuf "Definitely not the same!" + equal <- checkEquiv e1 e2 + assertBoolM "Should not be equivalent!" $ not equal + ] + -- 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 + -- unsimplified one + , adjustOption (\(Test.Tasty.QuickCheck.QuickCheckTests n) -> Test.Tasty.QuickCheck.QuickCheckTests (div n 2)) $ testGroup "SimplifierTests" + [ testProperty "buffer-simplification" $ \(expr :: Expr Buf) -> propNoSimpNoFuzz $ do + let simplified = Expr.simplify expr + checkEquivAndLHS expr simplified + , testProperty "buffer-simplification-len" $ \(expr :: Expr Buf) -> propNoSimpNoFuzz $ do + let simplified = Expr.simplify (BufLength expr) + checkEquivAndLHS (BufLength expr) simplified + , testProperty "store-simplification" $ \(expr :: Expr Storage) -> propNoSimpNoFuzz $ do + let simplified = Expr.simplify expr + checkEquivAndLHS expr simplified + , testProperty "load-simplification" $ \(GenWriteStorageLoad expr) -> propNoSimpNoFuzz $ do + let simplified = Expr.simplify expr + checkEquivAndLHS expr simplified + , ignoreTest $ testProperty "load-decompose" $ \(GenWriteStorageLoad expr) -> propNoSimpNoFuzz $ do + putStrLnM $ T.unpack $ formatExpr expr + let simp = Expr.simplify expr + let decomposed = fromMaybe simp $ mapExprM Expr.decomposeStorage simp + -- putStrLnM $ "-----------------------------------------" + -- putStrLnM $ T.unpack $ formatExpr decomposed + -- putStrLnM $ "\n\n\n\n" + checkEquiv expr decomposed + , testProperty "byte-simplification" $ \(expr :: Expr Byte) -> propNoSimpNoFuzz $ do + let simplified = Expr.simplify expr + checkEquivAndLHS expr simplified + , testProperty "word-simplification" $ \(ZeroDepthWord expr) -> propNoSimpNoFuzz $ do + let simplified = Expr.simplify expr + checkEquivAndLHS expr simplified + , testProperty "readStorage-equivalance" $ \(store, slot) -> propNoSimpNoFuzz $ do + let simplified = Expr.readStorage' slot store + full = SLoad slot store + checkEquiv full simplified + , testProperty "writeStorage-equivalance" $ \(val, GenWriteStorageExpr (slot, store)) -> propNoSimpNoFuzz $ do + let simplified = Expr.writeStorage slot val store + full = SStore slot val store + checkEquiv full simplified + , testProperty "readWord-equivalance" $ \(buf, idx) -> propNoSimpNoFuzz $ do + let simplified = Expr.readWord idx buf + full = ReadWord idx buf + checkEquiv full simplified + , testProperty "writeWord-equivalance" $ \(idx, val, WriteWordBuf buf) -> propNoSimpNoFuzz $ do + let simplified = Expr.writeWord idx val buf + full = WriteWord idx val buf + checkEquiv full simplified + , testProperty "arith-simplification" $ \(_ :: Int) -> propNoSimpNoFuzz $ do + expr <- liftIO $ generate . sized $ genWordArith 15 + let simplified = Expr.simplify expr + checkEquivAndLHS expr simplified + , testProperty "readByte-equivalance" $ \(buf, idx) -> propNoSimpNoFuzz $ do + let simplified = Expr.readByte idx buf + full = ReadByte idx buf + checkEquiv full simplified + -- we currently only simplify concrete writes over concrete buffers so that's what we test here + , testProperty "writeByte-equivalance" $ \(LitOnly val, LitOnly buf, GenWriteByteIdx idx) -> propNoSimpNoFuzz $ do + let simplified = Expr.writeByte idx val buf + full = WriteByte idx val buf + checkEquiv full simplified + , testProperty "copySlice-equivalance" $ \(srcOff, GenCopySliceBuf src, GenCopySliceBuf dst, LitWord @300 size) -> propNoSimpNoFuzz $ do + -- we bias buffers to be concrete more often than not + dstOff <- liftIO $ generate (maybeBoundedLit 100_000) + let simplified = Expr.copySlice srcOff dstOff size src dst + full = CopySlice srcOff dstOff size src dst + checkEquiv full simplified + , testProperty "indexWord-equivalence" $ \(src, LitWord @50 idx) -> propNoSimpNoFuzz $ do + let simplified = Expr.indexWord idx src + full = IndexWord idx src + checkEquiv full simplified + , testProperty "indexWord-mask-equivalence" $ \(src :: Expr EWord, LitWord @35 idx) -> propNoSimpNoFuzz $ do + mask <- liftIO $ generate $ do + pow <- arbitrary :: Gen Int + frequency + [ (1, pure $ Lit $ (shiftL 1 (pow `mod` 256)) - 1) -- potentially non byte aligned + , (1, pure $ Lit $ (shiftL 1 ((pow * 8) `mod` 256)) - 1) -- byte aligned + ] + let + input = And mask src + simplified = Expr.indexWord idx input + full = IndexWord idx input + checkEquiv full simplified + , testProperty "toList-equivalance" $ \buf -> propNoSimpNoFuzz $ do + let + -- transforms the input buffer to give it a known length + fixLength :: Expr Buf -> Gen (Expr Buf) + fixLength = mapExprM go + where + go :: Expr a -> Gen (Expr a) + go = \case + WriteWord _ val b -> liftM3 WriteWord idx (pure val) (pure b) + WriteByte _ val b -> liftM3 WriteByte idx (pure val) (pure b) + CopySlice so _ sz src dst -> liftM5 CopySlice (pure so) idx (pure sz) (pure src) (pure dst) + AbstractBuf _ -> cbuf + e -> pure e + cbuf = do + bs <- arbitrary + pure $ ConcreteBuf bs + idx = do + w <- arbitrary + -- we use 100_000 as an upper bound for indices to keep tests reasonably fast here + pure $ Lit (w `mod` 100_000) + + input <- liftIO $ generate $ fixLength buf + case Expr.toList input of + Nothing -> do + putStrLnM "skip" + pure True -- ignore cases where the buf cannot be represented as a list + Just asList -> do + let asBuf = Expr.fromList asList + checkEquiv asBuf input + , testProperty "simplifyProp-equivalence-lit" $ \(LitProp p) -> propNoSimpNoFuzz $ do + let simplified = Expr.simplifyProps [p] + case simplified of + [] -> checkEquivProp (PBool True) p + [val@(PBool _)] -> checkEquivProp val p + _ -> liftIO $ assertFailure "must evaluate down to a literal bool" + , testProperty "simplifyProp-equivalence-sym" $ \(p) -> propNoSimpNoFuzz $ do + let simplified = Expr.simplifyProp p + checkEquivPropAndLHS p simplified + , testProperty "simplify-joinbytes" $ \(SymbolicJoinBytes exprList) -> propNoSimpNoFuzz $ do + let x = joinBytesFromList exprList + let simplified = Expr.simplify x + y <- checkEquiv x simplified + assertBoolM "Must be equal" y + , testProperty "simpProp-equivalence-sym-Prop" $ \(ps :: [Prop]) -> propNoSimpNoFuzz $ do + let simplified = pand (Expr.simplifyProps ps) + checkEquivPropAndLHS (pand ps) simplified + , testProperty "simpProp-equivalence-sym-LitProp" $ \(LitProp p) -> propNoSimpNoFuzz $ do + let simplified = pand (Expr.simplifyProps [p]) + checkEquivPropAndLHS p simplified + , testProperty "storage-slot-simp-property" $ \(StorageExp s) -> propNoSimpNoFuzz $ do + -- we have to run `Expr.litToKeccak` on the unsimplified system, or + -- we'd need some form of minimal simplifier for things to work out. As long as + -- we trust the litToKeccak, this is fine, as that function is stand-alone, + -- and quite minimal + let s2 = Expr.litToKeccak s + let simplified = Expr.simplify s2 + checkEquivAndLHS s2 simplified + , test "storage-slot-single" $ do + -- this tests that "" and "0"x32 is not equivalent in Keccak + let x = SLoad (Add (Keccak (ConcreteBuf "")) (Lit 1)) (SStore (Keccak (ConcreteBuf "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL")) (Lit 0) (AbstractStore (SymAddr "stuff") Nothing)) + let simplified = Expr.simplify x + y <- checkEquivAndLHS x simplified + assertBoolM "Must be equal" y + , test "word-eq-bug" $ do + -- This test is actually OK because the simplified takes into account that it's impossible to find a + -- near-collision in the keccak hash + let x = (SLoad (Keccak (AbstractBuf "es")) (SStore (Add (Keccak (ConcreteBuf "")) (Lit 0x1)) (Lit 0xacab) (ConcreteStore (Map.empty)))) + let simplified = Expr.simplify x + y <- checkEquiv x simplified + assertBoolM "Must be equal, given keccak distance axiom" y + ] + {- NOTE: These tests were designed to test behaviour on reading from a buffer such that the indices overflow 2^256. + However, such scenarios are impossible in the real world (the operation would run out of gas). The problem + is that the behaviour of bytecode interpreters does not match the semantics of SMT. Intrepreters just + return all zeroes for any read beyond buffer size, while in SMT reading multiple bytes may lead to overflow + on indices and subsequently to reading from the beginning of the buffer (wrap-around semantics). + , testGroup "concrete-buffer-simplification-large-index" [ + test "copy-slice-large-index-nooverflow" $ do + let + e = CopySlice (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Lit 0x0) (Lit 0x1) (ConcreteBuf "a") (ConcreteBuf "") + s = Expr.simplify e + equal <- checkEquiv e s + assertEqualM "Must be equal" True equal + , test "copy-slice-overflow-back-into-source" $ do + let + e = CopySlice (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Lit 0x0) (Lit 0x2) (ConcreteBuf "a") (ConcreteBuf "") + s = Expr.simplify e + equal <- checkEquiv e s + assertEqualM "Must be equal" True equal + , test "copy-slice-overflow-beyond-source" $ do + let + e = CopySlice (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Lit 0x0) (Lit 0x3) (ConcreteBuf "a") (ConcreteBuf "") + s = Expr.simplify e + equal <- checkEquiv e s + assertEqualM "Must be equal" True equal + , test "copy-slice-overflow-beyond-source-into-nonempty" $ do + let + e = CopySlice (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Lit 0x0) (Lit 0x3) (ConcreteBuf "a") (ConcreteBuf "b") + s = Expr.simplify e + equal <- checkEquiv e s + assertEqualM "Must be equal" True equal + , test "read-word-overflow-back-into-source" $ do + let + e = ReadWord (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (ConcreteBuf "kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk") + s = Expr.simplify e + equal <- checkEquiv e s + assertEqualM "Must be equal" True equal + ] + -} + , testGroup "isUnsat-concrete-tests" [ + test "disjunction-left-false" $ do + let + t = [PEq (Var "x") (Lit 1), POr (PEq (Var "x") (Lit 0)) (PEq (Var "y") (Lit 1)), PEq (Var "y") (Lit 2)] + propagated = Expr.constPropagate t + assertEqualM "Must contain PBool False" True ((PBool False) `elem` propagated) + , test "disjunction-right-false" $ do + let + t = [PEq (Var "x") (Lit 1), POr (PEq (Var "y") (Lit 1)) (PEq (Var "x") (Lit 0)), PEq (Var "y") (Lit 2)] + propagated = Expr.constPropagate t + assertEqualM "Must contain PBool False" True ((PBool False) `elem` propagated) + , test "disjunction-both-false" $ do + let + t = [PEq (Var "x") (Lit 1), POr (PEq (Var "x") (Lit 2)) (PEq (Var "x") (Lit 0)), PEq (Var "y") (Lit 2)] + propagated = Expr.constPropagate t + assertEqualM "Must contain PBool False" True ((PBool False) `elem` propagated) + , ignoreTest $ test "disequality-and-equality" $ do + let + t = [PNeg (PEq (Lit 1) (Var "arg1")), PEq (Lit 1) (Var "arg1")] + propagated = Expr.constPropagate t + assertEqualM "Must contain PBool False" True ((PBool False) `elem` propagated) + , test "equality-and-disequality" $ do + let + t = [PEq (Lit 1) (Var "arg1"), PNeg (PEq (Lit 1) (Var "arg1"))] + propagated = Expr.constPropagate t + assertEqualM "Must contain PBool False" True ((PBool False) `elem` propagated) + ] + , testGroup "simpProp-concrete-tests" [ + test "simpProp-concrete-trues" $ do + let + t = [PBool True, PBool True] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [] simplified + , test "simpProp-concrete-false1" $ do + let + t = [PBool True, PBool False] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [PBool False] simplified + , test "simpProp-concrete-false2" $ do + let + t = [PBool False, PBool False] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [PBool False] simplified + , test "simpProp-concrete-or-1" $ do + let + -- a = 5 && (a=4 || a=3) -> False + t = [PEq (Lit 5) (Var "a"), POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 3))] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [PBool False] simplified + , ignoreTest $ test "simpProp-concrete-or-2" $ do + let + -- Currently does not work, because we don't do simplification inside + -- POr/PAnd using canBeSat + -- a = 5 && (a=4 || a=5) -> a=5 + t = [PEq (Lit 5) (Var "a"), POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 5))] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [] simplified + , test "simpProp-concrete-and-1" $ do + let + -- a = 5 && (a=4 && a=3) -> False + t = [PEq (Lit 5) (Var "a"), PAnd (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 3))] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [PBool False] simplified + , test "simpProp-concrete-or-of-or" $ do + let + -- a = 5 && ((a=4 || a=6) || a=3) -> False + t = [PEq (Lit 5) (Var "a"), POr (POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 6))) (PEq (Var "a") (Lit 3))] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [PBool False] simplified + , test "simpProp-inner-expr-simp" $ do + let + -- 5+1 = 6 + t = [PEq (Add (Lit 5) (Lit 1)) (Var "a")] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [PEq (Lit 6) (Var "a")] simplified + , test "simpProp-inner-expr-simp-with-canBeSat" $ do + let + -- 5+1 = 6, 6 != 7 + t = [PAnd (PEq (Add (Lit 5) (Lit 1)) (Var "a")) (PEq (Var "a") (Lit 7))] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [PBool False] simplified + , test "simpProp-inner-expr-bitwise-and" $ do + let + -- 1 & 2 != 2 + t = [PEq (And (Lit 1) (Lit 2)) (Lit 2)] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [PBool False] simplified + , test "simpProp-inner-expr-bitwise-or" $ do + let + -- 2 | 4 == 6 + t = [PEq (Or (Lit 2) (Lit 4)) (Lit 6)] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [] simplified + , test "simpProp-constpropagate-1" $ do + let + -- 5+1 = 6 + t = [PEq (Add (Lit 5) (Lit 1)) (Var "a"), PEq (Var "b") (Var "a")] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [PEq (Lit 6) (Var "a"), PEq (Lit 6) (Var "b")] simplified + , test "simpProp-constpropagate-2" $ do + let + -- 5+1 = 6 + t = [PEq (Add (Lit 5) (Lit 1)) (Var "a"), PEq (Var "b") (Var "a"), PEq (Var "c") (Sub (Var "b") (Lit 1))] + simplified = Expr.simplifyProps t + assertEqualM "Must be equal" [PEq (Lit 6) (Var "a"), PEq (Lit 6) (Var "b"), PEq (Lit 5) (Var "c")] simplified + , test "simpProp-constpropagate-3" $ do + let + t = [ PEq (Add (Lit 5) (Lit 1)) (Var "a") -- a = 6 + , PEq (Var "b") (Var "a") -- b = 6 + , PEq (Var "c") (Sub (Var "b") (Lit 1)) -- c = 5 + , PEq (Var "d") (Sub (Var "b") (Var "c"))] -- d = 1 + simplified = Expr.simplifyProps t + assertEqualM "Must know d == 1" ((PEq (Lit 1) (Var "d")) `elem` simplified) True + ] + , testGroup "MemoryTests" + [ test "read-write-same-byte" $ assertEqualM "" + (LitByte 0x12) + (Expr.readByte (Lit 0x20) (WriteByte (Lit 0x20) (LitByte 0x12) mempty)) + , test "read-write-same-word" $ assertEqualM "" + (Lit 0x12) + (Expr.readWord (Lit 0x20) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) + , test "read-byte-write-word" $ assertEqualM "" + -- reading at byte 31 a word that's been written should return LSB + (LitByte 0x12) + (Expr.readByte (Lit 0x1f) (WriteWord (Lit 0x0) (Lit 0x12) mempty)) + , test "read-byte-write-word2" $ assertEqualM "" + -- Same as above, but offset not 0 + (LitByte 0x12) + (Expr.readByte (Lit 0x20) (WriteWord (Lit 0x1) (Lit 0x12) mempty)) + ,test "read-write-with-offset" $ assertEqualM "" + -- 0x3F = 63 decimal, 0x20 = 32. 0x12 = 18 + -- We write 128bits (32 Bytes), representing 18 at offset 32. + -- Hence, when reading out the 63rd byte, we should read out the LSB 8 bits + -- which is 0x12 + (LitByte 0x12) + (Expr.readByte (Lit 0x3F) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) + ,test "read-write-with-offset2" $ assertEqualM "" + -- 0x20 = 32, 0x3D = 61 + -- we write 128 bits (32 Bytes) representing 0x10012, at offset 32. + -- we then read out a byte at offset 61. + -- So, at 63 we'd read 0x12, at 62 we'd read 0x00, at 61 we should read 0x1 + (LitByte 0x1) + (Expr.readByte (Lit 0x3D) (WriteWord (Lit 0x20) (Lit 0x10012) mempty)) + , test "read-write-with-extension-to-zero" $ assertEqualM "" + -- write word and read it at the same place (i.e. 0 offset) + (Lit 0x12) + (Expr.readWord (Lit 0x0) (WriteWord (Lit 0x0) (Lit 0x12) mempty)) + , test "read-write-with-extension-to-zero-with-offset" $ assertEqualM "" + -- write word and read it at the same offset of 4 + (Lit 0x12) + (Expr.readWord (Lit 0x4) (WriteWord (Lit 0x4) (Lit 0x12) mempty)) + , test "read-write-with-extension-to-zero-with-offset2" $ assertEqualM "" + -- write word and read it at the same offset of 16 + (Lit 0x12) + (Expr.readWord (Lit 0x20) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) + , test "read-word-copySlice-overlap" $ assertEqualM "" + -- we should not recurse into a copySlice if the read index + 32 overlaps the sliced region + (ReadWord (Lit 40) (CopySlice (Lit 0) (Lit 30) (Lit 12) (WriteWord (Lit 10) (Lit 0x64) (AbstractBuf "hi")) (AbstractBuf "hi"))) + (Expr.readWord (Lit 40) (CopySlice (Lit 0) (Lit 30) (Lit 12) (WriteWord (Lit 10) (Lit 0x64) (AbstractBuf "hi")) (AbstractBuf "hi"))) + , test "indexword-MSB" $ assertEqualM "" + -- 31st is the LSB byte (of 32) + (LitByte 0x78) + (Expr.indexWord (Lit 31) (Lit 0x12345678)) + , test "indexword-LSB" $ assertEqualM "" + -- 0th is the MSB byte (of 32), Lit 0xff22bb... is exactly 32 Bytes. + (LitByte 0xff) + (Expr.indexWord (Lit 0) (Lit 0xff22bb4455667788990011223344556677889900112233445566778899001122)) + , test "indexword-LSB2" $ assertEqualM "" + -- same as above, but with offset 2 + (LitByte 0xbb) + (Expr.indexWord (Lit 2) (Lit 0xff22bb4455667788990011223344556677889900112233445566778899001122)) + , test "encodeConcreteStore-overwrite" $ + assertEqualM "" + (pure "(store (store ((as const Storage) #x0000000000000000000000000000000000000000000000000000000000000000) (_ bv1 256) (_ bv2 256)) (_ bv3 256) (_ bv4 256))") + (EVM.SMT.encodeConcreteStore $ Map.fromList [(W256 1, W256 2), (W256 3, W256 4)]) + , test "indexword-oob-sym" $ assertEqualM "" + -- indexWord should return 0 for oob access + (LitByte 0x0) + (Expr.indexWord (Lit 100) (JoinBytes + (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) + (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) + (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) + (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0))) + , test "stripbytes-concrete-bug" $ assertEqualM "" + (Expr.simplifyReads (ReadByte (Lit 0) (ConcreteBuf "5"))) + (LitByte 53) + ] + , testGroup "ABI" + [ testProperty "Put/get inverse" $ \x -> + case runGetOrFail (getAbi (abiValueType x)) (runPut (putAbi x)) of + Right ("", _, x') -> x' == x + _ -> False + ] + , testGroup "Solidity-Expressions" + [ test "Trivial" $ + SolidityCall "x = 3;" [] + ===> AbiUInt 256 3 + , test "Arithmetic" $ do + SolidityCall "x = a + 1;" + [AbiUInt 256 1] ===> AbiUInt 256 2 + SolidityCall "unchecked { x = a - 1; }" + [AbiUInt 8 0] ===> AbiUInt 8 255 + , test "negative-numbers-nonzero-comp-1" $ do + Just c <- solcRuntime "C" [i| + contract C { + function fun(int256 x) public { + // Cheatcode address + address vm = 0x7109709ECfa91a80626fF3989D68f67F5b1DD12D; + bytes memory data = abi.encodeWithSignature("assertGe(int256,int256)", x, -1); + (bool success, ) = vm.staticcall(data); + assert(success == true); + } + } |] + let sig = Just $ Sig "fun(int256)" [AbiIntType 256] + (e, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + assertBoolM "The expression must not be partial" $ not (Expr.containsNode isPartial e) + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 1 numCexes + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 0 numQeds + , test "negative-numbers-nonzero-comp-2" $ do + Just c <- solcRuntime "C" [i| + contract C { + function fun(int256 x) public { + // Cheatcode address + address vm = 0x7109709ECfa91a80626fF3989D68f67F5b1DD12D; + bytes memory data = abi.encodeWithSignature("assertGe(int256,int256)", x, 1); + (bool success, ) = vm.staticcall(data); + assert(success == true); + } + } |] + let sig = Just $ Sig "fun(int256)" [AbiIntType 256] + (e, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + assertBoolM "The expression must not be partial" $ not (Expr.containsNode isPartial e) + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 1 numCexes + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 0 numQeds + , test "negative-numbers-min" $ do + Just c <- solcRuntime "C" [i| + contract C { + function fun(int256 x) public { + // Cheatcode address + address vm = 0x7109709ECfa91a80626fF3989D68f67F5b1DD12D; + bytes memory data = abi.encodeWithSignature("assertLt(int256,int256)", x, type(int256).min); + (bool success, ) = vm.staticcall(data); + assert(success == true); + } + } |] + let sig = Just $ Sig "fun(int256)" [AbiIntType 256] + (e, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + assertBoolM "The expression must not be partial" $ not (Expr.containsNode isPartial e) + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 1 numCexes + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 0 numQeds + , test "negative-numbers-int128-1" $ do + Just c <- solcRuntime "C" [i| + contract C { + function fun(int128 y) public { + int256 x = int256(y); + // Cheatcode address + address vm = 0x7109709ECfa91a80626fF3989D68f67F5b1DD12D; + bytes memory data = abi.encodeWithSignature("assertLt(int256,int256)", x, -1); + (bool success, ) = vm.staticcall(data); + assert(success == true); + } + } |] + let sig = Just $ Sig "fun(int128)" [AbiIntType 128] + (e, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + assertBoolM "The expression must not be partial" $ not (Expr.containsNode isPartial e) + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 1 numCexes + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 0 numQeds + , test "negative-numbers-zero-comp-simpleassert" $ do + Just c <- solcRuntime "C" [i| + contract C { + function fun(int256 x) public { + assert(x >= 0); + } + } |] + let sig = Just $ Sig "fun(int256)" [AbiIntType 256] + (e, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + assertBoolM "The expression must not be partial" $ not (Expr.containsNode isPartial e) + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 1 numCexes + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 0 numQeds + , test "negative-numbers-zero-comp" $ do + Just c <- solcRuntime "C" [i| + contract C { + function fun(int256 x) public { + // Cheatcode address + address vm = 0x7109709ECfa91a80626fF3989D68f67F5b1DD12D; + bytes memory data = abi.encodeWithSignature("assertGe(int256,int256)", x, 0); + (bool success, ) = vm.staticcall(data); + assert(success == true); + } + } |] + let sig = Just $ Sig "fun(int256)" [AbiIntType 256] + (e, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + assertBoolM "The expression must not be partial" $ not (Expr.containsNode isPartial e) + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 1 numCexes + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 0 numQeds + , test "positive-numbers-cex" $ do + Just c <- solcRuntime "C" [i| + contract C { + function fun(uint256 x) public { + // Cheatcode address + address vm = 0x7109709ECfa91a80626fF3989D68f67F5b1DD12D; + bytes memory data = abi.encodeWithSignature("assertGe(uint256,uint256)", x, 1); + (bool success, ) = vm.staticcall(data); + assert(success == true); + } + } |] + let sig = Just $ Sig "fun(uint256)" [AbiUIntType 256] + (e, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + assertBoolM "The expression must not be partial" $ not (Expr.containsNode isPartial e) + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 1 numCexes + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 0 numQeds + , test "positive-numbers-qed" $ do + Just c <- solcRuntime "C" [i| + contract C { + function fun(uint256 x) public { + // Cheatcode address + address vm = 0x7109709ECfa91a80626fF3989D68f67F5b1DD12D; + bytes memory data = abi.encodeWithSignature("assertGe(uint256,uint256)", x, 0); + (bool success, ) = vm.staticcall(data); + assert(success == true); + } + } |] + let sig = Just $ Sig "fun(uint256)" [AbiUIntType 256] + (e, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + assertBoolM "The expression must not be partial" $ not (Expr.containsNode isPartial e) + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 0 numCexes + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 1 numQeds + + , test "keccak256()" $ + SolidityCall "x = uint(keccak256(abi.encodePacked(a)));" + [AbiString ""] ===> AbiUInt 256 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470 + + , testProperty "symbolic-abi-enc-vs-solidity" $ \(SymbolicAbiVal y) -> prop $ do + Just encoded <- runStatements [i| x = abi.encode(a);|] [y] AbiBytesDynamicType + let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of + AbiTuple (V.toList -> [e]) -> e + _ -> internalError "AbiTuple expected" + let + frag = [symAbiArg "y" (AbiTupleType $ V.fromList [abiValueType y])] + (hevmEncoded, _) = first (Expr.drop 4) $ combineFragments frag (ConcreteBuf "") + expectedVals = expectedConcVals "y" (AbiTuple . V.fromList $ [y]) + hevmConcretePre = fromRight (error "cannot happen") $ subModel expectedVals hevmEncoded + hevmConcrete = case Expr.simplify hevmConcretePre of + ConcreteBuf b -> b + buf -> internalError ("valMap: " <> show expectedVals <> "\ny:" <> show y <> "\n" <> "buf: " <> show buf) + -- putStrLnM $ "frag: " <> show frag + -- putStrLnM $ "expectedVals: " <> show expectedVals + -- putStrLnM $ "frag: " <> show frag + -- putStrLnM $ "hevmEncoded: " <> show hevmEncoded + -- putStrLnM $ "solidity encoded: " <> show solidityEncoded + -- putStrLnM $ "our encoded : " <> show (AbiBytesDynamic hevmConcrete) + -- putStrLnM $ "y : " <> show y + -- putStrLnM $ "y type: " <> showAlter y + -- putStrLnM $ "hevmConcretePre: " <> show hevmConcretePre + assertEqualM "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmConcrete) + , testProperty "symbolic-abi encoding-vs-solidity-2-args" $ \(SymbolicAbiVal x', SymbolicAbiVal y') -> prop $ do + Just encoded <- runStatements [i| x = abi.encode(a, b);|] [x', y'] AbiBytesDynamicType + let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of + AbiTuple (V.toList -> [e]) -> e + _ -> internalError "AbiTuple expected" + let hevmEncoded = encodeAbiValue (AbiTuple $ V.fromList [x',y']) + assertEqualM "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) + , testProperty "abi-encoding-vs-solidity" $ forAll (arbitrary >>= genAbiValue) $ + \y -> prop $ do + Just encoded <- runStatements [i| x = abi.encode(a);|] + [y] AbiBytesDynamicType + let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of + AbiTuple (V.toList -> [e]) -> e + _ -> internalError "AbiTuple expected" + let hevmEncoded = encodeAbiValue (AbiTuple $ V.fromList [y]) + assertEqualM "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) + + , testProperty "abi-encoding-vs-solidity-2-args" $ forAll (arbitrary >>= bothM genAbiValue) $ + \(x', y') -> prop $ do + Just encoded <- runStatements [i| x = abi.encode(a, b);|] + [x', y'] AbiBytesDynamicType + let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of + AbiTuple (V.toList -> [e]) -> e + _ -> internalError "AbiTuple expected" + let hevmEncoded = encodeAbiValue (AbiTuple $ V.fromList [x',y']) + assertEqualM "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) + + -- we need a separate test for this because the type of a function is "function() external" in solidity but just "function" in the abi: + , askOption $ \(QuickCheckTests n) -> testProperty "abi-encoding-vs-solidity-function-pointer" $ withMaxSuccess (min n 20) $ forAll (genAbiValue AbiFunctionType) $ + \y -> prop $ do + Just encoded <- runFunction [i| + function foo(function() external a) public pure returns (bytes memory x) { + x = abi.encode(a); + } + |] (abiMethod "foo(function)" (AbiTuple (V.singleton y))) + let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of + AbiTuple (V.toList -> [e]) -> e + _ -> internalError "AbiTuple expected" + let hevmEncoded = encodeAbiValue (AbiTuple $ V.fromList [y]) + assertEqualM "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) + ] + + , testGroup "Precompiled contracts" + [ testGroup "Example (reverse)" + [ test "success" $ + assertEqualM "example contract reverses" + (execute 0xdeadbeef "foobar" 6) (Just "raboof") + , test "failure" $ + assertEqualM "example contract fails on length mismatch" + (execute 0xdeadbeef "foobar" 5) Nothing + ] + + , testGroup "ECRECOVER" + [ test "success" $ do + let + r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4732" + s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" + v = hex "000000000000000000000000000000000000000000000000000000000000001c" + h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31" + a = hex "0000000000000000000000002d5e56d45c63150d937f2182538a0f18510cb11f" + assertEqualM "successful recovery" + (Just a) + (execute 1 (h <> v <> r <> s) 32) + , test "fail on made up values" $ do + let + r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4731" + s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" + v = hex "000000000000000000000000000000000000000000000000000000000000001c" + h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31" + assertEqualM "fail because bit flip" + Nothing + (execute 1 (h <> v <> r <> s) 32) + ] + ] + , testGroup "Byte/word manipulations" + [ testProperty "padLeft length" $ \n (Bytes bs) -> + BS.length (padLeft n bs) == max n (BS.length bs) + , testProperty "padLeft identity" $ \(Bytes bs) -> + padLeft (BS.length bs) bs == bs + , testProperty "padRight length" $ \n (Bytes bs) -> + BS.length (padLeft n bs) == max n (BS.length bs) + , testProperty "padRight identity" $ \(Bytes bs) -> + padLeft (BS.length bs) bs == bs + , testProperty "padLeft zeroing" $ \(NonNegative n) (Bytes bs) -> + let x = BS.take n (padLeft (BS.length bs + n) bs) + y = BS.replicate n 0 + in x == y + ] + + , testGroup "Unresolved link detection" + [ test "holes detected" $ do + let code' = "608060405234801561001057600080fd5b5060405161040f38038061040f83398181016040528101906100329190610172565b73__$f3cbc3eb14e5bd0705af404abcf6f741ec$__63ab5c1ffe826040518263ffffffff1660e01b81526004016100699190610217565b60206040518083038186803b15801561008157600080fd5b505af4158015610095573d6000803e3d6000fd5b505050506040513d601f19601f820116820180604052508101906100b99190610145565b50506103c2565b60006100d36100ce84610271565b61024c565b9050828152602081018484840111156100ef576100ee610362565b5b6100fa8482856102ca565b509392505050565b600081519050610111816103ab565b92915050565b600082601f83011261012c5761012b61035d565b5b815161013c8482602086016100c0565b91505092915050565b60006020828403121561015b5761015a61036c565b5b600061016984828501610102565b91505092915050565b6000602082840312156101885761018761036c565b5b600082015167ffffffffffffffff8111156101a6576101a5610367565b5b6101b284828501610117565b91505092915050565b60006101c6826102a2565b6101d081856102ad565b93506101e08185602086016102ca565b6101e981610371565b840191505092915050565b60006102016003836102ad565b915061020c82610382565b602082019050919050565b6000604082019050818103600083015261023181846101bb565b90508181036020830152610244816101f4565b905092915050565b6000610256610267565b905061026282826102fd565b919050565b6000604051905090565b600067ffffffffffffffff82111561028c5761028b61032e565b5b61029582610371565b9050602081019050919050565b600081519050919050565b600082825260208201905092915050565b60008115159050919050565b60005b838110156102e85780820151818401526020810190506102cd565b838111156102f7576000848401525b50505050565b61030682610371565b810181811067ffffffffffffffff821117156103255761032461032e565b5b80604052505050565b7f4e487b7100000000000000000000000000000000000000000000000000000000600052604160045260246000fd5b600080fd5b600080fd5b600080fd5b600080fd5b6000601f19601f8301169050919050565b7f6261720000000000000000000000000000000000000000000000000000000000600082015250565b6103b4816102be565b81146103bf57600080fd5b50565b603f806103d06000396000f3fe6080604052600080fdfea26469706673582212207d03b26e43dc3d116b0021ddc9817bde3762a3b14315351f11fc4be384fd14a664736f6c63430008060033" + assertBoolM "linker hole not detected" (containsLinkerHole code'), + test "no false positives" $ do + let code' = "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fea265627a7a723158205d775f914dcb471365a430b5f5b2cfe819e615cbbb5b2f1ccc7da1fd802e43c364736f6c634300050b0032" + assertBoolM "false positive" (not . containsLinkerHole $ code') + ] + + , testGroup "metadata stripper" + [ test "it strips the metadata for solc => 0.6" $ do + let code' = hexText "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fea265627a7a723158205d775f914dcb471365a430b5f5b2cfe819e615cbbb5b2f1ccc7da1fd802e43c364736f6c634300050b0032" + stripped = stripBytecodeMetadata code' + assertEqualM "failed to strip metadata" (show (ByteStringS stripped)) "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fe" + , + testCase "it strips the metadata and constructor args" $ do + let srccode = + [i| + contract A { + uint y; + constructor(uint x) public { + y = x; + } + } + |] + + Just initCode <- solidity "A" srccode + assertEqual "constructor args screwed up metadata stripping" (stripBytecodeMetadata (initCode <> encodeAbiValue (AbiUInt 256 1))) (stripBytecodeMetadata initCode) + ] + + , testGroup "RLP encodings" + [ testProperty "rlp decode is a retraction (bytes)" $ \(Bytes bs) -> + rlpdecode (rlpencode (BS bs)) == Just (BS bs) + , testProperty "rlp encode is a partial inverse (bytes)" $ \(Bytes bs) -> + case rlpdecode bs of + Just r -> rlpencode r == bs + Nothing -> True + , testProperty "rlp decode is a retraction (RLP)" $ \(RLPData r) -> + rlpdecode (rlpencode r) == Just r + ] + , testGroup "Panic code tests via symbolic execution" + [ + test "assert-fail" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a) external pure { + assert(a != 0); + } + } + |] + (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s [0x01] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + assertEqualM "Must be 0" 0 $ getVar ctr "arg1" + putStrLnM $ "expected counterexample found, and it's correct: " <> (show $ getVar ctr "arg1") + , + test "safeAdd-fail" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure returns (uint256 c) { + c = a+b; + } + } + |] + (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s [0x11] c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + let x = getVar ctr "arg1" + let y = getVar ctr "arg2" + + let maxUint = 2 ^ (256 :: Integer) :: Integer + assertBoolM "Overflow must occur" (toInteger x + toInteger y >= maxUint) + putStrLnM "expected counterexample found" + , + test "div-by-zero-fail" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure returns (uint256 c) { + c = a/b; + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Bitwuzla 1 1 Nothing $ \s -> checkAssert s [0x12] c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + assertEqualM "Division by 0 needs b=0" (getVar ctr "arg2") 0 + putStrLnM "expected counterexample found" + , + test "unused-args-fail" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun(uint256 a) public pure { + assert(false); + } + } + |] + (_, [Cex _]) <- withSolvers Bitwuzla 1 1 Nothing $ \s -> checkAssert s [0x1] c Nothing [] defaultVeriOpts + putStrLnM "expected counterexample found" + , test "gas-decrease-monotone" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint8 a) external { + uint a = gasleft(); + uint b = gasleft(); + assert(a > b); + } + } + |] + let sig = (Just (Sig "fun(uint8)" [AbiUIntType 8])) + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + putStrLnM "expected Qed found" + , test "enum-conversion-fail" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + enum MyEnum { ONE, TWO } + function fun(uint256 a) external pure returns (MyEnum b) { + b = MyEnum(a); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Bitwuzla 1 1 Nothing $ \s -> checkAssert s [0x21] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + assertBoolM "Enum is only defined for 0 and 1" $ (getVar ctr "arg1") > 1 + putStrLnM "expected counterexample found" + , + -- TODO 0x22 is missing: "0x22: If you access a storage byte array that is incorrectly encoded." + -- TODO below should NOT fail + -- TODO this has a loop that depends on a symbolic value and currently causes interpret to loop + ignoreTest $ test "pop-empty-array" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] private arr; + function fun(uint8 a) external { + arr.push(1); + arr.push(2); + for (uint i = 0; i < a; i++) { + arr.pop(); + } + } + } + |] + a <- withDefaultSolver $ \s -> checkAssert s [0x31] c (Just (Sig "fun(uint8)" [AbiUIntType 8])) [] defaultVeriOpts + liftIO $ do + print $ length a + print $ show a + putStrLnM "expected counterexample found" + , + test "access-out-of-bounds-array" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] private arr; + function fun(uint8 a) external returns (uint x){ + arr.push(1); + arr.push(2); + x = arr[a]; + } + } + |] + (_, [Cex (_, _)]) <- withDefaultSolver $ \s -> checkAssert s [0x32] c (Just (Sig "fun(uint8)" [AbiUIntType 8])) [] defaultVeriOpts + -- assertBoolM "Access must be beyond element 2" $ (getVar ctr "arg1") > 1 + putStrLnM "expected counterexample found" + , + -- Note: we catch the assertion here, even though we are only able to explore partially + test "alloc-too-much" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a) external { + uint[] memory arr = new uint[](a); + } + } + |] + (_, [Cex _]) <- withDefaultSolver $ \s -> + checkAssert s [0x41] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "expected counterexample found" + , + test "vm.deal unknown address" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function deal(address,uint256) external; + } + contract C { + // this is not supported yet due to restrictions around symbolic address aliasing... + function f(address e, uint val) external { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + vm.deal(e, val); + assert(e.balance == val); + } + } + |] + Right e <- reachableUserAsserts c (Just $ Sig "f(address,uint256)" [AbiAddressType, AbiUIntType 256]) + assertBoolM "The expression is not partial" $ Expr.containsNode isPartial e + , + test "vm.prank-create" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function prank(address) external; + } + contract Owned { + address public owner; + constructor() { + owner = msg.sender; + } + } + contract C { + function f() external { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + + Owned target = new Owned(); + assert(target.owner() == address(this)); + + address usr = address(1312); + vm.prank(usr); + target = new Owned(); + assert(target.owner() == usr); + target = new Owned(); + assert(target.owner() == address(this)); + } + } + |] + Right _ <- reachableUserAsserts c (Just $ Sig "f()" []) + liftIO $ putStrLn "no reachable assertion violations" + , + test "vm.prank underflow" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function prank(address) external; + } + contract Payable { + function hi() public payable {} + } + contract C { + function f() external { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + + uint amt = 10; + address from = address(0xacab); + require(from.balance < amt); + + Payable target = new Payable(); + vm.prank(from); + target.hi{value : amt}(); + } + } + |] + r <- allBranchesFail c Nothing + assertBoolM "all branches must fail" (isRight r) + , test "cheatcode-nonexistent" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function nonexistent_cheatcode(uint) external; + } + contract C { + function fun(uint a) public { + // Cheatcode address + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + vm.nonexistent_cheatcode(a); + assert(1 == 1); + } + } + |] + let sig = Just (Sig "fun(uint256)" [AbiUIntType 256]) + (e, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + assertBoolM "The expression must contain Partial." $ Expr.containsNode isPartial e + , test "cheatcode-with-selector" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function prove_warp_symbolic(uint128 jump) public { + uint pre = block.timestamp; + address hevm = 0x7109709ECfa91a80626fF3989D68f67F5b1DD12D; + (bool success, ) = hevm.call(abi.encodeWithSelector(bytes4(keccak256("warp(uint256)")), block.timestamp+jump)); + require(success, "Call to hevm.warp failed"); + assert(block.timestamp == pre + jump); + } + } + |] + Right e <- reachableUserAsserts c Nothing + assertBoolM "The expression should not contain Partial." $ Prelude.not $ Expr.containsNode isPartial e + , + test "call ffi when disabled" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function ffi(string[] calldata) external; + } + contract C { + function f() external { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + + string[] memory inputs = new string[](2); + inputs[0] = "echo"; + inputs[1] = "acab"; + + // should fail to explore this branch + vm.ffi(inputs); + } + } + |] + Right e <- reachableUserAsserts c Nothing + assertBoolM "The expression is not partial" $ Expr.containsNode isPartial e + , + -- TODO: we can't deal with symbolic jump conditions + expectFail $ test "call-zero-inited-var-thats-a-function" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function (uint256) internal returns (uint) funvar; + function fun2(uint256 a) internal returns (uint){ + return a; + } + function fun(uint256 a) external returns (uint) { + if (a != 44) { + funvar = fun2; + } + return funvar(a); + } + } + |] + (_, [Cex (_, cex)]) <- withDefaultSolver $ + \s -> checkAssert s [0x51] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + let a = fromJust $ Map.lookup (Var "arg1") cex.vars + assertEqualM "unexpected cex value" a 44 + putStrLnM "expected counterexample found" + , test "symbolic-exp-0-to-n" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b, uint256 k) external pure { + uint x = 0 ** b; + assert (x == 1); + } + } + |] + let sig = Just (Sig "fun(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256]) + a <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + case a of + (_, [Cex (_, ctr)]) -> do + let b = getVar ctr "arg2" + putStrLnM $ "b:" <> show b + assertBoolM "b must be non-0" (b /= 0) + _ -> assertBoolM "Wrong" False + , test "symbolic-exp-0-to-n2" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b, uint256 k) external pure { + uint x = 0 ** b; + assert (x == 0); + } + } + |] + let sig = Just (Sig "fun(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256]) + a <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + case a of + (_, [Cex (_, ctr)]) -> do + let b = getVar ctr "arg2" + putStrLnM $ "b:" <> show b + assertBoolM "b must be 0" (b == 0) + _ -> assertBoolM "Wrong" False + , + test "symbolic-mcopy" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 s) external returns (uint) { + require(a < 5); + assembly { + mcopy(0x2, 0, s) + a:=mload(s) + } + assert(a < 5); + return a; + } + } + |] + let sig = Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) + (_, k) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numErrs = sum $ map (fromEnum . isError) k + assertEqualM "number of errors (i.e. copySlice issues) is 1" 1 numErrs + let errStrings = mapMaybe getResError k + assertEqualM "All errors are from copyslice" True $ all ("CopySlice" `List.isInfixOf`) errStrings + -- below we hit the limit of the depth of the symbolic execution tree + , testCase "limit-num-explore-hit-limit" $ do + let conf = testEnv.config {maxDepth = Just 3} + let myTestEnv :: Env = (testEnv :: Env) {config = conf :: Config} + runEnv myTestEnv $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(uint256 a, uint256 b, uint256 c) public { + if (a == b) { + if (b == c) { + assert(false); + } + } + } + } + |] + let sig = Just (Sig "checkval(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256]) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertBoolM "The expression MUST be partial" (Expr.containsNode isPartial expr) + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of counterexamples" 0 numCexes + assertEqualM "number of qed-s" 1 numQeds + -- below we don't hit the limit of the depth of the symbolic execution tree + , testCase "limit-num-explore-no-hit-limit" $ do + let conf = testEnv.config {maxDepth = Just 7} + let myTestEnv :: Env = (testEnv :: Env) {config = conf :: Config} + runEnv myTestEnv $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(uint256 a, uint256 b, uint256 c) public { + if (a == b) { + if (b == c) { + assert(false); + } + } + } + } + |] + let sig = Just (Sig "checkval(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256]) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertBoolM "The expression MUST NOT be partial" $ Prelude.not (Expr.containsNode isPartial expr) + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of counterexamples" 1 numCexes + assertEqualM "number of qed-s" 0 numQeds + , test "symbolic-copyslice" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 s) external returns (uint) { + require(a < 10); + if (a >= 8) { + assembly { + calldatacopy(0x5, s, s) + a:=mload(s) + } + } else { + assembly { + calldatacopy(0x2, 0x2, 5) + a:=mload(s) + } + } + assert(a < 9); + return a; + } + } + |] + let sig = Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) + (_, k) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numErrs = sum $ map (fromEnum . isError) k + assertEqualM "number of errors (i.e. copySlice issues) is 1" 1 numErrs + let errStrings = mapMaybe getResError k + assertEqualM "All errors are from copyslice" True $ all ("CopySlice" `List.isInfixOf`) errStrings + ] + , testGroup "Symbolic-Constructor-Args" + -- this produced some hard to debug failures. keeping it around since it seemed to exercise the contract creation code in interesting ways... + [ test "multiple-symbolic-constructor-calls" $ do + Just initCode <- solidity "C" + [i| + contract A { + uint public x; + constructor (uint z) {} + } + + contract B { + constructor (uint i) {} + + } + + contract C { + constructor(uint u) { + new A(u); + new B(u); + } + } + |] + withSolvers Bitwuzla 1 1 Nothing $ \s -> do + let calldata = (WriteWord (Lit 0x0) (Var "u") (ConcreteBuf ""), []) + initVM <- liftIO $ stToIO $ abstractVM calldata initCode Nothing True + let iterConf = IterConfig {maxIter=Nothing, askSmtIters=1, loopHeuristic=StackBased } + expr <- Expr.simplify <$> interpret (Fetch.oracle s Nothing) iterConf initVM runExpr + assertBoolM "unexptected partial execution" (not $ Expr.containsNode isPartial expr) + , test "mixed-concrete-symbolic-args" $ do + Just c <- solcRuntime "C" + [i| + contract B { + uint public x; + uint public y; + constructor (uint i, uint j) { + x = i; + y = j; + } + + } + + contract C { + function foo(uint i) public { + B b = new B(10, i); + assert(b.x() == 10); + assert(b.y() == i); + } + } + |] + Right expr <- reachableUserAsserts c (Just $ Sig "foo(uint256)" [AbiUIntType 256]) + assertBoolM "unexptected partial execution" (not $ Expr.containsNode isPartial expr) + , test "extcodesize-symbolic" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(address a, uint x) public { + require(x > 10); + uint size; + assembly { + size := extcodesize(a) + } + assert(x >= 5); + } + } + |] + let sig = (Just $ Sig "foo(address,uint256)" [AbiAddressType, AbiUIntType 256]) + (e, res) <- withDefaultSolver $ + \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + liftIO $ printWarnings [e] res "the contracts under test" + assertEqualM "Must be QED" res [Qed] + , test "extcodesize-symbolic2" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(address a, uint x) public { + uint size; + assembly { + size := extcodesize(a) + } + assert(size > 5); + } + } + |] + let sig = (Just $ Sig "foo(address,uint256)" [AbiAddressType, AbiUIntType 256]) + (e, res@[Cex _]) <- withDefaultSolver $ + \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + liftIO $ printWarnings [e] res "the contracts under test" + , test "jump-into-symbolic-region" $ do + let + -- our initCode just jumps directly to the end + code = BS.pack . mapMaybe maybeLitByteSimp $ V.toList $ assemble + [ OpPush (Lit 0x85) + , OpJump + , OpPush (Lit 1) + , OpPush (Lit 1) + , OpPush (Lit 1) + , OpJumpdest + ] + -- we write a symbolic word to the middle, so the jump above should + -- fail since the target is not in the concrete region + initCode = (WriteWord (Lit 0x43) (Var "HI") (ConcreteBuf code), []) + + -- we pass in the above initCode buffer as calldata, and then copy + -- it into memory before calling Create + runtimecode = RuntimeCode (SymbolicRuntimeCode $ assemble + [ OpPush (Lit 0x85) + , OpPush (Lit 0x0) + , OpPush (Lit 0x0) + , OpCalldatacopy + , OpPush (Lit 0x85) + , OpPush (Lit 0x0) + , OpPush (Lit 0x0) + , OpCreate + ]) + withDefaultSolver $ \s -> do + vm <- liftIO $ stToIO $ loadSymVM runtimecode (Lit 0) initCode False + let iterConf = IterConfig {maxIter=Nothing, askSmtIters=1, loopHeuristic=StackBased } + expr <- Expr.simplify <$> interpret (Fetch.oracle s Nothing) iterConf vm runExpr + case expr of + Partial _ _ (JumpIntoSymbolicCode _ _) -> assertBoolM "" True + _ -> assertBoolM "did not encounter expected partial node" False + ] + , testGroup "Dapp-Tests" + [ test "Trivial-Pass" $ do + let testFile = "test/contracts/pass/trivial.sol" + runSolidityTest testFile ".*" >>= assertEqualM "test result" (True, True) + , test "Foundry" $ do + -- quick smokecheck to make sure that we can parse ForgeStdLib style build outputs + -- return is a pair of (No Cex, No Warnings) + let cases = + [ ("test/contracts/pass/trivial.sol", ".*", (True, True)) + , ("test/contracts/pass/dsProvePass.sol", ".*", (True, True)) + , ("test/contracts/pass/revertEmpty.sol", ".*", (True, True)) + , ("test/contracts/pass/revertString.sol", ".*", (True, True)) + , ("test/contracts/pass/requireEmpty.sol", ".*", (True, True)) + , ("test/contracts/pass/requireString.sol", ".*", (True, True)) + -- overapproximation + , ("test/contracts/pass/no-overapprox-staticcall.sol", ".*", (True, True)) + , ("test/contracts/pass/no-overapprox-delegatecall.sol", ".*", (True, True)) + -- failure cases + , ("test/contracts/fail/trivial.sol", ".*", (False, False)) + , ("test/contracts/fail/dsProveFail.sol", "prove_add", (False, True)) + , ("test/contracts/fail/dsProveFail.sol", "prove_multi", (False, True)) + -- all branches revert, which is a warning + , ("test/contracts/fail/dsProveFail.sol", "prove_trivial.*", (False, False)) + , ("test/contracts/fail/dsProveFail.sol", "prove_distributivity", (False, True)) + , ("test/contracts/fail/assertEq.sol", ".*", (False, True)) + -- bad cheatcode detected, hence the warning + , ("test/contracts/fail/bad-cheatcode.sol", ".*", (False, False)) + -- symbolic failures -- either the text or the selector is symbolic + , ("test/contracts/fail/symbolicFail.sol", "prove_conc_fail_allrev.*", (False, False)) + , ("test/contracts/fail/symbolicFail.sol", "prove_conc_fail_somerev.*", (False, True)) + , ("test/contracts/fail/symbolicFail.sol", "prove_symb_fail_allrev_text.*", (False, False)) + , ("test/contracts/fail/symbolicFail.sol", "prove_symb_fail_somerev_text.*", (False, True)) + , ("test/contracts/fail/symbolicFail.sol", "prove_symb_fail_allrev_selector.*", (False, False)) + , ("test/contracts/fail/symbolicFail.sol", "prove_symb_fail_somerev_selector.*", (False, True))] + forM_ cases $ \(testFile, match, expected) -> do + actual <- runSolidityTestCustom testFile match Nothing Nothing False Nothing Foundry + putStrLnM $ "Test result for " <> testFile <> " match: " <> T.unpack match <> ": " <> show actual + assertEqualM "Must match" expected actual + , test "Trivial-Fail" $ do + let testFile = "test/contracts/fail/trivial.sol" + runSolidityTest testFile "prove_false" >>= assertEqualM "test result" (False, False) + , test "Abstract" $ do + let testFile = "test/contracts/pass/abstract.sol" + runSolidityTest testFile ".*" >>= assertEqualM "test result" (True, True) + , test "Constantinople" $ do + let testFile = "test/contracts/pass/constantinople.sol" + runSolidityTest testFile ".*" >>= assertEqualM "test result" (True, True) + , test "ConstantinopleMin" $ do + let testFile = "test/contracts/pass/constantinople_min.sol" + runSolidityTest testFile ".*" >>= assertEqualM "test result" (True, True) + , test "Prove-Tests-Pass" $ do + let testFile = "test/contracts/pass/dsProvePass.sol" + runSolidityTest testFile ".*" >>= assertEqualM "test result" (True, True) + , test "prefix-check-for-dapp" $ do + let testFile = "test/contracts/fail/check-prefix.sol" + runSolidityTest testFile "prove_trivial" >>= assertEqualM "test result" (False, False) + , test "transfer-dapp" $ do + let testFile = "test/contracts/pass/transfer.sol" + runSolidityTest testFile "prove_transfer" >>= assertEqualM "should prove transfer" (True, True) + , test "nonce-issues" $ do + let testFile = "test/contracts/pass/nonce-issues.sol" + runSolidityTest testFile "prove_prank_addr_exists" >>= assertEqualM "should not bail" (True, True) + runSolidityTest testFile "prove_nonce_addr_nonexistent" >>= assertEqualM "should not bail" (True, True) + , test "Prove-Tests-Fail" $ do + let testFile = "test/contracts/fail/dsProveFail.sol" + runSolidityTest testFile "prove_trivial" >>= assertEqualM "prove_trivial" (False, False) + runSolidityTest testFile "prove_trivial_dstest" >>= assertEqualM "prove_trivial_dstest" (False, False) + runSolidityTest testFile "prove_add" >>= assertEqualM "prove_add" (False, True) + runSolidityTestCustom testFile "prove_smtTimeout" (Just 1) Nothing False Nothing Foundry + >>= assertEqualM "prove_smtTimeout" (True, False) + runSolidityTest testFile "prove_multi" >>= assertEqualM "prove_multi" (False, True) + runSolidityTest testFile "prove_distributivity" >>= assertEqualM "prove_distributivity" (False, True) + , test "Loop-Tests" $ do + let testFile = "test/contracts/pass/loops.sol" + runSolidityTestCustom testFile "prove_loop" Nothing (Just 10) False Nothing Foundry >>= assertEqualM "test result" (True, False) + runSolidityTestCustom testFile "prove_loop" Nothing (Just 100) False Nothing Foundry >>= assertEqualM "test result" (False, False) + , test "Cheat-Codes-Pass" $ do + let testFile = "test/contracts/pass/cheatCodes.sol" + runSolidityTest testFile ".*" >>= assertEqualM "test result" (True, False) + , test "Cheat-Codes-Fork-Pass" $ do + let testFile = "test/contracts/pass/cheatCodesFork.sol" + runSolidityTest testFile ".*" >>= assertEqualM "test result" (True, True) + , test "Unwind" $ do + let testFile = "test/contracts/pass/unwind.sol" + runSolidityTest testFile ".*" >>= assertEqualM "test result" (True, True) + ] + , testGroup "max-iterations" + [ test "concrete-loops-reached" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun() external payable returns (uint) { + uint count = 0; + for (uint i = 0; i < 5; i++) count++; + return count; + } + } + |] + let sig = Just $ Sig "fun()" [] + opts = defaultVeriOpts { iterConf = defaultIterConf {maxIter = Just 3 }} + (e, [Qed]) <- withDefaultSolver $ + \s -> checkAssert s defaultPanicCodes c sig [] opts + assertBoolM "The expression is not partial" $ isPartial e + , test "concrete-loops-not-reached" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun() external payable returns (uint) { + uint count = 0; + for (uint i = 0; i < 5; i++) count++; + return count; + } + } + |] + + let sig = Just $ Sig "fun()" [] + opts = defaultVeriOpts{ iterConf = defaultIterConf {maxIter = Just 6 }} + (e, [Qed]) <- withDefaultSolver $ + \s -> checkAssert s defaultPanicCodes c sig [] opts + assertBoolM "The expression is partial" $ not $ isPartial e + , test "symbolic-loops-reached" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun(uint j) external payable returns (uint) { + uint count = 0; + for (uint i = 0; i < j; i++) count++; + return count; + } + } + |] + let veriOpts = defaultVeriOpts { iterConf = defaultIterConf { maxIter = Just 5 }} + (e, [Qed]) <- withDefaultSolver $ + \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] veriOpts + assertBoolM "The expression MUST be partial" $ Expr.containsNode isPartial e + , test "inconsistent-paths" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun(uint j) external payable returns (uint) { + require(j <= 3); + uint count = 0; + for (uint i = 0; i < j; i++) count++; + return count; + } + } + |] + let sig = Just $ Sig "fun(uint256)" [AbiUIntType 256] + -- we don't ask the solver about the loop condition until we're + -- already in an inconsistent path (i == 5, j <= 3, i < j), so we + -- will continue looping here until we hit max iterations + opts = defaultVeriOpts{ iterConf = defaultIterConf { maxIter = Just 10, askSmtIters = 5 }} + (e, [Qed]) <- withDefaultSolver $ + \s -> checkAssert s defaultPanicCodes c sig [] opts + assertBoolM "The expression is not partial" $ Expr.containsNode isPartial e + , test "mem-tuple" $ do + Just c <- solcRuntime "C" + [i| + contract C { + struct Pair { + uint x; + uint y; + } + function prove_tuple_pass(Pair memory p) public pure { + uint256 f = p.x; + uint256 g = p.y; + unchecked { + p.x+=p.y; + assert(p.x == (f + g)); + } + } + } + |] + let opts = defaultVeriOpts + let sig = Just $ Sig "prove_tuple_pass((uint256,uint256))" [AbiTupleType (V.fromList [AbiUIntType 256, AbiUIntType 256])] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] opts + putStrLnM "Qed, memory tuple is good" + , test "symbolic-loops-not-reached" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun(uint j) external payable returns (uint) { + require(j <= 3); + uint count = 0; + for (uint i = 0; i < j; i++) count++; + return count; + } + } + |] + let sig = Just $ Sig "fun(uint256)" [AbiUIntType 256] + -- askSmtIters is low enough here to avoid the inconsistent path + -- conditions, so we never hit maxIters + opts = defaultVeriOpts{ iterConf = defaultIterConf {maxIter = Just 5, askSmtIters = 1 }} + (e, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] opts + assertBoolM "The expression MUST NOT be partial" $ not (Expr.containsNode isPartial e) + ] + , testGroup "Symbolic Addresses" + [ test "symbolic-address-create" $ do + let src = [i| + contract A { + constructor() payable {} + } + contract C { + function fun(uint256 a) external{ + require(address(this).balance > a); + new A{value:a}(); + } + } + |] + Just a <- solcRuntime "A" src + Just c <- solcRuntime "C" src + let sig = Sig "fun(uint256)" [AbiUIntType 256] + (expr, [Qed]) <- withDefaultSolver $ \s -> + verifyContract s c (Just sig) [] defaultVeriOpts Nothing Nothing + let isSuc (Success {}) = True + isSuc _ = False + case filter isSuc (flattenExpr expr) of + [Success _ _ _ store] -> do + let ca = fromJust (Map.lookup (SymAddr "freshSymAddr1") store) + let code = case ca.code of + RuntimeCode (ConcreteRuntimeCode c') -> c' + _ -> internalError "expected concrete code" + assertEqualM "balance mismatch" (Var "arg1") ca.balance + assertEqualM "code mismatch" (stripBytecodeMetadata a) (stripBytecodeMetadata code) + assertEqualM "nonce mismatch" (Just 1) ca.nonce + _ -> assertBoolM "too many success nodes!" False + , test "symbolic-balance-call" $ do + let src = [i| + contract A { + function f() public payable returns (uint) { + return msg.value; + } + } + contract C { + function fun(uint256 x) external { + require(address(this).balance > x); + A a = new A(); + uint res = a.f{value:x}(); + assert(res == x); + } + } + |] + Just c <- solcRuntime "C" src + res <- reachableUserAsserts c Nothing + assertBoolM "unexpected cex" (isRight res) + , test "deployed-contract-addresses-cannot-alias1" $ do + Just c <- solcRuntime "C" + [i| + contract A {} + contract C { + function f() external { + A a = new A(); + uint256 addr = uint256(uint160(address(a))); + uint256 addr2 = uint256(uint160(address(this))); + assert(addr != addr2); + } + } + |] + res <- reachableUserAsserts c Nothing + assertBoolM "should not be able to alias" (isRight res) + , test "deployed-contract-addresses-cannot-alias2" $ do + Just c <- solcRuntime "C" + [i| + contract A {} + contract C { + function f() external { + A a = new A(); + assert(address(a) != address(this)); + } + } + |] + res <- reachableUserAsserts c Nothing + assertBoolM "should not be able to alias" (isRight res) + , test "addresses-in-args-can-alias-anything" $ do + let addrs :: [Text] + addrs = ["address(this)", "tx.origin", "block.coinbase", "msg.sender"] + sig = Just $ Sig "f(address)" [AbiAddressType] + checkVs vs = [i| + contract C { + function f(address a) external { + if (${vs} == a) assert(false); + } + } + |] + + [self, origin, coinbase, caller] <- forM addrs $ \addr -> do + Just c <- solcRuntime "C" (checkVs addr) + Left [cex] <- reachableUserAsserts c sig + pure cex.addrs + + liftIO $ do + let check as a = (Map.lookup (SymAddr "arg1") as) @?= (Map.lookup a as) + check self (SymAddr "entrypoint") + check origin (SymAddr "origin") + check coinbase (SymAddr "coinbase") + check caller (SymAddr "caller") + , test "addresses-in-args-can-alias-themselves" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function f(address a, address b) external { + if (a == b) assert(false); + } + } + |] + let sig = Just $ Sig "f(address,address)" [AbiAddressType,AbiAddressType] + Left [cex] <- reachableUserAsserts c sig + let arg1 = fromJust $ Map.lookup (SymAddr "arg1") cex.addrs + arg2 = fromJust $ Map.lookup (SymAddr "arg1") cex.addrs + assertEqualM "should match" arg1 arg2 + -- TODO: fails due to missing aliasing rules + , expectFail $ test "tx.origin cannot alias deployed contracts" $ do + Just c <- solcRuntime "C" + [i| + contract A {} + contract C { + function f() external { + address a = address(new A()); + if (tx.origin == a) assert(false); + } + } + |] + cexs <- reachableUserAsserts c Nothing + assertBoolM "unexpected cex" (isRight cexs) + , test "tx.origin can alias everything else" $ do + let addrs = ["address(this)", "block.coinbase", "msg.sender", "arg"] :: [Text] + sig = Just $ Sig "f(address)" [AbiAddressType] + checkVs vs = [i| + contract C { + function f(address arg) external { + if (${vs} == tx.origin) assert(false); + } + } + |] + + [self, coinbase, caller, arg] <- forM addrs $ \addr -> do + Just c <- solcRuntime "C" (checkVs addr) + Left [cex] <- reachableUserAsserts c sig + pure cex.addrs + + liftIO $ do + let check as a = (Map.lookup (SymAddr "origin") as) @?= (Map.lookup a as) + check self (SymAddr "entrypoint") + check coinbase (SymAddr "coinbase") + check caller (SymAddr "caller") + check arg (SymAddr "arg1") + , test "coinbase can alias anything" $ do + let addrs = ["address(this)", "tx.origin", "msg.sender", "a", "arg"] :: [Text] + sig = Just $ Sig "f(address)" [AbiAddressType] + checkVs vs = [i| + contract A {} + contract C { + function f(address arg) external { + address a = address(new A()); + if (${vs} == block.coinbase) assert(false); + } + } + |] + + [self, origin, caller, a, arg] <- forM addrs $ \addr -> do + Just c <- solcRuntime "C" (checkVs addr) + Left [cex] <- reachableUserAsserts c sig + pure cex.addrs + + liftIO $ do + let check as a' = (Map.lookup (SymAddr "coinbase") as) @?= (Map.lookup a' as) + check self (SymAddr "entrypoint") + check origin (SymAddr "origin") + check caller (SymAddr "caller") + check a (SymAddr "freshSymAddr1") + check arg (SymAddr "arg1") + , test "caller can alias anything" $ do + let addrs = ["address(this)", "tx.origin", "block.coinbase", "a", "arg"] :: [Text] + sig = Just $ Sig "f(address)" [AbiAddressType] + checkVs vs = [i| + contract A {} + contract C { + function f(address arg) external { + address a = address(new A()); + if (${vs} == msg.sender) assert(false); + } + } + |] + + [self, origin, coinbase, a, arg] <- forM addrs $ \addr -> do + Just c <- solcRuntime "C" (checkVs addr) + Left [cex] <- reachableUserAsserts c sig + pure cex.addrs + + liftIO $ do + let check as a' = (Map.lookup (SymAddr "caller") as) @?= (Map.lookup a' as) + check self (SymAddr "entrypoint") + check origin (SymAddr "origin") + check coinbase (SymAddr "coinbase") + check a (SymAddr "freshSymAddr1") + check arg (SymAddr "arg1") + , test "vm.load fails for a potentially aliased address" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function load(address,bytes32) external returns (bytes32); + } + contract C { + function f() external { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + vm.load(msg.sender, 0x0); + } + } + |] + -- NOTE: we have a postcondition here, not just a regular verification + (_, [Cex _]) <- withDefaultSolver $ \s -> + verifyContract s c Nothing [] defaultVeriOpts Nothing (Just $ checkBadCheatCode "load(address,bytes32)") + pure () + , test "vm.store fails for a potentially aliased address" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function store(address,bytes32,bytes32) external; + } + contract C { + function f() external { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + vm.store(msg.sender, 0x0, 0x0); + } + } + |] + -- NOTE: we have a postcondition here, not just a regular verification + (_, [Cex _]) <- withDefaultSolver $ \s -> + verifyContract s c Nothing [] defaultVeriOpts Nothing (Just $ checkBadCheatCode "store(address,bytes32,bytes32)") + pure () + -- TODO: make this work properly + , test "transfering-eth-does-not-dealias" $ do + Just c <- solcRuntime "C" + [i| + // we can't do calls to unknown code yet so we use selfdestruct + contract Send { + constructor(address payable dst) payable { + selfdestruct(dst); + } + } + contract C { + function f() external { + uint preSender = msg.sender.balance; + uint preOrigin = tx.origin.balance; + + new Send{value:10}(payable(msg.sender)); + new Send{value:5}(payable(tx.origin)); + + if (msg.sender == tx.origin) { + assert(preSender == preOrigin + && msg.sender.balance == preOrigin + 15 + && tx.origin.balance == preSender + 15); + } else { + assert(msg.sender.balance == preSender + 10 + && tx.origin.balance == preOrigin + 5); + } + } + } + |] + Right e <- reachableUserAsserts c Nothing + -- TODO: this should work one day + assertBoolM "should be partial" (Expr.containsNode isPartial e) + , test "symbolic-addresses-cannot-be-zero-or-precompiles" $ do + let addrs = [T.pack . show . Addr $ a | a <- [0x0..0x09]] + mkC a = fromJust <$> solcRuntime "A" + [i| + contract A { + function f() external { + assert(msg.sender != address(${a})); + } + } + |] + codes <- mapM mkC addrs + results <- mapM (flip reachableUserAsserts (Just (Sig "f()" []))) codes + let ok = and $ fmap (isRight) results + assertBoolM "unexpected cex" ok + , test "addresses-in-context-are-symbolic" $ do + Just a <- solcRuntime "A" + [i| + contract A { + function f() external { + assert(msg.sender != address(0x10)); + } + } + |] + Just b <- solcRuntime "B" + [i| + contract B { + function f() external { + assert(block.coinbase != address(0x11)); + } + } + |] + Just c <- solcRuntime "C" + [i| + contract C { + function f() external { + assert(tx.origin != address(0x12)); + } + } + |] + Just d <- solcRuntime "D" + [i| + contract D { + function f() external { + assert(address(this) != address(0x13)); + } + } + |] + [acex,bcex,ccex,dcex] <- forM [a,b,c,d] $ \con -> do + Left [cex] <- reachableUserAsserts con Nothing + assertEqualM "wrong number of addresses" 1 (length (Map.keys cex.addrs)) + pure cex + + -- Lowest allowed address is 0x10 due to reserved addresses up to 0x9 + assertEqualM "wrong model for a" (Addr 0x10) (fromJust $ Map.lookup (SymAddr "caller") acex.addrs) + assertEqualM "wrong model for b" (Addr 0x11) (fromJust $ Map.lookup (SymAddr "coinbase") bcex.addrs) + assertEqualM "wrong model for c" (Addr 0x12) (fromJust $ Map.lookup (SymAddr "origin") ccex.addrs) + assertEqualM "wrong model for d" (Addr 0x13) (fromJust $ Map.lookup (SymAddr "entrypoint") dcex.addrs) + ] + , testGroup "Symbolic execution" + [ + test "require-test" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 a) external pure { + require(a <= 0); + assert (a <= 0); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256)" [AbiIntType 256])) [] defaultVeriOpts + putStrLnM "Require works as expected" + , test "symbolic-block-number" $ do + Just c <- solcRuntime "C" [i| + interface Vm { + function roll(uint) external; + } + contract C { + function myfun(uint x, uint y) public { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + vm.roll(x); + assert(block.number == y); + } + } |] + (e, [Cex _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + assertBoolM "The expression MUST NOT be partial" $ Prelude.not (Expr.containsNode isPartial e) + , test "symbolic-to-concrete-multi" $ do + Just c <- solcRuntime "MyContract" + [i| + interface Vm { + function deal(address,uint256) external; + } + contract MyContract { + function fun(uint160 a) external { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + uint160 c = 10 + (a % 2); + address b = address(c); + vm.deal(b, 10); + } + } + |] + let sig = Just (Sig "fun(uint160)" [AbiUIntType 160]) + (e, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + assertBoolM "The expression is not partial" $ Prelude.not (Expr.containsNode isPartial e) + , + -- here test + test "ITE-with-bitwise-AND" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function f(uint256 x) public pure { + require(x > 0); + uint256 a = (x & 8); + bool w; + // assembly is needed here, because solidity doesn't allow uint->bool conversion + assembly { + w:=a + } + if (!w) assert(false); //we should get a CEX: when x has a 0 at bit 3 + } + } + |] + -- should find a counterexample + (_, [Cex _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "expected counterexample found" + , + test "ITE-with-bitwise-OR" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function f(uint256 x) public pure { + uint256 a = (x | 8); + bool w; + // assembly is needed here, because solidity doesn't allow uint->bool conversion + assembly { + w:=a + } + assert(w); // due to bitwise OR with positive value, this must always be true + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "this should always be true, due to bitwise OR with positive value" + , + test "abstract-returndata-size" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function f(uint256 x) public pure { + assembly { + return(0, x) + } + } + } + |] + expr <- withDefaultSolver $ \s -> getExpr s c (Just (Sig "f(uint256)" [])) [] defaultVeriOpts + assertBoolM "The expression is partial" $ not $ Expr.containsNode isPartial expr + , + -- CopySlice check + -- uses identity precompiled contract (0x4) to copy memory + -- checks 9af114613075a2cd350633940475f8b6699064de (readByte + CopySlice had src/dest mixed up) + -- without 9af114613 it dies with: `Exception: UnexpectedSymbolicArg 296 "MSTORE index"` + -- TODO: check 9e734b9da90e3e0765128b1f20ce1371f3a66085 (bufLength + copySlice was off by 1) + test "copyslice-check" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(uint8 a) public { + bytes memory data = new bytes(5); + for(uint i = 0; i < 5; i++) data[i] = bytes1(a); + bytes memory ret = new bytes(data.length); + assembly { + let len := mload(data) + if iszero(call(0xff, 0x04, 0, add(data, 0x20), len, add(ret,0x20), len)) { + invalid() + } + } + for(uint i = 0; i < 5; i++) assert(ret[i] == data[i]); + } + } + |] + let sig = Just (Sig "checkval(uint8)" [AbiUIntType 8]) + (res, [Qed]) <- withDefaultSolver $ \s -> + checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , test "staticcall-check-orig" $ do + Just c <- solcRuntime "C" + [i| + contract Target { + function add(uint256 x, uint256 y) external pure returns (uint256) { + unchecked { + return x + y; + } + } + } + + contract C { + function checkval(uint256 x, uint256 y) public { + Target t = new Target(); + address realAddr = address(t); + bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y); + (bool success, bytes memory returnData) = realAddr.staticcall(data); + assert(success); + + uint result = abi.decode(returnData, (uint256)); + uint expected; + unchecked { + expected = x + y; + } + assert(result == expected); + } + } + |] + let sig = Just (Sig "checkval(uint256,uint256)" [AbiAddressType, AbiUIntType 256, AbiUIntType 256]) + (res, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 0 numCexes + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 1 numQeds + , test "staticcall-check-orig2" $ do + Just c <- solcRuntime "C" + [i| + contract Target { + function add(uint256 x, uint256 y) external pure returns (uint256) { + assert(1 == 0); + } + } + contract C { + function checkval(uint256 x, uint256 y) public { + Target t = new Target(); + address realAddr = address(t); + bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y); + (bool success, bytes memory returnData) = realAddr.staticcall(data); + assert(success); + } + } + |] + let sig = Just (Sig "checkval(uint256,uint256)" [AbiAddressType, AbiUIntType 256, AbiUIntType 256]) + (res, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + assertBoolM "The expression is NOT partial" $ not $ Expr.containsNode isPartial res + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 1 numCexes + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 0 numQeds + , test "copyslice-symbolic-ok" $ do + Just c <- solcRuntime "C" + [i| + contract Target { + function get(address addr) external view returns (uint256) { + return 55; + } + } + contract C { + function retFor(address addr) public returns (uint256) { + Target mm = new Target(); + uint256 ret = mm.get(addr); + assert(ret == 4); + return ret; + } + } + |] + let sig2 = Just (Sig "retFor(address)" [AbiAddressType]) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig2 [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches expr) <> " paths" + assertBoolM "The expression is NOT error" $ not $ any isError ret + assertBoolM "The expression is NOT partial" $ not $ Expr.containsNode isPartial expr + , test "no-overapprox-when-present" $ do + Just c <- solcRuntime "C" [i| + contract ERC20 { + function f() public { + } + } + + contract C { + address token; + + function no_overapp() public { + token = address(new ERC20()); + token.delegatecall(abi.encodeWithSignature("f()")); + } + } |] + let sig2 = Just (Sig "no_overapp()" []) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig2 [] defaultVeriOpts + -- putStrLnM $ "expr: " <> show expr + putStrLnM $ "successfully explored: " <> show (Expr.numBranches expr) <> " paths" + assertBoolM "The expression is NOT error" $ not $ any isError ret + assertBoolM "The expression is NOT partial" $ not $ Expr.containsNode isPartial expr + let numCexes = sum $ map (fromEnum . isCex) ret + assertEqualM "number of counterexamples" 0 numCexes + -- NOTE: below used to be symbolic copyslice copy error before new copyslice + -- simplifications in Expr.simplify + , test "overapproximates-undeployed-contract-symbolic" $ do + Just c <- solcRuntime "C" + [i| + contract Target { + function get(address addr) external view returns (uint256) { + return 55; + } + } + contract C { + Target mm; + function retFor(address addr) public returns (uint256) { + // NOTE: this is symbolic execution, and no setUp has been ran + // hence, this below calls unknown code! It's trying to load: + // (SLoad (Lit 0x0) (AbstractStore (SymAddr "entrypoint") Nothing)) + // So it overapproximates. + uint256 ret = mm.get(addr); + assert(ret == 4); + return ret; + } + } + |] + let sig2 = Just (Sig "retFor(address)" [AbiAddressType]) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig2 [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches expr) <> " paths" + assertBoolM "The expression is NOT error" $ not $ any isError ret + assertBoolM "The expression is NOT partial" $ not $ Expr.containsNode isPartial expr + let numCexes = sum $ map (fromEnum . isCex) ret + -- There are 2 CEX-es + -- This is because with one CEX, the return DATA + -- is empty, and in the other, the return data is non-empty (but symbolic) + assertEqualM "number of counterexamples" 2 numCexes + , test "overapproximates-unknown-addr" $ do + Just c <- solcRuntime "C" + [i| + contract Target { + function get() external view returns (uint256) { + return 55; + } + } + contract C { + Target mm; + function retFor(address addr) public returns (uint256) { + Target target = Target(addr); + uint256 ret = target.get(); + assert(ret == 4); + return ret; + } + } + |] + let sig2 = Just (Sig "retFor(address)" [AbiAddressType]) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig2 [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches expr) <> " paths" + assertBoolM "The expression is NOT error" $ not $ any isError ret + let numCexes = sum $ map (fromEnum . isCex) ret + assertBoolM "The expression is NOT partial" $ not $ Expr.containsNode isPartial expr + -- There are 2 CEX-es + -- This is because with one CEX, the return DATA + -- is empty, and in the other, the return data is non-empty (but symbolic) + assertEqualM "number of counterexamples" 2 numCexes + , test "overapproximates-fixed-zero-addr" $ do + Just c <- solcRuntime "C" + [i| + contract Target { + function get() external view returns (uint256) { + return 55; + } + } + contract C { + Target mm; + function retFor() public returns (uint256) { + Target target = Target(address(0)); + uint256 ret = target.get(); + assert(ret == 4); + return ret; + } + } + |] + let sig2 = Just (Sig "retFor()" []) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig2 [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches expr) <> " paths" + assertBoolM "The expression is NOT error" $ not $ any isError ret + let numCexes = sum $ map (fromEnum . isCex) ret + assertBoolM "The expression is NOT partial" $ not $ Expr.containsNode isPartial expr + -- There are 2 CEX-es + -- This is because with one CEX, the return DATA + -- is empty, and in the other, the return data is non-empty (but symbolic) + assertEqualM "number of counterexamples" 2 numCexes + , test "overapproximates-fixed-wrong-addr" $ do + Just c <- solcRuntime "C" + [i| + contract Target { + function get() external view returns (uint256) { + return 55; + } + } + contract C { + Target mm; + function retFor() public returns (uint256) { + Target target = Target(address(0xacab)); + uint256 ret = target.get(); + assert(ret == 4); + return ret; + } + } + |] + let sig2 = Just (Sig "retFor()" []) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig2 [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches expr) <> " paths" + assertBoolM "The expression is NOT error" $ not $ any isError ret + assertBoolM "The expression is NOT partial" $ not $ Expr.containsNode isPartial expr + let numCexes = sum $ map (fromEnum . isCex) ret + -- There are 2 CEX-es + -- This is because with one CEX, the return DATA + -- is empty, and in the other, the return data is non-empty (but symbolic) + assertEqualM "number of counterexamples" 2 numCexes + , test "staticcall-no-overapprox-2" $ do + Just c <- solcRuntime "C" + [i| + contract Target { + function add(uint256 x, uint256 y) external pure returns (uint256) { + unchecked { + return x + y; + } + } + } + contract C { + function checkval(uint256 x, uint256 y) public { + Target t = new Target(); + address realAddr = address(t); + bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y); + (bool success, bytes memory returnData) = realAddr.staticcall(data); + assert(success); + assert(returnData.length == 32); + + // Decode the return value + uint256 result = abi.decode(returnData, (uint256)); + + // Assert that the result is equal to x + y + unchecked { + assert(result == x + y); + } + } + } + |] + let sig = Just (Sig "checkval(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) + (res, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + assertBoolM "The expression is NOT partial" $ not $ Expr.containsNode isPartial res + assertBoolM "The expression is NOT unknown" $ not $ any isUnknown ret + assertBoolM "The expression is NOT error" $ not $ any isError ret + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 0 numCexes + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 1 numQeds + , test "staticcall-check-symbolic1" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(address inputAddr, uint256 x, uint256 y) public { + bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y); + (bool success, bytes memory returnData) = inputAddr.staticcall(data); + assert(success); + } + } + |] + let sig = Just (Sig "checkval(address,uint256,uint256)" [AbiAddressType, AbiUIntType 256, AbiUIntType 256]) + (res, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + -- There are 2 CEX-es, in contrast to the above (staticcall-check-orig2). + -- This is because with one CEX, the return DATA + -- is empty, and in the other, the return data is non-empty (but symbolic) + assertEqualM "number of counterexamples" 2 numCexes + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 0 numQeds + -- This checks that calling a symbolic address with staticcall will ALWAYS return 0/1 + -- which is the semantic of the EVM. We insert a constraint over the return value + -- even when overapproximation is used, as below. + , test "staticcall-check-symbolic-yul" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(address inputAddr, uint256 x, uint256 y) public { + uint success; + assembly { + // Allocate memory for the call data + let callData := mload(0x40) + + // Function signature for "add(uint256,uint256)" is "0x771602f7" + mstore(callData, 0x771602f700000000000000000000000000000000000000000000000000000000) + + // Store the parameters x and y + mstore(add(callData, 4), x) + mstore(add(callData, 36), y) + + // Perform the static call + success := staticcall( + gas(), // Forward all available gas + inputAddr, // Address to call + callData, // Input data location + 68, // Input data size (4 bytes for function signature + 32 bytes each for x and y) + 0, // Output data location (0 means we don't care about the output) + 0 // Output data size + ) + } + assert(success <= 1); + } + } + |] + let sig = Just (Sig "checkval(address,uint256,uint256)" [AbiAddressType, AbiUIntType 256, AbiUIntType 256]) + (res, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 0 numCexes -- no counterexamples, because it is always 0/1 + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 1 numQeds + , test "staticcall-check-symbolic2" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(address inputAddr, uint256 x, uint256 y) public { + bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y); + (bool success, bytes memory returnData) = inputAddr.staticcall(data); + assert(success); + + uint result = abi.decode(returnData, (uint256)); + uint expected; + unchecked { + expected = x + y; + } + assert(result == expected); + } + } + |] + let sig = Just (Sig "checkval(address,uint256,uint256)" [AbiAddressType, AbiUIntType 256, AbiUIntType 256]) + (res, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" 2 numCexes + assertEqualM "number of errors" 1 numErrs + assertEqualM "number of qed-s" 0 numQeds + , testCase "call-symbolic-noreent" $ do + let conf = testEnv.config {promiseNoReent = True} + let myTestEnv :: Env = (testEnv :: Env) {config = conf :: Config} + runEnv myTestEnv $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(address inputAddr, uint256 x, uint256 y) public { + bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y); + (bool success, bytes memory returnData) = inputAddr.call(data); + assert(success); + } + } + |] + let sig = Just (Sig "checkval(address,uint256,uint256)" [AbiAddressType, AbiUIntType 256, AbiUIntType 256]) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertBoolM "The expression MUST NOT be partial" $ Prelude.not (Expr.containsNode isPartial expr) + -- There are 2 CEX-es + -- This is because with one CEX, the return DATA + -- is empty, and in the other, the return data is non-empty and success is false + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of counterexamples" 2 numCexes + assertEqualM "number of qed-s" 0 numQeds + , test "call-symbolic-reent" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(address inputAddr, uint256 x, uint256 y) public { + bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y); + (bool success, bytes memory returnData) = inputAddr.call(data); + assert(success); + } + } + |] + let sig = Just (Sig "checkval(address,uint256,uint256)" [AbiAddressType, AbiUIntType 256, AbiUIntType 256]) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + assertBoolM "The expression MUST be partial due to CALL to unknown code and no promise" $ (Expr.containsNode isPartial expr) + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of counterexamples" 0 numCexes + assertEqualM "number of qed-s" 1 numQeds + , testCase "call-symbolic-noreent-maxbufsize16" $ do + let conf = testEnv.config {promiseNoReent = True, maxBufSize = 4} + let myTestEnv :: Env = (testEnv :: Env) {config = conf :: Config} + runEnv myTestEnv $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(address inputAddr, uint256 x, uint256 y) public { + bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y); + (bool success, bytes memory returnData) = inputAddr.call(data); + assert(returnData.length < 16); + } + } + |] + let sig = Just (Sig "checkval(address,uint256,uint256)" [AbiAddressType, AbiUIntType 256, AbiUIntType 256]) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertBoolM "The expression MUST NOT be partial" $ Prelude.not (Expr.containsNode isPartial expr) + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of counterexamples" 0 numCexes + assertEqualM "number of qed-s" 1 numQeds + , testCase "call-symbolic-noreent-maxbufsize16-fail" $ do + let conf = testEnv.config {promiseNoReent = True, maxBufSize = 20} + let myTestEnv :: Env = (testEnv :: Env) {config = conf :: Config} + runEnv myTestEnv $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(address inputAddr, uint256 x, uint256 y) public { + bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y); + (bool success, bytes memory returnData) = inputAddr.call(data); + assert(returnData.length < 16); + } + } + |] + let sig = Just (Sig "checkval(address,uint256,uint256)" [AbiAddressType, AbiUIntType 256, AbiUIntType 256]) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertBoolM "The expression MUST NOT be partial" $ Prelude.not (Expr.containsNode isPartial expr) + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of counterexamples" 1 numCexes + assertEqualM "number of qed-s" 0 numQeds + , test "call-balance-symb" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(address inputAddr) public { + uint256 balance = inputAddr.balance; + assert(balance < 10); + } + } + |] + let sig = Just (Sig "checkval(address)" [AbiAddressType]) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + assertBoolM "The expression MUST NOT be partial" $ Prelude.not (Expr.containsNode isPartial expr) + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of counterexamples" 1 numCexes + , test "call-balance-symb2" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval() public { + uint256 balance = address(0xacab).balance; + assert(balance < 10); + } + } + |] + let sig = Just (Sig "checkval()" []) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + assertBoolM "The expression MUST NOT be partial" $ Prelude.not (Expr.containsNode isPartial expr) + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of counterexamples" 1 numCexes + , test "call-balance-concrete-pass" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function deal(address,uint256) external; + } + contract Target { + } + contract C { + function checkval() public { + Target t = new Target(); + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + vm.deal(address(t), 5); + uint256 balance = address(t).balance; + assert(balance < 10); + } + } + |] + let sig = Just (Sig "checkval()" []) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertBoolM "The expression MUST NOT be partial" $ Prelude.not (Expr.containsNode isPartial expr) + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of qed-s" 1 numQeds + , test "call-balance-concrete-fail" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function deal(address,uint256) external; + } + contract Target { + } + contract C { + function checkval() public { + Target t = new Target(); + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + vm.deal(address(t), 5); + uint256 balance = address(t).balance; + assert(balance < 5); + } + } + |] + let sig = Just (Sig "checkval()" []) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numErrs = sum $ map (fromEnum . isError) ret + let numCexes = sum $ map (fromEnum . isCex) ret + assertBoolM "The expression MUST NOT be partial" $ Prelude.not (Expr.containsNode isPartial expr) + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of counterexamples" 1 numCexes + , test "call-extcodehash-symb1" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(address inputAddr) public { + bytes32 hash = inputAddr.codehash; + assert(uint(hash) < 10); + } + } + |] + let sig = Just (Sig "checkval(address)" [AbiAddressType]) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + assertBoolM "The expression MUST NOT be partial" $ Prelude.not (Expr.containsNode isPartial expr) + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of counterexamples" 1 numCexes + , test "call-extcodehash-symb2" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval() public { + bytes32 hash = address(0xacab).codehash; + assert(uint(hash) < 10); + } + } + |] + let sig = Just (Sig "checkval()" []) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + assertBoolM "The expression MUST NOT be partial" $ Prelude.not (Expr.containsNode isPartial expr) + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of counterexamples" 1 numCexes + , test "call-extcodehash-concrete-fail" $ do + Just c <- solcRuntime "C" + [i| + contract Target { + } + contract C { + function checkval() public { + Target t = new Target(); + bytes32 hash = address(t).codehash; + assert(uint(hash) == 8); + } + } + |] + let sig = Just (Sig "checkval()" []) + (expr, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + let numErrs = sum $ map (fromEnum . isError) ret + let numCexes = sum $ map (fromEnum . isCex) ret + assertBoolM "The expression MUST NOT be partial" $ Prelude.not (Expr.containsNode isPartial expr) + assertEqualM "number of errors" 0 numErrs + assertEqualM "number of counterexamples" 1 numCexes + , test "jump-symbolic" $ do + Just c <- solcRuntime "C" + [i| + // Target contract with a view function + contract Target { + } + + // Caller contract using staticcall + contract C { + function checkval(address inputAddr, uint256 x, uint256 y) public { + Target t = new Target(); + address realAddr = address(t); + + bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y); + (bool success, bytes memory returnData) = inputAddr.staticcall(data); + assert(success == true); + } + } + |] + let sig = Just (Sig "checkval(address,uint256,uint256)" [AbiAddressType, AbiUIntType 256, AbiUIntType 256]) + (res, ret) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + let numCexes = sum $ map (fromEnum . isCex) ret + let numErrs = sum $ map (fromEnum . isError) ret + let numQeds = sum $ map (fromEnum . isQed) ret + assertEqualM "number of counterexamples" numCexes 2 + assertEqualM "number of symbolic copy errors" numErrs 0 + assertEqualM "number of qed-s" numQeds 0 + , + test "opcode-mul-assoc" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 a, int256 b, int256 c) external pure { + int256 tmp1; + int256 out1; + int256 tmp2; + int256 out2; + assembly { + tmp1 := mul(a, b) + out1 := mul(tmp1,c) + tmp2 := mul(b, c) + out2 := mul(a, tmp2) + } + assert (out1 == out2); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256,int256)" [AbiIntType 256, AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLnM "MUL is associative" + , + -- TODO look at tests here for SAR: https://github.com/dapphub/dapptools/blob/01ef8ea418c3fe49089a44d56013d8fcc34a1ec2/src/dapp-tests/pass/constantinople.sol#L250 + test "opcode-sar-neg" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 shift_by, int256 val) external pure returns (int256 out) { + require(shift_by >= 0); + require(val <= 0); + assembly { + out := sar(shift_by,val) + } + assert (out <= 0); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLnM "SAR works as expected" + , + test "opcode-sar-pos" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 shift_by, int256 val) external pure returns (int256 out) { + require(shift_by >= 0); + require(val >= 0); + assembly { + out := sar(shift_by,val) + } + assert (out >= 0); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLnM "SAR works as expected" + , + test "opcode-sar-fixedval-pos" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 shift_by, int256 val) external pure returns (int256 out) { + require(shift_by == 1); + require(val == 64); + assembly { + out := sar(shift_by,val) + } + assert (out == 32); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLnM "SAR works as expected" + , + test "opcode-sar-fixedval-neg" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 shift_by, int256 val) external pure returns (int256 out) { + require(shift_by == 1); + require(val == -64); + assembly { + out := sar(shift_by,val) + } + assert (out == -32); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLnM "SAR works as expected" + , + test "opcode-div-zero-1" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val) external pure { + uint out; + assembly { + out := div(val, 0) + } + assert(out == 0); + + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "sdiv works as expected" + , + test "opcode-sdiv-zero-1" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val) external pure { + uint out; + assembly { + out := sdiv(val, 0) + } + assert(out == 0); + + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "sdiv works as expected" + , + test "opcode-sdiv-zero-2" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val) external pure { + uint out; + assembly { + out := sdiv(0, val) + } + assert(out == 0); + + } + } + |] + (_, [Qed]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "sdiv works as expected" + , + test "signed-overflow-checks" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun(int256 a) external returns (int256) { + return a + a; + } + } + |] + (_, [Cex (_, _)]) <- withDefaultSolver $ \s -> checkAssert s [0x11] c (Just (Sig "fun(int256)" [AbiIntType 256])) [] defaultVeriOpts + putStrLnM "expected cex discovered" + , + test "opcode-signextend-neg" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val, uint8 b) external pure { + require(b <= 31); + require(b >= 0); + require(val < (1 <<(b*8))); + require(val & (1 <<(b*8-1)) != 0); // MSbit set, i.e. negative + uint256 out; + assembly { + out := signextend(b, val) + } + if (b == 31) assert(out == val); + else assert(out > val); + assert(out & (1<<254) != 0); // MSbit set, i.e. negative + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "signextend works as expected" + , + test "opcode-signextend-pos-nochop" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val, uint8 b) external pure { + require(val < (1 <<(b*8))); + require(val & (1 <<(b*8-1)) == 0); // MSbit not set, i.e. positive + uint256 out; + assembly { + out := signextend(b, val) + } + assert (out == val); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts + putStrLnM "signextend works as expected" + , + test "opcode-signextend-pos-chopped" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val, uint8 b) external pure { + require(b == 0); // 1-byte + require(val == 514); // but we set higher bits + uint256 out; + assembly { + out := signextend(b, val) + } + assert (out == 2); // chopped + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts + putStrLnM "signextend works as expected" + , + -- when b is too large, value is unchanged + test "opcode-signextend-pos-b-toolarge" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val, uint8 b) external pure { + require(b >= 31); + uint256 out; + assembly { + out := signextend(b, val) + } + assert (out == val); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts + putStrLnM "signextend works as expected" + , + test "opcode-shl" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 shift_by, uint256 val) external pure { + require(val < (1<<16)); + require(shift_by < 16); + uint256 out; + assembly { + out := shl(shift_by,val) + } + assert (out >= val); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "SAR works as expected" + , + test "opcode-xor-cancel" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure { + require(a == b); + uint256 c; + assembly { + c := xor(a,b) + } + assert (c == 0); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "XOR works as expected" + , + test "opcode-xor-reimplement" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure { + uint256 c; + assembly { + c := xor(a,b) + } + assert (c == (~(a & b)) & (a | b)); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "XOR works as expected" + , + test "opcode-add-commutative" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure { + uint256 res1; + uint256 res2; + assembly { + res1 := add(a,b) + res2 := add(b,a) + } + assert (res1 == res2); + } + } + |] + a <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + case a of + (_, [Cex (_, ctr)]) -> do + let x = getVar ctr "arg1" + let y = getVar ctr "arg2" + putStrLnM $ "y:" <> show y + putStrLnM $ "x:" <> show x + assertEqualM "Addition is not commutative... that's wrong" False True + (_, [Qed]) -> do + putStrLnM "adding is commutative" + _ -> internalError "Unexpected" + , + test "opcode-div-res-zero-on-div-by-zero" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint16 a) external pure { + uint16 b = 0; + uint16 res; + assembly { + res := div(a,b) + } + assert (res == 0); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint16)" [AbiUIntType 16])) [] defaultVeriOpts + putStrLnM "DIV by zero is zero" + , + -- Somewhat tautological since we are asserting the precondition + -- on the same form as the actual "requires" clause. + test "SafeAdd success case" $ do + Just safeAdd <- solcRuntime "SafeAdd" + [i| + contract SafeAdd { + function add(uint x, uint y) public pure returns (uint z) { + require((z = x + y) >= x); + } + } + |] + let pre preVM = let (x, y) = case getStaticAbiArgs 2 preVM of + [x', y'] -> (x', y') + _ -> internalError "expected 2 args" + in (x .<= Expr.add x y) + -- TODO check if it's needed + .&& preVM.state.callvalue .== Lit 0 + post prestate leaf = + let (x, y) = case getStaticAbiArgs 2 prestate of + [x', y'] -> (x', y') + _ -> internalError "expected 2 args" + in case leaf of + Success _ _ b _ -> (ReadWord (Lit 0) b) .== (Add x y) + _ -> PBool True + sig = Just (Sig "add(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) + (res, [Qed]) <- withDefaultSolver $ \s -> + verifyContract s safeAdd sig [] defaultVeriOpts (Just pre) (Just post) + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + + test "x == y => x + y == 2 * y" $ do + Just safeAdd <- solcRuntime "SafeAdd" + [i| + contract SafeAdd { + function add(uint x, uint y) public pure returns (uint z) { + require((z = x + y) >= x); + } + } + |] + let pre preVM = let (x, y) = case getStaticAbiArgs 2 preVM of + [x', y'] -> (x', y') + _ -> internalError "expected 2 args" + in (x .<= Expr.add x y) + .&& (x .== y) + .&& preVM.state.callvalue .== Lit 0 + post prestate leaf = + let (_, y) = case getStaticAbiArgs 2 prestate of + [x', y'] -> (x', y') + _ -> internalError "expected 2 args" + in case leaf of + Success _ _ b _ -> (ReadWord (Lit 0) b) .== (Mul (Lit 2) y) + _ -> PBool True + (res, [Qed]) <- withDefaultSolver $ \s -> + verifyContract s safeAdd (Just (Sig "add(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts (Just pre) (Just post) + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + test "summary storage writes" $ do + Just c <- solcRuntime "A" + [i| + contract A { + uint x; + function f(uint256 y) public { + unchecked { + x += y; + x += y; + } + } + } + |] + let pre vm = Lit 0 .== vm.state.callvalue + post prestate leaf = + let y = case getStaticAbiArgs 1 prestate of + [y'] -> y' + _ -> internalError "expected 1 arg" + this = prestate.state.codeContract + prestore = (fromJust (Map.lookup this prestate.env.contracts)).storage + prex = Expr.readStorage' (Lit 0) prestore + in case leaf of + Success _ _ _ postState -> let + poststore = (fromJust (Map.lookup this postState)).storage + in Expr.add prex (Expr.mul (Lit 2) y) .== (Expr.readStorage' (Lit 0) poststore) + _ -> PBool True + sig = Just (Sig "f(uint256)" [AbiUIntType 256]) + (res, [Qed]) <- withDefaultSolver $ \s -> + verifyContract s c sig [] defaultVeriOpts (Just pre) (Just post) + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + -- tests how whiffValue handles Neg via application of the triple IsZero simplification rule + -- regression test for: https://github.com/dapphub/dapptools/pull/698 + test "Neg" $ do + let src = + [i| + object "Neg" { + code { + // Deploy the contract + datacopy(0, dataoffset("runtime"), datasize("runtime")) + return(0, datasize("runtime")) + } + object "runtime" { + code { + let v := calldataload(4) + if iszero(iszero(and(v, not(0xffffffffffffffffffffffffffffffffffffffff)))) { + invalid() + } + } + } + } + |] + Just c <- liftIO $ yulRuntime "Neg" src + (res, [Qed]) <- withSolvers Z3 4 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "hello(address)" [AbiAddressType])) [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + test "catch-storage-collisions-noproblem" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y) public { + if (x != y) { + assembly { + let newx := sub(sload(x), 1) + let newy := add(sload(y), 1) + sstore(x,newx) + sstore(y,newy) + } + } + } + } + |] + 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 = prestate.state.codeContract + prestore = (fromJust (Map.lookup this prestate.env.contracts)).storage + prex = Expr.readStorage' x prestore + prey = Expr.readStorage' y prestore + in case poststate of + Success _ _ _ postcs -> let + poststore = (fromJust (Map.lookup this postcs)).storage + postx = Expr.readStorage' x poststore + posty = Expr.readStorage' y poststore + in Expr.add prex prey .== Expr.add postx posty + _ -> PBool True + sig = Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) + (_, [Qed]) <- withDefaultSolver $ \s -> + verifyContract s c sig [] defaultVeriOpts (Just pre) (Just post) + putStrLnM "Correct, this can never fail" + , + -- Inspired by these `msg.sender == to` token bugs + -- which break linearity of totalSupply. + test "catch-storage-collisions-good" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y) public { + assembly { + let newx := sub(sload(x), 1) + let newy := add(sload(y), 1) + sstore(x,newx) + sstore(y,newy) + } + } + } + |] + let pre vm = (Lit 0) .== vm.state.callvalue + post prestate leaf = + let (x,y) = case getStaticAbiArgs 2 prestate of + [x',y'] -> (x',y') + _ -> error "expected 2 args" + this = prestate.state.codeContract + prestore = (fromJust (Map.lookup this prestate.env.contracts)).storage + prex = Expr.readStorage' x prestore + prey = Expr.readStorage' y prestore + in case leaf of + Success _ _ _ poststate -> let + poststore = (fromJust (Map.lookup this poststate)).storage + postx = Expr.readStorage' x poststore + posty = Expr.readStorage' y poststore + in Expr.add prex prey .== Expr.add postx posty + _ -> PBool True + sig = Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) + (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> + verifyContract s c sig [] defaultVeriOpts (Just pre) (Just post) + let x = getVar ctr "arg1" + let y = getVar ctr "arg2" + putStrLnM $ "y:" <> show y + putStrLnM $ "x:" <> show x + assertEqualM "Catch storage collisions" x y + putStrLnM "expected counterexample found" + , + test "simple-assert" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo() external pure { + assert(false); + } + } + |] + (_, [Cex (Failure _ _ (Revert msg), _)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo()" [])) [] defaultVeriOpts + assertEqualM "incorrect revert msg" msg (ConcreteBuf $ panicMsg 0x01) + , + test "simple-assert-2" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + assert(x != 10); + } + } + |] + (_, [(Cex (_, ctr))]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + assertEqualM "Must be 10" 10 $ getVar ctr "arg1" + putStrLnM "Got 10 Cex, as expected" + , + test "assert-fail-equal" $ do + Just c <- solcRuntime "AssertFailEqual" + [i| + contract AssertFailEqual { + function fun(uint256 deposit_count) external pure { + assert(deposit_count == 0); + assert(deposit_count == 11); + } + } + |] + (_, [Cex (_, a), Cex (_, b)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + let ints = map (flip getVar "arg1") [a,b] + assertBoolM "0 must be one of the Cex-es" $ isJust $ List.elemIndex 0 ints + putStrLnM "expected 2 counterexamples found, one Cex is the 0 value" + , + test "assert-fail-notequal" $ do + Just c <- solcRuntime "AssertFailNotEqual" + [i| + contract AssertFailNotEqual { + function fun(uint256 deposit_count) external pure { + assert(deposit_count != 0); + assert(deposit_count != 11); + } + } + |] + (_, [Cex (_, a), Cex (_, b)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + let x = getVar a "arg1" + let y = getVar b "arg1" + assertBoolM "At least one has to be 0, to go through the first assert" (x == 0 || y == 0) + putStrLnM "expected 2 counterexamples found." + , + test "assert-fail-twoargs" $ do + Just c <- solcRuntime "AssertFailTwoParams" + [i| + contract AssertFailTwoParams { + function fun(uint256 deposit_count1, uint256 deposit_count2) external pure { + assert(deposit_count1 != 0); + assert(deposit_count2 != 11); + } + } + |] + (_, [Cex _, Cex _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "expected 2 counterexamples found" + , + test "assert-2nd-arg" $ do + Just c <- solcRuntime "AssertFailTwoParams" + [i| + contract AssertFailTwoParams { + function fun(uint256 deposit_count1, uint256 deposit_count2) external pure { + assert(deposit_count2 != 666); + } + } + |] + (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + assertEqualM "Must be 666" 666 $ getVar ctr "arg2" + putStrLnM "Found arg2 Ctx to be 666" + , + -- LSB is zeroed out, byte(31,x) takes LSB, so y==0 always holds + test "check-lsb-msb1" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + x &= 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff00; + uint8 y; + assembly { y := byte(31,x) } + assert(y == 0); + } + } + |] + (res, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + -- We zero out everything but the LSB byte. However, byte(31,x) takes the LSB byte + -- so there is a counterexamle, where LSB of x is not zero + test "check-lsb-msb2" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + x &= 0x00000000000000000000000000000000000000000000000000000000000000ff; + uint8 y; + assembly { y := byte(31,x) } + assert(y == 0); + } + } + |] + (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + assertBoolM "last byte must be non-zero" $ ((Data.Bits..&.) (getVar ctr "arg1") 0xff) > 0 + putStrLnM "Expected counterexample found" + , + -- We zero out everything but the 2nd LSB byte. However, byte(31,x) takes the 2nd LSB byte + -- so there is a counterexamle, where 2nd LSB of x is not zero + test "check-lsb-msb3 -- 2nd byte" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + x &= 0x000000000000000000000000000000000000000000000000000000000000ff00; + uint8 y; + assembly { y := byte(30,x) } + assert(y == 0); + } + } + |] + (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + assertBoolM "second to last byte must be non-zero" $ ((Data.Bits..&.) (getVar ctr "arg1") 0xff00) > 0 + putStrLnM "Expected counterexample found" + , + -- Reverse of test above + test "check-lsb-msb4 2nd byte rev" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + x &= 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff00ff; + uint8 y; + assembly { + y := byte(30,x) + } + assert(y == 0); + } + } + |] + (res, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + -- Bitwise OR operation test + test "opcode-bitwise-or-full-1s" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + uint256 y; + uint256 z = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff; + assembly { y := or(x, z) } + assert(y == 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "When OR-ing with full 1's we should get back full 1's" + , + -- Bitwise OR operation test + test "opcode-bitwise-or-byte-of-1s" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + uint256 y; + uint256 z = 0x000000000000000000000000000000000000000000000000000000000000ff00; + assembly { y := or(x, z) } + assert((y & 0x000000000000000000000000000000000000000000000000000000000000ff00) == + 0x000000000000000000000000000000000000000000000000000000000000ff00); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "When OR-ing with a byte of 1's, we should get 1's back there" + , + test "Deposit contract loop (z3)" $ do + Just c <- solcRuntime "Deposit" + [i| + contract Deposit { + function deposit(uint256 deposit_count) external pure { + require(deposit_count < 2**32 - 1); + ++deposit_count; + bool found = false; + for (uint height = 0; height < 32; height++) { + if ((deposit_count & 1) == 1) { + found = true; + break; + } + deposit_count = deposit_count >> 1; + } + assert(found); + } + } + |] + (res, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "deposit(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + test "Deposit-contract-loop-error-version" $ do + Just c <- solcRuntime "Deposit" + [i| + contract Deposit { + function deposit(uint8 deposit_count) external pure { + require(deposit_count < 2**32 - 1); + ++deposit_count; + bool found = false; + for (uint height = 0; height < 32; height++) { + if ((deposit_count & 1) == 1) { + found = true; + break; + } + deposit_count = deposit_count >> 1; + } + assert(found); + } + } + |] + (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s allPanicCodes c (Just (Sig "deposit(uint8)" [AbiUIntType 8])) [] defaultVeriOpts + assertEqualM "Must be 255" 255 $ getVar ctr "arg1" + putStrLnM $ "expected counterexample found, and it's correct: " <> (show $ getVar ctr "arg1") + , + test "explore function dispatch" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x) public pure returns (uint) { + return x; + } + } + |] + (res, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + test "check-asm-byte-in-bounds" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 idx, uint256 val) external pure { + uint256 actual; + uint256 expected; + require(idx < 32); + assembly { + actual := byte(idx,val) + expected := shr(248, shl(mul(idx, 8), val)) + } + assert(actual == expected); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLnM "in bounds byte reads return the expected value" + , + test "check-div-mod-sdiv-smod-by-zero-constant-prop" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 e) external pure { + uint x = 0; + uint y = 55; + uint z; + assembly { z := div(y,x) } + assert(z == 0); + assembly { z := div(x,y) } + assert(z == 0); + assembly { z := sdiv(y,x) } + assert(z == 0); + assembly { z := sdiv(x,y) } + assert(z == 0); + assembly { z := mod(y,x) } + assert(z == 0); + assembly { z := mod(x,y) } + assert(z == 0); + assembly { z := smod(y,x) } + assert(z == 0); + assembly { z := smod(x,y) } + assert(z == 0); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "div/mod/sdiv/smod by zero works as expected during constant propagation" + , + test "check-asm-byte-oob" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x, uint256 y) external pure { + uint256 z; + require(x >= 32); + assembly { z := byte(x,y) } + assert(z == 0); + } + } + |] + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLnM "oob byte reads always return 0" + , + test "injectivity of keccak (diff sizes)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint128 x, uint256 y) external pure { + assert( + keccak256(abi.encodePacked(x)) != + keccak256(abi.encodePacked(y)) + ); + } + } + |] + Right _ <- reachableUserAsserts c (Just $ Sig "f(uint128,uint256)" [AbiUIntType 128, AbiUIntType 256]) + pure () + , + test "injectivity of keccak (32 bytes)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y) public pure { + if (keccak256(abi.encodePacked(x)) == keccak256(abi.encodePacked(y))) assert(x == y); + } + } + |] + (res, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + test "injectivity of keccak contrapositive (32 bytes)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y) public pure { + require (x != y); + assert (keccak256(abi.encodePacked(x)) != keccak256(abi.encodePacked(y))); + } + } + |] + (res, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + test "injectivity of keccak (64 bytes)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y, uint w, uint z) public pure { + assert (keccak256(abi.encodePacked(x,y)) != keccak256(abi.encodePacked(w,z))); + } + } + |] + (_, [Cex (_, ctr)]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256,uint256,uint256,uint256)" (replicate 4 (AbiUIntType 256)))) [] defaultVeriOpts + let x = getVar ctr "arg1" + let y = getVar ctr "arg2" + let w = getVar ctr "arg3" + let z = getVar ctr "arg4" + assertEqualM "x==y for hash collision" x y + assertEqualM "w==z for hash collision" w z + putStrLnM "expected counterexample found" + , + test "calldata beyond calldatasize is 0 (symbolic calldata)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f() public pure { + uint y; + assembly { + let x := calldatasize() + y := calldataload(x) + } + assert(y == 0); + } + } + |] + (res, [Qed]) <- withBitwuzlaSolver $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + test "calldata beyond calldatasize is 0 (concrete dalldata prefix)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint256 z) public pure { + uint y; + assembly { + let x := calldatasize() + y := calldataload(x) + } + assert(y == 0); + } + } + |] + (res, [Qed]) <- withBitwuzlaSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + test "calldata symbolic access" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint256 z) public pure { + uint x; uint y; + assembly { + y := calldatasize() + } + require(z >= y); + require(z < 2**64); // Accesses to larger indices are not supported + assembly { + x := calldataload(z) + } + assert(x == 0); + } + } + |] + (res, [Qed]) <- withBitwuzlaSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + test "multiple-contracts" $ do + let code = + [i| + contract C { + uint x; + A constant a = A(0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B); + + function call_A() public view { + // should fail since x can be anything + assert(a.x() == x); + } + } + contract A { + uint public x; + } + |] + aAddr = LitAddr (Addr 0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B) + cAddr = SymAddr "entrypoint" + Just c <- solcRuntime "C" code + Just a <- solcRuntime "A" code + (_, [Cex (_, cex)]) <- withDefaultSolver $ \s -> do + calldata <- mkCalldata (Just (Sig "call_A()" [])) [] + vm <- liftIO $ stToIO $ abstractVM calldata c Nothing False + <&> set (#state % #callvalue) (Lit 0) + <&> over (#env % #contracts) + (Map.insert aAddr (initialContract (RuntimeCode (ConcreteRuntimeCode a)))) + verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) + + let storeCex = cex.store + testCex = case (Map.lookup cAddr storeCex, Map.lookup aAddr storeCex) of + (Just sC, Just sA) -> case (Map.lookup 0 sC, Map.lookup 0 sA) of + (Just x, Just y) -> x /= y + (Just x, Nothing) -> x /= 0 + _ -> False + _ -> False + assertBoolM "Did not find expected storage cex" testCex + putStrLnM "expected counterexample found" + , test "calling-unique-contracts--read-from-storage" $ do + Just c <- solcRuntime "C" + [i| + contract C { + uint x; + A a; + + function call_A() public { + a = new A(); + // should fail since x can be anything + assert(a.x() == x); + } + } + contract A { + uint public x; + } + |] + (_, [Cex _]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "call_A()" [])) [] defaultVeriOpts + putStrLnM "expected counterexample found" + , + test "keccak-concrete-and-sym-agree" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function kecc(uint x) public pure { + if (x == 0) { + assert(keccak256(abi.encode(x)) == keccak256(abi.encode(0))); + } + } + } + |] + (res, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "kecc(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + test "keccak-concrete-and-sym-agree-nonzero" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function kecc(uint x) public pure { + if (x == 55) { + // Note: 3014... is the encode & keccak & uint256 conversion of 55 + assert(uint256(keccak256(abi.encode(x))) == 30148980456718914367279254941528755963179627010946392082519497346671089299886); + } + } + } + |] + (res, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "kecc(uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + test "keccak concrete and sym injectivity" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x) public pure { + if (x !=3) assert(keccak256(abi.encode(x)) != keccak256(abi.encode(3))); + } + } + |] + (res, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLnM $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + test "safemath-distributivity-yul" $ do + let yulsafeDistributivity = hex "6355a79a6260003560e01c14156016576015601f565b5b60006000fd60a1565b603d602d604435600435607c565b6039602435600435607c565b605d565b6052604b604435602435605d565b600435607c565b141515605a57fe5b5b565b6000828201821115151560705760006000fd5b82820190505b92915050565b6000818384048302146000841417151560955760006000fd5b82820290505b92915050565b" + calldata <- mkCalldata (Just (Sig "distributivity(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] + vm <- liftIO $ stToIO $ abstractVM calldata yulsafeDistributivity Nothing False + (_, [Qed]) <- withDefaultSolver $ \s -> verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) + putStrLnM "Proven" + , + test "safemath-distributivity-sol" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function distributivity(uint x, uint y, uint z) public { + assert(mul(x, add(y, z)) == add(mul(x, y), mul(x, z))); + } + + function add(uint x, uint y) internal pure returns (uint z) { + unchecked { + require((z = x + y) >= x, "ds-math-add-overflow"); + } + } + + function mul(uint x, uint y) internal pure returns (uint z) { + unchecked { + require(y == 0 || (z = x * y) / y == x, "ds-math-mul-overflow"); + } + } + } + |] + + (_, [Qed]) <- withSolvers Bitwuzla 1 1 (Just 99999999) $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "distributivity(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLnM "Proven" + , + test "storage-cex-1" $ do + Just c <- solcRuntime "C" + [i| + contract C { + uint x; + uint y; + function fun(uint256 a) external{ + require(x != 0); + require(y != 0); + assert (x == y); + } + } + |] + (_, [(Cex (_, cex))]) <- withDefaultSolver $ \s -> checkAssert s [0x01] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + let addr = SymAddr "entrypoint" + testCex = Map.size cex.store == 1 && + case Map.lookup addr cex.store of + Just s -> Map.size s == 2 && + case (Map.lookup 0 s, Map.lookup 1 s) of + (Just x, Just y) -> x /= y + _ -> False + _ -> False + assertBoolM "Did not find expected storage cex" testCex + putStrLnM "Expected counterexample found" + , + test "storage-cex-2" $ do + Just c <- solcRuntime "C" + [i| + contract C { + uint[10] arr1; + uint[10] arr2; + function fun(uint256 a) external{ + assert (arr1[0] < arr2[a]); + } + } + |] + (_, [(Cex (_, cex))]) <- withDefaultSolver $ \s -> checkAssert s [0x01] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + let addr = SymAddr "entrypoint" + a = getVar cex "arg1" + testCex = Map.size cex.store == 1 && + case Map.lookup addr cex.store of + Just s -> case (Map.lookup 0 s, Map.lookup (10 + a) s) of + (Just x, Just y) -> x >= y + (Just x, Nothing) -> x > 0 -- arr1 can be Nothing, it'll then be zero + _ -> False + Nothing -> False -- arr2 must contain an element, or it'll be 0 + assertBoolM "Did not find expected storage cex" testCex + putStrLnM "Expected counterexample found" + , + test "storage-cex-concrete" $ do + Just c <- solcRuntime "C" + [i| + contract C { + uint x; + uint y; + function fun(uint256 a) external{ + require (x != 0); + require (y != 0); + assert (x != y); + } + } + |] + let sig = Just (Sig "fun(uint256)" [AbiUIntType 256]) + (_, [Cex (_, cex)]) <- withDefaultSolver $ + \s -> verifyContract s c sig [] defaultVeriOpts Nothing (Just $ checkAssertions [0x01]) + let addr = SymAddr "entrypoint" + testCex = Map.size cex.store == 1 && + case Map.lookup addr cex.store of + Just s -> Map.size s == 2 && + case (Map.lookup 0 s, Map.lookup 1 s) of + (Just x, Just y) -> x == y + _ -> False + _ -> False + assertBoolM "Did not find expected storage cex" testCex + putStrLnM "Expected counterexample found" + , test "temp-store-check" $ do + Just c <- solcRuntime "C" + [i| + pragma solidity ^0.8.25; + contract C { + mapping(address => bool) sentGifts; + function stuff(address k) public { + require(sentGifts[k] == false); + assembly { + if tload(0) { revert(0, 0) } + tstore(0, 1) + } + sentGifts[k] = true; + assembly { + tstore(0, 0) + } + assert(sentGifts[k]); + } + } + |] + let sig = (Just (Sig "stuff(address)" [AbiAddressType])) + (_, [Qed]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + putStrLnM $ "Basic tstore check passed" + ] + , testGroup "concr-fuzz" + [ testFuzz "fuzz-complicated-mul" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function complicated(uint x, uint y, uint z) public { + uint a; + uint b; + unchecked { + a = x * x * x * y * y * y * z; + b = x * x * x * x * y * y * z * z; + } + assert(a == b); + } + } + |] + let sig = (Sig "complicated(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256]) + (_, [Cex (_, ctr)]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts + let + x = getVar ctr "arg1" + y = getVar ctr "arg2" + z = getVar ctr "arg3" + a = x * x * x * y * y * y * z; + b = x * x * x * x * y * y * z * z; + val = a == b + assertBoolM "Must fail" (not val) + putStrLnM $ "expected counterexample found, x: " <> (show x) <> " y: " <> (show y) <> " z: " <> (show z) + putStrLnM $ "cex a: " <> (show a) <> " b: " <> (show b) + , testFuzz "fuzz-stores" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping(uint => uint) items; + function func() public { + assert(items[5] == 0); + } + } + |] + let sig = (Sig "func()" []) + (_, [Cex (_, ctr)]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts + putStrLnM $ "expected counterexample found. ctr: " <> (show ctr) + , testFuzz "fuzz-simple-fixed-value" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping(uint => uint) items; + function func(uint a) public { + assert(a != 1337); + } + } + |] + let sig = (Sig "func(uint256)" [AbiUIntType 256]) + (_, [Cex (_, ctr)]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts + putStrLnM $ "expected counterexample found. ctr: " <> (show ctr) + , testFuzz "fuzz-simple-fixed-value2" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function func(uint a, uint b) public { + assert(!((a == 1337) && (b == 99))); + } + } + |] + let sig = (Sig "func(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) + (_, [Cex (_, ctr)]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts + putStrLnM $ "expected counterexample found. ctr: " <> (show ctr) + , testFuzz "fuzz-simple-fixed-value3" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function func(uint a, uint b) public { + assert(((a != 1337) && (b != 99))); + } + } + |] + let sig = (Sig "func(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) + (_, [Cex (_, ctr1), Cex (_, ctr2)]) <- withSolvers Bitwuzla 1 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts + putStrLnM $ "expected counterexamples found. ctr1: " <> (show ctr1) <> " ctr2: " <> (show ctr2) + , testFuzz "fuzz-simple-fixed-value-store1" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping(uint => uint) items; + function func(uint a) public { + uint f = items[2]; + assert(a != f); + } + } + |] + let sig = (Sig "func(uint256)" [AbiUIntType 256, AbiUIntType 256]) + (_, [Cex _]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts + putStrLnM $ "expected counterexamples found" + , testFuzz "fuzz-simple-fixed-value-store2" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping(uint => uint) items; + function func(uint a) public { + items[0] = 1337; + assert(a != items[0]); + } + } + |] + let sig = (Sig "func(uint256)" [AbiUIntType 256, AbiUIntType 256]) + (_, [Cex (_, ctr1)]) <- withCVC5Solver $ \s -> checkAssert s defaultPanicCodes c (Just sig) [] defaultVeriOpts + putStrLnM $ "expected counterexamples found: " <> show ctr1 + ] + , testGroup "prop-and-expr-properties" + [ + test "nubOrd-Prop-PLT" $ do + let a = [ PLT (Lit 0x0) (ReadWord (ReadWord (Lit 0x0) (AbstractBuf "txdata")) (AbstractBuf "txdata")) + , PLT (Lit 0x1) (ReadWord (ReadWord (Lit 0x0) (AbstractBuf "txdata")) (AbstractBuf "txdata")) + , PLT (Lit 0x2) (ReadWord (ReadWord (Lit 0x0) (AbstractBuf "txdata")) (AbstractBuf "txdata")) + , PLT (Lit 0x0) (ReadWord (ReadWord (Lit 0x0) (AbstractBuf "txdata")) (AbstractBuf "txdata"))] + let simp = nubOrd a + simp2 = List.nub a + assertEqualM "Must be 3-length" 3 (length simp) + assertEqualM "Must be 3-length" 3 (length simp2) + , test "nubOrd-Prop-PEq" $ do + let a = [ PEq (Lit 0x0) (ReadWord (Lit 0x0) (AbstractBuf "txdata")) + , PEq (Lit 0x0) (ReadWord (Lit 0x1) (AbstractBuf "txdata")) + , PEq (Lit 0x0) (ReadWord (Lit 0x2) (AbstractBuf "txdata")) + , PEq (Lit 0x0) (ReadWord (Lit 0x0) (AbstractBuf "txdata"))] + let simp = nubOrd a + simp2 = List.nub a + assertEqualM "Must be 3-length" 3 (length simp) + assertEqualM "Must be 3-length" 3 (length simp2) + -- we run these without the simplifier inside `checkSatWithProps`, so + -- we can test the SMT solver's ability to handle sign extension + , test "sign-extend-conc-1" $ do + let p = Expr.sex (Lit 0) (Lit 0xff) + assertEqualM "stuff" p (Expr.simplify (Sub (Lit 0) (Lit 1))) + let p2 = Expr.sex (Lit 30) (Lit 0xff) + assertEqualM "stuff" p2 (Lit 0xff) + let p3 = Expr.sex (Lit 1) (Lit 0xff) + assertEqualM "stuff" p3 (Lit 0xff) + let p4 = Expr.sex (Lit 0) (Lit 0x1) + assertEqualM "stuff" p4 (Lit 0x1) + let p5 = Expr.sex (Lit 0) (Lit 0x0) + assertEqualM "stuff" p5 (Lit 0x0) + , testNoSimplify "sign-extend-1" $ do + let p = (PEq (Lit 1) (SLT (Lit 1774544) (SEx (Lit 2) (Lit 1774567)))) + let simp = Expr.simplifyProps [p] + assertEqualM "Must simplify to PBool True" simp [] + withDefaultSolver $ \s -> do + (res, _) <- checkSatWithProps s [p] + _ <- case res of + Cex c -> pure c + _ -> liftIO $ assertFailure "Must be satisfiable!" + pure () + , testNoSimplify "sign-extend-2" $ do + let p = (PEq (Lit 1) (SLT (SEx (Lit 2) (Var "arg1")) (Lit 0))) + withDefaultSolver $ \s -> do + (res, _) <- checkSatWithProps s [p] + _ <- case res of + Cex c -> pure c + _ -> liftIO $ assertFailure "Must be satisfiable!" + pure() + , testNoSimplify "sign-extend-3" $ do + let p = PAnd + (PEq (Lit 1) (SLT (SEx (Lit 2) (Var "arg1")) (Lit 115792089237316195423570985008687907853269984665640564039457584007913128752664))) + (PEq (Var "arg1") (SEx (Lit 2) (Var "arg1"))) + withDefaultSolver $ \s -> do + (res, _) <- checkSatWithProps s [p] + _ <- case res of + Cex c -> pure c + _ -> liftIO $ assertFailure "Must be satisfiable!" + pure() + , testProperty "sign-extend-vs-smt" $ \(a :: W256, b :: W256) -> propNoSimpNoFuzz $ do + let p = (PEq (Var "arg1") (SEx (Lit (a `mod` 50)) (Lit b))) + withDefaultSolver $ \s -> do + (res, _) <- checkSatWithProps s [p] + cex <- case res of + Cex c -> pure c + _ -> liftIO $ assertFailure "Must be satisfiable!" + let res1 = fromRight (internalError "cannot be") $ subModel cex (Var "arg1") + res1W <- case res1 of + Lit x -> pure x + _ -> internalError "Expected Lit" + let res2 = Expr.simplifyProps [p] + res2W <- case res2 of + [PEq (Lit x) (Var "arg1")] -> pure x + _ -> internalError "Expected PEq" + assertEqualM "Must be equivalent concrete values" res1W res2W + ] + , testGroup "simplification-working" + [ + test "PEq-and-PNot-PEq-1" $ do + let a = [PEq (Lit 0x539) (Var "arg1"),PNeg (PEq (Lit 0x539) (Var "arg1"))] + assertEqualM "Must simplify to PBool False" (Expr.simplifyProps a) ([PBool False]) + , test "PEq-and-PNot-PEq-2" $ do + let a = [PEq (Var "arg1") (Lit 0x539),PNeg (PEq (Lit 0x539) (Var "arg1"))] + assertEqualM "Must simplify to PBool False" (Expr.simplifyProps a) ([PBool False]) + , test "PEq-and-PNot-PEq-3" $ do + let a = [PEq (Var "arg1") (Lit 0x539),PNeg (PEq (Var "arg1") (Lit 0x539))] + assertEqualM "Must simplify to PBool False" (Expr.simplifyProps a) ([PBool False]) + , test "prop-simp-bool1" $ do + let + a = successGen [PAnd (PBool True) (PBool False)] + b = Expr.simplify a + assertEqualM "Must simplify down" (successGen [PBool False]) b + , test "prop-simp-bool2" $ do + let + a = successGen [POr (PBool True) (PBool False)] + b = Expr.simplify a + assertEqualM "Must simplify down" (successGen []) b + , test "prop-simp-LT" $ do + let + a = successGen [PLT (Lit 1) (Lit 2)] + b = Expr.simplify a + assertEqualM "Must simplify down" (successGen []) b + , test "prop-simp-GEq" $ do + let + a = successGen [PGEq (Lit 1) (Lit 2)] + b = Expr.simplify a + assertEqualM "Must simplify down" (successGen [PBool False]) b + , test "prop-simp-liteq-false" $ do + let + a = [PEq (LitByte 10) (LitByte 12)] + b = Expr.simplifyProps a + assertEqualM "Must simplify to PBool" ([PBool False]) b + , test "prop-simp-concbuf-false" $ do + let + a = [PEq (ConcreteBuf "a") (ConcreteBuf "ab")] + b = Expr.simplifyProps a + assertEqualM "Must simplify to PBool" ([PBool False]) b + , test "prop-simp-sort-eq-arguments" $ do + let + a = [PEq (Var "a") (Var "b"), PEq (Var "b") (Var "a")] + b = Expr.simplifyProps a + assertEqualM "Must reorder and nubOrd" (length b) 1 + , test "expr-simp-and-commut-assoc" $ do + let + a = And (Lit 4) (And (Lit 5) (Var "a")) + b = Expr.simplify a + assertEqualM "Must reorder and perform And" (And (Lit 4) (Var "a")) b + , test "expr-simp-order-eqbyte" $ do + let + a = EqByte (ReadByte (Lit 1) (AbstractBuf "b")) (ReadByte (Lit 1) (AbstractBuf "a")) + b = Expr.simplify a + assertEqualM "Must order eqbyte params" b (EqByte (ReadByte (Lit 1) (AbstractBuf "a")) (ReadByte (Lit 1) (AbstractBuf "b"))) + , test "prop-simp-demorgan-pneg-pand" $ do + let + a = [PNeg (PAnd (PEq (Lit 4) (Var "a")) (PEq (Lit 5) (Var "b")))] + b = Expr.simplifyProps a + assertEqualM "Must apply demorgan" b [POr (PNeg (PEq (Lit 4) (Var "a"))) (PNeg (PEq (Lit 5) (Var "b")))] + , test "prop-simp-demorgan-pneg-por" $ do + let + a = [PNeg (POr (PEq (Lit 4) (Var "a")) (PEq (Lit 5) (Var "b")))] + b = Expr.simplifyProps a + assertEqualM "Must apply demorgan" [PNeg (PEq (Lit 4) (Var "a")), PNeg (PEq (Lit 5) (Var "b"))] b + , test "prop-simp-lit0-or-both-0" $ do + let + a = [PEq (Lit 0) (Or (Var "a") (Var "b"))] + b = Expr.simplifyProps a + assertEqualM "Must apply demorgan" [PEq (Lit 0) (Var "a"), PEq (Lit 0) (Var "b")] b + , test "prop-simp-multiple" $ do + let + a = successGen [PBool False, PBool True] + b = Expr.simplify a + assertEqualM "Must simplify down" (successGen [PBool False]) b + , test "prop-simp-expr" $ do + let + a = successGen [PEq (Add (Lit 1) (Lit 2)) (Sub (Lit 4) (Lit 1))] + b = Expr.simplify a + assertEqualM "Must simplify down" (successGen []) b + , test "prop-simp-impl" $ do + let + a = successGen [PImpl (PBool False) (PEq (Var "abc") (Var "bcd"))] + b = Expr.simplify a + assertEqualM "Must simplify down" (successGen []) b + , test "propSimp-no-duplicate1" $ do + let a = [PAnd (PGEq (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x44)) (PLT (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x10000000000000000)), PAnd (PGEq (Var "arg1") (Lit 0x0)) (PLEq (Var "arg1") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PEq (Lit 0x63) (Var "arg2"),PEq (Lit 0x539) (Var "arg1"),PEq TxValue (Lit 0x0),PEq (IsZero (Eq (Lit 0x63) (Var "arg2"))) (Lit 0x0)] + let simp = Expr.simplifyProps a + assertEqualM "must not duplicate" simp (nubOrd simp) + assertEqualM "We must be able to remove all duplicates" (length $ nubOrd simp) (length $ List.nub simp) + , test "propSimp-no-duplicate2" $ do + let a = [PNeg (PBool False),PAnd (PGEq (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x44)) (PLT (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x10000000000000000)),PAnd (PGEq (Var "arg2") (Lit 0x0)) (PLEq (Var "arg2") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PAnd (PGEq (Var "arg1") (Lit 0x0)) (PLEq (Var "arg1") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PEq (Lit 0x539) (Var "arg1"),PNeg (PEq (Lit 0x539) (Var "arg1")),PEq TxValue (Lit 0x0),PLT (BufLength (AbstractBuf "txdata")) (Lit 0x10000000000000000),PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0),PNeg (PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0)),PNeg (PEq (IsZero TxValue) (Lit 0x0))] + let simp = Expr.simplifyProps a + assertEqualM "must not duplicate" simp (nubOrd simp) + assertEqualM "must not duplicate" (length simp) (length $ List.nub simp) + , test "full-order-prop1" $ do + let a = [PNeg (PBool False),PAnd (PGEq (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x44)) (PLT (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x10000000000000000)),PAnd (PGEq (Var "arg2") (Lit 0x0)) (PLEq (Var "arg2") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PAnd (PGEq (Var "arg1") (Lit 0x0)) (PLEq (Var "arg1") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PEq (Lit 0x539) (Var "arg1"),PNeg (PEq (Lit 0x539) (Var "arg1")),PEq TxValue (Lit 0x0),PLT (BufLength (AbstractBuf "txdata")) (Lit 0x10000000000000000),PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0),PNeg (PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0)),PNeg (PEq (IsZero TxValue) (Lit 0x0))] + let simp = Expr.simplifyProps a + assertEqualM "We must be able to remove all duplicates" (length $ nubOrd simp) (length $ List.nub simp) + , test "full-order-prop2" $ do + let a =[PNeg (PBool False),PAnd (PGEq (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x44)) (PLT (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x10000000000000000)),PAnd (PGEq (Var "arg2") (Lit 0x0)) (PLEq (Var "arg2") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PAnd (PGEq (Var "arg1") (Lit 0x0)) (PLEq (Var "arg1") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PEq (Lit 0x63) (Var "arg2"),PEq (Lit 0x539) (Var "arg1"),PEq TxValue (Lit 0x0),PLT (BufLength (AbstractBuf "txdata")) (Lit 0x10000000000000000),PEq (IsZero (Eq (Lit 0x63) (Var "arg2"))) (Lit 0x0),PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0),PNeg (PEq (IsZero TxValue) (Lit 0x0))] + let simp = Expr.simplifyProps a + assertEqualM "must not duplicate" simp (nubOrd simp) + assertEqualM "We must be able to remove all duplicates" (length $ nubOrd simp) (length $ List.nub simp) + ] + , testGroup "calling-solvers" + [ test "no-error-on-large-buf" $ do + -- These two tests generates a very large buffer that previously would cause an internalError when + -- printed via "formatCex". We should be able to print it now. + Just c <- solcRuntime "MyContract" [i| + contract MyContract { + function fun(bytes calldata a) external pure { + if (a.length > 0x800000000000) { + assert(false); + } + } + } |] + (_, [Cex cex]) <- withDefaultSolver $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLnM $ "Cex found:" <> T.unpack (formatCex (AbstractBuf "txdata") Nothing (snd cex)) + , test "no-error-on-large-buf-pure-print" $ do + let bufs = Map.singleton (AbstractBuf "txdata") + (EVM.Types.Comp Write {byte = 1, idx = 0x27, next = Base {byte = 0x66, length = 0xffff000000000000000}}) + let mycex = SMTCex {vars = mempty + , addrs = mempty + , buffers = bufs + , store = mempty + , blockContext = mempty + , txContext = Map.fromList [(TxValue,0x0)]} + putStrLnM $ "Cex found:" <> T.unpack (formatCex (AbstractBuf "txdata") Nothing mycex) + , testCase "correct-model-for-empty-buffer" $ runEnv (testEnv {config = testEnv.config {numCexFuzz = 0}}) $ do + withDefaultSolver $ \s -> do + let props = [(PEq (BufLength (AbstractBuf "b")) (Lit 0x0))] + (res, _) <- checkSatWithProps s props + (cex) <- case res of + Cex c -> pure c + _ -> liftIO $ assertFailure "Must be satisfiable!" + let value = fromRight (error "cannot be") $ subModel cex (AbstractBuf "b") + assertEqualM "Buffer must be empty" (ConcreteBuf "") value + , testCase "correct-model-for-non-empty-buffer-of-all-zeroes" $ runEnv (testEnv {config = testEnv.config {numCexFuzz = 0}}) $ do + withDefaultSolver $ \s -> do + let props = [(PAnd (PEq (ReadByte (Lit 0x0) (AbstractBuf "b")) (LitByte 0x0)) (PEq (BufLength (AbstractBuf "b")) (Lit 0x1)))] + (res, _) <- checkSatWithProps s props + (cex) <- case res of + Cex c -> pure c + _ -> liftIO $ assertFailure "Must be satisfiable!" + let value = fromRight (error "cannot be") $ subModel cex (AbstractBuf "b") + assertEqualM "Buffer must have size 1 and contain zero byte" (ConcreteBuf "\0") value + , testCase "buffer-shrinking-does-not-loop" $ runEnv (testEnv {config = testEnv.config {numCexFuzz = 0}}) $ do + withDefaultSolver $ \s -> do + let props = [(PGT (BufLength (AbstractBuf "b")) (Lit 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeb4))] + (res, _) <- checkSatWithProps s props + let + sat = case res of + Cex _ -> True + _ -> False + assertBoolM "Must be satisfiable!" sat + , testCase "can-get-value-unrelated-to-large-buffer" $ runEnv (testEnv {config = testEnv.config {numCexFuzz = 0}}) $ do + withDefaultSolver $ \s -> do + let props = [(PEq (Var "a") (Lit 0x1)), (PGT (BufLength (AbstractBuf "b")) (Lit 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeb4))] + (res, _) <- checkSatWithProps s props + cex :: SMTCex <- case res of + Cex c -> pure c + _ -> liftIO $ assertFailure "Must be satisfiable!" + let value = subModel cex (Var "a") + assertEqualM "Can get value out of model in the presence of large buffer!" value (Right $ Lit 0x1) + , test "no-duplicates-with-concrete-keccak" $ do + let props = [(PGT (Var "a") (Keccak (ConcreteBuf "abcdef"))), (PGT (Var "b") (Keccak (ConcreteBuf "abcdef")))] + conf <- readConfig + let SMT2 builders _ _ = fromRight (internalError "Must succeed") (assertProps conf props) + let texts = fmap toLazyText builders + let sexprs = splitSExpr texts + let noDuplicates = ((length sexprs) == (Set.size (Set.fromList sexprs))) + assertBoolM "There were duplicate lines in SMT encoding" noDuplicates + , test "no-duplicates-with-read-assumptions" $ do + let props = [(PGT (ReadWord (Lit 2) (AbstractBuf "test")) (Lit 0)), (PGT (Expr.padByte $ ReadByte (Lit 10) (AbstractBuf "test")) (Expr.padByte $ LitByte 1))] + conf <- readConfig + let SMT2 builders _ _ = fromRight (internalError "Must succeed") (assertProps conf props) + let texts = fmap toLazyText builders + let sexprs = splitSExpr texts + let noDuplicates = ((length sexprs) == (Set.size (Set.fromList sexprs))) + assertBoolM "There were duplicate lines in SMT encoding" noDuplicates + ] + , testGroup "equivalence-checking" + [ + test "eq-simple-diff" $ do + Just a <- solcRuntime "C" + [i| + contract C { + function stuff() public returns (uint256) { + return 4; + } + } + |] + Just b <- solcRuntime "C" + [i| + contract C { + function stuff() public returns (uint256) { + return 5; + } + } + |] + withSolvers Bitwuzla 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s a b defaultVeriOpts calldata False + assertBoolM "Must have a difference" (any (isCex . fst) eq.res) + let cexs = mapMaybe (getCex . fst) eq.res + assertEqualM "Must have exactly one cex" (length cexs) 1 + -- diverging gas overapproximations are caught + -- previously, they had the same name (gas_...), so they compared equal + , test "eq-divergent-overapprox-gas" $ do + Just a <- solcRuntime "C" + [i| + contract C { + uint x; + function stuff(uint a) public returns (uint256) { + unchecked { x = a * 2; } + return gasleft(); + } + } + |] + Just b <- solcRuntime "C" + [i| + contract C { + uint x; + function stuff(uint a) public returns (uint256) { + unchecked { x = a + a; } + return gasleft(); + } + } + |] + withSolvers Bitwuzla 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s a b defaultVeriOpts calldata False + assertBoolM "Must have a difference" (any (isCex . fst) eq.res) + let cexs = mapMaybe (getCex . fst) eq.res + assertEqualM "Must have exactly one cex" (length cexs) 1 + -- diverging gas overapproximations are caught + -- previously, CALL fresh variables were the same so they compared equal + , test "eq-divergent-overapprox-call" $ do + Just a <- solcRuntime "C" + [i| + contract C { + function checkval(address inputAddr, uint256 x, uint256 y) public returns (bool) { + bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y); + (bool success, bytes memory returnData) = inputAddr.staticcall(data); + return success; + } + } + |] + Just b <- solcRuntime "C" + [i| + contract C { + function checkval(address inputAddr, uint256 x, uint256 y) public returns (bool) { + bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, x); + (bool success, bytes memory returnData) = inputAddr.staticcall(data); + return success; + } + } + |] + withSolvers Bitwuzla 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s a b defaultVeriOpts calldata False + assertBoolM "Must have a difference" (any (isCex . fst) eq.res) + let cexs = mapMaybe (getCex . fst) eq.res + assertEqualM "Must have exactly one cex" (length cexs) 1 + -- check bug https://github.com/ethereum/hevm/issues/679 + , test "eq-issue-with-length-cex-bug679" $ do + let a = fromJust (hexByteString "5f610100526020610100f3") + b = fromJust (hexByteString "5f356101f40115610100526020610100f3") + withSolvers Z3 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s a b defaultVeriOpts calldata False + assertBoolM "Must have a difference" (any (isCex . fst) eq.res) + let cexs :: [SMTCex] = mapMaybe (getCex . fst) eq.res + cex <- case cexs of + [cex] -> pure cex + _ -> liftIO $ assertFailure "Must have exactly one cex" + let def = fromRight (error "cannot be") $ defaultSymbolicValues $ subModel cex (AbstractBuf "txdata") + let buf = prettyBuf $ Expr.concKeccakSimpExpr def + assertBoolM "Must start with specific string" (T.isPrefixOf "0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe0cf" buf) + , test "eq-yul-simple-cex" $ do + Just aPrgm <- liftIO $ yul "" + [i| + { + calldatacopy(0, 0, 32) + switch mload(0) + case 0 { } + case 1 { } + default { invalid() } + } + |] + Just bPrgm <- liftIO $ yul "" + [i| + { + calldatacopy(0, 0, 32) + switch mload(0) + case 0 { } + case 2 { } + default { invalid() } + } + |] + withSolvers Z3 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts calldata False + assertBoolM "Must have a difference" (any (isCex . fst) eq.res) + , test "constructor-same-deployed-diff" $ do + Just initA <- solidity "C" + [i| + contract C { + uint public immutable NUMBER; + constructor(uint a) { + NUMBER = 4; + } + function stuff(uint b) public returns (uint256) { + unchecked{return 2*b+NUMBER;} + } + } + |] + Just initB <- solidity "C" + [i| + contract C { + uint public immutable NUMBER; + constructor(uint a) { + NUMBER = 4; + } + function stuff(uint b) public returns (uint256) { + unchecked {return 4*b+NUMBER;} + } + } + |] + withSolvers Z3 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s initA initB defaultVeriOpts calldata True + assertBoolM "Must have difference, we return different values" (all (isCex . fst) eq.res) + , test "constructor-same-deployed-diff2" $ do + Just initA <- solidity "C" + [i| + contract C { + uint public immutable NUMBER; + constructor(uint a) { + NUMBER = 4; + } + function stuff(uint b) public returns (uint256) { + unchecked{return 4*b+NUMBER;} + } + } + |] + Just initB <- solidity "C" + [i| + contract C { + uint public immutable NUMBER; + constructor(uint a) { + NUMBER = 4; + } + function stuff(uint b) public returns (uint256) { + unchecked {return 4*b+NUMBER;} + } + function stuff_other(uint b) public returns (uint256) { + unchecked {return 2*b+NUMBER;} + } + } + |] + withSolvers Z3 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s initA initB defaultVeriOpts calldata True + assertBoolM "Must have difference, we return different values" (all (isCex . fst) eq.res) + , test "constructor-same-deployed-diff3" $ do + Just initA <- solidity "C" + [i| + contract C { + uint public immutable NUMBER; + constructor(uint a) { + NUMBER = 4; + } + function stuff(uint b) public returns (uint256) { + unchecked{return 4*b+NUMBER;} + } + } + |] + Just initB <- solidity "C" + [i| + contract C { + uint public immutable NUMBER; + constructor(uint a) { + NUMBER = 4; + } + } + |] + withSolvers Z3 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s initA initB defaultVeriOpts calldata True + assertBoolM "Must have difference, we return different values" (all (isCex . fst) eq.res) + -- We set x to be 0 on deployment. Default value is also 0. So they are equivalent + -- We cannot deal with symbolic code. However, the below will generate symbolic code, + -- because of the parameter in the constructor that is set to NUMBER in the deployed code. + -- Hence, this test is ignored. + , ignoreTest $ test "constructor-diff-deploy" $ do + Just initA <- solidity "C" + [i| + contract C { + uint public immutable NUMBER; + constructor(uint a) { + NUMBER = a+4; + } + function stuff(uint b) public returns (uint256) { + return NUMBER; + } + } + |] + Just initB <- solidity "C" + [i| + contract C { + uint public immutable NUMBER; + constructor(uint a) { + NUMBER = a*2; + } + function stuff(uint b) public returns (uint256) { + return NUMBER; + } + } + |] + withSolvers Z3 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s initA initB defaultVeriOpts calldata True + assertBoolM "Must have difference" (all (isCex . fst) eq.res) + -- We set x to be 0 on deployment. Default value is also 0. So they are equivalent + , test "constructor-implicit" $ do + Just initA <- solidity "C" + [i| + contract C { + uint immutable x; + function stuff(uint a) public returns (uint256) { + unchecked {return 8+a;} + } + } + |] + Just initB <- solidity "C" + [i| + contract C { + uint immutable x; + constructor() { + x = 0; + } + function stuff(uint a) public returns (uint256) { + unchecked {return a+8;} + } + } + |] + withSolvers Z3 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s initA initB defaultVeriOpts calldata True + assertEqualM "Must have no difference" [Qed] (map fst eq.res) + -- We set x to be 3 vs 0 (default) on deployment. + , test "constructor-differing" $ do + Just initA <- solidity "C" + [i| + contract C { + uint x; + function stuff(uint a) public returns (uint256) { + unchecked {return a+x;} + } + } + |] + Just initB <- solidity "C" + [i| + contract C { + uint x; + constructor() { + x = 3; + } + function stuff(uint a) public returns (uint256) { + unchecked {return a+x;} + } + } + |] + withSolvers Z3 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s initA initB defaultVeriOpts calldata True + let cexes = filter (isCex . fst) eq.res + assertBoolM "Must have a difference" (not $ null cexes) + , test "eq-sol-exp-qed" $ do + Just aPrgm <- solcRuntime "C" + [i| + contract C { + function a(uint8 x) public returns (uint8 b) { + unchecked { + b = x*2; + } + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract C { + function a(uint8 x) public returns (uint8 b) { + unchecked { + b = x<<1; + } + } + } + |] + withSolvers Z3 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts calldata False + assertEqualM "Must have no difference" [Qed] (map fst eq.res) + , + test "eq-balance-differs" $ do + Just aPrgm <- solcRuntime "C" + [i| + contract Send { + constructor(address payable dst) payable { + selfdestruct(dst); + } + } + contract C { + function f() public { + new Send{value:2}(payable(address(0x0))); + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract Send { + constructor(address payable dst) payable { + selfdestruct(dst); + } + } + contract C { + function f() public { + new Send{value:1}(payable(address(0x0))); + } + } + |] + withSolvers Z3 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts calldata False + assertBoolM "Must differ" (all (isCex . fst) eq.res) + , + -- TODO: this fails because we don't check equivalence of deployed contracts + expectFail $ test "eq-handles-contract-deployment" $ do + Just aPrgm <- solcRuntime "B" + [i| + contract Send { + constructor(address payable dst) payable { + selfdestruct(dst); + } + } + + contract A { + address parent; + constructor(address p) { + parent = p; + } + function evil() public { + parent.call(abi.encode(B.drain.selector)); + } + } + + contract B { + address child; + function a() public { + child = address(new A(address(this))); + } + function drain() public { + require(msg.sender == child); + new Send{value: address(this).balance}(payable(address(0x0))); + } + } + |] + Just bPrgm <- solcRuntime "D" + [i| + contract Send { + constructor(address payable dst) payable { + selfdestruct(dst); + } + } + + contract C { + address parent; + constructor(address p) { + parent = p; + } + } + + contract D { + address child; + function a() public { + child = address(new C(address(this))); + } + function drain() public { + require(msg.sender == child); + new Send{value: address(this).balance}(payable(address(0x0))); + } + } + |] + withSolvers Z3 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts calldata False + assertBoolM "Must differ" (all (isCex . fst) eq.res) + , + test "eq-unknown-addr" $ do + Just aPrgm <- solcRuntime "C" + [i| + contract C { + address addr; + function a(address a, address b) public { + addr = a; + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract C { + address addr; + function a(address a, address b) public { + addr = b; + } + } + |] + withSolvers Z3 3 1 Nothing $ \s -> do + cd <- mkCalldata (Just (Sig "a(address,address)" [AbiAddressType, AbiAddressType])) [] + eq <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts cd False + assertEqualM "Must be different" (any (isCex . fst) eq.res) True + , + test "eq-sol-exp-cex" $ do + Just aPrgm <- solcRuntime "C" + [i| + contract C { + function a(uint8 x) public returns (uint8 b) { + unchecked { + b = x*2+1; + } + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract C { + function a(uint8 x) public returns (uint8 b) { + unchecked { + b = x<<1; + } + } + } + |] + withSolvers Bitwuzla 3 1 Nothing $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts calldata False + assertEqualM "Must be different" (any (isCex . fst) eq.res) True + , + test "eq-storage-write-to-static-array-uint128" $ do + Just aPrgm <- solcRuntime "C" + [i| + contract C { + uint128[5] arr; + function set(uint i, uint128 v) external returns (uint) { + arr[i] = v; + arr[i] = v; + return 0; + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract C { + uint128[5] arr; + function set(uint i, uint128 v) external returns (uint) { + arr[i] = v; + return 0; + } + } + |] + withSolvers Bitwuzla 1 1 Nothing $ \s -> do + calldata <- mkCalldata (Just (Sig "set(uint256,uint128)" [AbiUIntType 256, AbiUIntType 128])) [] + eq <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts calldata False + assertEqualM "Must have no difference" [Qed] (map fst eq.res) + , + test "eq-storage-write-to-static-array-uint8" $ do + Just aPrgm <- solcRuntime "C" + [i| + contract C { + uint8[10] arr; + function set(uint i, uint8 v) external returns (uint) { + arr[i] = v; + arr[i] = v; + return 0; + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract C { + uint8[10] arr; + function set(uint i, uint8 v) external returns (uint) { + arr[i] = v; + return 0; + } + } + |] + withSolvers Bitwuzla 1 1 Nothing $ \s -> do + calldata <- mkCalldata (Just (Sig "set(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] + eq <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts calldata False + assertEqualM "Must have no difference" [Qed] (map fst eq.res) + , + test "eq-storage-write-to-static-array-uint32" $ do + Just aPrgm <- solcRuntime "C" + [i| + contract C { + uint32[5] arr; + function set(uint i, uint32 v) external returns (uint) { + arr[i] = 1; + arr[i] = v; + return 0; + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract C { + uint32[5] arr; + function set(uint i, uint32 v) external returns (uint) { + arr[i] = v; + return 0; + } + } + |] + withSolvers Bitwuzla 1 1 Nothing $ \s -> do + calldata <- mkCalldata (Just (Sig "set(uint256,uint32)" [AbiUIntType 256, AbiUIntType 32])) [] + eq <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts calldata False + assertEqualM "Must have no difference" [Qed] (map fst eq.res) + , test "eq-all-yul-optimization-tests" $ do + let opts = defaultVeriOpts{ iterConf = defaultIterConf {maxIter = Just 5, askSmtIters = 20, loopHeuristic = Naive }} + ignoredTests = + -- unbounded loop -- + [ "commonSubexpressionEliminator/branches_for.yul" + , "conditionalSimplifier/no_opt_if_break_is_not_last.yul" + , "conditionalUnsimplifier/no_opt_if_break_is_not_last.yul" + , "expressionSimplifier/inside_for.yul" + , "forLoopConditionIntoBody/cond_types.yul" + , "forLoopConditionIntoBody/simple.yul" + , "fullSimplify/inside_for.yul" + , "fullSuite/no_move_loop_orig.yul" + , "loopInvariantCodeMotion/multi.yul" + , "redundantAssignEliminator/for_deep_simple.yul" + , "unusedAssignEliminator/for_deep_noremove.yul" + , "unusedAssignEliminator/for_deep_simple.yul" + , "ssaTransform/for_def_in_init.yul" + , "loopInvariantCodeMotion/simple_state.yul" + , "loopInvariantCodeMotion/simple.yul" + , "loopInvariantCodeMotion/recursive.yul" + , "loopInvariantCodeMotion/no_move_staticall_returndatasize.yul" + , "loopInvariantCodeMotion/no_move_state_loop.yul" + , "loopInvariantCodeMotion/no_move_state.yul" -- not infinite, but rollaround on a large int + , "loopInvariantCodeMotion/no_move_loop.yul" + + -- infinite recursion + , "unusedStoreEliminator/function_side_effects_2.yul" + , "unusedStoreEliminator/write_before_recursion.yul" + , "fullInliner/multi_fun_callback.yul" + , "conditionalUnsimplifier/side_effects_of_functions.yul" + , "expressionInliner/double_recursive_calls.yul" + , "conditionalSimplifier/side_effects_of_functions.yul" + + -- Takes too long, would timeout on most test setups. + -- We could probably fix these by "bunching together" queries + , "reasoningBasedSimplifier/mulmod.yul" + , "loadResolver/multi_sload_loop.yul" + , "reasoningBasedSimplifier/mulcheck.yul" + , "reasoningBasedSimplifier/smod.yul" + , "fullSuite/abi_example1.yul" + , "yulOptimizerTests/fullInliner/large_function_multi_use.yul" + , "loadResolver/merge_known_write_with_distance.yul" + , "loadResolver/second_mstore_with_delta.yul" + , "rematerialiser/for_continue_2.yul" + , "rematerialiser/for_continue_with_assignment_in_post.yul" + + -- invalid test -- + -- https://github.com/ethereum/solidity/issues/9500 + , "commonSubexpressionEliminator/object_access.yul" + , "expressionSplitter/object_access.yul" + + -- stack too deep -- + , "fullSuite/abi2.yul" + , "fullSuite/aztec.yul" + , "stackCompressor/inlineInBlock.yul" + , "stackCompressor/inlineInFunction.yul" + , "stackCompressor/unusedPrunerWithMSize.yul" + , "wordSizeTransform/function_call.yul" + , "fullInliner/no_inline_into_big_function.yul" + , "controlFlowSimplifier/switch_only_default.yul" + , "stackLimitEvader" -- all that are in this subdirectory + + -- typed yul -- + , "conditionalSimplifier/add_correct_type_wasm.yul" + , "conditionalSimplifier/add_correct_type.yul" + , "disambiguator/for_statement.yul" + , "disambiguator/funtion_call.yul" + , "disambiguator/if_statement.yul" + , "disambiguator/long_names.yul" + , "disambiguator/switch_statement.yul" + , "disambiguator/variables_clash.yul" + , "disambiguator/variables_inside_functions.yul" + , "disambiguator/variables.yul" + , "expressionInliner/simple.yul" + , "expressionInliner/with_args.yul" + , "expressionSplitter/typed.yul" + , "fullInliner/multi_return_typed.yul" + , "functionGrouper/empty_block.yul" + , "functionGrouper/multi_fun_mixed.yul" + , "functionGrouper/nested_fun.yul" + , "functionGrouper/single_fun.yul" + , "functionHoister/empty_block.yul" + , "functionHoister/multi_mixed.yul" + , "functionHoister/nested.yul" + , "functionHoister/single.yul" + , "mainFunction/empty_block.yul" + , "mainFunction/multi_fun_mixed.yul" + , "mainFunction/nested_fun.yul" + , "mainFunction/single_fun.yul" + , "ssaTransform/typed_for.yul" + , "ssaTransform/typed_switch.yul" + , "ssaTransform/typed.yul" + , "varDeclInitializer/typed.yul" + + -- New: symbolic index on MSTORE/MLOAD/CopySlice/CallDataCopy/ExtCodeCopy/Revert, + -- or exponent is symbolic (requires symbolic gas) + -- or SHA3 offset symbolic + , "blockFlattener/basic.yul" + , "commonSubexpressionEliminator/case2.yul" + , "equalStoreEliminator/indirect_inferrence.yul" + , "expressionJoiner/reassignment.yul" + , "expressionSimplifier/exp_simplifications.yul" + , "expressionSimplifier/zero_length_read.yul" + , "expressionSimplifier/side_effects_in_for_condition.yul" + , "fullSuite/create_and_mask.yul" + , "fullSuite/unusedFunctionParameterPruner_return.yul" + , "fullSuite/unusedFunctionParameterPruner_simple.yul" + , "fullSuite/unusedFunctionParameterPruner.yul" + , "loadResolver/double_mload_with_other_reassignment.yul" + , "loadResolver/double_mload_with_reassignment.yul" + , "loadResolver/double_mload.yul" + , "loadResolver/keccak_reuse_basic.yul" + , "loadResolver/keccak_reuse_expr_mstore.yul" + , "loadResolver/keccak_reuse_msize.yul" + , "loadResolver/keccak_reuse_mstore.yul" + , "loadResolver/keccak_reuse_reassigned_branch.yul" + , "loadResolver/keccak_reuse_reassigned_value.yul" + , "loadResolver/keccak_symbolic_memory.yul" + , "loadResolver/merge_mload_with_known_distance.yul" + , "loadResolver/mload_self.yul" + , "loadResolver/keccak_reuse_in_expression.yul" + , "loopInvariantCodeMotion/complex_move.yul" + , "loopInvariantCodeMotion/move_memory_function.yul" + , "loopInvariantCodeMotion/move_state_function.yul" + , "loopInvariantCodeMotion/no_move_memory.yul" + , "loopInvariantCodeMotion/no_move_storage.yul" + , "loopInvariantCodeMotion/not_first.yul" + , "ssaAndBack/single_assign_if.yul" + , "ssaAndBack/single_assign_switch.yul" + , "structuralSimplifier/switch_inline_no_match.yul" + , "unusedFunctionParameterPruner/simple.yul" + , "unusedStoreEliminator/covering_calldatacopy.yul" + , "unusedStoreEliminator/remove_before_revert.yul" + , "unusedStoreEliminator/unknown_length2.yul" + , "unusedStoreEliminator/unrelated_relative.yul" + , "fullSuite/extcodelength.yul" + , "unusedStoreEliminator/create_inside_function.yul"-- "trying to reset symbolic storage with writes in create" + + -- Due to tstorage warnings treated as errors when running solc with --standard-json + -- these cannot be currently run. See: https://github.com/ethereum/solidity/issues/15397 + -- When that fix comes to upstream, we can re-enabled again + , "equalStoreEliminator/transient_storage.yul" + , "unusedStoreEliminator/tload.yul" + , "unusedStoreEliminator/tstore.yul" + , "yulOptimizerTests/fullSuite/transient_storage.yul" + , "yulOptimizerTests/unusedPruner/transient_storage.yul" + + -- Bug in solidity, fixed in newer versions: + -- https://github.com/ethereum/solidity/issues/15397#event-14116827816 + , "no_move_transient_storage.yul" + ] + + solcRepo <- liftIO $ fromMaybe (internalError "cannot find solidity repo") <$> (lookupEnv "HEVM_SOLIDITY_REPO") + let testDir = solcRepo <> "/test/libyul/yulOptimizerTests" + dircontents <- liftIO $ System.Directory.listDirectory testDir + let + fullpaths = map ((testDir ++ "/") ++) dircontents + recursiveList :: [FilePath] -> [FilePath] -> IO [FilePath] + recursiveList (a:ax) b = do + isdir <- doesDirectoryExist a + case isdir of + True -> do + fs <- System.Directory.listDirectory a + let fs2 = map ((a ++ "/") ++) fs + recursiveList (ax++fs2) b + False -> recursiveList ax (a:b) + recursiveList [] b = pure b + files <- liftIO $ recursiveList fullpaths [] + let filesFiltered = filter (\file -> not $ any (`List.isInfixOf` file) ignoredTests) files + + -- Takes one file which follows the Solidity Yul optimizer unit tests format, + -- extracts both the nonoptimized and the optimized versions, and checks equivalence. + forM_ filesFiltered (\f-> do + liftIO $ print f + origcont <- liftIO $ readFile f + let + onlyAfter pattern (a:ax) = if a =~ pattern then (a:ax) else onlyAfter pattern ax + onlyAfter _ [] = [] + replaceOnce pat repl inp = go inp [] where + go (a:ax) b = if a =~ pat then let a2 = replaceAll repl $ a *=~ pat in b ++ a2:ax + else go ax (b ++ [a]) + go [] b = b + + -- takes a yul program and ensures memory is symbolic by prepending + -- `calldatacopy(0,0,1024)`. (calldata is symbolic, but memory starts empty). + -- This forces the exploration of more branches, and makes the test vectors a + -- little more thorough. + symbolicMem (a:ax) = if a =~ [re|"^ *object"|] then + let a2 = replaceAll "a calldatacopy(0,0,1024)" $ a *=~ [re|code {|] + in (a2:ax) + else replaceOnce [re|^ *{|] "{\ncalldatacopy(0,0,1024)" $ onlyAfter [re|^ *{|] (a:ax) + symbolicMem _ = internalError "Program too short" + + unfiltered = lines origcont + filteredASym = symbolicMem [ x | x <- unfiltered, (not $ x =~ [re|^//|]) && (not $ x =~ [re|^$|]) ] + filteredBSym = symbolicMem [ replaceAll "" $ x *=~[re|^//|] | x <- onlyAfter [re|^// step:|] unfiltered, not $ x =~ [re|^$|] ] + start <- liftIO $ getCurrentTime + putStrLnM $ "Checking file: " <> f + conf <- readConfig + when conf.debug $ liftIO $ do + putStrLnM "-------------Original Below-----------------" + mapM_ putStrLn unfiltered + putStrLnM "------------- Filtered A + Symb below-----------------" + mapM_ putStrLn filteredASym + putStrLnM "------------- Filtered B + Symb below-----------------" + mapM_ putStrLn filteredBSym + putStrLnM "------------- END -----------------" + Just aPrgm <- liftIO $ yul "" $ T.pack $ unlines filteredASym + Just bPrgm <- liftIO $ yul "" $ T.pack $ unlines filteredBSym + procs <- liftIO $ getNumProcessors + withSolvers CVC5 (unsafeInto procs) 1 (Just 100) $ \s -> do + calldata <- mkCalldata Nothing [] + eq <- equivalenceCheck s aPrgm bPrgm opts calldata False + let res = map fst eq.res + end <- liftIO $ getCurrentTime + case any isCex res of + False -> liftIO $ do + print $ "OK. Took " <> (show $ diffUTCTime end start) <> " seconds" + let timeouts = filter isUnknown res + let errors = filter isError res + unless (null timeouts && null errors) $ do + putStrLnM $ "But " <> (show $ length timeouts) <> " timeout(s) and " <> (show $ length errors) <> " error(s) occurred" + internalError "Encountered timeout(s) and/or error(s)" + True -> liftIO $ do + putStrLnM $ "Not OK: " <> show f <> " Got: " <> show res + internalError "Was NOT equivalent" + ) + ] + ] + where + (===>) = assertSolidityComputation + +checkEquivProp :: App m => Prop -> Prop -> m Bool +checkEquivProp a b = fmap (fromMaybe True) $ checkEquivBase (\l r -> PNeg (PImpl l r .&& PImpl r l)) a b True + +checkEquivPropAndLHS :: App m => Prop -> Prop -> m Bool +checkEquivPropAndLHS orig simp = do + let lhsConst = Expr.checkLHSConstProp simp + equiv <- checkEquivProp orig simp + pure $ lhsConst && equiv + +checkEquiv :: (Typeable a, App m) => Expr a -> Expr a -> m Bool +checkEquiv a b = do + opts <- readConfig + if a == b then pure True else do + when (opts.debug) $ liftIO $ putStrLn $ "Checking equivalence of " <> show a <> " and " <> show b + x <- checkEquivBase (./=) a b True + when (opts.debug) $ liftIO $ putStrLn $ "UNSAT check, expect True: " <> show x + y <- checkEquivBase (.==) a b False + when (opts.debug) $ liftIO $ putStrLn $ "SAT check, expect False: " <> show y + pure $ (fromMaybe True x) && not (fromMaybe False y) + +checkEquivAndLHS :: (Typeable a, App m) => Expr a -> Expr a -> m Bool +checkEquivAndLHS orig simp = do + opts <- readConfig + let lhsConst = Expr.checkLHSConst simp + when (opts.debug) $ liftIO $ putStrLn $ "LHS const: " <> show lhsConst + equiv <- checkEquiv orig simp + pure $ lhsConst && equiv + +checkEquivBase :: (Eq a, App m) => (a -> a -> Prop) -> a -> a -> Bool -> m (Maybe Bool) +checkEquivBase mkprop l r expect = do + withSolvers Z3 1 1 (Just 1) $ \solvers -> do + (res, _) <- checkSatWithProps solvers [mkprop l r] + let ret = case res of + Qed -> Just True + Cex {} -> Just False + Error _ -> Just (not expect) + Unknown _ -> Nothing + when (ret == Just (not expect)) $ liftIO $ print res + pure ret + +-- | Takes a runtime code and calls it with the provided calldata + +-- | Takes a creation code and some calldata, runs the creation code, and calls the resulting contract with the provided calldata +runSimpleVM :: App m => ByteString -> ByteString -> m (Maybe ByteString) +runSimpleVM x ins = do + loadVM x >>= \case + Nothing -> pure Nothing + Just vm -> do + let calldata = (ConcreteBuf ins) + vm' = set (#state % #calldata) calldata vm + res <- Stepper.interpret (Fetch.zero 0 Nothing) vm' Stepper.execFully + case res of + Right (ConcreteBuf bs) -> pure $ Just bs + s -> internalError $ show s + +-- | Takes a creation code and returns a vm with the result of executing the creation code +loadVM :: App m => ByteString -> m (Maybe (VM Concrete RealWorld)) +loadVM x = do + vm <- liftIO $ stToIO $ vmForEthrunCreation x + vm1 <- Stepper.interpret (Fetch.zero 0 Nothing) vm Stepper.runFully + case vm1.result of + Just (VMSuccess (ConcreteBuf targetCode)) -> do + let target = vm1.state.contract + vm2 <- Stepper.interpret (Fetch.zero 0 Nothing) vm1 (prepVm target targetCode) + writeTrace vm2 + pure $ Just vm2 + _ -> pure Nothing + where + prepVm target targetCode = Stepper.evm $ do + replaceCodeOfSelf (RuntimeCode $ ConcreteRuntimeCode targetCode) + resetState + assign (#state % #gas) 0xffffffffffffffff -- kludge + execState (loadContract target) <$> get >>= put + get + +hex :: ByteString -> ByteString +hex s = + case BS16.decodeBase16Untyped s of + Right x -> x + Left e -> internalError $ T.unpack e + +singleContract :: Text -> Text -> IO (Maybe ByteString) +singleContract x s = + solidity x [i| + pragma experimental ABIEncoderV2; + contract ${x} { ${s} } + |] + +defaultDataLocation :: AbiType -> Text +defaultDataLocation t = + if (case t of + AbiBytesDynamicType -> True + AbiStringType -> True + AbiArrayDynamicType _ -> True + AbiArrayType _ _ -> True + _ -> False) + then "memory" + else "" + +runFunction :: App m => Text -> ByteString -> m (Maybe ByteString) +runFunction c input = do + x <- liftIO $ singleContract "X" c + runSimpleVM (fromJust x) input + +runStatements :: App m => Text -> [AbiValue] -> AbiType -> m (Maybe ByteString) +runStatements stmts args t = do + let params = + T.intercalate ", " + (map (\(x, c) -> abiTypeSolidity (abiValueType x) + <> " " <> defaultDataLocation (abiValueType x) + <> " " <> T.pack [c]) + (zip args "abcdefg")) + s = + "foo(" <> T.intercalate "," + (map (abiTypeSolidity . abiValueType) args) <> ")" + + runFunction [i| + function foo(${params}) public pure returns (${abiTypeSolidity t} ${defaultDataLocation t} x) { + ${stmts} + } + |] (abiMethod s (AbiTuple $ V.fromList args)) + +getStaticAbiArgs :: Int -> VM Symbolic s -> [Expr EWord] +getStaticAbiArgs n vm = + let cd = vm.state.calldata + in decodeStaticArgs 4 n cd + +-- includes shaving off 4 byte function sig +decodeAbiValues :: [AbiType] -> ByteString -> [AbiValue] +decodeAbiValues types bs = + let xy = case decodeAbiValue (AbiTupleType $ V.fromList types) (BS.fromStrict (BS.drop 4 bs)) of + AbiTuple xy' -> xy' + _ -> internalError "AbiTuple expected" + in V.toList xy + +-- abi types that are supported in the symbolic abi encoder +newtype SymbolicAbiType = SymbolicAbiType AbiType + deriving (Eq, Show) + +newtype SymbolicAbiVal = SymbolicAbiVal AbiValue + deriving (Eq, Show) + +instance Arbitrary SymbolicAbiVal where + arbitrary = do + SymbolicAbiType ty <- arbitrary + SymbolicAbiVal <$> genAbiValue ty + +instance Arbitrary SymbolicAbiType where + arbitrary = SymbolicAbiType <$> frequency + [ (5, (AbiUIntType . (* 8)) <$> choose (1, 32)) + , (5, (AbiIntType . (* 8)) <$> choose (1, 32)) + , (5, pure AbiAddressType) + , (5, pure AbiBoolType) + , (5, AbiBytesType <$> choose (1,32)) + , (1, do SymbolicAbiType ty <- scale (`div` 2) arbitrary + AbiArrayType <$> (choose (1, 30)) <*> pure ty + ) + ] + +newtype Bytes = Bytes ByteString + deriving Eq + +instance Show Bytes where + showsPrec _ (Bytes x) _ = show (BS.unpack x) + +instance Arbitrary Bytes where + arbitrary = fmap (Bytes . BS.pack) arbitrary + +newtype RLPData = RLPData RLP + deriving (Eq, Show) + +-- bias towards bytestring to try to avoid infinite recursion +instance Arbitrary RLPData where + arbitrary = frequency + [(5, do + Bytes bytes <- arbitrary + return $ RLPData $ BS bytes) + , (1, do + k <- choose (0,10) + ls <- vectorOf k arbitrary + return $ RLPData $ List [r | RLPData r <- ls]) + ] + +instance Arbitrary Word128 where + arbitrary = liftM2 fromHiAndLo arbitrary arbitrary + +instance Arbitrary Word160 where + arbitrary = liftM2 fromHiAndLo arbitrary arbitrary + +instance Arbitrary Word256 where + arbitrary = liftM2 fromHiAndLo arbitrary arbitrary + +instance Arbitrary W64 where + arbitrary = fmap W64 arbitrary + +instance Arbitrary W256 where + arbitrary = fmap W256 arbitrary + +instance Arbitrary Addr where + arbitrary = fmap Addr arbitrary + +instance Arbitrary (Expr EAddr) where + arbitrary = oneof + [ fmap LitAddr arbitrary + , fmap SymAddr (genName "addr") + ] + +instance Arbitrary (Expr Storage) where + arbitrary = sized genStorage + +instance Arbitrary (Expr EWord) where + arbitrary = sized defaultWord + +instance Arbitrary (Expr Byte) where + arbitrary = sized genByte + +newtype SymbolicJoinBytes = SymbolicJoinBytes [Expr Byte] + deriving (Eq, Show) + +instance Arbitrary SymbolicJoinBytes where + arbitrary = liftM SymbolicJoinBytes $ replicateM 32 arbitrary + +joinBytesFromList :: [Expr Byte] -> Expr EWord +joinBytesFromList [a0, a1, a2, a3, a4, a5, a6, a7, + a8, a9, a10, a11, a12, a13, a14, a15, + a16, a17, a18, a19, a20, a21, a22, a23, + a24, a25, a26, a27, a28, a29, a30, a31] = + JoinBytes a0 a1 a2 a3 a4 a5 a6 a7 + a8 a9 a10 a11 a12 a13 a14 a15 + a16 a17 a18 a19 a20 a21 a22 a23 + a24 a25 a26 a27 a28 a29 a30 a31 +joinBytesFromList _ = internalError "List must contain exactly 32 elements" + +instance Arbitrary (Expr Buf) where + arbitrary = sized defaultBuf + +instance Arbitrary (Expr End) where + arbitrary = sized genEnd + +instance Arbitrary (ContractCode) where + arbitrary = oneof + [ fmap UnknownCode arbitrary + , liftM2 InitCode arbitrary arbitrary + , fmap RuntimeCode arbitrary + ] + +instance Arbitrary (RuntimeCode) where + arbitrary = oneof + [ fmap ConcreteRuntimeCode arbitrary + , fmap SymbolicRuntimeCode arbitrary + ] + +instance Arbitrary (V.Vector (Expr Byte)) where + arbitrary = fmap V.fromList (listOf1 arbitrary) + +instance Arbitrary (Expr EContract) where + arbitrary = sized genEContract + +-- LitOnly +newtype LitOnly a = LitOnly a + deriving (Show, Eq) + +newtype LitWord (sz :: Nat) = LitWord (Expr EWord) + deriving (Show) + +instance (KnownNat sz) => Arbitrary (LitWord sz) where + arbitrary = LitWord <$> genLit (fromInteger v) + where + v = natVal (Proxy @sz) + +instance Arbitrary (LitOnly (Expr Byte)) where + arbitrary = LitOnly . LitByte <$> arbitrary + +instance Arbitrary (LitOnly (Expr EWord)) where + arbitrary = LitOnly . Lit <$> arbitrary + +instance Arbitrary (LitOnly (Expr Buf)) where + arbitrary = LitOnly . ConcreteBuf <$> arbitrary + +genEContract :: Int -> Gen (Expr EContract) +genEContract sz = do + c <- arbitrary + b <- defaultWord sz + n <- arbitrary + s <- genStorage sz + ts <- genStorage sz + pure $ C {code=c, storage=s, tStorage=ts, balance=b, nonce=n} + +-- ZeroDepthWord +newtype ZeroDepthWord = ZeroDepthWord (Expr EWord) + deriving (Show, Eq) + +instance Arbitrary ZeroDepthWord where + arbitrary = do + fmap ZeroDepthWord . sized $ genWord 0 + +-- WriteWordBuf +newtype WriteWordBuf = WriteWordBuf (Expr Buf) + deriving (Show, Eq) + +instance Arbitrary WriteWordBuf where + arbitrary = do + let mkBuf = oneof + [ pure $ ConcreteBuf "" -- empty + , fmap ConcreteBuf arbitrary -- concrete + , sized (genBuf 100) -- overlapping writes + , arbitrary -- sparse writes + ] + fmap WriteWordBuf mkBuf + +-- GenCopySliceBuf +newtype GenCopySliceBuf = GenCopySliceBuf (Expr Buf) + deriving (Show, Eq) + +instance Arbitrary GenCopySliceBuf where + arbitrary = do + let mkBuf = oneof + [ pure $ ConcreteBuf "" + , fmap ConcreteBuf arbitrary + , arbitrary + ] + fmap GenCopySliceBuf mkBuf + +-- GenWriteStorageExpr +newtype GenWriteStorageExpr = GenWriteStorageExpr (Expr EWord, Expr Storage) + deriving (Show, Eq) + +instance Arbitrary GenWriteStorageExpr where + arbitrary = do + slot <- arbitrary + let mkStore = oneof + [ pure $ ConcreteStore mempty + , fmap ConcreteStore arbitrary + , do + -- generate some write chains where we know that at least one + -- write matches either the input addr, or both the input + -- addr and slot + let addWrites :: Expr Storage -> Int -> Gen (Expr Storage) + addWrites b 0 = pure b + addWrites b n = liftM3 SStore arbitrary arbitrary (addWrites b (n - 1)) + s <- arbitrary + addMatch <- fmap (SStore slot) arbitrary + let withMatch = addMatch s + newWrites <- oneof [ pure 0, pure 1, fmap (`mod` 5) arbitrary ] + addWrites withMatch newWrites + , arbitrary + ] + store <- mkStore + pure $ GenWriteStorageExpr (slot, store) + +-- GenWriteByteIdx +newtype GenWriteByteIdx = GenWriteByteIdx (Expr EWord) + deriving (Show, Eq) + +instance Arbitrary GenWriteByteIdx where + arbitrary = do + -- 1st: can never overflow an Int + -- 2nd: can overflow an Int + let mkIdx = frequency [ (10, genLit 1_000_000) , (1, fmap Lit arbitrary) ] + fmap GenWriteByteIdx mkIdx + +newtype LitProp = LitProp Prop + deriving (Show, Eq) + +instance Arbitrary LitProp where + arbitrary = LitProp <$> sized (genProp True) + + +newtype StorageExp = StorageExp (Expr EWord) + deriving (Show, Eq) + +instance Arbitrary StorageExp where + arbitrary = StorageExp <$> (genStorageExp) + +genStorageExp :: Gen (Expr EWord) +genStorageExp = do + fromPos <- genSlot + storage <- genStorageWrites + pure $ SLoad fromPos storage + +genSlot :: Gen (Expr EWord) +genSlot = frequency [ (1, do + buf <- genConcreteBufSlot 64 + case buf of + (ConcreteBuf b) -> do + key <- genLit 10 + pure $ Expr.MappingSlot b key + _ -> internalError "impossible" + ) + -- map element + ,(2, do + l <- genLit 10 + buf <- genConcreteBufSlot 64 + pure $ Add (Keccak buf) l) + -- Array element + ,(2, do + l <- genLit 10 + buf <- genConcreteBufSlot 32 + pure $ Add (Keccak buf) l) + -- member of the Contract + ,(2, pure $ Lit 20) + -- array element + ,(2, do + arrayNum :: Int <- arbitrary + offs :: W256 <- arbitrary + pure $ Lit $ fst (Expr.preImages !! (arrayNum `mod` 3)) + (offs `mod` 3)) + -- random stuff + ,(1, pure $ Lit (maxBound :: W256)) + ] + +-- Generates an N-long buffer, all with the same value, at most 8 different ones +genConcreteBufSlot :: Int -> Gen (Expr Buf) +genConcreteBufSlot len = do + b :: Word8 <- arbitrary + pure $ ConcreteBuf $ BS.pack ([ 0 | _ <- [0..(len-2)]] ++ [b]) + +genStorageWrites :: Gen (Expr Storage) +genStorageWrites = do + toSlot <- genSlot + val <- genLit (maxBound :: W256) + store <- frequency [ (3, pure $ AbstractStore (SymAddr "") Nothing) + , (2, genStorageWrites) + ] + pure $ SStore toSlot val store + +instance Arbitrary Prop where + arbitrary = sized (genProp False) + +genProps :: Bool -> Int -> Gen [Prop] +genProps onlyLits sz2 = listOf $ genProp onlyLits sz2 + +genProp :: Bool -> Int -> Gen (Prop) +genProp _ 0 = PBool <$> arbitrary +genProp onlyLits sz = oneof + [ liftM2 PEq subWord subWord + , liftM2 PLT subWord subWord + , liftM2 PGT subWord subWord + , liftM2 PLEq subWord subWord + , liftM2 PGEq subWord subWord + , fmap PNeg subProp + , liftM2 PAnd subProp subProp + , liftM2 POr subProp subProp + , liftM2 PImpl subProp subProp + ] + where + subWord = if onlyLits then frequency [(2, Lit <$> arbitrary) + ,(1, pure $ Lit 0) + ,(1, pure $ Lit Expr.maxLit) + ] + else genWord 1 (sz `div` 2) + subProp = genProp onlyLits (sz `div` 2) + +genByte :: Int -> Gen (Expr Byte) +genByte 0 = fmap LitByte arbitrary +genByte sz = oneof + [ liftM2 IndexWord subWord subWord + , liftM2 ReadByte subWord subBuf + ] + where + subWord = defaultWord (sz `div` 10) + subBuf = defaultBuf (sz `div` 10) + +genLit :: W256 -> Gen (Expr EWord) +genLit bound = do + w <- arbitrary + pure $ Lit (w `mod` bound) + +genNat :: Gen Int +genNat = fmap unsafeInto (arbitrary :: Gen Natural) + +genName :: String -> Gen Text +-- In order not to generate SMT reserved words, we prepend with "esc_" +genName ty = fmap (T.pack . (("esc_" <> ty <> "_") <> )) $ listOf1 (oneof . (fmap pure) $ ['a'..'z'] <> ['A'..'Z']) + +genEnd :: Int -> Gen (Expr End) +genEnd 0 = oneof + [ fmap (Failure mempty mempty . UnrecognizedOpcode) arbitrary + , pure $ Failure mempty mempty IllegalOverflow + , pure $ Failure mempty mempty SelfDestruction + ] +genEnd sz = oneof + [ liftM3 Failure subProp (pure mempty) (fmap Revert subBuf) + , liftM4 Success subProp (pure mempty) subBuf arbitrary + , liftM3 ITE subWord subEnd subEnd + -- TODO Partial + ] + where + subBuf = defaultBuf (sz `div` 2) + subWord = defaultWord (sz `div` 2) + subEnd = genEnd (sz `div` 2) + subProp = genProps False (sz `div` 2) + +genWord :: Int -> Int -> Gen (Expr EWord) +genWord litFreq 0 = frequency + [ (litFreq, do + val <- frequency + [ (10, fmap (`mod` 100) arbitrary) + , (1, pure 0) + , (1, pure Expr.maxLit) + , (1, arbitrary) + ] + pure $ Lit val + ) + , (1, oneof + [ pure Origin + , pure Coinbase + , pure Timestamp + , pure BlockNumber + , pure PrevRandao + , pure GasLimit + , pure ChainId + , pure BaseFee + --, liftM2 SelfBalance arbitrary arbitrary + --, liftM2 Gas arbitrary arbitrary + , fmap Lit arbitrary + , fmap joinBytesFromList $ replicateM 32 arbitrary + , fmap Var (genName "word") + ] + ) + ] +genWord litFreq sz = frequency + [ (litFreq, do + val <- frequency + [ (10, fmap (`mod` 100) arbitrary) + , (1, arbitrary) + ] + pure $ Lit val + ) + , (1, oneof + [ liftM2 Add subWord subWord + , liftM2 Sub subWord subWord + , liftM2 Mul subWord subWord + , liftM2 Div subWord subWord + , liftM2 SDiv subWord subWord + , liftM2 Mod subWord subWord + , liftM2 SMod subWord subWord + --, liftM3 AddMod subWord subWord subWord + --, liftM3 MulMod subWord subWord subWord -- it works, but it's VERY SLOW + --, liftM2 Exp subWord litWord + , liftM2 SEx subWord subWord + , liftM2 Min subWord subWord + , liftM2 LT subWord subWord + , liftM2 GT subWord subWord + , liftM2 LEq subWord subWord + , liftM2 GEq subWord subWord + , liftM2 SLT subWord subWord + --, liftM2 SGT subWord subWord + , liftM2 Eq subWord subWord + , fmap IsZero subWord + , liftM2 And subWord subWord + , liftM2 Or subWord subWord + , liftM2 Xor subWord subWord + , fmap Not subWord + , liftM2 SHL subWord subWord + , liftM2 SHR subWord subWord + , liftM2 SAR subWord subWord + , fmap BlockHash subWord + --, liftM3 Balance arbitrary arbitrary subWord + --, fmap CodeSize subWord + --, fmap ExtCodeHash subWord + , fmap Keccak subBuf + , fmap SHA256 subBuf + , liftM2 SLoad subWord subStore + , liftM2 ReadWord genReadIndex subBuf + , fmap BufLength subBuf + , do + one <- subByte + two <- subByte + three <- subByte + four <- subByte + five <- subByte + six <- subByte + seven <- subByte + eight <- subByte + nine <- subByte + ten <- subByte + eleven <- subByte + twelve <- subByte + thirteen <- subByte + fourteen <- subByte + fifteen <- subByte + sixteen <- subByte + seventeen <- subByte + eighteen <- subByte + nineteen <- subByte + twenty <- subByte + twentyone <- subByte + twentytwo <- subByte + twentythree <- subByte + twentyfour <- subByte + twentyfive <- subByte + twentysix <- subByte + twentyseven <- subByte + twentyeight <- subByte + twentynine <- subByte + thirty <- subByte + thirtyone <- subByte + thirtytwo <- subByte + pure $ JoinBytes + one two three four five six seven eight nine ten + eleven twelve thirteen fourteen fifteen sixteen + seventeen eighteen nineteen twenty twentyone + twentytwo twentythree twentyfour twentyfive + twentysix twentyseven twentyeight twentynine + thirty thirtyone thirtytwo + ]) + ] + where + subWord = genWord litFreq (sz `div` 5) + subBuf = defaultBuf (sz `div` 10) + subStore = genStorage (sz `div` 10) + subByte = genByte (sz `div` 10) + genReadIndex = do + o :: (Expr EWord) <- subWord + pure $ case o of + Lit w -> Lit $ w `mod` into (maxBound :: Word64) + _ -> o + +genWordArith :: Int -> Int -> Gen (Expr EWord) +genWordArith litFreq 0 = frequency + [ (litFreq, fmap Lit arbitrary) + , (1, oneof [ fmap Lit arbitrary ]) + ] +genWordArith litFreq sz = frequency + [ (litFreq, fmap Lit arbitrary) + , (20, frequency + [ (20, liftM2 Add subWord subWord) + , (20, liftM2 Sub subWord subWord) + , (20, liftM2 Mul subWord subWord) + , (20, liftM2 SEx subWord subWord) + , (20, liftM2 Xor subWord subWord) + -- these reduce variability + , (3 , liftM2 Min subWord subWord) + , (3 , liftM2 Div subWord subWord) + , (3 , liftM2 SDiv subWord subWord) + , (3 , liftM2 Mod subWord subWord) + , (3 , liftM2 SMod subWord subWord) + , (3 , liftM2 SHL subWord subWord) + , (3 , liftM2 SHR subWord subWord) + , (3 , liftM2 SAR subWord subWord) + , (3 , liftM2 Or subWord subWord) + -- comparisons, reducing variability greatly + , (1 , liftM2 LEq subWord subWord) + , (1 , liftM2 GEq subWord subWord) + , (1 , liftM2 SLT subWord subWord) + --(1, , liftM2 SGT subWord subWord + , (1 , liftM2 Eq subWord subWord) + , (1 , liftM2 And subWord subWord) + , (1 , fmap IsZero subWord ) + -- Expensive below + --(1, liftM3 AddMod subWord subWord subWord + --(1, liftM3 MulMod subWord subWord subWord + --(1, liftM2 Exp subWord litWord + ]) + ] + where + subWord = genWordArith (litFreq `div` 2) (sz `div` 2) + + +-- Finds SLoad -> SStore. This should not occur in most scenarios +-- as we can simplify them away +badStoresInExpr :: Expr a -> Bool +badStoresInExpr = getAny . foldExpr match mempty + where + match (SLoad _ (SStore _ _ _)) = Any True + match _ = Any False + +defaultBuf :: Int -> Gen (Expr Buf) +defaultBuf = genBuf (4_000_000) + +defaultWord :: Int -> Gen (Expr EWord) +defaultWord = genWord 10 + +maybeBoundedLit :: W256 -> Gen (Expr EWord) +maybeBoundedLit bound = do + o <- (arbitrary :: Gen (Expr EWord)) + pure $ case o of + Lit w -> Lit $ w `mod` bound + _ -> o + +genBuf :: W256 -> Int -> Gen (Expr Buf) +genBuf _ 0 = oneof + [ fmap AbstractBuf (genName "buf") + , fmap ConcreteBuf arbitrary + ] +genBuf bound sz = oneof + [ liftM3 WriteWord (maybeBoundedLit bound) subWord subBuf + , liftM3 WriteByte (maybeBoundedLit bound) subByte subBuf + -- we don't generate copyslice instances where: + -- - size is abstract + -- - size > 100 (due to unrolling in SMT.hs) + -- - literal dstOffsets are > 4,000,000 (due to unrolling in SMT.hs) + -- n.b. that 4,000,000 is the theoretical maximum memory size given a 30,000,000 block gas limit + , liftM5 CopySlice genReadIndex (maybeBoundedLit bound) smolLitWord subBuf subBuf + ] + where + -- copySlice gets unrolled in the generated SMT so we can't go too crazy here + smolLitWord = do + w <- arbitrary + pure $ Lit (w `mod` 100) + subWord = defaultWord (sz `div` 5) + subByte = genByte (sz `div` 10) + subBuf = genBuf bound (sz `div` 10) + genReadIndex = do + o :: (Expr EWord) <- subWord + pure $ case o of + Lit w -> Lit $ w `mod` into (maxBound :: Word64) + _ -> o + +genStorage :: Int -> Gen (Expr Storage) +genStorage 0 = oneof + [ liftM2 AbstractStore arbitrary (pure Nothing) + , fmap ConcreteStore arbitrary + ] +genStorage sz = liftM3 SStore key val subStore + where + subStore = genStorage (sz `div` 10) + val = defaultWord (sz `div` 5) + key = genStorageKey + +genStorageKey :: Gen (Expr EWord) +genStorageKey = frequency + -- array slot + [ (4, liftM2 Expr.ArraySlotWithOffs (genByteStringKey 32) (genLit 5)) + , (4, fmap Expr.ArraySlotZero (genByteStringKey 32)) + -- mapping slot + , (8, liftM2 Expr.MappingSlot (genByteStringKey 64) (genLit 5)) + -- small slot + , (4, genLit 20) + -- unrecognized slot type + , (1, genLit 5) + ] + +genByteStringKey :: W256 -> Gen (ByteString) +genByteStringKey len = do + b :: Word8 <- arbitrary + pure $ BS.pack ([ 0 | _ <- [0..(len-2)]] ++ [b `mod` 5]) + +-- GenWriteStorageLoad +newtype GenWriteStorageLoad = GenWriteStorageLoad (Expr EWord) + deriving (Show, Eq) + +instance Arbitrary GenWriteStorageLoad where + arbitrary = do + load <- genStorageLoad 10 + pure $ GenWriteStorageLoad load + + where + genStorageLoad :: Int -> Gen (Expr EWord) + genStorageLoad sz = liftM2 SLoad key subStore + where + subStore = genStorage (sz `div` 10) + key = genStorageKey + +data Invocation + = SolidityCall Text [AbiValue] + deriving Show + +assertSolidityComputation :: App m => Invocation -> AbiValue -> m () +assertSolidityComputation (SolidityCall s args) x = + do y <- runStatements s args (abiValueType x) + liftIO $ assertEqual (T.unpack s) + (fmap Bytes (Just (encodeAbiValue x))) + (fmap Bytes y) + +bothM :: (Monad m) => (a -> m b) -> (a, a) -> m (b, b) +bothM f (a, a') = do + b <- f a + b' <- f a' + return (b, b') + +applyPattern :: String -> TestTree -> TestTree +applyPattern p = localOption (TestPattern (parseExpr p)) + +checkBadCheatCode :: Text -> Postcondition s +checkBadCheatCode sig _ = \case + (Failure _ c (Revert _)) -> case mapMaybe findBadCheatCode (concatMap flatten c.traces) of + (s:_) -> (ConcreteBuf $ into s.unFunctionSelector) ./= (ConcreteBuf $ selector sig) + _ -> PBool True + _ -> PBool True + where + findBadCheatCode :: Trace -> Maybe FunctionSelector + findBadCheatCode Trace { tracedata = td } = case td of + ErrorTrace (BadCheatCode _ s) -> Just s + _ -> Nothing + +allBranchesFail :: App m => ByteString -> Maybe Sig -> m (Either [SMTCex] (Expr End)) +allBranchesFail = checkPost (Just p) + where + p _ = \case + Success _ _ _ _ -> PBool False + _ -> PBool True + +reachableUserAsserts :: App m => ByteString -> Maybe Sig -> m (Either [SMTCex] (Expr End)) +reachableUserAsserts = checkPost (Just $ checkAssertions [0x01]) + +checkPost :: App m => Maybe (Postcondition RealWorld) -> ByteString -> Maybe Sig -> m (Either [SMTCex] (Expr End)) +checkPost post c sig = do + (e, res) <- withDefaultSolver $ \s -> + verifyContract s c sig [] defaultVeriOpts Nothing post + let cexs = snd <$> mapMaybe getCex res + case cexs of + [] -> pure $ Right e + cs -> pure $ Left cs + +successGen :: [Prop] -> Expr End +successGen props = Success props mempty (ConcreteBuf "") mempty + +-- gets the expected concrete values for symbolic abi testing +expectedConcVals :: Text -> AbiValue -> SMTCex +expectedConcVals nm val = case val of + AbiUInt {} -> mempty { vars = Map.fromList [(Var nm, mkWord val)] } + AbiInt {} -> mempty { vars = Map.fromList [(Var nm, mkWord val)] } + AbiAddress {} -> mempty { addrs = Map.fromList [(SymAddr nm, truncateToAddr (mkWord val))] } + AbiBool {} -> mempty { vars = Map.fromList [(Var nm, mkWord val)] } + AbiBytes {} -> mempty { vars = Map.fromList [(Var nm, mkWord val)] } + AbiArray _ _ vals -> mconcat . V.toList . V.imap (\(T.pack . show -> idx) v -> expectedConcVals (nm <> "-a-" <> idx) v) $ vals + AbiTuple vals -> mconcat . V.toList . V.imap (\(T.pack . show -> idx) v -> expectedConcVals (nm <> "-t-" <> idx) v) $ vals + _ -> internalError $ "unsupported Abi type " <> show nm <> " val: " <> show val <> " val type: " <> showAlter val + where + mkWord = word . encodeAbiValue + +hexStringToByteString :: String -> BS.ByteString +hexStringToByteString hexStr + | odd (length hexStr) = error "Hex string has an odd length" + | otherwise = case traverse hexPairToByte (pairs hexStr) of + Just bytes -> (BS.pack bytes) + Nothing -> error "Invalid hex string" + where + -- Convert a pair of hex characters to a byte + hexPairToByte :: (Char, Char) -> Maybe Word8 + hexPairToByte (c1, c2) = do + b1 <- hexCharToDigit c1 + b2 <- hexCharToDigit c2 + return $ fromIntegral (b1 * 16 + b2) + + -- Convert a single hex character to its integer value + hexCharToDigit :: Char -> Maybe Int + hexCharToDigit c + | c >= '0' && c <= '9' = Just (digitToInt c) + | c >= 'a' && c <= 'f' = Just (digitToInt c) + | c >= 'A' && c <= 'F' = Just (digitToInt c) + | otherwise = Nothing + + -- Split a string into pairs of characters + pairs :: [a] -> [(a, a)] + pairs [] = [] + pairs (x:y:xs) = (x, y) : pairs xs + pairs _ = error "Unexpected odd length"