diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,20 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.50.3] - 2023-02-17 + +### Fixed + +- `hevm symbolic` exits with status code `1` if counterexamples or timeouts are found + +### Added + +- New cheatcode `prank(address)` that sets `msg.sender` to the specified address for the next call. +- Improved equivalence checker that avoids checking similar branches more than once. +- Improved simplification for arithmetic expressions +- Construction of storage counterexamples based on the model returned by the SMT solver. +- Static binaries for macos + ## [0.50.2] - 2023-01-06 ### Fixed diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -0,0 +1,85 @@ +module Main where + +import GHC.Natural + +import qualified Paths_hevm as Paths + +import Test.Tasty (localOption) +import Test.Tasty.Bench +import Data.Functor +import Data.String.Here +import Data.ByteString (ByteString) +import qualified Data.Text as T + +import EVM (StorageModel(..)) +import EVM.SymExec +import EVM.Solidity +import EVM.Solvers +import EVM.ABI +import EVM.Dapp +import EVM.Types +import qualified EVM.TTY as TTY + +findPanics :: Solver -> Natural -> Maybe Integer -> ByteString -> IO () +findPanics solver count iters c = do + (_, res) <- withSolvers solver count Nothing $ \s -> do + let opts = defaultVeriOpts + { maxIter = iters + , askSmtIters = (+ 1) <$> iters + } + checkAssert s allPanicCodes c Nothing [] opts + putStrLn "done" + + +-- constructs a benchmark suite that checks the given bytecode for reachable +-- assertion violations takes an iteration bound, as well as a list of solver +-- counts to benchmark, allowing us to construct benchmarks that compare the +-- performance impact of increasing solver parallelisation +mkbench :: IO ByteString -> String -> Maybe Integer -> [Natural] -> Benchmark +mkbench c name iters counts = localOption WallTime $ env c (bgroup name . bmarks) + where + bmarks c' = concat $ [ + [ bench ("cvc5-" <> show i) $ nfIO $ findPanics CVC5 i iters c' + , bench ("z3-" <> show i) $ nfIO $ findPanics Z3 i iters c' + ] + | i <- counts + ] + +main :: IO () +main = defaultMain + [ mkbench erc20 "erc20" Nothing [1, 2, 4, 8, 16] + , mkbench (pure vat) "vat" Nothing [4] + , mkbench (pure deposit) "deposit" (Just 32) [4] + , mkbench (pure uniV2Pair) "uniV2" (Just 10) [4] + ] + + +--- Helpers ---------------------------------------------------------------------------------------- + + +debugContract :: ByteString -> IO () +debugContract c = withSolvers CVC5 4 Nothing $ \solvers -> do + let prestate = abstractVM Nothing [] c Nothing SymbolicS + void $ TTY.runFromVM solvers Nothing Nothing emptyDapp prestate + + +--- Bytecodes -------------------------------------------------------------------------------------- + + +erc20 :: IO ByteString +erc20 = do + source <- readFile =<< Paths.getDataFileName "bench/contracts/erc20.sol" + Just c <- solcRuntime "ERC20" (T.pack source) + pure c + +-- requires solc-0.6.12 to build from source +vat :: ByteString +vat = hexByteString "vat" "608060405234801561001057600080fd5b50600436106101c45760003560e01c80637cdd3fde116100f9578063bb35783b11610097578063dc4d20fa11610071578063dc4d20fa1461096c578063f059212a146109b0578063f24e23eb14610a08578063f37ac61c14610a76576101c4565b8063bb35783b14610848578063bf353dbb146108b6578063d9638d361461090e576101c4565b80639c52a7f1116100d35780639c52a7f11461074a578063a3b22fc41461078e578063b65337df146107d2578063babe8a3f1461082a576101c4565b80637cdd3fde14610652578063870c616d146106aa578063957aa58c1461072c576101c4565b80634538c4eb11610166578063692450091161014057806369245009146104ac5780636c25b346146104b6578063760887031461050e5780637bab3f40146105b0576101c4565b80634538c4eb146103785780636111be2e146103f057806365fae35e14610468576101c4565b80632424be5c116101a25780632424be5c1461028b57806329ae8114146102f45780632d61a3551461032c5780633b6631951461034a576101c4565b80630dca59c1146101c95780631a0b287e146101e7578063214414d514610229575b600080fd5b6101d1610aa4565b6040518082815260200191505060405180910390f35b610227600480360360608110156101fd57600080fd5b81019080803590602001909291908035906020019092919080359060200190929190505050610aaa565b005b6102756004803603604081101561023f57600080fd5b8101908080359060200190929190803573ffffffffffffffffffffffffffffffffffffffff169060200190929190505050610d23565b6040518082815260200191505060405180910390f35b6102d7600480360360408110156102a157600080fd5b8101908080359060200190929190803573ffffffffffffffffffffffffffffffffffffffff169060200190929190505050610d48565b604051808381526020018281526020019250505060405180910390f35b61032a6004803603604081101561030a57600080fd5b810190808035906020019092919080359060200190929190505050610d79565b005b610334610f4b565b6040518082815260200191505060405180910390f35b6103766004803603602081101561036057600080fd5b8101908080359060200190929190505050610f51565b005b6103da6004803603604081101561038e57600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff1690602001909291905050506110bb565b6040518082815260200191505060405180910390f35b6104666004803603608081101561040657600080fd5b8101908080359060200190929190803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803590602001909291905050506110e0565b005b6104aa6004803603602081101561047e57600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff1690602001909291905050506112be565b005b6104b4611431565b005b6104f8600480360360208110156104cc57600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff1690602001909291905050506114ef565b6040518082815260200191505060405180910390f35b6105ae600480360360c081101561052457600080fd5b8101908080359060200190929190803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff1690602001909291908035906020019092919080359060200190929190505050611507565b005b610650600480360360c08110156105c657600080fd5b8101908080359060200190929190803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff1690602001909291908035906020019092919080359060200190929190505050611cbe565b005b6106a86004803603606081101561066857600080fd5b8101908080359060200190929190803573ffffffffffffffffffffffffffffffffffffffff16906020019092919080359060200190929190505050611f88565b005b61072a600480360360a08110156106c057600080fd5b8101908080359060200190929190803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff16906020019092919080359060200190929190803590602001909291905050506120ef565b005b6107346124ee565b6040518082815260200191505060405180910390f35b61078c6004803603602081101561076057600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff1690602001909291905050506124f4565b005b6107d0600480360360208110156107a457600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190505050612667565b005b610828600480360360608110156107e857600080fd5b8101908080359060200190929190803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803590602001909291905050506126eb565b005b6108326128fb565b6040518082815260200191505060405180910390f35b6108b46004803603606081101561085e57600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff16906020019092919080359060200190929190505050612901565b005b6108f8600480360360208110156108cc57600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190505050612a9a565b6040518082815260200191505060405180910390f35b61093a6004803603602081101561092457600080fd5b8101908080359060200190929190505050612ab2565b604051808681526020018581526020018481526020018381526020018281526020019550505050505060405180910390f35b6109ae6004803603602081101561098257600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190505050612ae8565b005b6109f2600480360360208110156109c657600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190505050612b6d565b6040518082815260200191505060405180910390f35b610a7460048036036060811015610a1e57600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff16906020019092919080359060200190929190505050612b85565b005b610aa260048036036020811015610a8c57600080fd5b8101908080359060200190929190505050612d7a565b005b60075481565b60016000803373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205414610b5e576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260128152602001807f5661742f6e6f742d617574686f72697a6564000000000000000000000000000081525060200191505060405180910390fd5b6001600a5414610bd6576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600c8152602001807f5661742f6e6f742d6c697665000000000000000000000000000000000000000081525060200191505060405180910390fd5b7f73706f7400000000000000000000000000000000000000000000000000000000821415610c1e57806002600085815260200190815260200160002060020181905550610d1e565b7f6c696e6500000000000000000000000000000000000000000000000000000000821415610c6657806002600085815260200190815260200160002060030181905550610d1d565b7f6475737400000000000000000000000000000000000000000000000000000000821415610cae57806002600085815260200190815260200160002060040181905550610d1c565b6040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252601b8152602001807f5661742f66696c652d756e7265636f676e697a65642d706172616d000000000081525060200191505060405180910390fd5b5b5b505050565b6004602052816000526040600020602052806000526040600020600091509150505481565b6003602052816000526040600020602052806000526040600020600091509150508060000154908060010154905082565b60016000803373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205414610e2d576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260128152602001807f5661742f6e6f742d617574686f72697a6564000000000000000000000000000081525060200191505060405180910390fd5b6001600a5414610ea5576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600c8152602001807f5661742f6e6f742d6c697665000000000000000000000000000000000000000081525060200191505060405180910390fd5b7f4c696e6500000000000000000000000000000000000000000000000000000000821415610ed95780600981905550610f47565b6040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252601b8152602001807f5661742f66696c652d756e7265636f676e697a65642d706172616d000000000081525060200191505060405180910390fd5b5050565b60085481565b60016000803373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205414611005576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260128152602001807f5661742f6e6f742d617574686f72697a6564000000000000000000000000000081525060200191505060405180910390fd5b6000600260008381526020019081526020016000206001015414611091576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260148152602001807f5661742f696c6b2d616c72656164792d696e697400000000000000000000000081525060200191505060405180910390fd5b6b033b2e3c9fd0803ce8000000600260008381526020019081526020016000206001018190555050565b6001602052816000526040600020602052806000526040600020600091509150505481565b6110ea8333612ebf565b61115c576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600f8152602001807f5661742f6e6f742d616c6c6f776564000000000000000000000000000000000081525060200191505060405180910390fd5b6111b66004600086815260200190815260200160002060008573ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205482612f7f565b6004600086815260200190815260200160002060008573ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020819055506112646004600086815260200190815260200160002060008473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205482612f99565b6004600086815260200190815260200160002060008473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000208190555050505050565b60016000803373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205414611372576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260128152602001807f5661742f6e6f742d617574686f72697a6564000000000000000000000000000081525060200191505060405180910390fd5b6001600a54146113ea576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600c8152602001807f5661742f6e6f742d6c697665000000000000000000000000000000000000000081525060200191505060405180910390fd5b60016000808373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000208190555050565b60016000803373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002054146114e5576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260128152602001807f5661742f6e6f742d617574686f72697a6564000000000000000000000000000081525060200191505060405180910390fd5b6000600a81905550565b60056020528060005260406000206000915090505481565b6001600a541461157f576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600c8152602001807f5661742f6e6f742d6c697665000000000000000000000000000000000000000081525060200191505060405180910390fd5b6115876130b2565b6003600088815260200190815260200160002060008773ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000206040518060400160405290816000820154815260200160018201548152505090506116006130cc565b600260008981526020019081526020016000206040518060a00160405290816000820154815260200160018201548152602001600282015481526020016003820154815260200160048201548152505090506000816020015114156116cd576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260108152602001807f5661742f696c6b2d6e6f742d696e69740000000000000000000000000000000081525060200191505060405180910390fd5b6116db826000015185612fb3565b8260000181815250506116f2826020015184612fb3565b826020018181525050611709816000015184612fb3565b8160000181815250506000611722826020015185612ff2565b905060006117388360200151856020015161302d565b905061174660075483612fb3565b600781905550611782600086131561177d856060015161176e8760000151886020015161302d565b11156009546007541115613059565b613066565b6117f4576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260148152602001807f5661742f6365696c696e672d657863656564656400000000000000000000000081525060200191505060405180910390fd5b61182361180960008713156000891215613059565b61181b8660000151866040015161302d565b831115613066565b611895576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600c8152602001807f5661742f6e6f742d73616665000000000000000000000000000000000000000081525060200191505060405180910390fd5b6118b96118aa60008713156000891215613059565b6118b48b33612ebf565b613066565b61192b576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260118152602001807f5661742f6e6f742d616c6c6f7765642d7500000000000000000000000000000081525060200191505060405180910390fd5b611942600087131561193d8a33612ebf565b613066565b6119b4576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260118152602001807f5661742f6e6f742d616c6c6f7765642d7600000000000000000000000000000081525060200191505060405180910390fd5b6119cb60008612156119c68933612ebf565b613066565b611a3d576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260118152602001807f5661742f6e6f742d616c6c6f7765642d7700000000000000000000000000000081525060200191505060405180910390fd5b611a5560008560200151148460800151831015613066565b611ac7576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260088152602001807f5661742f6475737400000000000000000000000000000000000000000000000081525060200191505060405180910390fd5b611b21600460008c815260200190815260200160002060008a73ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205487613073565b600460008c815260200190815260200160002060008a73ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002081905550611bbe600560008973ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205483612fb3565b600560008973ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000208190555083600360008c815260200190815260200160002060008b73ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020600082015181600001556020820151816001015590505082600260008c8152602001908152602001600020600082015181600001556020820151816001015560408201518160020155606082015181600301556080820151816004015590505050505050505050505050565b60016000803373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205414611d72576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260128152602001807f5661742f6e6f742d617574686f72697a6564000000000000000000000000000081525060200191505060405180910390fd5b60006003600088815260200190815260200160002060008773ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002090506000600260008981526020019081526020016000209050611deb826000015485612fb3565b8260000181905550611e01826001015484612fb3565b8260010181905550611e17816000015484612fb3565b81600001819055506000611e2f826001015485612ff2565b9050611e8b600460008b815260200190815260200160002060008973ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205486613073565b600460008b815260200190815260200160002060008973ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002081905550611f28600660008873ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205482613073565b600660008873ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002081905550611f7760085482613073565b600881905550505050505050505050565b60016000803373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020541461203c576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260128152602001807f5661742f6e6f742d617574686f72697a6564000000000000000000000000000081525060200191505060405180910390fd5b6120966004600085815260200190815260200160002060008473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205482612fb3565b6004600085815260200190815260200160002060008473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002081905550505050565b60006003600087815260200190815260200160002060008673ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020905060006003600088815260200190815260200160002060008673ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020905060006002600089815260200190815260200160002090506121bc836000015486613073565b83600001819055506121d2836001015485613073565b83600101819055506121e8826000015486612fb3565b82600001819055506121fe826001015485612fb3565b8260010181905550600061221a8460010154836001015461302d565b905060006122308460010154846001015461302d565b905061224e61223f8a33612ebf565b6122498a33612ebf565b613059565b6122c0576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600f8152602001807f5661742f6e6f742d616c6c6f776564000000000000000000000000000000000081525060200191505060405180910390fd5b6122d28560000154846002015461302d565b821115612347576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260108152602001807f5661742f6e6f742d736166652d7372630000000000000000000000000000000081525060200191505060405180910390fd5b6123598460000154846002015461302d565b8111156123ce576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260108152602001807f5661742f6e6f742d736166652d6473740000000000000000000000000000000081525060200191505060405180910390fd5b6123e683600401548310156000876001015414613066565b612458576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600c8152602001807f5661742f647573742d737263000000000000000000000000000000000000000081525060200191505060405180910390fd5b61247083600401548210156000866001015414613066565b6124e2576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600c8152602001807f5661742f647573742d647374000000000000000000000000000000000000000081525060200191505060405180910390fd5b50505050505050505050565b600a5481565b60016000803373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002054146125a8576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260128152602001807f5661742f6e6f742d617574686f72697a6564000000000000000000000000000081525060200191505060405180910390fd5b6001600a5414612620576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600c8152602001807f5661742f6e6f742d6c697665000000000000000000000000000000000000000081525060200191505060405180910390fd5b60008060008373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000208190555050565b60018060003373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002060008373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000208190555050565b60016000803373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020541461279f576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260128152602001807f5661742f6e6f742d617574686f72697a6564000000000000000000000000000081525060200191505060405180910390fd5b6001600a5414612817576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600c8152602001807f5661742f6e6f742d6c697665000000000000000000000000000000000000000081525060200191505060405180910390fd5b600060026000858152602001908152602001600020905061283c816001015483612fb3565b81600101819055506000612854826000015484612ff2565b905061289f600560008673ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205482612fb3565b600560008673ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020819055506128ee60075482612fb3565b6007819055505050505050565b60095481565b61290b8333612ebf565b61297d576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600f8152602001807f5661742f6e6f742d616c6c6f776564000000000000000000000000000000000081525060200191505060405180910390fd5b6129c6600560008573ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205482612f7f565b600560008573ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002081905550612a52600560008473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205482612f99565b600560008473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002081905550505050565b60006020528060005260406000206000915090505481565b60026020528060005260406000206000915090508060000154908060010154908060020154908060030154908060040154905085565b6000600160003373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002060008373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000208190555050565b60066020528060005260406000206000915090505481565b60016000803373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205414612c39576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260128152602001807f5661742f6e6f742d617574686f72697a6564000000000000000000000000000081525060200191505060405180910390fd5b612c82600660008573ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205482612f99565b600660008573ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002081905550612d0e600560008473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205482612f99565b600560008473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002081905550612d5d60085482612f99565b600881905550612d6f60075482612f99565b600781905550505050565b6000339050612dc8600660008373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205483612f7f565b600660008373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002081905550612e54600560008373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205483612f7f565b600560008373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002081905550612ea360085483612f7f565b600881905550612eb560075483612f7f565b6007819055505050565b6000612f778273ffffffffffffffffffffffffffffffffffffffff168473ffffffffffffffffffffffffffffffffffffffff161460018060008773ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002060008673ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205414613066565b905092915050565b6000828284039150811115612f9357600080fd5b92915050565b6000828284019150811015612fad57600080fd5b92915050565b60008183019050600082121580612fca5750828111155b612fd357600080fd5b600082131580612fe35750828110155b612fec57600080fd5b92915050565b60008183029050600083121561300757600080fd5b600082148061301e57508282828161301b57fe5b05145b61302757600080fd5b92915050565b60008082148061304a575082828385029250828161304757fe5b04145b61305357600080fd5b92915050565b6000818316905092915050565b6000818317905092915050565b6000818303905060008213158061308a5750828111155b61309357600080fd5b6000821215806130a35750828110155b6130ac57600080fd5b92915050565b604051806040016040528060008152602001600081525090565b6040518060a001604052806000815260200160008152602001600081526020016000815260200160008152509056fea2646970667358221220a6981c73e66c77a4325e4426a14f7d3876fbe831438d34792d1fdac37b02a51d64736f6c634300060c0033" + +-- requires solc-0.6.13 to build +deposit :: ByteString +deposit = hexByteString "deposit" "60806040526004361061003f5760003560e01c806301ffc9a71461004457806322895118146100b6578063621fd130146101e3578063c5f2892f14610273575b600080fd5b34801561005057600080fd5b5061009c6004803603602081101561006757600080fd5b8101908080357bffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916906020019092919050505061029e565b604051808215151515815260200191505060405180910390f35b6101e1600480360360808110156100cc57600080fd5b81019080803590602001906401000000008111156100e957600080fd5b8201836020820111156100fb57600080fd5b8035906020019184600183028401116401000000008311171561011d57600080fd5b90919293919293908035906020019064010000000081111561013e57600080fd5b82018360208201111561015057600080fd5b8035906020019184600183028401116401000000008311171561017257600080fd5b90919293919293908035906020019064010000000081111561019357600080fd5b8201836020820111156101a557600080fd5b803590602001918460018302840111640100000000831117156101c757600080fd5b909192939192939080359060200190929190505050610370565b005b3480156101ef57600080fd5b506101f8610fd0565b6040518080602001828103825283818151815260200191508051906020019080838360005b8381101561023857808201518184015260208101905061021d565b50505050905090810190601f1680156102655780820380516001836020036101000a031916815260200191505b509250505060405180910390f35b34801561027f57600080fd5b50610288610fe2565b6040518082815260200191505060405180910390f35b60007f01ffc9a7000000000000000000000000000000000000000000000000000000007bffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916827bffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916148061036957507f85640907000000000000000000000000000000000000000000000000000000007bffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916827bffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916145b9050919050565b603087879050146103cc576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260268152602001806116ec6026913960400191505060405180910390fd5b60208585905014610428576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260368152602001806116836036913960400191505060405180910390fd5b60608383905014610484576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252602981526020018061175f6029913960400191505060405180910390fd5b670de0b6b3a76400003410156104e5576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260268152602001806117396026913960400191505060405180910390fd5b6000633b9aca0034816104f457fe5b061461054b576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260338152602001806116b96033913960400191505060405180910390fd5b6000633b9aca00348161055a57fe5b04905067ffffffffffffffff80168111156105c0576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260278152602001806117126027913960400191505060405180910390fd5b60606105cb82611314565b90507f649bbc62d0e31342afea4e5cd82d4049e7e1ee912fc0889aa790803be39038c589898989858a8a610600602054611314565b60405180806020018060200180602001806020018060200186810386528e8e82818152602001925080828437600081840152601f19601f82011690508083019250505086810385528c8c82818152602001925080828437600081840152601f19601f82011690508083019250505086810384528a818151815260200191508051906020019080838360005b838110156106a657808201518184015260208101905061068b565b50505050905090810190601f1680156106d35780820380516001836020036101000a031916815260200191505b508681038352898982818152602001925080828437600081840152601f19601f820116905080830192505050868103825287818151815260200191508051906020019080838360005b8381101561073757808201518184015260208101905061071c565b50505050905090810190601f1680156107645780820380516001836020036101000a031916815260200191505b509d505050505050505050505050505060405180910390a1600060028a8a600060801b6040516020018084848082843780830192505050826fffffffffffffffffffffffffffffffff19166fffffffffffffffffffffffffffffffff1916815260100193505050506040516020818303038152906040526040518082805190602001908083835b6020831061080e57805182526020820191506020810190506020830392506107eb565b6001836020036101000a038019825116818451168082178552505050505050905001915050602060405180830381855afa158015610850573d6000803e3d6000fd5b5050506040513d602081101561086557600080fd5b8101908080519060200190929190505050905060006002808888600090604092610891939291906115da565b6040516020018083838082843780830192505050925050506040516020818303038152906040526040518082805190602001908083835b602083106108eb57805182526020820191506020810190506020830392506108c8565b6001836020036101000a038019825116818451168082178552505050505050905001915050602060405180830381855afa15801561092d573d6000803e3d6000fd5b5050506040513d602081101561094257600080fd5b8101908080519060200190929190505050600289896040908092610968939291906115da565b6000801b604051602001808484808284378083019250505082815260200193505050506040516020818303038152906040526040518082805190602001908083835b602083106109cd57805182526020820191506020810190506020830392506109aa565b6001836020036101000a038019825116818451168082178552505050505050905001915050602060405180830381855afa158015610a0f573d6000803e3d6000fd5b5050506040513d6020811015610a2457600080fd5b810190808051906020019092919050505060405160200180838152602001828152602001925050506040516020818303038152906040526040518082805190602001908083835b60208310610a8e5780518252602082019150602081019050602083039250610a6b565b6001836020036101000a038019825116818451168082178552505050505050905001915050602060405180830381855afa158015610ad0573d6000803e3d6000fd5b5050506040513d6020811015610ae557600080fd5b810190808051906020019092919050505090506000600280848c8c604051602001808481526020018383808284378083019250505093505050506040516020818303038152906040526040518082805190602001908083835b60208310610b615780518252602082019150602081019050602083039250610b3e565b6001836020036101000a038019825116818451168082178552505050505050905001915050602060405180830381855afa158015610ba3573d6000803e3d6000fd5b5050506040513d6020811015610bb857600080fd5b8101908080519060200190929190505050600286600060401b866040516020018084805190602001908083835b60208310610c085780518252602082019150602081019050602083039250610be5565b6001836020036101000a0380198251168184511680821785525050505050509050018367ffffffffffffffff191667ffffffffffffffff1916815260180182815260200193505050506040516020818303038152906040526040518082805190602001908083835b60208310610c935780518252602082019150602081019050602083039250610c70565b6001836020036101000a038019825116818451168082178552505050505050905001915050602060405180830381855afa158015610cd5573d6000803e3d6000fd5b5050506040513d6020811015610cea57600080fd5b810190808051906020019092919050505060405160200180838152602001828152602001925050506040516020818303038152906040526040518082805190602001908083835b60208310610d545780518252602082019150602081019050602083039250610d31565b6001836020036101000a038019825116818451168082178552505050505050905001915050602060405180830381855afa158015610d96573d6000803e3d6000fd5b5050506040513d6020811015610dab57600080fd5b81019080805190602001909291905050509050858114610e16576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252605481526020018061162f6054913960600191505060405180910390fd5b6001602060020a0360205410610e77576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252602181526020018061160e6021913960400191505060405180910390fd5b60016020600082825401925050819055506000602054905060008090505b6020811015610fb75760018083161415610ec8578260008260208110610eb757fe5b018190555050505050505050610fc7565b600260008260208110610ed757fe5b01548460405160200180838152602001828152602001925050506040516020818303038152906040526040518082805190602001908083835b60208310610f335780518252602082019150602081019050602083039250610f10565b6001836020036101000a038019825116818451168082178552505050505050905001915050602060405180830381855afa158015610f75573d6000803e3d6000fd5b5050506040513d6020811015610f8a57600080fd5b8101908080519060200190929190505050925060028281610fa757fe5b0491508080600101915050610e95565b506000610fc057fe5b5050505050505b50505050505050565b6060610fdd602054611314565b905090565b6000806000602054905060008090505b60208110156111d057600180831614156110e05760026000826020811061101557fe5b01548460405160200180838152602001828152602001925050506040516020818303038152906040526040518082805190602001908083835b60208310611071578051825260208201915060208101905060208303925061104e565b6001836020036101000a038019825116818451168082178552505050505050905001915050602060405180830381855afa1580156110b3573d6000803e3d6000fd5b5050506040513d60208110156110c857600080fd5b810190808051906020019092919050505092506111b6565b600283602183602081106110f057fe5b015460405160200180838152602001828152602001925050506040516020818303038152906040526040518082805190602001908083835b6020831061114b5780518252602082019150602081019050602083039250611128565b6001836020036101000a038019825116818451168082178552505050505050905001915050602060405180830381855afa15801561118d573d6000803e3d6000fd5b5050506040513d60208110156111a257600080fd5b810190808051906020019092919050505092505b600282816111c057fe5b0491508080600101915050610ff2565b506002826111df602054611314565b600060401b6040516020018084815260200183805190602001908083835b6020831061122057805182526020820191506020810190506020830392506111fd565b6001836020036101000a0380198251168184511680821785525050505050509050018267ffffffffffffffff191667ffffffffffffffff1916815260180193505050506040516020818303038152906040526040518082805190602001908083835b602083106112a55780518252602082019150602081019050602083039250611282565b6001836020036101000a038019825116818451168082178552505050505050905001915050602060405180830381855afa1580156112e7573d6000803e3d6000fd5b5050506040513d60208110156112fc57600080fd5b81019080805190602001909291905050509250505090565b6060600867ffffffffffffffff8111801561132e57600080fd5b506040519080825280601f01601f1916602001820160405280156113615781602001600182028036833780820191505090505b50905060008260c01b90508060076008811061137957fe5b1a60f81b8260008151811061138a57fe5b60200101907effffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916908160001a905350806006600881106113c657fe5b1a60f81b826001815181106113d757fe5b60200101907effffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916908160001a9053508060056008811061141357fe5b1a60f81b8260028151811061142457fe5b60200101907effffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916908160001a9053508060046008811061146057fe5b1a60f81b8260038151811061147157fe5b60200101907effffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916908160001a905350806003600881106114ad57fe5b1a60f81b826004815181106114be57fe5b60200101907effffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916908160001a905350806002600881106114fa57fe5b1a60f81b8260058151811061150b57fe5b60200101907effffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916908160001a9053508060016008811061154757fe5b1a60f81b8260068151811061155857fe5b60200101907effffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916908160001a9053508060006008811061159457fe5b1a60f81b826007815181106115a557fe5b60200101907effffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff1916908160001a90535050919050565b600080858511156115ea57600080fd5b838611156115f757600080fd5b600185028301915084860390509450949250505056fe4465706f736974436f6e74726163743a206d65726b6c6520747265652066756c6c4465706f736974436f6e74726163743a207265636f6e7374727563746564204465706f7369744461746120646f6573206e6f74206d6174636820737570706c696564206465706f7369745f646174615f726f6f744465706f736974436f6e74726163743a20696e76616c6964207769746864726177616c5f63726564656e7469616c73206c656e6774684465706f736974436f6e74726163743a206465706f7369742076616c7565206e6f74206d756c7469706c65206f6620677765694465706f736974436f6e74726163743a20696e76616c6964207075626b6579206c656e6774684465706f736974436f6e74726163743a206465706f7369742076616c756520746f6f20686967684465706f736974436f6e74726163743a206465706f7369742076616c756520746f6f206c6f774465706f736974436f6e74726163743a20696e76616c6964207369676e6174757265206c656e677468a2646970667358221220e859959599195b69dd53a5a8e7d6218056606794a75a0aadd9fecf8dc64eae7064736f6c634300060b0033" + +-- requires waffle to be installed to build +uniV2Pair :: ByteString +uniV2Pair = hexByteString "uniV2" "608060405234801561001057600080fd5b50600436106101a95760003560e01c80636a627842116100f9578063ba9a7a5611610097578063d21220a711610071578063d21220a7146108c4578063d505accf1461090e578063dd62ed3e146109a7578063fff6cae914610a1f576101a9565b8063ba9a7a5614610818578063bc25cf7714610836578063c45a01551461087a576101a9565b80637ecebe00116100d35780637ecebe001461067857806389afcb44146106d057806395d89b411461072f578063a9059cbb146107b2576101a9565b80636a627842146105aa57806370a08231146106025780637464fc3d1461065a576101a9565b806323b872dd116101665780633644e515116101405780633644e515146104ec578063485cc9551461050a5780635909c0d51461056e5780635a3d54931461058c576101a9565b806323b872dd1461042457806330adf81f146104aa578063313ce567146104c8576101a9565b8063022c0d9f146101ae57806306fdde031461025b5780630902f1ac146102de578063095ea7b3146103565780630dfe1681146103bc57806318160ddd14610406575b600080fd5b610259600480360360808110156101c457600080fd5b810190808035906020019092919080359060200190929190803573ffffffffffffffffffffffffffffffffffffffff1690602001909291908035906020019064010000000081111561021557600080fd5b82018360208201111561022757600080fd5b8035906020019184600183028401116401000000008311171561024957600080fd5b9091929391929390505050610a29565b005b610263611216565b6040518080602001828103825283818151815260200191508051906020019080838360005b838110156102a3578082015181840152602081019050610288565b50505050905090810190601f1680156102d05780820380516001836020036101000a031916815260200191505b509250505060405180910390f35b6102e661124f565b60405180846dffffffffffffffffffffffffffff166dffffffffffffffffffffffffffff168152602001836dffffffffffffffffffffffffffff166dffffffffffffffffffffffffffff1681526020018263ffffffff1663ffffffff168152602001935050505060405180910390f35b6103a26004803603604081101561036c57600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803590602001909291905050506112ac565b604051808215151515815260200191505060405180910390f35b6103c46112c3565b604051808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060405180910390f35b61040e6112e9565b6040518082815260200191505060405180910390f35b6104906004803603606081101561043a57600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803590602001909291905050506112ef565b604051808215151515815260200191505060405180910390f35b6104b26114ba565b6040518082815260200191505060405180910390f35b6104d06114e1565b604051808260ff1660ff16815260200191505060405180910390f35b6104f46114e6565b6040518082815260200191505060405180910390f35b61056c6004803603604081101561052057600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff1690602001909291905050506114ec565b005b610576611635565b6040518082815260200191505060405180910390f35b61059461163b565b6040518082815260200191505060405180910390f35b6105ec600480360360208110156105c057600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190505050611641565b6040518082815260200191505060405180910390f35b6106446004803603602081101561061857600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190505050611af2565b6040518082815260200191505060405180910390f35b610662611b0a565b6040518082815260200191505060405180910390f35b6106ba6004803603602081101561068e57600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190505050611b10565b6040518082815260200191505060405180910390f35b610712600480360360208110156106e657600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190505050611b28565b604051808381526020018281526020019250505060405180910390f35b610737612115565b6040518080602001828103825283818151815260200191508051906020019080838360005b8381101561077757808201518184015260208101905061075c565b50505050905090810190601f1680156107a45780820380516001836020036101000a031916815260200191505b509250505060405180910390f35b6107fe600480360360408110156107c857600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff1690602001909291908035906020019092919050505061214e565b604051808215151515815260200191505060405180910390f35b610820612165565b6040518082815260200191505060405180910390f35b6108786004803603602081101561084c57600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff16906020019092919050505061216b565b005b610882612446565b604051808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060405180910390f35b6108cc61246c565b604051808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060405180910390f35b6109a5600480360360e081101561092457600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff1690602001909291908035906020019092919080359060200190929190803560ff1690602001909291908035906020019092919080359060200190929190505050612492565b005b610a09600480360360408110156109bd57600080fd5b81019080803573ffffffffffffffffffffffffffffffffffffffff169060200190929190803573ffffffffffffffffffffffffffffffffffffffff1690602001909291905050506127d6565b6040518082815260200191505060405180910390f35b610a276127fb565b005b6001600c5414610aa1576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260118152602001807f556e697377617056323a204c4f434b454400000000000000000000000000000081525060200191505060405180910390fd5b6000600c819055506000851180610ab85750600084115b610b0d576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252602581526020018061397c6025913960400191505060405180910390fd5b600080610b1861124f565b5091509150816dffffffffffffffffffffffffffff1687108015610b4b5750806dffffffffffffffffffffffffffff1686105b610ba0576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260218152602001806139c56021913960400191505060405180910390fd5b6000806000600660009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1690506000600760009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1690508173ffffffffffffffffffffffffffffffffffffffff168973ffffffffffffffffffffffffffffffffffffffff1614158015610c5957508073ffffffffffffffffffffffffffffffffffffffff168973ffffffffffffffffffffffffffffffffffffffff1614155b610ccb576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260158152602001807f556e697377617056323a20494e56414c49445f544f000000000000000000000081525060200191505060405180910390fd5b60008b1115610ce057610cdf828a8d612a7b565b5b60008a1115610cf557610cf4818a8c612a7b565b5b6000888890501115610ddd578873ffffffffffffffffffffffffffffffffffffffff166310d1e85c338d8d8c8c6040518663ffffffff1660e01b8152600401808673ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001858152602001848152602001806020018281038252848482818152602001925080828437600081840152601f19601f8201169050808301925050509650505050505050600060405180830381600087803b158015610dc457600080fd5b505af1158015610dd8573d6000803e3d6000fd5b505050505b8173ffffffffffffffffffffffffffffffffffffffff166370a08231306040518263ffffffff1660e01b8152600401808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060206040518083038186803b158015610e5a57600080fd5b505afa158015610e6e573d6000803e3d6000fd5b505050506040513d6020811015610e8457600080fd5b810190808051906020019092919050505093508073ffffffffffffffffffffffffffffffffffffffff166370a08231306040518263ffffffff1660e01b8152600401808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060206040518083038186803b158015610f1457600080fd5b505afa158015610f28573d6000803e3d6000fd5b505050506040513d6020811015610f3e57600080fd5b810190808051906020019092919050505092505050600089856dffffffffffffffffffffffffffff16038311610f75576000610f8b565b89856dffffffffffffffffffffffffffff160383035b9050600089856dffffffffffffffffffffffffffff16038311610faf576000610fc5565b89856dffffffffffffffffffffffffffff160383035b90506000821180610fd65750600081115b61102b576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260248152602001806139a16024913960400191505060405180910390fd5b6000611067611044600385612cc890919063ffffffff16565b6110596103e888612cc890919063ffffffff16565b612d5d90919063ffffffff16565b905060006110a5611082600385612cc890919063ffffffff16565b6110976103e888612cc890919063ffffffff16565b612d5d90919063ffffffff16565b90506110ef620f42406110e1896dffffffffffffffffffffffffffff168b6dffffffffffffffffffffffffffff16612cc890919063ffffffff16565b612cc890919063ffffffff16565b6111028284612cc890919063ffffffff16565b1015611176576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252600c8152602001807f556e697377617056323a204b000000000000000000000000000000000000000081525060200191505060405180910390fd5b505061118484848888612de0565b8873ffffffffffffffffffffffffffffffffffffffff163373ffffffffffffffffffffffffffffffffffffffff167fd78ad95fa46c994b6551d0da85fc275fe613ce37657fb8d5e3d130840159d82284848f8f6040518085815260200184815260200183815260200182815260200194505050505060405180910390a35050505050506001600c819055505050505050565b6040518060400160405280600a81526020017f556e69737761702056320000000000000000000000000000000000000000000081525081565b6000806000600860009054906101000a90046dffffffffffffffffffffffffffff1692506008600e9054906101000a90046dffffffffffffffffffffffffffff1691506008601c9054906101000a900463ffffffff169050909192565b60006112b933848461315e565b6001905092915050565b600660009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1681565b60005481565b60007fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff600260008673ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002060003373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002054146114a45761142382600260008773ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002060003373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002054612d5d90919063ffffffff16565b600260008673ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002060003373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020819055505b6114af848484613249565b600190509392505050565b7f6e71edae12b1b97f4d1f60370fef10105fa2faae0126114a169c64845d6126c960001b81565b601281565b60035481565b600560009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff163373ffffffffffffffffffffffffffffffffffffffff16146115af576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260148152602001807f556e697377617056323a20464f5242494444454e00000000000000000000000081525060200191505060405180910390fd5b81600660006101000a81548173ffffffffffffffffffffffffffffffffffffffff021916908373ffffffffffffffffffffffffffffffffffffffff16021790555080600760006101000a81548173ffffffffffffffffffffffffffffffffffffffff021916908373ffffffffffffffffffffffffffffffffffffffff1602179055505050565b60095481565b600a5481565b60006001600c54146116bb576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260118152602001807f556e697377617056323a204c4f434b454400000000000000000000000000000081525060200191505060405180910390fd5b6000600c819055506000806116ce61124f565b50915091506000600660009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff166370a08231306040518263ffffffff1660e01b8152600401808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060206040518083038186803b15801561177457600080fd5b505afa158015611788573d6000803e3d6000fd5b505050506040513d602081101561179e57600080fd5b810190808051906020019092919050505090506000600760009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff166370a08231306040518263ffffffff1660e01b8152600401808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060206040518083038186803b15801561185257600080fd5b505afa158015611866573d6000803e3d6000fd5b505050506040513d602081101561187c57600080fd5b8101908080519060200190929190505050905060006118b4856dffffffffffffffffffffffffffff1684612d5d90919063ffffffff16565b905060006118db856dffffffffffffffffffffffffffff1684612d5d90919063ffffffff16565b905060006118e987876133dd565b9050600080549050600081141561193d576119296103e861191b6119168688612cc890919063ffffffff16565b6135be565b612d5d90919063ffffffff16565b985061193860006103e8613620565b6119a0565b61199d886dffffffffffffffffffffffffffff166119648387612cc890919063ffffffff16565b8161196b57fe5b04886dffffffffffffffffffffffffffff166119908487612cc890919063ffffffff16565b8161199757fe5b0461373a565b98505b600089116119f9576040517f08c379a0000000000000000000000000000000000000000000000000000000008152600401808060200182810382526028815260200180613a0e6028913960400191505060405180910390fd5b611a038a8a613620565b611a0f86868a8a612de0565b8115611a8757611a806008600e9054906101000a90046dffffffffffffffffffffffffffff166dffffffffffffffffffffffffffff16600860009054906101000a90046dffffffffffffffffffffffffffff166dffffffffffffffffffffffffffff16612cc890919063ffffffff16565b600b819055505b3373ffffffffffffffffffffffffffffffffffffffff167f4c209b5fc8ad50758f13e2e1088ba56a560dff690a1c6fef26394f4c03821c4f8585604051808381526020018281526020019250505060405180910390a250505050505050506001600c81905550919050565b60016020528060005260406000206000915090505481565b600b5481565b60046020528060005260406000206000915090505481565b6000806001600c5414611ba3576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260118152602001807f556e697377617056323a204c4f434b454400000000000000000000000000000081525060200191505060405180910390fd5b6000600c81905550600080611bb661124f565b50915091506000600660009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1690506000600760009054906101000a900473ffffffffffffffffffffffffffffffffffffffff16905060008273ffffffffffffffffffffffffffffffffffffffff166370a08231306040518263ffffffff1660e01b8152600401808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060206040518083038186803b158015611c8857600080fd5b505afa158015611c9c573d6000803e3d6000fd5b505050506040513d6020811015611cb257600080fd5b8101908080519060200190929190505050905060008273ffffffffffffffffffffffffffffffffffffffff166370a08231306040518263ffffffff1660e01b8152600401808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060206040518083038186803b158015611d4457600080fd5b505afa158015611d58573d6000803e3d6000fd5b505050506040513d6020811015611d6e57600080fd5b810190808051906020019092919050505090506000600160003073ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000205490506000611dd188886133dd565b905060008054905080611ded8685612cc890919063ffffffff16565b81611df457fe5b049a5080611e0b8585612cc890919063ffffffff16565b81611e1257fe5b04995060008b118015611e25575060008a115b611e7a576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260288152602001806139e66028913960400191505060405180910390fd5b611e843084613753565b611e8f878d8d612a7b565b611e9a868d8c612a7b565b8673ffffffffffffffffffffffffffffffffffffffff166370a08231306040518263ffffffff1660e01b8152600401808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060206040518083038186803b158015611f1757600080fd5b505afa158015611f2b573d6000803e3d6000fd5b505050506040513d6020811015611f4157600080fd5b810190808051906020019092919050505094508573ffffffffffffffffffffffffffffffffffffffff166370a08231306040518263ffffffff1660e01b8152600401808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060206040518083038186803b158015611fd157600080fd5b505afa158015611fe5573d6000803e3d6000fd5b505050506040513d6020811015611ffb57600080fd5b8101908080519060200190929190505050935061201a85858b8b612de0565b81156120925761208b6008600e9054906101000a90046dffffffffffffffffffffffffffff166dffffffffffffffffffffffffffff16600860009054906101000a90046dffffffffffffffffffffffffffff166dffffffffffffffffffffffffffff16612cc890919063ffffffff16565b600b819055505b8b73ffffffffffffffffffffffffffffffffffffffff163373ffffffffffffffffffffffffffffffffffffffff167fdccd412f0b1252819cb1fd330b93224ca42612892bb3f4f789976e6d819364968d8d604051808381526020018281526020019250505060405180910390a35050505050505050506001600c81905550915091565b6040518060400160405280600681526020017f554e492d5632000000000000000000000000000000000000000000000000000081525081565b600061215b338484613249565b6001905092915050565b6103e881565b6001600c54146121e3576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260118152602001807f556e697377617056323a204c4f434b454400000000000000000000000000000081525060200191505060405180910390fd5b6000600c819055506000600660009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1690506000600760009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1690506123398284612334600860009054906101000a90046dffffffffffffffffffffffffffff166dffffffffffffffffffffffffffff168673ffffffffffffffffffffffffffffffffffffffff166370a08231306040518263ffffffff1660e01b8152600401808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060206040518083038186803b1580156122eb57600080fd5b505afa1580156122ff573d6000803e3d6000fd5b505050506040513d602081101561231557600080fd5b8101908080519060200190929190505050612d5d90919063ffffffff16565b612a7b565b61243981846124346008600e9054906101000a90046dffffffffffffffffffffffffffff166dffffffffffffffffffffffffffff168573ffffffffffffffffffffffffffffffffffffffff166370a08231306040518263ffffffff1660e01b8152600401808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060206040518083038186803b1580156123eb57600080fd5b505afa1580156123ff573d6000803e3d6000fd5b505050506040513d602081101561241557600080fd5b8101908080519060200190929190505050612d5d90919063ffffffff16565b612a7b565b50506001600c8190555050565b600560009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1681565b600760009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1681565b42841015612508576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260128152602001807f556e697377617056323a2045585049524544000000000000000000000000000081525060200191505060405180910390fd5b60006003547f6e71edae12b1b97f4d1f60370fef10105fa2faae0126114a169c64845d6126c960001b898989600460008e73ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000206000815480929190600101919050558a604051602001808781526020018673ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020018573ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200184815260200183815260200182815260200196505050505050506040516020818303038152906040528051906020012060405160200180807f190100000000000000000000000000000000000000000000000000000000000081525060020183815260200182815260200192505050604051602081830303815290604052805190602001209050600060018286868660405160008152602001604052604051808581526020018460ff1660ff1681526020018381526020018281526020019450505050506020604051602081039080840390855afa1580156126da573d6000803e3d6000fd5b505050602060405103519050600073ffffffffffffffffffffffffffffffffffffffff168173ffffffffffffffffffffffffffffffffffffffff161415801561274e57508873ffffffffffffffffffffffffffffffffffffffff168173ffffffffffffffffffffffffffffffffffffffff16145b6127c0576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252601c8152602001807f556e697377617056323a20494e56414c49445f5349474e41545552450000000081525060200191505060405180910390fd5b6127cb89898961315e565b505050505050505050565b6002602052816000526040600020602052806000526040600020600091509150505481565b6001600c5414612873576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260118152602001807f556e697377617056323a204c4f434b454400000000000000000000000000000081525060200191505060405180910390fd5b6000600c81905550612a71600660009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff166370a08231306040518263ffffffff1660e01b8152600401808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060206040518083038186803b15801561291d57600080fd5b505afa158015612931573d6000803e3d6000fd5b505050506040513d602081101561294757600080fd5b8101908080519060200190929190505050600760009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff166370a08231306040518263ffffffff1660e01b8152600401808273ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200191505060206040518083038186803b1580156129f757600080fd5b505afa158015612a0b573d6000803e3d6000fd5b505050506040513d6020811015612a2157600080fd5b8101908080519060200190929190505050600860009054906101000a90046dffffffffffffffffffffffffffff166008600e9054906101000a90046dffffffffffffffffffffffffffff16612de0565b6001600c81905550565b600060608473ffffffffffffffffffffffffffffffffffffffff166040518060400160405280601981526020017f7472616e7366657228616464726573732c75696e743235362900000000000000815250805190602001208585604051602401808373ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200182815260200192505050604051602081830303815290604052907bffffffffffffffffffffffffffffffffffffffffffffffffffffffff19166020820180517bffffffffffffffffffffffffffffffffffffffffffffffffffffffff83818316178352505050506040518082805190602001908083835b60208310612ba85780518252602082019150602081019050602083039250612b85565b6001836020036101000a0380198251168184511680821785525050505050509050019150506000604051808303816000865af19150503d8060008114612c0a576040519150601f19603f3d011682016040523d82523d6000602084013e612c0f565b606091505b5091509150818015612c4f5750600081511480612c4e5750808060200190516020811015612c3c57600080fd5b81019080805190602001909291905050505b5b612cc1576040517f08c379a000000000000000000000000000000000000000000000000000000000815260040180806020018281038252601a8152602001807f556e697377617056323a205452414e534645525f4641494c454400000000000081525060200191505060405180910390fd5b5050505050565b600080821480612ce55750828283850292508281612ce257fe5b04145b612d57576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260148152602001807f64732d6d6174682d6d756c2d6f766572666c6f7700000000000000000000000081525060200191505060405180910390fd5b92915050565b6000828284039150811115612dda576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260158152602001807f64732d6d6174682d7375622d756e646572666c6f77000000000000000000000081525060200191505060405180910390fd5b92915050565b7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff6dffffffffffffffffffffffffffff168411158015612e5057507fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff6dffffffffffffffffffffffffffff168311155b612ec2576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260138152602001807f556e697377617056323a204f564552464c4f570000000000000000000000000081525060200191505060405180910390fd5b60006401000000004281612ed257fe5b06905060006008601c9054906101000a900463ffffffff168203905060008163ffffffff16118015612f1557506000846dffffffffffffffffffffffffffff1614155b8015612f3257506000836dffffffffffffffffffffffffffff1614155b15613014578063ffffffff16612f7785612f4b8661386d565b7bffffffffffffffffffffffffffffffffffffffffffffffffffffffff1661389890919063ffffffff16565b7bffffffffffffffffffffffffffffffffffffffffffffffffffffffff16026009600082825401925050819055508063ffffffff16612fe584612fb98761386d565b7bffffffffffffffffffffffffffffffffffffffffffffffffffffffff1661389890919063ffffffff16565b7bffffffffffffffffffffffffffffffffffffffffffffffffffffffff1602600a600082825401925050819055505b85600860006101000a8154816dffffffffffffffffffffffffffff02191690836dffffffffffffffffffffffffffff160217905550846008600e6101000a8154816dffffffffffffffffffffffffffff02191690836dffffffffffffffffffffffffffff160217905550816008601c6101000a81548163ffffffff021916908363ffffffff1602179055507f1c411e9a96e071241c2f21f7726b17ae89e3cab4c78be50e062b03a9fffbbad1600860009054906101000a90046dffffffffffffffffffffffffffff166008600e9054906101000a90046dffffffffffffffffffffffffffff1660405180836dffffffffffffffffffffffffffff166dffffffffffffffffffffffffffff168152602001826dffffffffffffffffffffffffffff166dffffffffffffffffffffffffffff1681526020019250505060405180910390a1505050505050565b80600260008573ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002060008473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020819055508173ffffffffffffffffffffffffffffffffffffffff168373ffffffffffffffffffffffffffffffffffffffff167f8c5be1e5ebec7d5bd14f71427d1e84f3dd0314c0f7b2291e5b200ac8c7c3b925836040518082815260200191505060405180910390a3505050565b61329b81600160008673ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002054612d5d90919063ffffffff16565b600160008573ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1681526020019081526020016000208190555061333081600160008573ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020546138f890919063ffffffff16565b600160008473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020819055508173ffffffffffffffffffffffffffffffffffffffff168373ffffffffffffffffffffffffffffffffffffffff167fddf252ad1be2c89b69c2b068fc378daa952ba7f163c4a11628f55a4df523b3ef836040518082815260200191505060405180910390a3505050565b600080600560009054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663017e7e586040518163ffffffff1660e01b815260040160206040518083038186803b15801561344857600080fd5b505afa15801561345c573d6000803e3d6000fd5b505050506040513d602081101561347257600080fd5b81019080805190602001909291905050509050600073ffffffffffffffffffffffffffffffffffffffff168173ffffffffffffffffffffffffffffffffffffffff16141591506000600b54905082156135a4576000811461359f57600061350a613505866dffffffffffffffffffffffffffff16886dffffffffffffffffffffffffffff16612cc890919063ffffffff16565b6135be565b90506000613517836135be565b90508082111561359c57600061354a6135398385612d5d90919063ffffffff16565b600054612cc890919063ffffffff16565b9050600061357483613566600587612cc890919063ffffffff16565b6138f890919063ffffffff16565b9050600081838161358157fe5b0490506000811115613598576135978782613620565b5b5050505b50505b6135b6565b600081146135b5576000600b819055505b5b505092915050565b6000600382111561360d5781905060006001600284816135da57fe5b040190505b81811015613607578091506002818285816135f657fe5b0401816135ff57fe5b0490506135df565b5061361b565b6000821461361a57600190505b5b919050565b613635816000546138f890919063ffffffff16565b60008190555061368d81600160008573ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020546138f890919063ffffffff16565b600160008473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020819055508173ffffffffffffffffffffffffffffffffffffffff16600073ffffffffffffffffffffffffffffffffffffffff167fddf252ad1be2c89b69c2b068fc378daa952ba7f163c4a11628f55a4df523b3ef836040518082815260200191505060405180910390a35050565b6000818310613749578161374b565b825b905092915050565b6137a581600160008573ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff16815260200190815260200160002054612d5d90919063ffffffff16565b600160008473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff168152602001908152602001600020819055506137fd81600054612d5d90919063ffffffff16565b600081905550600073ffffffffffffffffffffffffffffffffffffffff168273ffffffffffffffffffffffffffffffffffffffff167fddf252ad1be2c89b69c2b068fc378daa952ba7f163c4a11628f55a4df523b3ef836040518082815260200191505060405180910390a35050565b60006e010000000000000000000000000000826dffffffffffffffffffffffffffff16029050919050565b6000816dffffffffffffffffffffffffffff167bffffffffffffffffffffffffffffffffffffffffffffffffffffffff16837bffffffffffffffffffffffffffffffffffffffffffffffffffffffff16816138ef57fe5b04905092915050565b6000828284019150811015613975576040517f08c379a00000000000000000000000000000000000000000000000000000000081526004018080602001828103825260148152602001807f64732d6d6174682d6164642d6f766572666c6f7700000000000000000000000081525060200191505060405180910390fd5b9291505056fe556e697377617056323a20494e53554646494349454e545f4f55545055545f414d4f554e54556e697377617056323a20494e53554646494349454e545f494e5055545f414d4f554e54556e697377617056323a20494e53554646494349454e545f4c4951554944495459556e697377617056323a20494e53554646494349454e545f4c49515549444954595f4255524e4544556e697377617056323a20494e53554646494349454e545f4c49515549444954595f4d494e544544a265627a7a723158201d9cc769ec1244e0335eb71f99a94869ae6ea3596ebb2c69f8185f53f440e2c664736f6c63430005100032" diff --git a/bench/contracts/erc20.sol b/bench/contracts/erc20.sol new file mode 100644 --- /dev/null +++ b/bench/contracts/erc20.sol @@ -0,0 +1,42 @@ +contract ERC20 { + // --- ERC20 Data --- + string public constant name = "TOKEN"; + string public constant symbol = "TKN"; + string public constant version = "1"; + uint8 public constant decimals = 18; + uint256 public totalSupply; + + mapping (address => uint) public balanceOf; + mapping (address => mapping (address => uint)) public allowance; + + event Approval(address indexed src, address indexed guy, uint wad); + event Transfer(address indexed src, address indexed dst, uint wad); + + constructor(uint supply) public { + balanceOf[msg.sender] = supply; + totalSupply = supply; + } + + // --- Token --- + function transfer(address dst, uint wad) external returns (bool) { + return transferFrom(msg.sender, dst, wad); + } + function transferFrom(address src, address dst, uint wad) + public returns (bool) + { + require(balanceOf[src] >= wad, "erc20/insufficient-balance"); + if (src != msg.sender && allowance[src][msg.sender] != type(uint).max) { + require(allowance[src][msg.sender] >= wad, "erc20/insufficient-allowance"); + allowance[src][msg.sender] -= wad; + } + balanceOf[src] -= wad; + balanceOf[dst] += wad; + emit Transfer(src, dst, wad); + return true; + } + function approve(address usr, uint wad) external returns (bool) { + allowance[msg.sender][usr] = wad; + emit Approval(msg.sender, usr, wad); + return true; + } +} diff --git a/hevm-cli/hevm-cli.hs b/hevm-cli/hevm-cli.hs --- a/hevm-cli/hevm-cli.hs +++ b/hevm-cli/hevm-cli.hs @@ -16,6 +16,7 @@ import EVM.Debug import qualified EVM.Expr as Expr import EVM.SMT +import EVM.Solvers import qualified EVM.TTY as TTY import EVM.Solidity import EVM.Expr (litAddr) @@ -187,8 +188,8 @@ optsMode :: Command Options.Unwrapped -> Mode optsMode x - | Main.debug x = Debug - | jsontrace x = JsonTrace + | x.debug = Debug + | x.jsontrace = JsonTrace | otherwise = Run applyCache :: (Maybe String, Maybe String) -> IO (EVM.VM -> EVM.VM) @@ -211,51 +212,51 @@ unitTestOptions :: Command Options.Unwrapped -> SolverGroup -> String -> IO UnitTestOptions unitTestOptions cmd solvers testFile = do - let root = fromMaybe "." (dappRoot cmd) + let root = fromMaybe "." cmd.dappRoot srcInfo <- readSolc testFile >>= \case Nothing -> error "Could not read .sol.json file" Just (contractMap, sourceCache) -> pure $ dappInfo root contractMap sourceCache - vmModifier <- applyCache (state cmd, cache cmd) + vmModifier <- applyCache (cmd.state, cmd.cache) - params <- getParametersFromEnvironmentVariables (rpc cmd) + params <- getParametersFromEnvironmentVariables cmd.rpc let - testn = testNumber params + testn = params.testNumber block' = if 0 == testn then EVM.Fetch.Latest else EVM.Fetch.BlockNumber testn pure EVM.UnitTest.UnitTestOptions - { EVM.UnitTest.solvers = solvers - , EVM.UnitTest.rpcInfo = case rpc cmd of + { solvers = solvers + , rpcInfo = case cmd.rpc of Just url -> Just (block', url) Nothing -> Nothing - , EVM.UnitTest.maxIter = maxIterations cmd - , EVM.UnitTest.askSmtIters = askSmtIterations cmd - , EVM.UnitTest.smtDebug = smtdebug cmd - , EVM.UnitTest.smtTimeout = smttimeout cmd - , EVM.UnitTest.solver = solver cmd - , EVM.UnitTest.covMatch = pack <$> covMatch cmd - , EVM.UnitTest.verbose = verbose cmd - , EVM.UnitTest.match = pack $ fromMaybe ".*" (match cmd) - , EVM.UnitTest.maxDepth = depth cmd - , EVM.UnitTest.fuzzRuns = fromMaybe 100 (fuzzRuns cmd) - , EVM.UnitTest.replay = do - arg' <- replay cmd + , maxIter = cmd.maxIterations + , askSmtIters = cmd.askSmtIterations + , smtDebug = cmd.smtdebug + , smtTimeout = cmd.smttimeout + , solver = cmd.solver + , covMatch = pack <$> cmd.covMatch + , verbose = cmd.verbose + , match = pack $ fromMaybe ".*" cmd.match + , maxDepth = cmd.depth + , fuzzRuns = fromMaybe 100 cmd.fuzzRuns + , replay = do + arg' <- cmd.replay return (fst arg', LazyByteString.fromStrict (hexByteString "--replay" $ strip0x $ snd arg')) - , EVM.UnitTest.vmModifier = vmModifier - , EVM.UnitTest.testParams = params - , EVM.UnitTest.dapp = srcInfo - , EVM.UnitTest.ffiAllowed = ffi cmd + , vmModifier = vmModifier + , testParams = params + , dapp = srcInfo + , ffiAllowed = cmd.ffi } main :: IO () main = do cmd <- Options.unwrapRecord "hevm -- Ethereum evaluator" let - root = fromMaybe "." (dappRoot cmd) + root = fromMaybe "." cmd.dappRoot case cmd of Version {} -> putStrLn (showVersion Paths.version) Symbolic {} -> withCurrentDirectory root $ assert cmd @@ -265,12 +266,12 @@ DappTest {} -> withCurrentDirectory root $ do cores <- num <$> getNumProcessors - withSolvers Z3 cores (smttimeout cmd) $ \solvers -> do - testFile <- findJsonFile (jsonFile cmd) + withSolvers Z3 cores cmd.smttimeout $ \solvers -> do + testFile <- findJsonFile cmd.jsonFile testOpts <- unitTestOptions cmd solvers testFile - case (coverage cmd, optsMode cmd) of + case (cmd.coverage, optsMode cmd) of (False, Run) -> do - res <- dappTest testOpts testFile (cache cmd) + res <- dappTest testOpts testFile cmd.cache unless res exitFailure (False, Debug) -> liftIO $ TTY.main testOpts root testFile (False, JsonTrace) -> error "json traces not implemented for dappTest" @@ -298,21 +299,21 @@ equivalence :: Command Options.Unwrapped -> IO () equivalence cmd = do - let bytecodeA = hexByteString "--code" . strip0x $ codeA cmd - bytecodeB = hexByteString "--code" . strip0x $ codeB cmd + let bytecodeA = hexByteString "--code" . strip0x $ cmd.codeA + bytecodeB = hexByteString "--code" . strip0x $ cmd.codeB veriOpts = VeriOpts { simp = True , debug = False - , maxIter = maxIterations cmd - , askSmtIters = askSmtIterations cmd + , maxIter = cmd.maxIterations + , askSmtIters = cmd.askSmtIterations , rpcInfo = Nothing } withSolvers Z3 3 Nothing $ \s -> do res <- equivalenceCheck s bytecodeA bytecodeB veriOpts Nothing - case containsA (Cex()) res of + case not (any isCex res) of False -> do putStrLn "No discrepancies found" - when (containsA (EVM.SymExec.Timeout()) res) $ do + when (any isTimeout res) $ do putStrLn "But timeout(s) occurred" exitFailure True -> do @@ -321,8 +322,8 @@ getSrcInfo :: Command Options.Unwrapped -> IO DappInfo getSrcInfo cmd = - let root = fromMaybe "." (dappRoot cmd) - in case (jsonFile cmd) of + let root = fromMaybe "." cmd.dappRoot + in case cmd.jsonFile of Nothing -> pure emptyDapp Just json -> readSolc json >>= \case @@ -339,10 +340,10 @@ -- If function signatures are known, they should always be given for best results. assert :: Command Options.Unwrapped -> IO () assert cmd = do - let block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) - rpcinfo = (,) block' <$> rpc cmd + let block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block + rpcinfo = (,) block' <$> cmd.rpc decipher = hexByteString "bytes" . strip0x - calldata' <- case (Main.calldata cmd, sig cmd) of + calldata' <- case (cmd.calldata, cmd.sig) of -- fully abstract calldata (Nothing, Nothing) -> pure ( AbstractBuf "txdata" @@ -350,7 +351,7 @@ -- 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 "txtdata") .< (Lit (2 ^ (64 :: Integer)))] + , [Expr.bufLength (AbstractBuf "txdata") .< (Lit (2 ^ (64 :: Integer)))] ) -- fully concrete calldata @@ -358,25 +359,25 @@ -- calldata according to given abi with possible specializations from the `arg` list (Nothing, Just sig') -> do method' <- functionAbi sig' - let typs = snd <$> view methodInputs method' - pure $ symCalldata (view methodSignature method') typs (arg cmd) mempty + let typs = snd <$> method'.inputs + pure $ symCalldata method'.methodSignature typs cmd.arg (AbstractBuf "txdata") _ -> error "incompatible options: calldata and abi" preState <- symvmFromCommand cmd calldata' - let errCodes = fromMaybe defaultPanicCodes (assertions cmd) + let errCodes = fromMaybe defaultPanicCodes cmd.assertions cores <- num <$> getNumProcessors - let solverCount = fromMaybe cores (numSolvers cmd) - withSolvers EVM.SMT.Z3 solverCount (smttimeout cmd) $ \solvers -> do - if Main.debug cmd then do + let solverCount = fromMaybe cores cmd.numSolvers + withSolvers EVM.Solvers.Z3 solverCount cmd.smttimeout $ \solvers -> do + if cmd.debug then do srcInfo <- getSrcInfo cmd void $ TTY.runFromVM solvers rpcinfo - (maxIterations cmd) + cmd.maxIterations srcInfo preState else do - let opts = VeriOpts { simp = True, debug = smtdebug cmd, maxIter = maxIterations cmd, askSmtIters = askSmtIterations cmd, rpcInfo = rpcinfo} + let opts = VeriOpts { simp = True, debug = cmd.smtdebug, maxIter = cmd.maxIterations, askSmtIters = cmd.askSmtIterations, rpcInfo = rpcinfo} (expr, res) <- verify solvers opts preState (Just $ checkAssertions errCodes) case res of [Qed _] -> putStrLn "\nQED: No reachable property violations discovered\n" @@ -396,16 +397,17 @@ , "" ] <> fmap (formatExpr) (getTimeouts cexs) T.putStrLn $ T.unlines (counterexamples <> unknowns) - when (showTree cmd) $ do + exitFailure + when cmd.showTree $ do putStrLn "=== Expression ===\n" T.putStrLn $ formatExpr expr putStrLn "" - when (showReachableTree cmd) $ do + when cmd.showReachableTree $ do reached <- reachable solvers expr putStrLn "=== Reachable Expression ===\n" T.putStrLn (formatExpr . snd $ reached) putStrLn "" - when (getModels cmd) $ do + when cmd.getModels $ do putStrLn $ "=== Models for " <> show (Expr.numBranches expr) <> " branches ===\n" ms <- produceModels solvers expr forM_ ms (showModel (fst calldata')) @@ -427,13 +429,13 @@ readSolc solcFile >>= \case Just (contractMap, sourceCache) -> do - let unitTests = findUnitTests (EVM.UnitTest.match opts) $ Map.elems contractMap + let unitTests = findUnitTests opts.match $ Map.elems contractMap covs <- mconcat <$> mapM (coverageForUnitTestContract opts contractMap sourceCache) unitTests let dapp = dappInfo "." contractMap sourceCache f (k, vs) = do - when (shouldPrintCoverage (EVM.UnitTest.covMatch opts) k) $ do + when (shouldPrintCoverage opts.covMatch k) $ do putStr ("\x1b[0m" ++ "————— hevm coverage for ") -- Prefixed with color reset putStrLn (unpack k ++ " —————") putStrLn "" @@ -470,7 +472,7 @@ case optsMode cmd of Run -> do vm' <- execStateT (EVM.Stepper.interpret (EVM.Fetch.oracle solvers rpcinfo) . void $ EVM.Stepper.execFully) vm - when (trace cmd) $ T.hPutStr stderr (showTraceTree dapp vm') + when cmd.trace $ T.hPutStr stderr (showTraceTree dapp vm') case view EVM.result vm' of Nothing -> error "internal error; no EVM result" @@ -488,11 +490,11 @@ ConcreteBuf msg' -> msg' _ -> "" print $ ByteStringS msg - case state cmd of + case cmd.state of Nothing -> pure () Just path -> Git.saveFacts (Git.RepoAt path) (Facts.vmFacts vm') - case cache cmd of + case cmd.cache of Nothing -> pure () Just path -> Git.saveFacts (Git.RepoAt path) (Facts.cacheFacts (view EVM.cache vm')) @@ -500,15 +502,15 @@ Debug -> void $ TTY.runFromVM solvers rpcinfo Nothing dapp vm --JsonTrace -> void $ execStateT (interpretWithTrace fetcher EVM.Stepper.runFully) vm _ -> error "TODO" - where block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) - rpcinfo = (,) block' <$> rpc cmd + where block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block + rpcinfo = (,) block' <$> cmd.rpc -- | Creates a (concrete) VM from command line options vmFromCommand :: Command Options.Unwrapped -> IO EVM.VM vmFromCommand cmd = do - withCache <- applyCache (state cmd, cache cmd) + withCache <- applyCache (cmd.state, cmd.cache) - (miner,ts,baseFee,blockNum,prevRan) <- case rpc cmd of + (miner,ts,baseFee,blockNum,prevRan) <- case cmd.rpc of Nothing -> return (0,Lit 0,0,0,0) Just url -> EVM.Fetch.fetchBlockFrom block' url >>= \case Nothing -> error "Could not fetch block" @@ -519,7 +521,7 @@ , _prevRandao ) - contract <- case (rpc cmd, address cmd, code cmd) of + contract <- case (cmd.rpc, cmd.address, cmd.code) of (Just url, Just addr', Just c) -> do EVM.Fetch.fetchContractFrom block' url addr' >>= \case Nothing -> @@ -552,43 +554,43 @@ return $ EVM.Transaction.initTx $ withCache (vm0 baseFee miner ts' blockNum prevRan contract) where - block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) - value' = word value 0 - caller' = addr caller 0 - origin' = addr origin 0 - calldata' = ConcreteBuf $ bytes Main.calldata "" + block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block + value' = word (.value) 0 + caller' = addr (.caller) 0 + origin' = addr (.origin) 0 + calldata' = ConcreteBuf $ bytes (.calldata) "" decipher = hexByteString "bytes" . strip0x - mkCode bs = if create cmd + mkCode bs = if cmd.create then EVM.InitCode bs mempty else EVM.RuntimeCode (EVM.ConcreteRuntimeCode bs) - address' = if create cmd - then addr address (createAddress origin' (word nonce 0)) - else addr address 0xacab + address' = if cmd.create + then addr (.address) (createAddress origin' (word (.nonce) 0)) + else addr (.address) 0xacab vm0 baseFee miner ts blockNum prevRan c = EVM.makeVm $ EVM.VMOpts - { EVM.vmoptContract = c - , EVM.vmoptCalldata = (calldata', []) - , EVM.vmoptValue = Lit value' - , EVM.vmoptAddress = address' - , EVM.vmoptCaller = litAddr caller' - , EVM.vmoptOrigin = origin' - , EVM.vmoptGas = word64 gas 0xffffffffffffffff - , EVM.vmoptBaseFee = baseFee - , EVM.vmoptPriorityFee = word priorityFee 0 - , EVM.vmoptGaslimit = word64 gaslimit 0xffffffffffffffff - , EVM.vmoptCoinbase = addr coinbase miner - , EVM.vmoptNumber = word number blockNum - , EVM.vmoptTimestamp = Lit $ word timestamp ts - , EVM.vmoptBlockGaslimit = word64 gaslimit 0xffffffffffffffff - , EVM.vmoptGasprice = word gasprice 0 - , EVM.vmoptMaxCodeSize = word maxcodesize 0xffffffff - , EVM.vmoptPrevRandao = word prevRandao prevRan - , EVM.vmoptSchedule = FeeSchedule.berlin - , EVM.vmoptChainId = word chainid 1 - , EVM.vmoptCreate = create cmd - , EVM.vmoptStorageBase = EVM.Concrete - , EVM.vmoptTxAccessList = mempty -- TODO: support me soon - , EVM.vmoptAllowFFI = False + { vmoptContract = c + , vmoptCalldata = (calldata', []) + , vmoptValue = Lit value' + , vmoptAddress = address' + , vmoptCaller = litAddr caller' + , vmoptOrigin = origin' + , vmoptGas = word64 (.gas) 0xffffffffffffffff + , vmoptBaseFee = baseFee + , vmoptPriorityFee = word (.priorityFee) 0 + , vmoptGaslimit = word64 (.gaslimit) 0xffffffffffffffff + , vmoptCoinbase = addr (.coinbase) miner + , vmoptNumber = word (.number) blockNum + , vmoptTimestamp = Lit $ word (.timestamp) ts + , vmoptBlockGaslimit = word64 (.gaslimit) 0xffffffffffffffff + , vmoptGasprice = word (.gasprice) 0 + , vmoptMaxCodeSize = word (.maxcodesize) 0xffffffff + , vmoptPrevRandao = word (.prevRandao) prevRan + , vmoptSchedule = FeeSchedule.berlin + , vmoptChainId = word (.chainid) 1 + , vmoptCreate = (.create) cmd + , vmoptStorageBase = EVM.Concrete + , vmoptTxAccessList = mempty -- TODO: support me soon + , vmoptAllowFFI = False } word f def = fromMaybe def (f cmd) word64 f def = fromMaybe def (f cmd) @@ -597,7 +599,7 @@ symvmFromCommand :: Command Options.Unwrapped -> (Expr Buf, [Prop]) -> IO (EVM.VM) symvmFromCommand cmd calldata' = do - (miner,blockNum,baseFee,prevRan) <- case rpc cmd of + (miner,blockNum,baseFee,prevRan) <- case cmd.rpc of Nothing -> return (0,0,0,0) Just url -> EVM.Fetch.fetchBlockFrom block' url >>= \case Nothing -> error "Could not fetch block" @@ -609,10 +611,10 @@ let caller' = Caller 0 - ts = maybe Timestamp Lit (timestamp cmd) - callvalue' = maybe (CallValue 0) Lit (value cmd) + ts = maybe Timestamp Lit cmd.timestamp + callvalue' = maybe (CallValue 0) Lit cmd.value -- TODO: rework this, ConcreteS not needed anymore - let store = case storageModel cmd of + let store = case cmd.storageModel of -- InitialS and SymbolicS can read and write to symbolic locations -- ConcreteS cannot (instead values can be fetched from rpc!) -- Initial defaults to 0 for uninitialized storage slots, @@ -620,18 +622,18 @@ Just InitialS -> EmptyStore Just ConcreteS -> ConcreteStore mempty Just SymbolicS -> AbstractStore - Nothing -> if create cmd then EmptyStore else AbstractStore + Nothing -> if cmd.create then EmptyStore else AbstractStore - withCache <- applyCache (state cmd, cache cmd) + withCache <- applyCache (cmd.state, cmd.cache) - contract' <- case (rpc cmd, address cmd, code cmd) of + contract' <- case (cmd.rpc, cmd.address, cmd.code) of (Just url, Just addr', _) -> EVM.Fetch.fetchContractFrom block' url addr' >>= \case Nothing -> error "contract not found." Just contract' -> return contract'' where - contract'' = case code cmd of + contract'' = case cmd.code of Nothing -> contract' -- if both code and url is given, -- fetch the contract and overwrite the code @@ -652,38 +654,38 @@ where decipher = hexByteString "bytes" . strip0x - block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) - origin' = addr origin 0 - mkCode bs = if create cmd + block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block + origin' = addr (.origin) 0 + mkCode bs = if cmd.create then EVM.InitCode bs mempty else EVM.RuntimeCode (EVM.ConcreteRuntimeCode bs) - address' = if create cmd - then addr address (createAddress origin' (word nonce 0)) - else addr address 0xacab + address' = if cmd.create + then addr (.address) (createAddress origin' (word (.nonce) 0)) + else addr (.address) 0xacab vm0 baseFee miner ts blockNum prevRan cd' callvalue' caller' c = EVM.makeVm $ EVM.VMOpts - { EVM.vmoptContract = c - , EVM.vmoptCalldata = cd' - , EVM.vmoptValue = callvalue' - , EVM.vmoptAddress = address' - , EVM.vmoptCaller = caller' - , EVM.vmoptOrigin = origin' - , EVM.vmoptGas = word64 gas 0xffffffffffffffff - , EVM.vmoptGaslimit = word64 gaslimit 0xffffffffffffffff - , EVM.vmoptBaseFee = baseFee - , EVM.vmoptPriorityFee = word priorityFee 0 - , EVM.vmoptCoinbase = addr coinbase miner - , EVM.vmoptNumber = word number blockNum - , EVM.vmoptTimestamp = ts - , EVM.vmoptBlockGaslimit = word64 gaslimit 0xffffffffffffffff - , EVM.vmoptGasprice = word gasprice 0 - , EVM.vmoptMaxCodeSize = word maxcodesize 0xffffffff - , EVM.vmoptPrevRandao = word prevRandao prevRan - , EVM.vmoptSchedule = FeeSchedule.berlin - , EVM.vmoptChainId = word chainid 1 - , EVM.vmoptCreate = create cmd - , EVM.vmoptStorageBase = EVM.Symbolic - , EVM.vmoptTxAccessList = mempty - , EVM.vmoptAllowFFI = False + { vmoptContract = c + , vmoptCalldata = cd' + , vmoptValue = callvalue' + , vmoptAddress = address' + , vmoptCaller = caller' + , vmoptOrigin = origin' + , vmoptGas = word64 (.gas) 0xffffffffffffffff + , vmoptGaslimit = word64 (.gaslimit) 0xffffffffffffffff + , vmoptBaseFee = baseFee + , vmoptPriorityFee = word (.priorityFee) 0 + , vmoptCoinbase = addr (.coinbase) miner + , vmoptNumber = word (.number) blockNum + , vmoptTimestamp = ts + , vmoptBlockGaslimit = word64 (.gaslimit) 0xffffffffffffffff + , vmoptGasprice = word (.gasprice) 0 + , vmoptMaxCodeSize = word (.maxcodesize) 0xffffffff + , vmoptPrevRandao = word (.prevRandao) prevRan + , vmoptSchedule = FeeSchedule.berlin + , vmoptChainId = word (.chainid) 1 + , vmoptCreate = (.create) cmd + , vmoptStorageBase = EVM.Symbolic + , vmoptTxAccessList = mempty + , vmoptAllowFFI = False } word f def = fromMaybe def (f cmd) addr f def = fromMaybe def (f cmd) diff --git a/hevm.cabal b/hevm.cabal --- a/hevm.cabal +++ b/hevm.cabal @@ -2,7 +2,7 @@ name: hevm version: - 0.50.2 + 0.50.3 synopsis: Ethereum virtual machine evaluator description: @@ -24,6 +24,7 @@ Simple extra-source-files: CHANGELOG.md + bench/contracts/erc20.sol test/contracts/lib/test.sol test/contracts/lib/erc20.sol test/contracts/pass/trivial.sol @@ -45,6 +46,11 @@ default: False manual: True +flag devel + description: Sets flag for compilation during development + default: False + manual: True + source-repository head type: git location: https://github.com/ethereum/hevm.git @@ -52,9 +58,14 @@ common shared if flag(ci) ghc-options: -Werror + if flag(devel) + ghc-options: -j default-language: GHC2021 default-extensions: + DuplicateRecordFields LambdaCase + NoFieldSelectors + OverloadedRecordDot OverloadedStrings RecordWildCards TypeFamilies @@ -72,6 +83,7 @@ EVM.Dev, EVM.Expr, EVM.SMT, + EVM.Solvers, EVM.Exec, EVM.Facts, EVM.Facts.Git, @@ -99,8 +111,10 @@ Paths_hevm autogen-modules: Paths_hevm - ghc-options: - -Wall -Wno-deprecations -Wno-unticked-promoted-constructors -Wno-orphans + if flag(devel) + ghc-options: -Wall -Wno-deprecations -Wno-unticked-promoted-constructors -Wno-orphans -j + else + ghc-options: -Wall -Wno-deprecations -Wno-unticked-promoted-constructors -Wno-orphans extra-libraries: secp256k1, ff if os(linux) @@ -164,6 +178,8 @@ smt2-parser >= 0.1.0.1, word-wrap >= 0.5 && < 0.6, spool >= 0.1 && < 0.2, + stm >= 2.5.0 && < 2.6.0, + spawn >= 0.3 && < 0.4 hs-source-dirs: src @@ -173,8 +189,10 @@ hevm-cli main-is: hevm-cli.hs - ghc-options: - -Wall -threaded -with-rtsopts=-N -Wno-unticked-promoted-constructors -Wno-orphans + if flag(devel) + ghc-options: -Wall -threaded -with-rtsopts=-N -Wno-unticked-promoted-constructors -Wno-orphans -j + else + ghc-options: -Wall -threaded -with-rtsopts=-N -Wno-unticked-promoted-constructors -Wno-orphans other-modules: Paths_hevm if os(darwin) @@ -213,12 +231,18 @@ text, unordered-containers, vector, - vty + vty, + stm, + spawn +--- Test Helpers --- + common test-base import: shared - ghc-options: - -Wall -Wno-unticked-promoted-constructors -Wno-orphans + if flag (devel) + ghc-options: -Wall -Wno-unticked-promoted-constructors -Wno-orphans -j + else + ghc-options: -Wall -Wno-unticked-promoted-constructors -Wno-orphans hs-source-dirs: test extra-libraries: @@ -257,6 +281,9 @@ time, array, vector, + tasty-bench, + stm >= 2.5.0, + spawn >= 0.3, witherable, smt2-parser >= 0.1.0.1 @@ -307,3 +334,30 @@ exitcode-stdio-1.0 main-is: BlockchainTests.hs + +--- Benchmarks --- + +benchmark bench + import: shared + type: + exitcode-stdio-1.0 + main-is: + bench.hs + hs-source-dirs: + bench + if os(darwin) + extra-libraries: c++ + else + extra-libraries: stdc++ + other-modules: + Paths_hevm + autogen-modules: + Paths_hevm + build-depends: + base, + tasty-bench, + tasty, + bytestring, + text, + hevm, + here diff --git a/src/EVM.hs b/src/EVM.hs --- a/src/EVM.hs +++ b/src/EVM.hs @@ -8,56 +8,53 @@ import Prelude hiding (log, exponent, GT, LT) -import Data.Text (unpack) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) import EVM.ABI -import EVM.Types hiding (IllegalOverflow, Error) -import EVM.Solidity import EVM.Concrete (createAddress, create2Address) -import EVM.Op -import EVM.Expr (readStorage, writeStorage, readByte, readWord, writeWord, writeByte, bufLength, indexWord, litAddr, readBytes, word256At, copySlice) +import EVM.Expr (readStorage, writeStorage, readByte, readWord, writeWord, + writeByte, bufLength, indexWord, litAddr, readBytes, word256At, copySlice) +import EVM.Expr qualified as Expr import EVM.FeeSchedule (FeeSchedule (..)) -import Options.Generic as Options -import qualified EVM.Precompiled -import qualified EVM.Expr as Expr +import EVM.Op +import EVM.Precompiled qualified +import EVM.Solidity +import EVM.Types hiding (IllegalOverflow, Error) import Control.Lens hiding (op, (:<), (|>), (.>)) import Control.Monad.State.Strict hiding (state) - -import Data.ByteString (ByteString) -import Data.ByteString.Lazy (fromStrict) -import Data.Map.Strict (Map) -import Data.Set (Set, insert, member, fromList) -import Data.Maybe (fromMaybe, fromJust) -import Data.Sequence (Seq) -import Data.Vector.Storable (Vector) -import Data.Foldable (toList) -import Data.Word (Word8, Word32, Word64) -import Data.Bits (FiniteBits, countLeadingZeros, finiteBitSize) - +import Data.Bits (FiniteBits, countLeadingZeros, finiteBitSize) +import Data.ByteArray qualified as BA +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy (fromStrict) +import Data.ByteString.Lazy qualified as LS +import Data.ByteString.Char8 qualified as Char8 +import Data.Foldable (toList) +import Data.List (find) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, fromJust) +import Data.Set (Set, insert, member, fromList) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Text (unpack) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Tree +import Data.Tree.Zipper qualified as Zipper import Data.Tuple.Curry -import Data.List (find) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LS -import qualified Data.ByteString.Char8 as Char8 -import qualified Data.ByteArray as BA -import qualified Data.Map.Strict as Map -import qualified Data.Sequence as Seq -import qualified Data.Tree.Zipper as Zipper -import qualified Data.Vector as V -import qualified Data.Vector.Storable as Vector -import qualified Data.Vector.Storable.Mutable as Vector - -import qualified Data.Vector as RegularVector +import Data.Vector qualified as RegularVector +import Data.Vector qualified as V +import Data.Vector.Storable (Vector) +import Data.Vector.Storable qualified as Vector +import Data.Vector.Storable.Mutable qualified as Vector +import Data.Word (Word8, Word32, Word64) +import Options.Generic as Options -import Crypto.Number.ModArithmetic (expFast) -import qualified Crypto.Hash as Crypto import Crypto.Hash (Digest, SHA256, RIPEMD160, digestFromByteString) +import Crypto.Hash qualified as Crypto +import Crypto.Number.ModArithmetic (expFast) import Crypto.PubKey.ECC.ECDSA (signDigestWith, PrivateKey(..), Signature(..)) -import Crypto.PubKey.ECC.Types (getCurveByName, CurveName(..), Point(..)) import Crypto.PubKey.ECC.Generate (generateQ) +import Crypto.PubKey.ECC.Types (getCurveByName, CurveName(..), Point(..)) -- * Data types @@ -112,6 +109,7 @@ , _constraints :: [Prop] , _keccakEqs :: [Prop] , _allowFFI :: Bool + , _overrideCaller :: Maybe (Expr EWord) } deriving (Show) @@ -433,9 +431,9 @@ instance Semigroup Cache where a <> b = Cache - { _fetchedContracts = Map.unionWith unifyCachedContract (view fetchedContracts a) (view fetchedContracts b) - , _fetchedStorage = Map.unionWith unifyCachedStorage (view fetchedStorage a) (view fetchedStorage b) - , _path = mappend (view path a) (view path b) + { _fetchedContracts = Map.unionWith unifyCachedContract a._fetchedContracts b._fetchedContracts + , _fetchedStorage = Map.unionWith unifyCachedStorage a._fetchedStorage b._fetchedStorage + , _path = mappend a._path b._path } unifyCachedStorage :: Map W256 W256 -> Map W256 W256 -> Map W256 W256 @@ -464,78 +462,79 @@ currentContract :: VM -> Maybe Contract currentContract vm = - view (env . contracts . at (view (state . codeContract) vm)) vm + Map.lookup vm._state._codeContract vm._env._contracts -- * Data constructors makeVm :: VMOpts -> VM makeVm o = - let txaccessList = vmoptTxAccessList o - txorigin = vmoptOrigin o - txtoAddr = vmoptAddress o + let txaccessList = o.vmoptTxAccessList + txorigin = o.vmoptOrigin + txtoAddr = o.vmoptAddress initialAccessedAddrs = fromList $ [txorigin, txtoAddr] ++ [1..9] ++ (Map.keys txaccessList) initialAccessedStorageKeys = fromList $ foldMap (uncurry (map . (,))) (Map.toList txaccessList) - touched = if vmoptCreate o then [txorigin] else [txorigin, txtoAddr] + touched = if o.vmoptCreate then [txorigin] else [txorigin, txtoAddr] in VM { _result = Nothing , _frames = mempty , _tx = TxState - { _gasprice = vmoptGasprice o - , _txgaslimit = vmoptGaslimit o - , _txPriorityFee = vmoptPriorityFee o + { _gasprice = o.vmoptGasprice + , _txgaslimit = o.vmoptGaslimit + , _txPriorityFee = o.vmoptPriorityFee , _origin = txorigin , _toAddr = txtoAddr - , _value = vmoptValue o + , _value = o.vmoptValue , _substate = SubState mempty touched initialAccessedAddrs initialAccessedStorageKeys mempty --, _accessList = txaccessList - , _isCreate = vmoptCreate o + , _isCreate = o.vmoptCreate , _txReversion = Map.fromList - [(vmoptAddress o, vmoptContract o)] + [(o.vmoptAddress , o.vmoptContract )] } , _logs = [] , _traces = Zipper.fromForest [] , _block = Block - { _coinbase = vmoptCoinbase o - , _timestamp = vmoptTimestamp o - , _number = vmoptNumber o - , _prevRandao = vmoptPrevRandao o - , _maxCodeSize = vmoptMaxCodeSize o - , _gaslimit = vmoptBlockGaslimit o - , _baseFee = vmoptBaseFee o - , _schedule = vmoptSchedule o + { _coinbase = o.vmoptCoinbase + , _timestamp = o.vmoptTimestamp + , _number = o.vmoptNumber + , _prevRandao = o.vmoptPrevRandao + , _maxCodeSize = o.vmoptMaxCodeSize + , _gaslimit = o.vmoptBlockGaslimit + , _baseFee = o.vmoptBaseFee + , _schedule = o.vmoptSchedule } , _state = FrameState { _pc = 0 , _stack = mempty , _memory = mempty , _memorySize = 0 - , _code = view contractcode $ vmoptContract o - , _contract = vmoptAddress o - , _codeContract = vmoptAddress o - , _calldata = fst $ vmoptCalldata o - , _callvalue = vmoptValue o - , _caller = vmoptCaller o - , _gas = vmoptGas o + , _code = o.vmoptContract._contractcode + , _contract = o.vmoptAddress + , _codeContract = o.vmoptAddress + , _calldata = fst o.vmoptCalldata + , _callvalue = o.vmoptValue + , _caller = o.vmoptCaller + , _gas = o.vmoptGas , _returndata = mempty , _static = False } , _env = Env { _sha3Crack = mempty - , _chainId = vmoptChainId o - , _storage = if vmoptStorageBase o == Concrete then EmptyStore else AbstractStore + , _chainId = o.vmoptChainId + , _storage = if o.vmoptStorageBase == Concrete then EmptyStore else AbstractStore , _origStorage = mempty , _contracts = Map.fromList - [(vmoptAddress o, vmoptContract o)] + [(o.vmoptAddress, o.vmoptContract )] --, _keccakUsed = mempty --, _storageModel = vmoptStorageModel o } , _cache = Cache mempty mempty mempty , _burned = 0 - , _constraints = snd $ vmoptCalldata o + , _constraints = snd o.vmoptCalldata , _keccakEqs = mempty , _iterations = mempty - , _allowFFI = vmoptAllowFFI o + , _allowFFI = o.vmoptAllowFFI + , _overrideCaller = Nothing } -- | Initialize empty contract with given code @@ -565,30 +564,25 @@ vm <- get let - -- Convenience function to access parts of the current VM state. - -- Arcane type signature needed to avoid monomorphism restriction. - the :: (b -> VM -> Const a VM) -> ((a -> Const a a) -> b) -> a - the f g = view (f . g) vm - -- Convenient aliases - mem = the state memory - stk = the state stack - self = the state contract - this = fromMaybe (error "internal error: state contract") (preview (ix self) (the env contracts)) + mem = vm._state._memory + stk = vm._state._stack + self = vm._state._contract + this = fromMaybe (error "internal error: state contract") (Map.lookup self vm._env._contracts) - fees@FeeSchedule {..} = the block schedule + fees@FeeSchedule {..} = vm._block._schedule doStop = finishFrame (FrameReturned mempty) if self > 0x0 && self <= 0x9 then do -- call to precompile let ?op = 0x00 -- dummy value - case bufLength (the state calldata) of + case bufLength vm._state._calldata of (Lit calldatasize) -> do - copyBytesToMemory (the state calldata) (Lit calldatasize) (Lit 0) (Lit 0) - executePrecompile self (the state gas) 0 calldatasize 0 0 [] + copyBytesToMemory vm._state._calldata (Lit calldatasize) (Lit 0) (Lit 0) + executePrecompile self vm._state._gas 0 calldatasize 0 0 [] vmx <- get - case view (state.stack) vmx of + case vmx._state._stack of (x:_) -> case x of Lit (num -> x' :: Integer) -> case x' of 0 -> do @@ -600,32 +594,32 @@ out <- use (state . returndata) finishFrame (FrameReturned out) e -> vmError $ - UnexpectedSymbolicArg (view (state . pc) vmx) "precompile returned a symbolic value" [e] + UnexpectedSymbolicArg vmx._state._pc "precompile returned a symbolic value" [e] _ -> underrun - e -> vmError $ UnexpectedSymbolicArg (the state pc) "cannot call precompiles with symbolic data" [e] + e -> vmError $ UnexpectedSymbolicArg vm._state._pc "cannot call precompiles with symbolic data" [e] - else if the state pc >= opslen (the state code) + else if vm._state._pc >= opslen vm._state._code then doStop else do - let ?op = case (the state code) of - InitCode conc _ -> BS.index conc (the state pc) - RuntimeCode (ConcreteRuntimeCode bs) -> BS.index bs (the state pc) + let ?op = case vm._state._code of + InitCode conc _ -> BS.index conc vm._state._pc + RuntimeCode (ConcreteRuntimeCode bs) -> BS.index bs vm._state._pc RuntimeCode (SymbolicRuntimeCode ops) -> fromMaybe (error "could not analyze symbolic code") $ - unlitByte $ ops V.! the state pc + unlitByte $ ops V.! vm._state._pc case ?op of -- op: PUSH x | x >= 0x60 && x <= 0x7f -> do let !n = num x - 0x60 + 1 - !xs = case the state code of - InitCode conc _ -> Lit $ word $ padRight n $ BS.take n (BS.drop (1 + the state pc) conc) - RuntimeCode (ConcreteRuntimeCode bs) -> Lit $ word $ BS.take n $ BS.drop (1 + the state pc) bs + !xs = case vm._state._code of + InitCode conc _ -> Lit $ word $ padRight n $ BS.take n (BS.drop (1 + vm._state._pc) conc) + RuntimeCode (ConcreteRuntimeCode bs) -> Lit $ word $ BS.take n $ BS.drop (1 + vm._state._pc) bs RuntimeCode (SymbolicRuntimeCode ops) -> - let bytes = V.take n $ V.drop (1 + the state pc) ops + let bytes = V.take n $ V.drop (1 + vm._state._pc) ops in readWord (Lit 0) $ Expr.fromList $ padLeft' 32 bytes limitStack 1 $ burn g_verylow $ do @@ -667,7 +661,7 @@ forceConcrete2 (xOffset', xSize') "LOG" $ \(xOffset, xSize) -> do let (topics, xs') = splitAt n xs bytes = readMemory xOffset' xSize' vm - logs' = (LogEntry (litAddr self) bytes topics) : (view logs vm) + logs' = (LogEntry (litAddr self) bytes topics) : vm._logs burn (g_log + g_logdata * (num xSize) + num n * g_logtopic) $ accessMemoryRange fees xOffset xSize $ do traceTopLog logs' @@ -770,33 +764,33 @@ fetchAccount (num x) $ \c -> do next assign (state . stack) xs - push (num $ view balance c) + push (num c._balance) [] -> underrun -- op: ORIGIN 0x32 -> limitStack 1 . burn g_base $ - next >> push (num (the tx origin)) + next >> push (num vm._tx._origin) -- op: CALLER 0x33 -> limitStack 1 . burn g_base $ - next >> pushSym (the state caller) + next >> pushSym vm._state._caller -- op: CALLVALUE 0x34 -> limitStack 1 . burn g_base $ - next >> pushSym (the state callvalue) + next >> pushSym vm._state._callvalue -- op: CALLDATALOAD 0x35 -> stackOp1 (const g_verylow) $ - \ind -> Expr.readWord ind (the state calldata) + \ind -> Expr.readWord ind vm._state._calldata -- op: CALLDATASIZE 0x36 -> limitStack 1 . burn g_base $ - next >> pushSym (bufLength (the state calldata)) + next >> pushSym (bufLength vm._state._calldata) -- op: CALLDATACOPY 0x37 -> @@ -808,13 +802,13 @@ accessMemoryRange fees xTo xSize $ do next assign (state . stack) xs - copyBytesToMemory (the state calldata) xSize' xFrom xTo' + copyBytesToMemory vm._state._calldata xSize' xFrom xTo' _ -> underrun -- op: CODESIZE 0x38 -> limitStack 1 . burn g_base $ - next >> pushSym (codelen (the state code)) + next >> pushSym (codelen vm._state._code) -- op: CODECOPY 0x39 -> @@ -830,14 +824,14 @@ accessMemoryRange fees memOffset n $ do next assign (state . stack) xs - copyBytesToMemory (toBuf $ the state code) n' codeOffset memOffset' + copyBytesToMemory (toBuf vm._state._code) n' codeOffset memOffset' else vmError IllegalOverflow _ -> underrun -- op: GASPRICE 0x3a -> limitStack 1 . burn g_base $ - next >> push (the tx gasprice) + next >> push vm._tx._gasprice -- op: EXTCODESIZE 0x3b -> @@ -857,6 +851,7 @@ _ -> do assign (state . stack) xs pushSym (CodeSize x') + next [] -> underrun @@ -883,7 +878,7 @@ -- op: RETURNDATASIZE 0x3d -> limitStack 1 . burn g_base $ - next >> pushSym (bufLength (the state returndata)) + next >> pushSym (bufLength vm._state._returndata) -- op: RETURNDATACOPY 0x3e -> @@ -896,13 +891,13 @@ assign (state . stack) xs let jump True = vmError EVM.InvalidMemoryAccess - jump False = copyBytesToMemory (the state returndata) xSize' xFrom xTo' + jump False = copyBytesToMemory vm._state._returndata xSize' xFrom xTo' - case (xFrom, bufLength (the state returndata)) of + case (xFrom, bufLength vm._state._returndata) of (Lit f, Lit l) -> jump $ l < f + xSize || f + xSize < f _ -> do - let oob = Expr.lt (bufLength $ the state returndata) (Expr.add xFrom xSize') + let oob = Expr.lt (bufLength vm._state._returndata) (Expr.add xFrom xSize') overflow = Expr.lt (Expr.add xFrom xSize') (xFrom) loc <- codeloc branch loc (Expr.or oob overflow) jump @@ -927,7 +922,7 @@ -- We adopt the fake block hash scheme of the VMTests, -- so that blockhash(i) is the hash of i as decimal ASCII. stackOp1 (const g_blockhash) $ \case - (Lit i) -> if i + 256 < the block number || i >= the block number + (Lit i) -> if i + 256 < vm._block._number || i >= vm._block._number then Lit 0 else (num i :: Integer) & show & Char8.pack & keccak' & Lit i -> BlockHash i @@ -935,42 +930,42 @@ -- op: COINBASE 0x41 -> limitStack 1 . burn g_base $ - next >> push (num (the block coinbase)) + next >> push (num vm._block._coinbase) -- op: TIMESTAMP 0x42 -> limitStack 1 . burn g_base $ - next >> pushSym (the block timestamp) + next >> pushSym vm._block._timestamp -- op: NUMBER 0x43 -> limitStack 1 . burn g_base $ - next >> push (the block number) + next >> push vm._block._number -- op: PREVRANDAO 0x44 -> do limitStack 1 . burn g_base $ - next >> push (the block prevRandao) + next >> push vm._block._prevRandao -- op: GASLIMIT 0x45 -> limitStack 1 . burn g_base $ - next >> push (num $ the block gaslimit) + next >> push (num vm._block._gaslimit) -- op: CHAINID 0x46 -> limitStack 1 . burn g_base $ - next >> push (the env chainId) + next >> push vm._env._chainId -- op: SELFBALANCE 0x47 -> limitStack 1 . burn g_low $ - next >> push (view balance this) + next >> push this._balance -- op: BASEFEE 0x48 -> limitStack 1 . burn g_base $ - next >> push (the block baseFee) + next >> push vm._block._baseFee -- op: POP 0x50 -> @@ -1034,7 +1029,7 @@ if num availableGas <= g_callstipend then finishFrame (FrameErrored (OutOfGas availableGas (num g_callstipend))) else do - let original = case readStorage (litAddr self) x (ConcreteStore $ the env origStorage) of + let original = case readStorage (litAddr self) x (ConcreteStore vm._env._origStorage) of Just (Lit v) -> v _ -> 0 let storage_cost = case (maybeLitWord current, maybeLitWord new) of @@ -1107,17 +1102,17 @@ -- op: PC 0x58 -> limitStack 1 . burn g_base $ - next >> push (num (the state pc)) + next >> push (num vm._state._pc) -- op: MSIZE 0x59 -> limitStack 1 . burn g_base $ - next >> push (num (the state memorySize)) + next >> push (num vm._state._memorySize) -- op: GAS 0x5a -> limitStack 1 . burn g_base $ - next >> push (num (the state gas - g_base)) + next >> push (num (vm._state._gas - g_base)) -- op: JUMPDEST 0x5b -> burn g_jumpdest next @@ -1149,7 +1144,7 @@ accessMemoryRange fees xOffset xSize $ do availableGas <- use (state . gas) let - newAddr = createAddress self (view nonce this) + newAddr = createAddress self this._nonce (cost, gas') = costOfCreate fees availableGas 0 _ <- accessAccountForGas newAddr burn (cost - gas') $ do @@ -1177,8 +1172,9 @@ delegateCall this (num xGas) xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ \callee -> do zoom state $ do assign callvalue (Lit xValue) - assign caller (litAddr self) + assign caller $ fromMaybe (litAddr self) (vm ^. overrideCaller) assign contract callee + assign overrideCaller Nothing transfer self callee xValue touchAccount self touchAccount callee @@ -1201,7 +1197,8 @@ delegateCall this (num xGas) xTo (litAddr self) xValue xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do zoom state $ do assign callvalue (Lit xValue) - assign caller (litAddr self) + assign caller $ fromMaybe (litAddr self) (vm ^. overrideCaller) + assign overrideCaller Nothing touchAccount self _ -> underrun @@ -1215,10 +1212,10 @@ output = readMemory xOffset' xSize' vm codesize = fromMaybe (error "RETURN: cannot return dynamically sized abstract data") . unlit . bufLength $ output - maxsize = the block maxCodeSize - creation = case view frames vm of - [] -> the tx isCreate - frame:_ -> case view frameContext frame of + maxsize = vm._block._maxCodeSize + creation = case vm._frames of + [] -> vm._tx._isCreate + frame:_ -> case frame._frameContext of CreationContext {} -> True CallContext {} -> False if creation @@ -1292,9 +1289,10 @@ delegateCall this (num xGas) xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs $ \callee -> do zoom state $ do assign callvalue (Lit 0) - assign caller (litAddr self) + assign caller $ fromMaybe (litAddr self) (vm ^. overrideCaller) assign contract callee assign static True + assign overrideCaller Nothing touchAccount self touchAccount callee _ -> @@ -1308,7 +1306,7 @@ (xTo':_) -> forceConcrete xTo' "SELFDESTRUCT" $ \(num -> xTo) -> do acc <- accessAccountForGas (num xTo) let cost = if acc then 0 else g_cold_account_access - funds = view balance this + funds = this._balance recipientExists = accountExists xTo vm c_new = if not recipientExists && funds /= 0 then g_selfdestruct_newaccount @@ -1351,20 +1349,20 @@ -> EVM () callChecks this xGas xContext xTo xValue xInOffset xInSize xOutOffset xOutSize xs continue = do vm <- get - let fees = view (block . schedule) vm + let fees = vm._block._schedule accessMemoryRange fees xInOffset xInSize $ accessMemoryRange fees xOutOffset xOutSize $ do availableGas <- use (state . gas) let recipientExists = accountExists xContext vm (cost, gas') <- costOfCall fees recipientExists xValue availableGas xGas xTo burn (cost - gas') $ do - if xValue > num (view balance this) + if xValue > num this._balance then do assign (state . stack) (Lit 0 : xs) assign (state . returndata) mempty - pushTrace $ ErrorTrace $ BalanceTooLow xValue (view balance this) + pushTrace $ ErrorTrace $ BalanceTooLow xValue this._balance next - else if length (view frames vm) >= 1024 + else if length vm._frames >= 1024 then do assign (state . stack) (Lit 0 : xs) assign (state . returndata) mempty @@ -1389,18 +1387,20 @@ self <- use (state . contract) stk <- use (state . stack) pc' <- use (state . pc) - case stk of - (x:_) -> case maybeLitWord x of - Just 0 -> - return () - Just 1 -> - fetchAccount recipient $ \_ -> do - - transfer self recipient xValue - touchAccount self - touchAccount recipient - _ -> vmError $ UnexpectedSymbolicArg pc' "symbolic return value from precompile" [x] - _ -> underrun + result' <- use result + case result' of + Nothing -> case stk of + (x:_) -> case maybeLitWord x of + Just 0 -> + return () + Just 1 -> + fetchAccount recipient $ \_ -> do + transfer self recipient xValue + touchAccount self + touchAccount recipient + _ -> vmError $ UnexpectedSymbolicArg pc' "unexpected return value from precompile" [x] + _ -> underrun + _ -> pure () executePrecompile :: (?op :: Word8) @@ -1410,7 +1410,7 @@ executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = do vm <- get let input = readMemory (Lit inOffset) (Lit inSize) vm - fees = view (block . schedule) vm + fees = vm._block._schedule cost = costOfPrecompile fees preCompileAddr input notImplemented = error $ "precompile at address " <> show preCompileAddr <> " not yet implemented" precompileFail = burn (gasCap - cost) $ do @@ -1426,32 +1426,29 @@ case preCompileAddr of -- ECRECOVER 0x1 -> - -- TODO: support symbolic variant - forceConcreteBuf input "ECRECOVER" $ \input' -> - case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of - Nothing -> do - -- return no output for invalid signature - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) mempty - next - Just output -> do - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) (ConcreteBuf output) - copyBytesToMemory (ConcreteBuf output) (Lit outSize) (Lit 0) (Lit outOffset) - next + -- TODO: support symbolic variant + forceConcreteBuf input "ECRECOVER" $ \input' -> do + case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of + Nothing -> do + -- return no output for invalid signature + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) mempty + next + Just output -> do + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) (ConcreteBuf output) + copyBytesToMemory (ConcreteBuf output) (Lit outSize) (Lit 0) (Lit outOffset) + next -- SHA2-256 - 0x2 -> + 0x2 -> forceConcreteBuf input "SHA2-256" $ \input' -> do let - hash = case input of - ConcreteBuf input' -> sha256Buf input' - _ -> WriteWord (Lit 0) (SHA256 input) mempty + hash = sha256Buf input' sha256Buf x = ConcreteBuf $ BA.convert (Crypto.hash x :: Digest SHA256) - in do - assign (state . stack) (Lit 1 : xs) - assign (state . returndata) hash - copyBytesToMemory hash (Lit outSize) (Lit 0) (Lit outOffset) - next + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) hash + copyBytesToMemory hash (Lit outSize) (Lit 0) (Lit outOffset) + next -- RIPEMD-160 0x3 -> @@ -1601,7 +1598,7 @@ pushToSequence f x = f %= (Seq.|> x) getCodeLocation :: VM -> CodeLocation -getCodeLocation vm = (view (state . contract) vm, view (state . pc) vm) +getCodeLocation vm = (vm._state._contract, vm._state._pc) branch :: CodeLocation -> Expr EWord -> (Bool -> EVM ()) -> EVM () branch loc cond continue = do @@ -1652,13 +1649,13 @@ Just x -> continue x Nothing -> - if view external c - then - -- check if the slot is cached - use (cache . fetchedContracts . at addr) >>= \case - Nothing -> forceConcrete slot "cannot read symbolic slots via RPC" mkQuery - Just _ -> forceConcrete slot "cannot read symbolic slots via rpc" $ - \s -> maybe (mkQuery s) continue (readStorage (litAddr addr) slot store) + if c._external then + forceConcrete slot "cannot read symbolic slots via RPC" $ \litSlot -> do + -- check if the slot is cached + cachedStore <- use (cache . fetchedStorage) + case Map.lookup (num addr) cachedStore >>= Map.lookup litSlot of + Nothing -> mkQuery litSlot + Just val -> continue (Lit val) else do modifying (env . storage) (writeStorage (litAddr addr) slot (Lit 0)) continue $ Lit 0 @@ -1676,19 +1673,19 @@ accountExists :: Addr -> VM -> Bool accountExists addr vm = - case view (env . contracts . at addr) vm of + case Map.lookup addr vm._env._contracts of Just c -> not (accountEmpty c) Nothing -> False -- EIP 161 accountEmpty :: Contract -> Bool accountEmpty c = - case view contractcode c of + case c._contractcode of RuntimeCode (ConcreteRuntimeCode "") -> True RuntimeCode (SymbolicRuntimeCode b) -> null b _ -> False - && (view nonce c == 0) - && (view balance c == 0) + && c._nonce == 0 + && c._balance == 0 -- * How to finalize a transaction finalize :: EVM () @@ -1731,7 +1728,7 @@ txOrigin <- use (tx . origin) sumRefunds <- (sum . (snd <$>)) <$> (use (tx . substate . refunds)) miner <- use (block . coinbase) - blockReward <- num . r_block <$> (use (block . schedule)) + blockReward <- num . (.r_block) <$> (use (block . schedule)) gasPrice <- use (tx . gasprice) priorityFee <- use (tx . txPriorityFee) gasLimit <- use (tx . txgaslimit) @@ -1813,16 +1810,11 @@ else vmError (OutOfGas available n) ---forceConcreteAddr :: SAddr -> (Addr -> EVM ()) -> EVM () ---forceConcreteAddr n continue = case maybeLitAddr n of - --Nothing -> vmError UnexpectedSymbolicArg - --Just c -> continue c - forceConcrete :: Expr EWord -> String -> (W256 -> EVM ()) -> EVM () forceConcrete n msg continue = case maybeLitWord n of Nothing -> do vm <- get - vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [n] + vmError $ UnexpectedSymbolicArg vm._state._pc msg [n] Just c -> continue c forceConcrete2 :: (Expr EWord, Expr EWord) -> String -> ((W256, W256) -> EVM ()) -> EVM () @@ -1830,41 +1822,41 @@ (Just c, Just d) -> continue (c, d) _ -> do vm <- get - vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [n, m] + vmError $ UnexpectedSymbolicArg vm._state._pc msg [n, m] forceConcrete3 :: (Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256) -> EVM ()) -> EVM () forceConcrete3 (k,n,m) msg continue = case (maybeLitWord k, maybeLitWord n, maybeLitWord m) of (Just c, Just d, Just f) -> continue (c, d, f) _ -> do vm <- get - vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [k, n, m] + vmError $ UnexpectedSymbolicArg vm._state._pc msg [k, n, m] forceConcrete4 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256) -> EVM ()) -> EVM () forceConcrete4 (k,l,n,m) msg continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord n, maybeLitWord m) of (Just b, Just c, Just d, Just f) -> continue (b, c, d, f) _ -> do vm <- get - vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [k, l, n, m] + vmError $ UnexpectedSymbolicArg vm._state._pc msg [k, l, n, m] forceConcrete5 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256, W256) -> EVM ()) -> EVM () forceConcrete5 (k,l,m,n,o) msg continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord m, maybeLitWord n, maybeLitWord o) of (Just a, Just b, Just c, Just d, Just e) -> continue (a, b, c, d, e) _ -> do vm <- get - vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [k, l, m, n, o] + vmError $ UnexpectedSymbolicArg vm._state._pc msg [k, l, m, n, o] forceConcrete6 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256, W256, W256) -> EVM ()) -> EVM () forceConcrete6 (k,l,m,n,o,p) msg continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord m, maybeLitWord n, maybeLitWord o, maybeLitWord p) of (Just a, Just b, Just c, Just d, Just e, Just f) -> continue (a, b, c, d, e, f) _ -> do vm <- get - vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [k, l, m, n, o, p] + vmError $ UnexpectedSymbolicArg vm._state._pc msg [k, l, m, n, o, p] forceConcreteBuf :: Expr Buf -> String -> (ByteString -> EVM ()) -> EVM () forceConcreteBuf (ConcreteBuf b) _ continue = continue b forceConcreteBuf b msg _ = do vm <- get - vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [b] + vmError $ UnexpectedSymbolicArg vm._state._pc msg [b] -- * Substate manipulation refund :: Word64 -> EVM () @@ -1933,7 +1925,7 @@ abi = readBytes 4 (Lit inOffset) mem input = readMemory (Lit $ inOffset + 4) (Lit $ inSize - 4) vm case maybeLitWord abi of - Nothing -> vmError $ UnexpectedSymbolicArg (view (state . pc) vm) "symbolic cheatcode selector" [abi] + Nothing -> vmError $ UnexpectedSymbolicArg vm._state._pc "symbolic cheatcode selector" [abi] Just (fromIntegral -> abi') -> case Map.lookup abi' cheatActions of Nothing -> @@ -1951,7 +1943,7 @@ [ action "ffi(string[])" $ \sig outOffset outSize input -> do vm <- get - if view EVM.allowFFI vm then + if vm._allowFFI then case decodeBuf [AbiArrayDynamicType AbiStringType] input of CAbi valsArr -> case valsArr of [AbiArrayDynamic AbiStringType strsV] -> @@ -2049,6 +2041,11 @@ addr = Lit . W256 . word256 . BS.drop 12 . BS.take 32 . keccakBytes $ pub assign (state . returndata . word256At (Lit 0)) addr assign (state . memory . word256At outOffset) addr + _ -> vmError (BadCheatCode sig), + + action "prank(address)" $ + \sig _ _ input -> case decodeStaticArgs 0 1 input of + [addr] -> assign overrideCaller (Just addr) _ -> vmError (BadCheatCode sig) ] @@ -2093,12 +2090,12 @@ , callContextContext = xContext' , callContextOffset = xOutOffset , callContextSize = xOutSize - , callContextCodehash = view codehash target - , callContextReversion = (view (env . contracts) vm0, view (env . storage) vm0) - , callContextSubState = view (tx . substate) vm0 + , callContextCodehash = target._codehash + , callContextReversion = (vm0._env._contracts, vm0._env._storage) + , callContextSubState = vm0._tx._substate , callContextAbi = if xInSize >= 4 - then case unlit $ readBytes 4 (Lit xInOffset) (view (state . memory) vm0) + then case unlit $ readBytes 4 (Lit xInOffset) vm0._state._memory of Nothing -> Nothing Just abi -> Just $ num abi else Nothing @@ -2110,7 +2107,7 @@ vm1 <- get pushTo frames $ Frame - { _frameState = (set stack xs) (view state vm1) + { _frameState = vm1._state { _stack = xs } , _frameContext = newContext } @@ -2121,13 +2118,13 @@ zoom state $ do assign gas (num xGas) assign pc 0 - assign code (clearInitCode (view contractcode target)) + assign code (clearInitCode target._contractcode) assign codeContract xTo' assign stack mempty assign memory mempty assign memorySize 0 assign returndata mempty - assign calldata (copySlice (Lit xInOffset) (Lit 0) (Lit xInSize) (view (state . memory) vm0) mempty) + assign calldata (copySlice (Lit xInOffset) (Lit 0) (Lit xInSize) vm0._state._memory mempty) continue xTo' @@ -2136,7 +2133,7 @@ -- EIP 684 collision :: Maybe Contract -> Bool collision c' = case c' of - Just c -> (view nonce c /= 0) || case view contractcode c of + Just c -> c._nonce /= 0 || case c._contractcode of RuntimeCode (ConcreteRuntimeCode "") -> False RuntimeCode (SymbolicRuntimeCode b) -> not $ null b _ -> True @@ -2148,25 +2145,25 @@ create self this xGas' xValue xs newAddr initCode = do vm0 <- get let xGas = num xGas' - if view nonce this == num (maxBound :: Word64) + if this._nonce == num (maxBound :: Word64) then do assign (state . stack) (Lit 0 : xs) assign (state . returndata) mempty pushTrace $ ErrorTrace NonceOverflow next - else if xValue > view balance this + else if xValue > this._balance then do assign (state . stack) (Lit 0 : xs) assign (state . returndata) mempty - pushTrace $ ErrorTrace $ BalanceTooLow xValue (view balance this) + pushTrace $ ErrorTrace $ BalanceTooLow xValue this._balance next - else if length (view frames vm0) >= 1024 + else if length vm0._frames >= 1024 then do assign (state . stack) (Lit 0 : xs) assign (state . returndata) mempty pushTrace $ ErrorTrace CallDepthLimitReached next - else if collision $ view (env . contracts . at newAddr) vm0 + else if collision $ Map.lookup newAddr vm0._env._contracts then burn xGas $ do assign (state . stack) (Lit 0 : xs) assign (state . returndata) mempty @@ -2188,20 +2185,20 @@ pure $ InitCode (BS.pack $ V.toList conc) sym case contract' of Nothing -> - vmError $ UnexpectedSymbolicArg (view (state . pc) vm0) "initcode must have a concrete prefix" [] + vmError $ UnexpectedSymbolicArg vm0._state._pc "initcode must have a concrete prefix" [] Just c -> do let newContract = initialContract c newContext = CreationContext { creationContextAddress = newAddr - , creationContextCodehash = view codehash newContract - , creationContextReversion = view (env . contracts) vm0 - , creationContextSubstate = view (tx . substate) vm0 + , creationContextCodehash = newContract._codehash + , creationContextReversion = vm0._env._contracts + , creationContextSubstate = vm0._tx._substate } zoom (env . contracts) $ do oldAcc <- use (at newAddr) - let oldBal = maybe 0 (view balance) oldAcc + let oldBal = maybe 0 (._balance) oldAcc assign (at newAddr) (Just (newContract & balance .~ oldBal)) modifying (ix self . nonce) succ @@ -2223,7 +2220,7 @@ vm1 <- get pushTo frames $ Frame { _frameContext = newContext - , _frameState = (set stack xs) (view state vm1) + , _frameState = vm1._state { _stack = xs } } assign state $ @@ -2241,12 +2238,13 @@ replaceCode target newCode = zoom (env . contracts . at target) $ get >>= \case - Just now -> case (view contractcode now) of + Just now -> case now._contractcode of InitCode _ _ -> put . Just $ - initialContract newCode - & set balance (view balance now) - & set nonce (view nonce now) + (initialContract newCode) + { _balance = now._balance + , _nonce = now._nonce + } RuntimeCode _ -> error ("internal error: can't replace code of deployed contract " <> show target) Nothing -> @@ -2255,7 +2253,7 @@ replaceCodeOfSelf :: ContractCode -> EVM () replaceCodeOfSelf newCode = do vm <- get - replaceCode (view (state . contract) vm) newCode + replaceCode vm._state._contract newCode resetState :: EVM () resetState = do @@ -2270,7 +2268,7 @@ vmError e = finishFrame (FrameErrored e) underrun :: EVM () -underrun = vmError StackUnderrun +underrun = vmError EVM.StackUnderrun -- | A stack frame can be popped in three ways. data FrameResult @@ -2288,7 +2286,7 @@ finishFrame how = do oldVm <- get - case view frames oldVm of + case oldVm._frames of -- Is the current frame the only one? [] -> do case how of @@ -2308,26 +2306,26 @@ FrameReverted e -> ErrorTrace (EVM.Revert e) FrameReturned output -> - ReturnTrace output (view frameContext nextFrame) + ReturnTrace output nextFrame._frameContext -- Pop to the previous level of the debug trace stack. popTrace -- Pop the top frame. assign frames remainingFrames -- Install the state of the frame to which we shall return. - assign state (view frameState nextFrame) + assign state nextFrame._frameState -- When entering a call, the gas allowance is counted as burned -- in advance; this unburns the remainder and adds it to the -- parent frame. - let remainingGas = view (state . gas) oldVm + let remainingGas = oldVm._state._gas reclaimRemainingGasAllowance = do modifying burned (subtract remainingGas) modifying (state . gas) (+ remainingGas) -- Now dispatch on whether we were creating or calling, -- and whether we shall return, revert, or error (six cases). - case view frameContext nextFrame of + case nextFrame._frameContext of -- Were we calling? CallContext _ _ (Lit -> outOffset) (Lit -> outSize) _ _ _ reversion substate' -> do @@ -2377,7 +2375,7 @@ CreationContext _ _ reversion substate' -> do creator <- use (state . contract) let - createe = view (state . contract) oldVm + createe = oldVm._state._contract revertContracts = assign (env . contracts) reversion' revertSubstate = assign (tx . substate) substate' @@ -2399,7 +2397,7 @@ case Expr.toList output of Nothing -> vmError $ UnexpectedSymbolicArg - (view (state . pc) oldVm) + oldVm._state._pc "runtime code cannot have an abstract length" [output] Just newCode -> do @@ -2476,19 +2474,18 @@ copySlice xOffset yOffset (Expr.min size (bufLength bs)) bs mem readMemory :: Expr EWord -> Expr EWord -> VM -> Expr Buf -readMemory offset size vm = copySlice offset (Lit 0) size (view (state . memory) vm) mempty +readMemory offset size vm = copySlice offset (Lit 0) size vm._state._memory mempty -- * Tracing -withTraceLocation - :: (MonadState VM m) => TraceData -> m Trace +withTraceLocation :: TraceData -> EVM Trace withTraceLocation x = do vm <- get let this = fromJust $ currentContract vm pure Trace { _traceData = x , _traceContract = this - , _traceOpIx = fromMaybe 0 $ (view opIxMap this) Vector.!? (view (state . pc) vm) + , _traceOpIx = fromMaybe 0 $ this._opIxMap Vector.!? vm._state._pc } pushTrace :: TraceData -> EVM () @@ -2517,9 +2514,9 @@ Just z' -> zipperRootForest (Zipper.nextSpace z') traceForest :: VM -> Forest Trace -traceForest = view (traces . to zipperRootForest) +traceForest vm = zipperRootForest vm._traces -traceTopLog :: (MonadState VM m) => [Expr Log] -> m () +traceTopLog :: [Expr Log] -> EVM () traceTopLog [] = noop traceTopLog ((LogEntry addr bytes topics) : _) = do trace <- withTraceLocation (EventTrace addr bytes topics) @@ -2666,7 +2663,7 @@ vmOpIx :: VM -> Maybe Int vmOpIx vm = do self <- currentContract vm - (view opIxMap self) Vector.!? (view (state . pc) vm) + self._opIxMap Vector.!? vm._state._pc opParams :: VM -> Map String (Expr EWord) opParams vm = @@ -2939,8 +2936,8 @@ codeloc :: EVM CodeLocation codeloc = do vm <- get - let self = view (state . contract) vm - loc = view (state . pc) vm + let self = vm._state._contract + loc = vm._state._pc pure (self, loc) -- * Emacs setup diff --git a/src/EVM/CSE.hs b/src/EVM/CSE.hs --- a/src/EVM/CSE.hs +++ b/src/EVM/CSE.hs @@ -40,43 +40,43 @@ -- buffers e@(WriteWord {}) -> do s <- get - case Map.lookup e (bufs s) of + case Map.lookup e s.bufs of Just v -> pure $ GVar (BufVar v) Nothing -> do let - next = count s - bs' = Map.insert e next (bufs s) + next = s.count + bs' = Map.insert e next s.bufs put $ s{bufs=bs', count=next+1} pure $ GVar (BufVar next) e@(WriteByte {}) -> do s <- get - case Map.lookup e (bufs s) of + case Map.lookup e s.bufs of Just v -> pure $ GVar (BufVar v) Nothing -> do let - next = count s - bs' = Map.insert e next (bufs s) + next = s.count + bs' = Map.insert e next s.bufs put $ s{bufs=bs', count=next+1} pure $ GVar (BufVar next) e@(CopySlice {}) -> do s <- get - case Map.lookup e (bufs s) of + case Map.lookup e s.bufs of Just v -> pure $ GVar (BufVar v) Nothing -> do let - next = count s - bs' = Map.insert e next (bufs s) + next = s.count + bs' = Map.insert e next s.bufs put $ s{count=next+1, bufs=bs'} pure $ GVar (BufVar next) -- storage e@(SStore {}) -> do s <- get - case Map.lookup e (stores s) of + case Map.lookup e s.stores of Just v -> pure $ GVar (StoreVar v) Nothing -> do let - next = count s - ss' = Map.insert e next (stores s) + next = s.count + ss' = Map.insert e next s.stores put $ s{count=next+1, stores=ss'} pure $ GVar (StoreVar next) e -> pure e @@ -91,7 +91,7 @@ eliminateExpr :: Expr a -> (Expr a, BufEnv, StoreEnv) eliminateExpr e = let (e', st) = runState (eliminateExpr' e) initState in - (e', invertKeyVal (bufs st), invertKeyVal (stores st)) + (e', invertKeyVal st.bufs, invertKeyVal st.stores) -- | Common subexpression elimination pass for Prop eliminateProp' :: Prop -> State BuilderState Prop @@ -106,4 +106,4 @@ eliminateProps :: [Prop] -> ([Prop], BufEnv, StoreEnv) eliminateProps props = let (props', st) = runState (eliminateProps' props) initState in - (props', invertKeyVal (bufs st), invertKeyVal (stores st)) + (props', invertKeyVal st.bufs, invertKeyVal st.stores) diff --git a/src/EVM/Dapp.hs b/src/EVM/Dapp.hs --- a/src/EVM/Dapp.hs +++ b/src/EVM/Dapp.hs @@ -1,64 +1,55 @@ -{-# Language TemplateHaskell #-} - module EVM.Dapp where -import EVM (Trace, traceContract, traceOpIx, ContractCode(..), Contract(..), codehash, contractcode, RuntimeCode (..)) +import EVM (Trace(..), ContractCode(..), Contract(..), RuntimeCode (..)) import EVM.ABI (Event, AbiType, SolError) +import EVM.Concrete import EVM.Debug (srcMapCodePos) import EVM.Solidity import EVM.Types (W256, abiKeccak, keccak', Addr, regexMatches, unlit, unlitByte) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Control.Arrow ((>>>)) import Data.Aeson (Value) import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.List (find, sort) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (isJust, fromJust, mapMaybe) +import Data.Sequence qualified as Seq import Data.Text (Text, isPrefixOf, pack, unpack) import Data.Text.Encoding (encodeUtf8) -import Data.Map (Map, toList, elems) -import Data.List (sort) -import Data.Maybe (isJust, fromJust, mapMaybe) +import Data.Vector qualified as V import Data.Word (Word32) -import EVM.Concrete -import Control.Arrow ((>>>)) -import Control.Lens - -import Data.List (find) -import qualified Data.Map as Map -import qualified Data.Vector as V - data DappInfo = DappInfo - { _dappRoot :: FilePath - , _dappSolcByName :: Map Text SolcContract - , _dappSolcByHash :: Map W256 (CodeType, SolcContract) - , _dappSolcByCode :: [(Code, SolcContract)] -- for contracts with `immutable` vars. - , _dappSources :: SourceCache - , _dappUnitTests :: [(Text, [(Test, [AbiType])])] - , _dappAbiMap :: Map Word32 Method - , _dappEventMap :: Map W256 Event - , _dappErrorMap :: Map W256 SolError - , _dappAstIdMap :: Map Int Value - , _dappAstSrcMap :: SrcMap -> Maybe Value + { root :: FilePath + , solcByName :: Map Text SolcContract + , solcByHash :: Map W256 (CodeType, SolcContract) + , solcByCode :: [(Code, SolcContract)] -- for contracts with `immutable` vars. + , sources :: SourceCache + , unitTests :: [(Text, [(Test, [AbiType])])] + , abiMap :: Map Word32 Method + , eventMap :: Map W256 Event + , errorMap :: Map W256 SolError + , astIdMap :: Map Int Value + , astSrcMap :: SrcMap -> Maybe Value } -- | bytecode modulo immutables, to identify contracts -data Code = - Code { - raw :: ByteString, - immutableLocations :: [Reference] +data Code = Code + { raw :: ByteString + , immutableLocations :: [Reference] } deriving Show data DappContext = DappContext - { _contextInfo :: DappInfo - , _contextEnv :: Map Addr Contract + { info :: DappInfo + , env :: Map Addr Contract } data Test = ConcreteTest Text | SymbolicTest Text | InvariantTest Text -makeLenses ''DappInfo -makeLenses ''DappContext - instance Show Test where show t = unpack $ extractSig t @@ -67,31 +58,31 @@ dappInfo root solcByName sources = let solcs = Map.elems solcByName - astIds = astIdMap $ snd <$> toList (view sourceAsts sources) - immutables = filter ((/=) mempty . (view immutableReferences)) solcs + astIds = astIdMap $ snd <$> Map.toList sources.asts + immutables = filter ((/=) mempty . (.immutableReferences)) solcs in DappInfo - { _dappRoot = root - , _dappUnitTests = findAllUnitTests solcs - , _dappSources = sources - , _dappSolcByName = solcByName - , _dappSolcByHash = + { root = root + , unitTests = findAllUnitTests solcs + , sources = sources + , solcByName = solcByName + , solcByHash = let - f g k = Map.fromList [(view g x, (k, x)) | x <- solcs] + f g k = Map.fromList [(g x, (k, x)) | x <- solcs] in mappend - (f runtimeCodehash Runtime) - (f creationCodehash Creation) + (f (.runtimeCodehash) Runtime) + (f (.creationCodehash) Creation) -- contracts with immutable locations can't be id by hash - , _dappSolcByCode = - [(Code (_runtimeCode x) (concat $ elems $ _immutableReferences x), x) | x <- immutables] + , solcByCode = + [(Code x.runtimeCode (concat $ Map.elems x.immutableReferences), x) | x <- immutables] -- Sum up the ABI maps from all the contracts. - , _dappAbiMap = mconcat (map (view abiMap) solcs) - , _dappEventMap = mconcat (map (view eventMap) solcs) - , _dappErrorMap = mconcat (map (view errorMap) solcs) + , abiMap = mconcat (map (.abiMap) solcs) + , eventMap = mconcat (map (.eventMap) solcs) + , errorMap = mconcat (map (.errorMap) solcs) - , _dappAstIdMap = astIds - , _dappAstSrcMap = astSrcMap astIds + , astIdMap = astIds + , astSrcMap = astSrcMap astIds } emptyDapp :: DappInfo @@ -123,24 +114,24 @@ findUnitTests :: Text -> ([SolcContract] -> [(Text, [(Test, [AbiType])])]) findUnitTests match = concatMap $ \c -> - case preview (abiMap . ix unitTestMarkerAbi) c of + case Map.lookup unitTestMarkerAbi c.abiMap of Nothing -> [] Just _ -> let testNames = unitTestMethodsFiltered (regexMatches match) c - in [(view contractName c, testNames) | not (BS.null (view runtimeCode c)) && not (null testNames)] + in [(c.contractName, testNames) | not (BS.null c.runtimeCode) && not (null testNames)] unitTestMethodsFiltered :: (Text -> Bool) -> (SolcContract -> [(Test, [AbiType])]) unitTestMethodsFiltered matcher c = let - testName method = (view contractName c) <> "." <> (extractSig (fst method)) + testName method = c.contractName <> "." <> (extractSig (fst method)) in filter (matcher . testName) (unitTestMethods c) unitTestMethods :: SolcContract -> [(Test, [AbiType])] unitTestMethods = - view abiMap + (.abiMap) >>> Map.elems - >>> map (\f -> (mkTest $ view methodSignature f, snd <$> view methodInputs f)) + >>> map (\f -> (mkTest f.methodSignature, snd <$> f.inputs)) >>> filter (isJust . fst) >>> fmap (first fromJust) @@ -150,41 +141,37 @@ extractSig (InvariantTest sig) = sig traceSrcMap :: DappInfo -> Trace -> Maybe SrcMap -traceSrcMap dapp trace = - let - h = view traceContract trace - i = view traceOpIx trace - in srcMap dapp h i +traceSrcMap dapp trace = srcMap dapp trace._traceContract trace._traceOpIx srcMap :: DappInfo -> Contract -> Int -> Maybe SrcMap srcMap dapp contr opIndex = do sol <- findSrc contr dapp - case view contractcode contr of + case contr._contractcode of (InitCode _ _) -> - preview (creationSrcmap . ix opIndex) sol + Seq.lookup opIndex sol.creationSrcmap (RuntimeCode _) -> - preview (runtimeSrcmap . ix opIndex) sol + Seq.lookup opIndex sol.runtimeSrcmap findSrc :: Contract -> DappInfo -> Maybe SolcContract findSrc c dapp = do - hash <- unlit (view codehash c) - case preview (dappSolcByHash . ix hash) dapp of + hash <- unlit c._codehash + case Map.lookup hash dapp.solcByHash of Just (_, v) -> Just v - Nothing -> lookupCode (view contractcode c) dapp + Nothing -> lookupCode c._contractcode dapp lookupCode :: ContractCode -> DappInfo -> Maybe SolcContract lookupCode (InitCode c _) a = - snd <$> preview (dappSolcByHash . ix (keccak' (stripBytecodeMetadata c))) a + snd <$> Map.lookup (keccak' (stripBytecodeMetadata c)) a.solcByHash lookupCode (RuntimeCode (ConcreteRuntimeCode c)) a = - case snd <$> preview (dappSolcByHash . ix (keccak' (stripBytecodeMetadata c))) a of + case snd <$> Map.lookup (keccak' (stripBytecodeMetadata c)) a.solcByHash of Just x -> return x - Nothing -> snd <$> find (compareCode c . fst) (view dappSolcByCode a) + Nothing -> snd <$> find (compareCode c . fst) a.solcByCode lookupCode (RuntimeCode (SymbolicRuntimeCode c)) a = let code = BS.pack $ mapMaybe unlitByte $ V.toList c - in case snd <$> preview (dappSolcByHash . ix (keccak' (stripBytecodeMetadata code))) a of + in case snd <$> Map.lookup (keccak' (stripBytecodeMetadata code)) a.solcByHash of Just x -> return x - Nothing -> snd <$> find (compareCode code . fst) (view dappSolcByCode a) + Nothing -> snd <$> find (compareCode code . fst) a.solcByCode compareCode :: ByteString -> Code -> Bool compareCode raw (Code template locs) = @@ -198,7 +185,7 @@ case traceSrcMap dapp trace of Nothing -> Left "" Just sm -> - case srcMapCodePos (view dappSources dapp) sm of + case srcMapCodePos dapp.sources sm of Nothing -> Left "" Just (fileName, lineIx) -> Right (fileName <> ":" <> pack (show lineIx)) diff --git a/src/EVM/Debug.hs b/src/EVM/Debug.hs --- a/src/EVM/Debug.hs +++ b/src/EVM/Debug.hs @@ -1,7 +1,7 @@ module EVM.Debug where import EVM (Contract, nonce, balance, bytecode, codehash) -import EVM.Solidity (SrcMap, srcMapFile, srcMapOffset, srcMapLength, SourceCache, sourceFiles) +import EVM.Solidity (SrcMap, srcMapFile, srcMapOffset, srcMapLength, SourceCache(..)) import EVM.Types (Addr) import EVM.Expr (bufLength) @@ -43,12 +43,12 @@ srcMapCodePos :: SourceCache -> SrcMap -> Maybe (Text, Int) srcMapCodePos cache sm = - fmap (second f) $ cache ^? sourceFiles . ix (srcMapFile sm) + fmap (second f) $ cache.files ^? ix sm.srcMapFile where - f v = ByteString.count 0xa (ByteString.take (srcMapOffset sm - 1) v) + 1 + f v = ByteString.count 0xa (ByteString.take (sm.srcMapOffset - 1) v) + 1 srcMapCode :: SourceCache -> SrcMap -> Maybe ByteString srcMapCode cache sm = - fmap f $ cache ^? sourceFiles . ix (srcMapFile sm) + fmap f $ cache.files ^? ix sm.srcMapFile where - f (_, v) = ByteString.take (min 80 (srcMapLength sm)) (ByteString.drop (srcMapOffset sm) v) + f (_, v) = ByteString.take (min 80 sm.srcMapLength) (ByteString.drop sm.srcMapOffset v) diff --git a/src/EVM/Dev.hs b/src/EVM/Dev.hs --- a/src/EVM/Dev.hs +++ b/src/EVM/Dev.hs @@ -19,6 +19,7 @@ import EVM import EVM.SMT +import EVM.Solvers import EVM.Types import EVM.Expr (numBranches, simplify) import EVM.SymExec diff --git a/src/EVM/Exec.hs b/src/EVM/Exec.hs --- a/src/EVM/Exec.hs +++ b/src/EVM/Exec.hs @@ -8,12 +8,10 @@ import qualified EVM.FeeSchedule as FeeSchedule import Control.Lens -import Control.Monad.State.Class (MonadState) -import Control.Monad.State.Strict (runState) +import Control.Monad.Trans.State.Strict (get, State) import Data.ByteString (ByteString) import Data.Maybe (isNothing) -import qualified Control.Monad.State.Class as State ethrunAddress :: Addr ethrunAddress = Addr 0x00a329c0648769a73afac7f9381e08fb43dbea72 @@ -47,26 +45,27 @@ }) & set (env . contracts . at ethrunAddress) (Just (initialContract (RuntimeCode (ConcreteRuntimeCode "")))) -exec :: MonadState VM m => m VMResult -exec = - use EVM.result >>= \case - Nothing -> State.state (runState exec1) >> exec - Just x -> return x +exec :: State VM VMResult +exec = do + vm <- get + case vm._result of + Nothing -> exec1 >> exec + Just r -> pure r -run :: MonadState VM m => m VM -run = - use EVM.result >>= \case - Nothing -> State.state (runState exec1) >> run - Just _ -> State.get +run :: State VM VM +run = do + vm <- get + case vm._result of + Nothing -> exec1 >> run + Just _ -> pure vm -execWhile :: MonadState VM m => (VM -> Bool) -> m Int +execWhile :: (VM -> Bool) -> State VM Int execWhile p = go 0 where go i = do - x <- State.get - if p x && isNothing (view result x) + vm <- get + if p vm && isNothing vm._result then do - State.state (runState exec1) go $! (i + 1) else - return i + pure i diff --git a/src/EVM/Expr.hs b/src/EVM/Expr.hs --- a/src/EVM/Expr.hs +++ b/src/EVM/Expr.hs @@ -678,6 +678,28 @@ | x == 0 = b | otherwise = a + -- 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 + + -- 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 + -- in infinite integers. In fact, it can be re-written as: + -- (a+(W256Max-b)+c), which is the same as: + -- (a+c+(W256Max-b)), which is the same as: + -- (a+(c-b)) + -- In other words, subtraction is just adding a much larger number. + -- So 3-1 mod 6 = 3+(6-1) mod 6 = 3+5 mod 6 = 5+3 mod 6 = 2 + go (Sub (Sub orig (Lit x)) (Lit y)) = Sub orig (Lit (y+x)) + go (Sub (Add orig (Lit x)) (Lit y)) = Sub orig (Lit (y-x)) + go (Add (Add orig (Lit x)) (Lit y)) = Add orig (Lit (y+x)) + go (Add (Sub orig (Lit x)) (Lit y)) = Add orig (Lit (y-x)) + -- redundant add / sub go o@(Sub (Add a b) c) | a == c = b diff --git a/src/EVM/Facts.hs b/src/EVM/Facts.hs --- a/src/EVM/Facts.hs +++ b/src/EVM/Facts.hs @@ -33,7 +33,7 @@ ) where import EVM (VM, Contract, Cache) -import EVM (balance, nonce, storage, bytecode, env, contracts, contract, state, cache, fetchedStorage, fetchedContracts) +import EVM (balance, nonce, storage, bytecode, env, contracts, cache, fetchedStorage, fetchedContracts) import EVM.Types (Addr, W256, Expr(..), num) import EVM.Expr (writeStorage, litAddr) @@ -112,15 +112,15 @@ contractFacts a x store = case view bytecode x of ConcreteBuf b -> storageFacts a store ++ - [ BalanceFact a (view balance x) - , NonceFact a (view nonce x) + [ BalanceFact a x._balance + , NonceFact a x._nonce , CodeFact a b ] _ -> -- here simply ignore storing the bytecode storageFacts a store ++ - [ BalanceFact a (view balance x) - , NonceFact a (view nonce x) + [ BalanceFact a x._balance + , NonceFact a x._nonce ] @@ -136,13 +136,13 @@ cacheFacts :: Cache -> Set Fact cacheFacts c = Set.fromList $ do - (k, v) <- Map.toList (view EVM.fetchedContracts c) - contractFacts k v (view EVM.fetchedStorage c) + (k, v) <- Map.toList c._fetchedContracts + contractFacts k v c._fetchedStorage vmFacts :: VM -> Set Fact vmFacts vm = Set.fromList $ do - (k, v) <- Map.toList (view (env . contracts) vm) - case view (env . storage) vm of + (k, v) <- Map.toList vm._env._contracts + case vm._env._storage of EmptyStore -> contractFacts k v Map.empty ConcreteStore s -> contractFacts k v s _ -> error "cannot serialize an abstract store" @@ -159,7 +159,7 @@ case fact of CodeFact {..} -> flip execState vm $ do assign (env . contracts . at addr) (Just (EVM.initialContract (EVM.RuntimeCode (EVM.ConcreteRuntimeCode blob)))) - when (view (state . contract) vm == addr) $ EVM.loadContract addr + when (vm._state._contract == addr) $ EVM.loadContract addr StorageFact {..} -> vm & over (env . storage) (writeStorage (litAddr addr) (Lit which) (Lit what)) BalanceFact {..} -> @@ -172,9 +172,9 @@ case fact of CodeFact {..} -> flip execState vm $ do assign (cache . fetchedContracts . at addr) (Just (EVM.initialContract (EVM.RuntimeCode (EVM.ConcreteRuntimeCode blob)))) - when (view (state . contract) vm == addr) $ EVM.loadContract addr + when (vm._state._contract == addr) $ EVM.loadContract addr StorageFact {..} -> let - store = view (cache . fetchedStorage) vm + store = vm._cache._fetchedStorage ctrct = Map.findWithDefault Map.empty (num addr) store in vm & set (cache . fetchedStorage) (Map.insert (num addr) (Map.insert which what ctrct) store) @@ -214,7 +214,7 @@ where mk :: AsASCII a => [ASCII] -> ASCII -> a -> File mk prefix base a = - File (Path (dump (addr fact) : prefix) base) + File (Path (dump fact.addr : prefix) base) (Data $ dump a) -- This lets us easier pattern match on serialized things. diff --git a/src/EVM/Fetch.hs b/src/EVM/Fetch.hs --- a/src/EVM/Fetch.hs +++ b/src/EVM/Fetch.hs @@ -8,6 +8,7 @@ import EVM.ABI import EVM.Types (Addr, W256, hexText, Expr(Lit), Expr(..), Prop(..), (.&&), (./=)) import EVM.SMT +import EVM.Solvers import EVM (EVM, Contract, Block, initialContract, nonce, balance, external) import qualified EVM.FeeSchedule as FeeSchedule diff --git a/src/EVM/Format.hs b/src/EVM/Format.hs --- a/src/EVM/Format.hs +++ b/src/EVM/Format.hs @@ -1,7 +1,6 @@ {-# Language DataKinds #-} {-# Language ImplicitParams #-} - module EVM.Format ( formatExpr , contractNamePart @@ -27,45 +26,39 @@ import Prelude hiding (Word) -import qualified EVM -import EVM.Dapp (DappInfo (..), dappSolcByHash, dappAbiMap, showTraceLocation, dappEventMap, dappErrorMap) -import EVM.Dapp (DappContext (..), contextInfo, contextEnv) -import EVM (VM, cheatCode, traceForest, traceData, Error (..)) -import EVM (Trace, TraceData (..), Query (..), FrameContext (..)) -import EVM.Types (maybeLitWord, W256 (..), num, word, Expr(..), EType(..)) -import EVM.Types (Addr, ByteStringS(..), Error(..)) -import EVM.ABI (AbiValue (..), Event (..), AbiType (..), SolError (..)) -import EVM.ABI (Indexed (NotIndexed), getAbiSeq) -import EVM.ABI (parseTypeName, formatString) -import EVM.Solidity (SolcContract(..), contractName, abiMap) -import EVM.Solidity (methodOutput, methodSignature, methodName) -import EVM.Hexdump - +import EVM qualified +import EVM (VM, cheatCode, traceForest, Error(..), Trace, + TraceData(..), Query(..), FrameContext(..)) +import EVM.ABI (AbiValue (..), Event (..), AbiType (..), SolError(..), + Indexed(NotIndexed), getAbiSeq, parseTypeName, formatString) +import EVM.Dapp (DappContext(..), DappInfo(..), showTraceLocation) +import EVM.Expr qualified as Expr +import EVM.Hexdump (prettyHex) +import EVM.Solidity (SolcContract(..), Method(..)) +import EVM.Types (maybeLitWord, W256(..), num, word, Expr(..), EType(..), Addr, + ByteStringS(..), Error(..)) import Control.Arrow ((>>>)) -import Control.Lens (view, preview, ix, _2, to, (^?!)) +import Control.Lens (preview, ix, _2) import Data.Binary.Get (runGetOrFail) -import Data.Bits (shiftR) +import Data.Bits (shiftR) import Data.ByteString (ByteString) +import Data.ByteString qualified as BS import Data.ByteString.Builder (byteStringHex, toLazyByteString) import Data.ByteString.Lazy (toStrict, fromStrict) +import Data.Char qualified as Char import Data.DoubleWord (signedWord) import Data.Foldable (toList) +import Data.Functor ((<&>)) +import Data.Map qualified as Map import Data.Maybe (catMaybes, fromMaybe, fromJust) -import Data.Text (Text, pack, unpack, intercalate) -import Data.Text (dropEnd, splitOn) +import Data.Text (Text, pack, unpack, intercalate, dropEnd, splitOn) +import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8, decodeUtf8') import Data.Tree.View (showTree) import Data.Vector (Vector) import Data.Word (Word32) import Numeric (showHex) -import qualified Data.ByteString as BS -import qualified Data.Char as Char -import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified EVM.Expr as Expr -import qualified Data.Text as T - data Signedness = Signed | Unsigned deriving (Show) @@ -73,7 +66,7 @@ showDec signed (W256 w) | i == num cheatCode = "" | (i :: Integer) == 2 ^ (256 :: Integer) - 1 = "MAX_UINT256" - | otherwise = Text.pack (show (i :: Integer)) + | otherwise = T.pack (show (i :: Integer)) where i = case signed of Signed -> num (signedWord w) @@ -85,18 +78,18 @@ showWordExplanation :: W256 -> DappInfo -> Text showWordExplanation w _ | w > 0xffffffff = showDec Unsigned w showWordExplanation w dapp = - case Map.lookup (fromIntegral w) (view dappAbiMap dapp) of + case Map.lookup (fromIntegral w) dapp.abiMap of Nothing -> showDec Unsigned w - Just x -> "keccak(\"" <> view methodSignature x <> "\")" + Just x -> "keccak(\"" <> x.methodSignature <> "\")" humanizeInteger :: (Num a, Integral a, Show a) => a -> Text humanizeInteger = - Text.intercalate "," + T.intercalate "," . reverse - . map Text.reverse - . Text.chunksOf 3 - . Text.reverse - . Text.pack + . map T.reverse + . T.chunksOf 3 + . T.reverse + . T.pack . show prettyIfConcreteWord :: Expr EWord -> Text @@ -109,14 +102,14 @@ showAbiValue (AbiBytesDynamic bs) = formatBytes bs showAbiValue (AbiBytes _ bs) = formatBinary bs showAbiValue (AbiAddress addr) = - let dappinfo = view contextInfo ?context - contracts = view contextEnv ?context - name = case (Map.lookup addr contracts) of + let dappinfo = ?context.info + contracts = ?context.env + name = case Map.lookup addr contracts of Nothing -> "" Just contract -> - let hash = maybeLitWord $ view EVM.codehash contract + let hash = maybeLitWord contract._codehash in case hash of - Just h -> maybeContractName' (preview (dappSolcByHash . ix h . _2) dappinfo) + Just h -> maybeContractName' (preview (ix h . _2) dappinfo.solcByHash) Nothing -> "" in name <> "@" <> (pack $ show addr) @@ -147,9 +140,9 @@ showError :: (?context :: DappContext) => Expr Buf -> Text showError (ConcreteBuf bs) = - let dappinfo = view contextInfo ?context + let dappinfo = ?context.info bs4 = BS.take 4 bs - in case Map.lookup (word bs4) (view dappErrorMap dappinfo) of + in case Map.lookup (word bs4) dappinfo.errorMap of Just (SolError errName ts) -> errName <> " " <> showCall ts (ConcreteBuf bs) Nothing -> case bs4 of -- Method ID for Error(string) @@ -165,7 +158,7 @@ decodeUtf8' >>> either (const False) - (Text.all (\c-> Char.isPrint c && (not . Char.isControl) c)) + (T.all (\c-> Char.isPrint c && (not . Char.isControl) c)) formatBytes :: ByteString -> Text formatBytes b = @@ -177,7 +170,7 @@ -- a string that came from bytes, displayed with special quotes formatBString :: ByteString -> Text -formatBString b = mconcat [ "«", Text.dropAround (=='"') (pack $ formatString b), "»" ] +formatBString b = mconcat [ "«", T.dropAround (=='"') (pack $ formatString b), "»" ] formatBinary :: ByteString -> Text formatBinary = @@ -199,14 +192,14 @@ showTrace :: DappInfo -> VM -> Trace -> Text showTrace dapp vm trace = - let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env . EVM.contracts } + let ?context = DappContext { info = dapp, env = vm._env._contracts } in let pos = case showTraceLocation dapp trace of Left x -> " \x1b[1m" <> x <> "\x1b[0m" Right x -> " \x1b[1m(" <> x <> ")\x1b[0m" - fullAbiMap = view dappAbiMap dapp - in case view traceData trace of + fullAbiMap = dapp.abiMap + in case trace._traceData of EventTrace _ bytes topics -> let logn = mconcat [ "\x1b[36m" @@ -233,7 +226,7 @@ (t1:_) -> case maybeLitWord t1 of Just topic -> - case Map.lookup (topic) (view dappEventMap dapp) of + case Map.lookup topic dapp.eventMap of Just (Event name _ types) -> knownTopic name types Nothing -> @@ -255,9 +248,9 @@ Nothing -> "" in - case Map.lookup sig (view dappAbiMap dapp) of + case Map.lookup sig dapp.abiMap of Just m -> - lognote (view methodSignature m) usr + lognote m.methodSignature usr Nothing -> logn _ -> @@ -289,7 +282,7 @@ "← " <> case Map.lookup (fromIntegral abi) fullAbiMap of Just m -> - case unzip (view methodOutput m) of + case unzip m.output of ([], []) -> formatSBinary out (_, ts) -> @@ -305,7 +298,7 @@ t FrameTrace (CreationContext addr (Lit hash) _ _ ) -> -- FIXME: irrefutable pattern "create " - <> maybeContractName (preview (dappSolcByHash . ix hash . _2) dapp) + <> maybeContractName (preview (ix hash . _2) dapp.solcByHash) <> "@" <> pack (show addr) <> pos FrameTrace (CreationContext addr _ _ _ ) -> @@ -318,7 +311,7 @@ then "call " else "delegatecall " hash' = fromJust $ maybeLitWord hash - in case preview (dappSolcByHash . ix hash' . _2) dapp of + in case preview (ix hash' . _2) dapp.solcByHash of Nothing -> calltype <> pack (show target) @@ -326,9 +319,9 @@ <> case Map.lookup (fromIntegral (fromMaybe 0x00 abi)) fullAbiMap of Just m -> "\x1b[1m" - <> view methodName m + <> m.name <> "\x1b[0m" - <> showCall (catMaybes (getAbiTypes (view methodSignature m))) calldata + <> showCall (catMaybes (getAbiTypes m.methodSignature)) calldata Nothing -> formatSBinary calldata <> pos @@ -336,7 +329,7 @@ Just solc -> calltype <> "\x1b[1m" - <> view (contractName . to contractNamePart) solc + <> contractNamePart solc.contractName <> "::" <> maybe "[fallback function]" (fromMaybe "[unknown method]" . maybeAbiName solc) @@ -356,20 +349,20 @@ maybeContractName :: Maybe SolcContract -> Text maybeContractName = - maybe "" (view (contractName . to contractNamePart)) + maybe "" (contractNamePart . (.contractName)) maybeContractName' :: Maybe SolcContract -> Text maybeContractName' = - maybe "" (view (contractName . to contractNamePart)) + maybe "" (contractNamePart . (.contractName)) maybeAbiName :: SolcContract -> W256 -> Maybe Text -maybeAbiName solc abi = preview (abiMap . ix (fromIntegral abi) . methodSignature) solc +maybeAbiName solc abi = Map.lookup (fromIntegral abi) solc.abiMap <&> (.methodSignature) contractNamePart :: Text -> Text -contractNamePart x = Text.split (== ':') x !! 1 +contractNamePart x = T.split (== ':') x !! 1 contractPathPart :: Text -> Text -contractPathPart x = Text.split (== ':') x !! 0 +contractPathPart x = T.split (== ':') x !! 0 prettyError :: EVM.Types.Error -> String prettyError= \case @@ -379,6 +372,7 @@ EVM.Types.StackLimitExceeded -> "Stack limit exceeded" EVM.Types.InvalidMemoryAccess -> "Invalid memory access" EVM.Types.BadJumpDestination -> "Bad jump destination" + EVM.Types.StackUnderrun -> "Stack underrun" TmpErr err -> "Temp error: " <> err diff --git a/src/EVM/Keccak.hs b/src/EVM/Keccak.hs --- a/src/EVM/Keccak.hs +++ b/src/EVM/Keccak.hs @@ -27,7 +27,7 @@ go = \case e@(Keccak _) -> do s <- get - put $ s{keccaks=Set.insert e (keccaks s)} + put $ s{keccaks=Set.insert e s.keccaks} pure e e -> pure e @@ -73,7 +73,7 @@ where (_, st) = runState (findKeccakPropsExprs ps bufs stores) initState - injectivity = fmap injProp $ combine (Set.toList (keccaks st)) - minValue = fmap minProp (Set.toList (keccaks st)) + injectivity = fmap injProp $ combine (Set.toList st.keccaks) + minValue = fmap minProp (Set.toList st.keccaks) diff --git a/src/EVM/Op.hs b/src/EVM/Op.hs --- a/src/EVM/Op.hs +++ b/src/EVM/Op.hs @@ -62,6 +62,7 @@ | OpGaslimit | OpChainid | OpSelfbalance + | OpBaseFee | OpPop | OpMload | OpMstore @@ -145,6 +146,7 @@ OpGaslimit -> "GASLIMIT" OpChainid -> "CHAINID" OpSelfbalance -> "SELFBALANCE" + OpBaseFee -> "BASEFEE" OpPop -> "POP" OpMload -> "MLOAD" OpMstore -> "MSTORE" diff --git a/src/EVM/SMT.hs b/src/EVM/SMT.hs --- a/src/EVM/SMT.hs +++ b/src/EVM/SMT.hs @@ -13,33 +13,28 @@ import Prelude hiding (LT, GT) -import GHC.Natural import Control.Monad -import GHC.IO.Handle (Handle, hFlush, hSetBuffering, BufferMode(..)) -import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan) -import Control.Concurrent (forkIO, killThread) -import Data.Char (isSpace) import Data.Containers.ListUtils (nubOrd) import Language.SMT2.Parser (getValueRes, parseCommentFreeFileMsg) -import Language.SMT2.Syntax (SpecConstant(..), GeneralRes(..), Term(..), QualIdentifier(..), Identifier(..), Sort(..), Index(..), VarBinding(..)) +import Language.SMT2.Syntax (Symbol, SpecConstant(..), GeneralRes(..), Term(..), QualIdentifier(..), Identifier(..), Sort(..), Index(..), VarBinding(..)) import Data.Word -import Numeric (readHex) +import Numeric (readHex, readBin) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.List as List import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NonEmpty import Data.String.Here -import Data.Maybe +import Data.Maybe (fromJust) import Data.Map (Map) import qualified Data.Map as Map import Data.Text.Lazy (Text) import qualified Data.Text as TS import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as T import Data.Text.Lazy.Builder import Data.Bifunctor (second) -import System.Process (createProcess, cleanupProcess, proc, ProcessHandle, std_in, std_out, std_err, StdStream(..)) +import Data.Semigroup (Any, Any(..), getAny) import EVM.Types import EVM.Traversals @@ -53,18 +48,20 @@ data CexVars = CexVars { calldataV :: [Text] , buffersV :: [Text] + , storeReads :: [(Expr EWord, Expr EWord)] -- a list of relevant store reads , blockContextV :: [Text] , txContextV :: [Text] } deriving (Eq, Show) instance Semigroup CexVars where - (CexVars a b c d) <> (CexVars a2 b2 c2 d2) = CexVars (a <> a2) (b <> b2) (c <> c2) (d <> d2) + (CexVars a b c d e) <> (CexVars a2 b2 c2 d2 e2) = CexVars (a <> a2) (b <> b2) (c <> c2) (d <> d2) (e <> e2) instance Monoid CexVars where mempty = CexVars { calldataV = mempty , buffersV = mempty + , storeReads = mempty , blockContextV = mempty , txContextV = mempty } @@ -72,13 +69,14 @@ data SMTCex = SMTCex { vars :: Map (Expr EWord) W256 , buffers :: Map (Expr Buf) ByteString + , store :: Map W256 (Map W256 W256) , blockContext :: Map (Expr EWord) W256 , txContext :: Map (Expr EWord) W256 } deriving (Eq, Show) getVar :: EVM.SMT.SMTCex -> TS.Text -> W256 -getVar cex name = fromJust $ Map.lookup (Var name) (vars cex) +getVar cex name = fromJust $ Map.lookup (Var name) cex.vars data SMT2 = SMT2 [Builder] CexVars deriving (Eq, Show) @@ -125,6 +123,7 @@ <> keccakAssumes <> SMT2 [""] mempty <> SMT2 (fmap (\p -> "(assert " <> p <> ")") encs) mempty + <> SMT2 [] mempty{storeReads = storageReads} where (ps_elim, bufs, stores) = eliminateProps ps @@ -137,11 +136,125 @@ bufVals = Map.elems bufs storeVals = Map.elems stores + storageReads = nubOrd $ concatMap findStorageReads ps + keccakAssumes = SMT2 ["; keccak assumptions"] mempty <> SMT2 (fmap (\p -> "(assert " <> propToSMT p <> ")") (keccakAssumptions ps_elim bufVals storeVals)) mempty +referencedBufsGo :: Expr a -> [Builder] +referencedBufsGo = \case + AbstractBuf s -> [fromText s] + _ -> [] + +referencedBufs :: Expr a -> [Builder] +referencedBufs expr = nubOrd $ foldExpr referencedBufsGo [] expr + +referencedBufs' :: Prop -> [Builder] +referencedBufs' prop = nubOrd $ foldProp referencedBufsGo [] prop + + +referencedVarsGo :: Expr a -> [Builder] +referencedVarsGo = \case + Var s -> [fromText s] + _ -> [] + +referencedVars :: Expr a -> [Builder] +referencedVars expr = nubOrd $ foldExpr referencedVarsGo [] expr + +referencedVars' :: Prop -> [Builder] +referencedVars' prop = nubOrd $ foldProp referencedVarsGo [] prop + + +referencedFrameContextGo :: Expr a -> [Builder] +referencedFrameContextGo = \case + CallValue a -> [fromLazyText $ T.append "callvalue_" (T.pack . show $ a)] + Caller a -> [fromLazyText $ T.append "caller_" (T.pack . show $ a)] + Address a -> [fromLazyText $ T.append "address_" (T.pack . show $ a)] + Balance {} -> error "TODO: BALANCE" + SelfBalance {} -> error "TODO: SELFBALANCE" + Gas {} -> error "TODO: GAS" + _ -> [] + +referencedFrameContext :: Expr a -> [Builder] +referencedFrameContext expr = nubOrd $ foldExpr referencedFrameContextGo [] expr + +referencedFrameContext' :: Prop -> [Builder] +referencedFrameContext' prop = nubOrd $ foldProp referencedFrameContextGo [] prop + + +referencedBlockContextGo :: Expr a -> [Builder] +referencedBlockContextGo = \case + Origin -> ["origin"] + Coinbase -> ["coinbase"] + Timestamp -> ["timestamp"] + BlockNumber -> ["blocknumber"] + PrevRandao -> ["prevrandao"] + GasLimit -> ["gaslimit"] + ChainId -> ["chainid"] + BaseFee -> ["basefee"] + _ -> [] + +referencedBlockContext :: Expr a -> [Builder] +referencedBlockContext expr = nubOrd $ foldExpr referencedBlockContextGo [] expr + +referencedBlockContext' :: Prop -> [Builder] +referencedBlockContext' prop = nubOrd $ foldProp referencedBlockContextGo [] prop + + +isAbstractStorage :: Expr Storage -> Bool +isAbstractStorage = getAny . foldExpr go (Any False) + where + go :: Expr a -> Any + go AbstractStore = Any True + go _ = Any False + +-- | This function overapproximates the reads from the abstract +-- storage. Potentially, it can return locations that do not read a +-- slot directly from the abstract store but from subsequent writes on +-- the store (e.g, SLoad addr idx (SStore addr idx val AbstractStore)). +-- However, we expect that most of such reads will have been +-- simplified away. +findStorageReads :: Prop -> [(Expr EWord, Expr EWord)] +findStorageReads = foldProp go [] + where + go :: Expr a -> [(Expr EWord, Expr EWord)] + go = \case + SLoad addr slot storage -> [(addr, slot) | isAbstractStorage storage] + _ -> [] + + +declareBufs :: [Builder] -> SMT2 +declareBufs names = SMT2 ("; buffers" : fmap declareBuf names <> ("; buffer lengths" : fmap declareLength names)) cexvars + where + declareBuf n = "(declare-const " <> n <> " (Array (_ BitVec 256) (_ BitVec 8)))" + declareLength n = "(define-const " <> n <> "_length" <> " (_ BitVec 256) (bufLength " <> n <> "))" + cexvars = mempty{buffersV = fmap toLazyText names} + + +-- Given a list of 256b VM variable names, create an SMT2 object with the variables declared +declareVars :: [Builder] -> SMT2 +declareVars names = SMT2 (["; variables"] <> fmap declare names) cexvars + where + declare n = "(declare-const " <> n <> " (_ BitVec 256))" + cexvars = mempty{calldataV = fmap toLazyText names} + + +declareFrameContext :: [Builder] -> SMT2 +declareFrameContext names = SMT2 (["; frame context"] <> fmap declare names) cexvars + where + declare n = "(declare-const " <> n <> " (_ BitVec 256))" + cexvars = mempty{txContextV = fmap toLazyText names} + + +declareBlockContext :: [Builder] -> SMT2 +declareBlockContext names = SMT2 (["; block context"] <> fmap declare names) cexvars + where + declare n = "(declare-const " <> n <> " (_ BitVec 256))" + cexvars = mempty{blockContextV = fmap toLazyText names} + + prelude :: SMT2 prelude = (flip SMT2) mempty $ fmap (fromLazyText . T.drop 2) . T.lines $ [i| ; logic @@ -348,6 +461,7 @@ (ite (= b (_ bv28 256)) ((_ sign_extend 24 ) ((_ extract 231 0) val)) (ite (= b (_ bv29 256)) ((_ sign_extend 16 ) ((_ extract 239 0) val)) (ite (= b (_ bv30 256)) ((_ sign_extend 8 ) ((_ extract 247 0) val)) val)))))))))))))))))))))))))))))))) + ; storage (declare-const abstractStore Storage) (define-const emptyStore Storage ((as const Storage) ((as const (Array (_ BitVec 256) (_ BitVec 256))) #x0000000000000000000000000000000000000000000000000000000000000000))) @@ -357,145 +471,7 @@ (define-fun sload ((addr Word) (key Word) (storage Storage)) Word (select (select storage addr) key)) |] -declareBufs :: [Builder] -> SMT2 -declareBufs names = SMT2 ("; buffers" : fmap declareBuf names <> ("; buffer lengths" : fmap declareLength names)) cexvars - where - declareBuf n = "(declare-const " <> n <> " (Array (_ BitVec 256) (_ BitVec 8)))" - declareLength n = "(define-const " <> n <> "_length" <> " (_ BitVec 256) (bufLength " <> n <> "))" - cexvars = CexVars - { calldataV = mempty - , buffersV = (fmap toLazyText names) - , blockContextV = mempty - , txContextV = mempty - } -referencedBufs :: Expr a -> [Builder] -referencedBufs expr = nubOrd (foldExpr go [] expr) - where - go :: Expr a -> [Builder] - go = \case - AbstractBuf s -> [fromText s] - _ -> [] - -referencedBufs' :: Prop -> [Builder] -referencedBufs' = \case - PEq a b -> nubOrd $ referencedBufs a <> referencedBufs b - PLT a b -> nubOrd $ referencedBufs a <> referencedBufs b - PGT a b -> nubOrd $ referencedBufs a <> referencedBufs b - PLEq a b -> nubOrd $ referencedBufs a <> referencedBufs b - PGEq a b -> nubOrd $ referencedBufs a <> referencedBufs b - PAnd a b -> nubOrd $ referencedBufs' a <> referencedBufs' b - POr a b -> nubOrd $ referencedBufs' a <> referencedBufs' b - PNeg a -> referencedBufs' a - PBool _ -> [] - -referencedVars' :: Prop -> [Builder] -referencedVars' = \case - PEq a b -> nubOrd $ referencedVars a <> referencedVars b - PLT a b -> nubOrd $ referencedVars a <> referencedVars b - PGT a b -> nubOrd $ referencedVars a <> referencedVars b - PLEq a b -> nubOrd $ referencedVars a <> referencedVars b - PGEq a b -> nubOrd $ referencedVars a <> referencedVars b - PAnd a b -> nubOrd $ referencedVars' a <> referencedVars' b - POr a b -> nubOrd $ referencedVars' a <> referencedVars' b - PNeg a -> referencedVars' a - PBool _ -> [] - -referencedFrameContext' :: Prop -> [Builder] -referencedFrameContext' = \case - PEq a b -> nubOrd $ referencedFrameContext a <> referencedFrameContext b - PLT a b -> nubOrd $ referencedFrameContext a <> referencedFrameContext b - PGT a b -> nubOrd $ referencedFrameContext a <> referencedFrameContext b - PLEq a b -> nubOrd $ referencedFrameContext a <> referencedFrameContext b - PGEq a b -> nubOrd $ referencedFrameContext a <> referencedFrameContext b - PAnd a b -> nubOrd $ referencedFrameContext' a <> referencedFrameContext' b - POr a b -> nubOrd $ referencedFrameContext' a <> referencedFrameContext' b - PNeg a -> referencedFrameContext' a - PBool _ -> [] - -referencedBlockContext' :: Prop -> [Builder] -referencedBlockContext' = \case - PEq a b -> nubOrd $ referencedBlockContext a <> referencedBlockContext b - PLT a b -> nubOrd $ referencedBlockContext a <> referencedBlockContext b - PGT a b -> nubOrd $ referencedBlockContext a <> referencedBlockContext b - PLEq a b -> nubOrd $ referencedBlockContext a <> referencedBlockContext b - PGEq a b -> nubOrd $ referencedBlockContext a <> referencedBlockContext b - PAnd a b -> nubOrd $ referencedBlockContext' a <> referencedBlockContext' b - POr a b -> nubOrd $ referencedBlockContext' a <> referencedBlockContext' b - PNeg a -> referencedBlockContext' a - PBool _ -> [] - --- Given a list of 256b VM variable names, create an SMT2 object with the variables declared -declareVars :: [Builder] -> SMT2 -declareVars names = SMT2 (["; variables"] <> fmap declare names) cexvars - where - declare n = "(declare-const " <> n <> " (_ BitVec 256))" - cexvars = CexVars - { calldataV = fmap toLazyText names - , buffersV = mempty - , blockContextV = mempty - , txContextV = mempty - } - -referencedVars :: Expr a -> [Builder] -referencedVars expr = nubOrd (foldExpr go [] expr) - where - go :: Expr a -> [Builder] - go = \case - Var s -> [fromText s] - _ -> [] - -declareFrameContext :: [Builder] -> SMT2 -declareFrameContext names = SMT2 (["; frame context"] <> fmap declare names) cexvars - where - declare n = "(declare-const " <> n <> " (_ BitVec 256))" - cexvars = CexVars - { calldataV = mempty - , buffersV = mempty - , blockContextV = mempty - , txContextV = fmap toLazyText names - } - -referencedFrameContext :: Expr a -> [Builder] -referencedFrameContext expr = nubOrd (foldExpr go [] expr) - where - go :: Expr a -> [Builder] - go = \case - CallValue a -> [fromLazyText $ T.append "callvalue_" (T.pack . show $ a)] - Caller a -> [fromLazyText $ T.append "caller_" (T.pack . show $ a)] - Address a -> [fromLazyText $ T.append "address_" (T.pack . show $ a)] - Balance {} -> error "TODO: BALANCE" - SelfBalance {} -> error "TODO: SELFBALANCE" - Gas {} -> error "TODO: GAS" - _ -> [] - -declareBlockContext :: [Builder] -> SMT2 -declareBlockContext names = SMT2 (["; block context"] <> fmap declare names) cexvars - where - declare n = "(declare-const " <> n <> " (_ BitVec 256))" - cexvars = CexVars - { calldataV = mempty - , buffersV = mempty - , blockContextV = fmap toLazyText names - , txContextV = mempty - } - -referencedBlockContext :: Expr a -> [Builder] -referencedBlockContext expr = nubOrd (foldExpr go [] expr) - where - go :: Expr a -> [Builder] - go = \case - Origin -> ["origin"] - Coinbase -> ["coinbase"] - Timestamp -> ["timestamp"] - BlockNumber -> ["blocknumber"] - PrevRandao -> ["prevrandao"] - GasLimit -> ["gaslimit"] - ChainId -> ["chainid"] - BaseFee -> ["basefee"] - _ -> [] - - exprToSMT :: Expr a -> Builder exprToSMT = \case Lit w -> fromLazyText $ "(_ bv" <> (T.pack $ show (num w :: Integer)) <> " 256)" @@ -565,6 +541,14 @@ bLift = "(concat (_ bv0 256) " <> bExp <> ")" cLift = "(concat (_ bv0 256) " <> cExp <> ")" in "((_ extract 255 0) (ite (= " <> cExp <> " (_ bv0 256)) (_ bv0 512) (bvurem (bvmul " <> aLift `sp` bLift <> ")" <> cLift <> ")))" + AddMod a b c -> + let aExp = exprToSMT a + bExp = exprToSMT b + cExp = exprToSMT c + aLift = "(concat (_ bv0 256) " <> aExp <> ")" + bLift = "(concat (_ bv0 256) " <> bExp <> ")" + cLift = "(concat (_ bv0 256) " <> cExp <> ")" + in "((_ extract 255 0) (ite (= " <> cExp <> " (_ bv0 256)) (_ bv0 512) (bvurem (bvadd " <> aLift `sp` bLift <> ")" <> cLift <> ")))" EqByte a b -> let cond = op2 "=" a b in "(ite " <> cond `sp` one `sp` zero <> ")" @@ -684,71 +668,70 @@ "(" <> op <> " " <> aenc <> " " <> benc <> ")" --- ** Execution ** ------------------------------------------------------------------------------- +-- ** Helpers ** --------------------------------------------------------------------------------- --- | Supported solvers -data Solver - = Z3 - | CVC5 - | Bitwuzla - | Custom Text -instance Show Solver where - show Z3 = "z3" - show CVC5 = "cvc5" - show Bitwuzla = "bitwuzla" - show (Custom s) = T.unpack s +-- | Stores a region of src into dst +copySlice :: Expr EWord -> Expr EWord -> Expr EWord -> Builder -> Builder -> Builder +copySlice srcOffset dstOffset size@(Lit _) src dst + | size == (Lit 0) = dst + | otherwise = + let size' = (sub size (Lit 1)) + encDstOff = exprToSMT (add dstOffset size') + encSrcOff = exprToSMT (add srcOffset size') + child = copySlice srcOffset dstOffset size' src dst in + "(store " <> child `sp` encDstOff `sp` "(select " <> src `sp` encSrcOff <> "))" +copySlice _ _ _ _ _ = error "TODO: implement copySlice with a symbolically sized region" +-- | Unrolls an exponentiation into a series of multiplications +expandExp :: Expr EWord -> W256 -> Builder +expandExp base expnt + | expnt == 1 = exprToSMT base + | otherwise = + let b = exprToSMT base + n = expandExp base (expnt - 1) in + "(bvmul " <> b `sp` n <> ")" --- | A running solver instance -data SolverInstance = SolverInstance - { _type :: Solver - , _stdin :: Handle - , _stdout :: Handle - , _stderr :: Handle - , _process :: ProcessHandle - } +-- | Concatenates a list of bytes into a larger bitvector +concatBytes :: [Expr Byte] -> Builder +concatBytes bytes = + let bytesRev = reverse bytes + a2 = exprToSMT (head bytesRev) in + foldl wrap a2 $ tail bytesRev + where + wrap inner byte = + let byteSMT = exprToSMT byte in + "(concat " <> byteSMT `sp` inner <> ")" --- | A channel representing a group of solvers -newtype SolverGroup = SolverGroup (Chan Task) +-- | Concatenates a list of bytes into a larger bitvector +writeBytes :: ByteString -> Expr Buf -> Builder +writeBytes bytes buf = snd $ BS.foldl' wrap (0, exprToSMT buf) bytes + where + -- we don't need to store zeros if the base buffer is empty + skipZeros = buf == mempty + wrap :: (Int, Builder) -> Word8 -> (Int, Builder) + wrap (idx, inner) byte = + if skipZeros && byte == 0 + then (idx + 1, inner) + else let + byteSMT = exprToSMT (LitByte byte) + idxSMT = exprToSMT . Lit . num $ idx + in (idx + 1, "(store " <> inner `sp` idxSMT `sp` byteSMT <> ")") --- | 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 - } +encodeConcreteStore :: Map W256 (Map W256 W256) -> Builder +encodeConcreteStore s = foldl encodeWrite "emptyStore" writes + where + asList = fmap (second Map.toList) $ Map.toList s + writes = concatMap (\(addr, ws) -> fmap (\(k, v) -> (addr, k, v)) ws) asList + encodeWrite prev (addr, key, val) = let + encAddr = exprToSMT (Lit addr) + encKey = exprToSMT (Lit key) + encVal = exprToSMT (Lit val) + in "(sstore " <> encAddr `sp` encKey `sp` encVal `sp` prev <> ")" --- | The result of a call to (check-sat) -data CheckSatResult - = Sat SMTCex - | Unsat - | Unknown - | Error TS.Text - deriving (Show, Eq) -isSat :: CheckSatResult -> Bool -isSat (Sat _) = True -isSat _ = False - -isErr :: CheckSatResult -> Bool -isErr (Error _) = True -isErr _ = False - -isUnsat :: CheckSatResult -> Bool -isUnsat Unsat = True -isUnsat _ = False - -checkSat :: SolverGroup -> SMT2 -> IO CheckSatResult -checkSat (SolverGroup taskQueue) script = do - -- prepare result channel - resChan <- newChan - - -- send task to solver group - writeChan taskQueue (Task script resChan) - - -- collect result - readChan resChan +-- ** Cex parsing ** -------------------------------------------------------------------------------- parseW256 :: SpecConstant -> W256 parseW256 = parseSC @@ -759,6 +742,11 @@ parseW8 :: SpecConstant -> Word8 parseW8 = parseSC +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 sc = error $ "Internal Error: cannot parse: " <> show sc + parseErr :: (Show a) => a -> b parseErr res = error $ "Internal Error: cannot parse solver response: " <> show res @@ -783,12 +771,12 @@ ('a':'d':'d':'r':'e':'s':'s':'_':frame) -> Address (read frame) t -> error $ "Internal Error: cannot parse " <> t <> " into an Expr" -getVars :: (TS.Text -> Expr EWord) -> SolverInstance -> [TS.Text] -> IO (Map (Expr EWord) W256) -getVars parseFn inst names = Map.mapKeys parseFn <$> foldM getOne mempty names +getVars :: (TS.Text -> Expr EWord) -> (Text -> IO Text) -> [TS.Text] -> IO (Map (Expr EWord) W256) +getVars parseFn getVal names = Map.mapKeys parseFn <$> foldM getOne mempty names where getOne :: Map TS.Text W256 -> TS.Text -> IO (Map TS.Text W256) getOne acc name = do - raw <- getValue inst (T.fromStrict name) + raw <- getVal (T.fromStrict name) let parsed = case parseCommentFreeFileMsg getValueRes (T.toStrict raw) of Right (ResSpecific (valParsed :| [])) -> valParsed @@ -803,12 +791,12 @@ r -> parseErr r pure $ Map.insert name val acc -getBufs :: SolverInstance -> [TS.Text] -> IO (Map (Expr Buf) ByteString) -getBufs inst names = foldM getBuf mempty names +getBufs :: (Text -> IO Text) -> [TS.Text] -> IO (Map (Expr Buf) ByteString) +getBufs getVal names = foldM getBuf mempty names where getLength :: TS.Text -> IO Int getLength name = do - val <- getValue inst (T.fromStrict name <> "_length") + val <- getVal (T.fromStrict name <> "_length") len <- case parseCommentFreeFileMsg getValueRes (T.toStrict val) of Right (ResSpecific (parsed :| [])) -> case parsed of (TermQualIdentifier (Unqualified (IdSymbol symbol)), (TermSpecConstant sc)) @@ -833,7 +821,7 @@ -- this buffer and then use that to produce a shorter counterexample (by -- replicating the constant byte up to the length). len <- getLength name - val <- getValue inst (T.fromStrict name) + val <- getVal (T.fromStrict name) buf <- case parseCommentFreeFileMsg getValueRes (T.toStrict val) of Right (ResSpecific (valParsed :| [])) -> case valParsed of (TermQualIdentifier (Unqualified (IdSymbol symbol)), term) @@ -886,213 +874,91 @@ <> " in environment mapping" p -> parseErr p - -parseSC :: (Num a, Eq a) => SpecConstant -> a -parseSC (SCHexadecimal a) = fst . head . Numeric.readHex . T.unpack . T.fromStrict $ a -parseSC sc = error $ "Internal Error: cannot parse: " <> show sc - -withSolvers :: Solver -> Natural -> Maybe Natural -> (SolverGroup -> IO a) -> IO a -withSolvers solver count timeout cont = do - -- spawn solvers - instances <- mapM (const $ spawnSolver solver timeout) [1..count] - - -- spawn orchestration thread - taskQueue <- newChan - availableInstances <- newChan - forM_ instances (writeChan availableInstances) - orchestrateId <- forkIO $ orchestrate taskQueue availableInstances +getStore :: (Text -> IO Text) -> [(Expr EWord, Expr EWord)] -> IO (Map W256 (Map W256 W256)) +getStore getVal sreads = do + raw <- getVal "abstractStore" + let parsed = case parseCommentFreeFileMsg getValueRes (T.toStrict raw) of + Right (ResSpecific (valParsed :| [])) -> valParsed + r -> parseErr r + -- first interpret SMT term as a function + fun = case parsed of + (TermQualIdentifier (Unqualified (IdSymbol symbol)), term) -> + if symbol == "abstractStore" + then interpret2DArray Map.empty term + else error "Internal Error: solver did not return model for requested value" + r -> parseErr r - -- run continuation with task queue - res <- cont (SolverGroup taskQueue) + -- then create a map by adding only the locations that are read by the program + foldM (\m (addr, slot) -> do + addr' <- queryValue addr + slot' <- queryValue slot + pure $ addElem addr' slot' m fun) Map.empty sreads - -- cleanup and return results - mapM_ stopSolver instances - killThread orchestrateId - pure res where - orchestrate queue avail = do - task <- readChan queue - inst <- readChan avail - _ <- forkIO $ runTask task inst avail - orchestrate queue avail - runTask (Task (SMT2 cmds cexvars) r) inst availableInstances = do - -- reset solver and send all lines of provided script - out <- sendScript inst (SMT2 ("(reset)" : cmds) cexvars) - case out of - -- if we got an error then return it - Left e -> writeChan r (Error ("error while writing SMT to solver: " <> T.toStrict e)) - -- otherwise call (check-sat), parse the result, and send it down the result channel - Right () -> do - sat <- sendLine inst "(check-sat)" - res <- case sat of - "sat" -> do - calldatamodels <- getVars parseVar inst (fmap T.toStrict $ calldataV cexvars) - buffermodels <- getBufs inst (fmap T.toStrict $ buffersV cexvars) - blockctxmodels <- getVars parseBlockCtx inst (fmap T.toStrict $ blockContextV cexvars) - txctxmodels <- getVars parseFrameCtx inst (fmap T.toStrict $ txContextV cexvars) - pure $ Sat $ SMTCex - { vars = calldatamodels - , buffers = buffermodels - , blockContext = blockctxmodels - , txContext = txctxmodels - } - "unsat" -> pure Unsat - "timeout" -> pure Unknown - "unknown" -> pure Unknown - _ -> pure . Error $ T.toStrict $ "Unable to parse solver output: " <> sat - writeChan r res + addElem :: W256 -> W256 -> Map W256 (Map W256 W256) -> (W256 -> W256 -> W256) -> Map W256 (Map W256 W256) + addElem addr slot store fun = + case Map.lookup addr store of + Just m -> Map.insert addr (Map.insert slot (fun addr slot) m) store + Nothing -> Map.insert addr (Map.singleton slot (fun addr slot)) store - -- put the instance back in the list of available instances - writeChan availableInstances inst --- | Arguments used when spawing a solver instance -solverArgs :: Solver -> Maybe (Natural) -> [Text] -solverArgs solver timeout = case solver of - Bitwuzla -> error "TODO: Bitwuzla args" - Z3 -> - [ "-in" ] - CVC5 -> - [ "--lang=smt" - , "--no-interactive" - , "--produce-models" - , "--tlimit-per=" <> T.pack (show (1000 * fromMaybe 10 timeout)) - ] - Custom _ -> [] + queryValue :: Expr EWord -> IO W256 + queryValue (Lit w) = pure w + queryValue w = do + let expr = toLazyText $ exprToSMT w + raw <- getVal expr + case parseCommentFreeFileMsg getValueRes (T.toStrict raw) of + Right (ResSpecific (valParsed :| [])) -> + case valParsed of + (_, TermSpecConstant sc) -> pure $ parseW256 sc + _ -> error "Internal Error: cannot parse model for storage index" + r -> parseErr r --- | Spawns a solver instance, and sets the various global config options that we use for our queries -spawnSolver :: Solver -> Maybe (Natural) -> IO SolverInstance -spawnSolver solver timeout = do - let cmd = (proc (show solver) (fmap T.unpack $ solverArgs solver timeout)) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } - (Just stdin, Just stdout, Just stderr, process) <- createProcess cmd - hSetBuffering stdin (BlockBuffering (Just 1000000)) - let solverInstance = SolverInstance solver stdin stdout stderr process - case timeout of - Nothing -> pure solverInstance - Just t -> case solver of - CVC5 -> pure solverInstance - _ -> do - _ <- sendLine' solverInstance $ "(set-option :timeout " <> T.pack (show t) <> ")" - pure solverInstance --- | Cleanly shutdown a running solver instnace -stopSolver :: SolverInstance -> IO () -stopSolver (SolverInstance _ stdin stdout stderr process) = cleanupProcess (Just stdin, Just stdout, Just stderr, 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 - sendLine' solver (T.unlines $ fmap toLazyText cmds) - pure $ Right() - --- | Sends a single command to the solver, returns the first available line from the output buffer -sendCommand :: SolverInstance -> Text -> IO Text -sendCommand inst cmd = do - -- trim leading whitespace - let cmd' = T.dropWhile isSpace cmd - case T.unpack cmd' of - "" -> pure "success" -- ignore blank lines - ';' : _ -> pure "success" -- ignore comments - _ -> sendLine inst cmd' - --- | Sends a string to the solver and appends a newline, returns the first available line from the output buffer -sendLine :: SolverInstance -> Text -> IO Text -sendLine (SolverInstance _ stdin stdout _ _) cmd = do - T.hPutStr stdin (T.append cmd "\n") - hFlush stdin - T.hGetLine stdout - --- | Sends a string to the solver and appends a newline, doesn't return stdout -sendLine' :: SolverInstance -> Text -> IO () -sendLine' (SolverInstance _ stdin _ _ _) cmd = do - T.hPutStr stdin (T.append cmd "\n") - hFlush stdin - --- | Returns a string representation of the model for the requested variable -getValue :: SolverInstance -> Text -> IO Text -getValue (SolverInstance _ stdin stdout _ _) var = do - T.hPutStr stdin (T.append (T.append "(get-value (" var) "))\n") - hFlush stdin - fmap (T.unlines . reverse) (readSExpr stdout) +-- | Interpret an N-dimensional array as a value of type a. +-- Parameterized by an interpretation function for array values. +interpretNDArray :: (Map Symbol Term -> Term -> a) -> (Map Symbol Term) -> Term -> (W256 -> a) +interpretNDArray interp env = \case + -- variable reference + TermQualIdentifier (Unqualified (IdSymbol s)) -> + case Map.lookup s env of + Just t -> interpretNDArray interp env t + Nothing -> error "Internal error: unknown identifier, cannot parse array" + -- (let (x t') t) + TermLet (VarBinding x t' :| []) t -> interpretNDArray interp (Map.insert x t' env) t + TermLet (VarBinding x t' :| lets) t -> interpretNDArray interp (Map.insert x t' env) (TermLet (NonEmpty.fromList lets) t) + -- (as const (Array (_ BitVec 256) (_ BitVec 256))) SpecConstant + TermApplication asconst (val :| []) | isArrConst asconst -> + \_ -> interp env val + -- (store arr ind val) + TermApplication store (arr :| [TermSpecConstant ind, val]) | isStore store -> + \x -> if x == parseW256 ind then interp env val else interpretNDArray interp env arr x + t -> error $ "Internal error: cannot parse array value. Unexpected term: " <> (show t) --- | Reads lines from h until we have a balanced sexpr -readSExpr :: Handle -> IO [Text] -readSExpr h = go 0 0 [] where - go 0 0 _ = do - line <- T.hGetLine h - let ls = T.length $ T.filter (== '(') line - rs = T.length $ T.filter (== ')') line - if ls == rs - then pure [line] - else go ls rs [line] - go ls rs prev = do - line <- T.hGetLine h - let ls' = T.length $ T.filter (== '(') line - rs' = T.length $ T.filter (== ')') line - if (ls + ls') == (rs + rs') - then pure $ line : prev - else go (ls + ls') (rs + rs') (line : prev) - - + isArrConst :: QualIdentifier -> Bool + isArrConst = \case + Qualified (IdSymbol "const") (SortParameter (IdSymbol "Array") _) -> True + _ -> False --- ** Helpers ** --------------------------------------------------------------------------------- + isStore :: QualIdentifier -> Bool + isStore t = t == Unqualified (IdSymbol "store") --- | Stores a region of src into dst -copySlice :: Expr EWord -> Expr EWord -> Expr EWord -> Builder -> Builder -> Builder -copySlice srcOffset dstOffset size@(Lit _) src dst - | size == (Lit 0) = dst - | otherwise = - let size' = (sub size (Lit 1)) - encDstOff = exprToSMT (add dstOffset size') - encSrcOff = exprToSMT (add srcOffset size') - child = copySlice srcOffset dstOffset size' src dst in - "(store " <> child `sp` encDstOff `sp` "(select " <> src `sp` encSrcOff <> "))" -copySlice _ _ _ _ _ = error "TODO: implement copySlice with a symbolically sized region" - --- | Unrolls an exponentiation into a series of multiplications -expandExp :: Expr EWord -> W256 -> Builder -expandExp base expnt - | expnt == 1 = exprToSMT base - | otherwise = - let b = exprToSMT base - n = expandExp base (expnt - 1) in - "(bvmul " <> b `sp` n <> ")" - --- | Concatenates a list of bytes into a larger bitvector -concatBytes :: [Expr Byte] -> Builder -concatBytes bytes = - let bytesRev = reverse bytes - a2 = exprToSMT (head bytesRev) in - foldl wrap a2 $ tail bytesRev - where - wrap inner byte = - let byteSMT = exprToSMT byte in - "(concat " <> byteSMT `sp` inner <> ")" - --- | Concatenates a list of bytes into a larger bitvector -writeBytes :: ByteString -> Expr Buf -> Builder -writeBytes bytes buf = snd $ BS.foldl' wrap (0, exprToSMT buf) bytes +-- | Interpret an 1-dimensional array as a function +interpret1DArray :: (Map Symbol Term) -> Term -> (W256 -> W256) +interpret1DArray = interpretNDArray interpretW256 where - -- we don't need to store zeros if the base buffer is empty - skipZeros = buf == mempty - wrap :: (Int, Builder) -> Word8 -> (Int, Builder) - wrap (idx, inner) byte = - if skipZeros && byte == 0 - then (idx + 1, inner) - else let - byteSMT = exprToSMT (LitByte byte) - idxSMT = exprToSMT . Lit . num $ idx - in (idx + 1, "(store " <> inner `sp` idxSMT `sp` byteSMT <> ")") + interpretW256 :: (Map Symbol Term) -> Term -> W256 + interpretW256 _ (TermSpecConstant val) = parseW256 val + interpretW256 env (TermQualIdentifier (Unqualified (IdSymbol s))) = + case Map.lookup s env of + Just t -> interpretW256 env t + Nothing -> error "Internal error: unknown identifier, cannot parse array" + interpretW256 _ t = error $ "Internal error: cannot parse array value. Unexpected term: " <> (show t) -encodeConcreteStore :: Map W256 (Map W256 W256) -> Builder -encodeConcreteStore s = foldl encodeWrite "emptyStore" writes - where - asList = fmap (second Map.toList) $ Map.toList s - writes = concatMap (\(addr, ws) -> fmap (\(k, v) -> (addr, k, v)) ws) asList - encodeWrite prev (addr, key, val) = let - encAddr = exprToSMT (Lit addr) - encKey = exprToSMT (Lit key) - encVal = exprToSMT (Lit val) - in "(sstore " <> encAddr `sp` encKey `sp` encVal `sp` prev <> ")" +-- | Interpret an 2-dimensional array as a function +interpret2DArray :: (Map Symbol Term) -> Term -> (W256 -> W256 -> W256) +interpret2DArray = interpretNDArray interpret1DArray diff --git a/src/EVM/Solidity.hs b/src/EVM/Solidity.hs --- a/src/EVM/Solidity.hs +++ b/src/EVM/Solidity.hs @@ -1,7 +1,6 @@ {-# Language DeriveAnyClass #-} {-# Language DataKinds #-} {-# Language StrictData #-} -{-# Language TemplateHaskell #-} {-# Language QuasiQuotes #-} module EVM.Solidity @@ -21,33 +20,12 @@ , SlotType (..) , Reference(..) , Mutability(..) - , methodName - , methodSignature - , methodInputs - , methodOutput - , methodMutability - , abiMap - , eventMap - , errorMap - , storageLayout - , contractName - , constructorInputs - , creationCode , functionAbi , makeSrcMaps , readSolc , readJSON , readStdJSON , readCombinedJSON - , runtimeCode - , runtimeCodehash - , creationCodehash - , runtimeSrcmap - , creationSrcmap - , sourceFiles - , sourceLines - , sourceAsts - , immutableReferences , stripBytecodeMetadata , stripBytecodeMetadataSym , signature @@ -66,49 +44,48 @@ import EVM.Types import Control.Applicative +import Control.Lens hiding (Indexed, (.=)) import Control.Monad -import Control.Lens hiding (Indexed, (.=)) -import qualified Data.String.Here as Here import Data.Aeson hiding (json) import Data.Aeson.Types import Data.Aeson.Lens -import qualified Data.Aeson.KeyMap as KeyMap +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap import Data.Scientific -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as BS16 import Data.ByteString.Lazy (toStrict) -import Data.Char (isDigit) +import Data.Char (isDigit) import Data.Foldable -import Data.Map.Strict (Map) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.HashMap.Strict qualified as HMap +import Data.List (sort, isPrefixOf, isInfixOf, elemIndex, tails, findIndex) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe -import Data.Word (Word8, Word32) -import Data.List.NonEmpty (NonEmpty) import Data.Semigroup -import Data.Sequence (Seq) -import Data.Text (Text, pack, intercalate) -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Data.Text.IO (readFile, writeFile) -import Data.Vector (Vector) -import GHC.Generics (Generic) -import Prelude hiding (readFile, writeFile) -import System.IO hiding (readFile, writeFile) +import Data.Sequence (Seq) +import Data.String.Here qualified as Here +import Data.Text (Text, pack, intercalate) +import Data.Text qualified as Text +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Text.IO (readFile, writeFile) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Data.Word (Word8, Word32) +import GHC.Generics (Generic) +import Prelude hiding (readFile, writeFile) +import System.IO hiding (readFile, writeFile) import System.IO.Temp import System.Process -import Text.Read (readMaybe) - -import qualified Data.Aeson.Key as Key -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as BS16 -import qualified Data.HashMap.Strict as HMap -import qualified Data.Map.Strict as Map -import qualified Data.Text as Text -import qualified Data.Vector as Vector -import qualified Data.List.NonEmpty as NonEmpty -import Data.List (sort, isPrefixOf, isInfixOf, elemIndex, tails, findIndex) +import Text.Read (readMaybe) -data StorageItem = StorageItem { - _type :: SlotType, - _offset :: Int, - _slot :: Int +data StorageItem = StorageItem + { slotType :: SlotType + , offset :: Int + , slot :: Int } deriving (Show, Eq) data SlotType @@ -143,27 +120,27 @@ readsPrec _ s = [(StorageValue $ fromMaybe (error "could not parse storage item") (parseTypeName mempty (pack s)),"")] data SolcContract = SolcContract - { _runtimeCodehash :: W256 - , _creationCodehash :: W256 - , _runtimeCode :: ByteString - , _creationCode :: ByteString - , _contractName :: Text - , _constructorInputs :: [(Text, AbiType)] - , _abiMap :: Map Word32 Method - , _eventMap :: Map W256 Event - , _errorMap :: Map W256 SolError - , _immutableReferences :: Map W256 [Reference] - , _storageLayout :: Maybe (Map Text StorageItem) - , _runtimeSrcmap :: Seq SrcMap - , _creationSrcmap :: Seq SrcMap + { runtimeCodehash :: W256 + , creationCodehash :: W256 + , runtimeCode :: ByteString + , creationCode :: ByteString + , contractName :: Text + , constructorInputs :: [(Text, AbiType)] + , abiMap :: Map Word32 Method + , eventMap :: Map W256 Event + , errorMap :: Map W256 SolError + , immutableReferences :: Map W256 [Reference] + , storageLayout :: Maybe (Map Text StorageItem) + , runtimeSrcmap :: Seq SrcMap + , creationSrcmap :: Seq SrcMap } deriving (Show, Eq, Generic) data Method = Method - { _methodOutput :: [(Text, AbiType)] - , _methodInputs :: [(Text, AbiType)] - , _methodName :: Text - , _methodSignature :: Text - , _methodMutability :: Mutability + { output :: [(Text, AbiType)] + , inputs :: [(Text, AbiType)] + , name :: Text + , methodSignature :: Text + , mutability :: Mutability } deriving (Show, Eq, Ord, Generic) data Mutability @@ -174,14 +151,14 @@ deriving (Show, Eq, Ord, Generic) data SourceCache = SourceCache - { _sourceFiles :: [(Text, ByteString)] - , _sourceLines :: [(Vector ByteString)] - , _sourceAsts :: Map Text Value + { files :: [(Text, ByteString)] + , lines :: [(Vector ByteString)] + , asts :: Map Text Value } deriving (Show, Eq, Generic) data Reference = Reference - { _refStart :: Int, - _refLength :: Int + { start :: Int, + length :: Int } deriving (Show, Eq) instance FromJSON Reference where @@ -220,10 +197,6 @@ data CodeType = Creation | Runtime deriving (Show, Eq, Ord) -makeLenses ''SolcContract -makeLenses ''SourceCache -makeLenses ''Method - -- Obscure but efficient parser for the Solidity sourcemap format. makeSrcMaps :: Text -> Maybe (Seq SrcMap) makeSrcMaps = (\case (_, Fe, _) -> Nothing; x -> Just (done x)) @@ -278,9 +251,9 @@ f (fp, Nothing) = BS.readFile $ Text.unpack fp xs <- mapM f paths return $! SourceCache - { _sourceFiles = zip (fst <$> paths) xs - , _sourceLines = map (Vector.fromList . BS.split 0xa) xs - , _sourceAsts = asts + { files = zip (fst <$> paths) xs + , lines = map (Vector.fromList . BS.split 0xa) xs + , asts = asts } lineSubrange :: @@ -324,19 +297,19 @@ solidity contract src = do (json, path) <- solidity' src let (sol, _, _) = fromJust $ readJSON json - return (sol ^? ix (path <> ":" <> contract) . creationCode) + pure $ Map.lookup (path <> ":" <> contract) sol <&> (.creationCode) solcRuntime :: Text -> Text -> IO (Maybe ByteString) solcRuntime contract src = do (json, path) <- solidity' src let (sol, _, _) = fromJust $ readJSON json - return (sol ^? ix (path <> ":" <> contract) . runtimeCode) + pure $ Map.lookup (path <> ":" <> contract) sol <&> (.runtimeCode) functionAbi :: Text -> IO Method functionAbi f = do (json, path) <- solidity' ("contract ABI { function " <> f <> " public {}}") let (sol, _, _) = fromJust $ readJSON json - case Map.toList $ sol ^?! ix (path <> ":ABI") . abiMap of + case Map.toList $ (fromJust (Map.lookup (path <> ":ABI") sol)).abiMap of [(_,b)] -> return b _ -> error "hevm internal error: unexpected abi format" @@ -365,24 +338,24 @@ Just v -> v -- solc >= 0.8 Nothing -> (x ^?! key "abi" . _String) ^?! _Array -- solc < 0.8 in SolcContract { - _runtimeCode = theRuntimeCode, - _creationCode = theCreationCode, - _runtimeCodehash = keccak' (stripBytecodeMetadata theRuntimeCode), - _creationCodehash = keccak' (stripBytecodeMetadata theCreationCode), - _runtimeSrcmap = force "internal error: srcmap-runtime" (makeSrcMaps (x ^?! key "srcmap-runtime" . _String)), - _creationSrcmap = force "internal error: srcmap" (makeSrcMaps (x ^?! key "srcmap" . _String)), - _contractName = s, - _constructorInputs = mkConstructor abis, - _abiMap = mkAbiMap abis, - _eventMap = mkEventMap abis, - _errorMap = mkErrorMap abis, - _storageLayout = mkStorageLayout $ x ^? key "storage-layout", - _immutableReferences = mempty -- TODO: deprecate combined-json + runtimeCode = theRuntimeCode, + creationCode = theCreationCode, + runtimeCodehash = keccak' (stripBytecodeMetadata theRuntimeCode), + creationCodehash = keccak' (stripBytecodeMetadata theCreationCode), + runtimeSrcmap = force "internal error: srcmap-runtime" (makeSrcMaps (x ^?! key "srcmap-runtime" . _String)), + creationSrcmap = force "internal error: srcmap" (makeSrcMaps (x ^?! key "srcmap" . _String)), + contractName = s, + constructorInputs = mkConstructor abis, + abiMap = mkAbiMap abis, + eventMap = mkEventMap abis, + errorMap = mkErrorMap abis, + storageLayout = mkStorageLayout $ x ^? key "storage-layout", + immutableReferences = mempty -- TODO: deprecate combined-json } readStdJSON :: Text -> Maybe (Map Text SolcContract, Map Text Value, [(Text, Maybe ByteString)]) readStdJSON json = do - contracts <- KeyMap.toHashMapText <$> json ^? key "contracts" ._Object + contracts <- KeyMap.toHashMapText <$> json ^? key "contracts" . _Object -- TODO: support the general case of "urls" and "content" in the standard json sources <- KeyMap.toHashMapText <$> json ^? key "sources" . _Object let asts = force "JSON lacks abstract syntax trees." . preview (key "ast") <$> sources @@ -408,19 +381,19 @@ abis = force ("abi key not found in " <> show x) $ toList <$> x ^? key "abi" . _Array in (s <> ":" <> c, (SolcContract { - _runtimeCode = theRuntimeCode, - _creationCode = theCreationCode, - _runtimeCodehash = keccak' (stripBytecodeMetadata theRuntimeCode), - _creationCodehash = keccak' (stripBytecodeMetadata theCreationCode), - _runtimeSrcmap = force "internal error: srcmap-runtime" (makeSrcMaps (runtime ^?! key "sourceMap" . _String)), - _creationSrcmap = force "internal error: srcmap" (makeSrcMaps (creation ^?! key "sourceMap" . _String)), - _contractName = s <> ":" <> c, - _constructorInputs = mkConstructor abis, - _abiMap = mkAbiMap abis, - _eventMap = mkEventMap abis, - _errorMap = mkErrorMap abis, - _storageLayout = mkStorageLayout $ x ^? key "storageLayout", - _immutableReferences = fromMaybe mempty $ + runtimeCode = theRuntimeCode, + creationCode = theCreationCode, + runtimeCodehash = keccak' (stripBytecodeMetadata theRuntimeCode), + creationCodehash = keccak' (stripBytecodeMetadata theCreationCode), + runtimeSrcmap = force "internal error: srcmap-runtime" (makeSrcMaps (runtime ^?! key "sourceMap" . _String)), + creationSrcmap = force "internal error: srcmap" (makeSrcMaps (creation ^?! key "sourceMap" . _String)), + contractName = s <> ":" <> c, + constructorInputs = mkConstructor abis, + abiMap = mkAbiMap abis, + eventMap = mkEventMap abis, + errorMap = mkErrorMap abis, + storageLayout = mkStorageLayout $ x ^? key "storageLayout", + immutableReferences = fromMaybe mempty $ do x' <- runtime ^? key "immutableReferences" case fromJSON x' of Success a -> return a @@ -433,13 +406,13 @@ relevant = filter (\y -> "function" == y ^?! key "type" . _String) abis f abi = (abiKeccak (encodeUtf8 (signature abi)), - Method { _methodName = abi ^?! key "name" . _String - , _methodSignature = signature abi - , _methodInputs = map parseMethodInput + Method { name = abi ^?! key "name" . _String + , methodSignature = signature abi + , inputs = map parseMethodInput (toList (abi ^?! key "inputs" . _Array)) - , _methodOutput = map parseMethodInput + , output = map parseMethodInput (toList (abi ^?! key "outputs" . _Array)) - , _methodMutability = parseMutability + , mutability = parseMutability (abi ^?! key "stateMutability" . _String) }) in f <$> relevant @@ -474,7 +447,7 @@ ( stripKeccak $ keccak' (encodeUtf8 (signature abi)) , SolError (abi ^?! key "name" . _String) - (map (\y -> ( force "internal error: type" (parseTypeName' y))) + (map (force "internal error: type" . parseTypeName') (toList $ abi ^?! key "inputs" . _Array)) ) in f <$> relevant diff --git a/src/EVM/Solvers.hs b/src/EVM/Solvers.hs new file mode 100644 --- /dev/null +++ b/src/EVM/Solvers.hs @@ -0,0 +1,239 @@ +{-# Language DataKinds #-} +{-# Language GADTs #-} +{-# Language PolyKinds #-} +{-# Language ScopedTypeVariables #-} +{-# Language TypeApplications #-} +{-# Language QuasiQuotes #-} + +{- | + Module: EVM.Solvers + Description: Solver orchestration +-} +module EVM.Solvers where + +import Prelude hiding (LT, GT) + +import GHC.Natural +import Control.Monad +import GHC.IO.Handle (Handle, hFlush, hSetBuffering, BufferMode(..)) +import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan) +import Control.Concurrent (forkIO, killThread) +import Data.Char (isSpace) + +import Data.Maybe (fromMaybe) +import Data.Text.Lazy (Text) +import qualified Data.Text as TS +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as T +import Data.Text.Lazy.Builder +import System.Process (createProcess, cleanupProcess, proc, ProcessHandle, std_in, std_out, std_err, StdStream(..)) + +import EVM.SMT + +-- | Supported solvers +data Solver + = Z3 + | CVC5 + | Bitwuzla + | Custom Text + +instance Show Solver where + show Z3 = "z3" + show CVC5 = "cvc5" + show Bitwuzla = "bitwuzla" + show (Custom s) = T.unpack s + + +-- | A running solver instance +data SolverInstance = SolverInstance + { _type :: Solver + , _stdin :: Handle + , _stdout :: Handle + , _stderr :: Handle + , _process :: ProcessHandle + } + +-- | 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 + } + +-- | The result of a call to (check-sat) +data CheckSatResult + = Sat SMTCex + | Unsat + | Unknown + | Error TS.Text + deriving (Show, Eq) + +isSat :: CheckSatResult -> Bool +isSat (Sat _) = True +isSat _ = False + +isErr :: CheckSatResult -> Bool +isErr (Error _) = True +isErr _ = False + +isUnsat :: CheckSatResult -> Bool +isUnsat Unsat = True +isUnsat _ = False + +checkSat :: SolverGroup -> SMT2 -> IO CheckSatResult +checkSat (SolverGroup taskQueue) script = do + -- prepare result channel + resChan <- newChan + + -- send task to solver group + writeChan taskQueue (Task script resChan) + + -- collect result + readChan resChan + +withSolvers :: Solver -> Natural -> Maybe Natural -> (SolverGroup -> IO a) -> IO a +withSolvers solver count timeout cont = do + -- spawn solvers + instances <- mapM (const $ spawnSolver solver timeout) [1..count] + + -- spawn orchestration thread + taskQueue <- newChan + availableInstances <- newChan + forM_ instances (writeChan availableInstances) + orchestrateId <- forkIO $ orchestrate taskQueue availableInstances + + -- run continuation with task queue + res <- cont (SolverGroup taskQueue) + + -- cleanup and return results + mapM_ stopSolver instances + killThread orchestrateId + pure res + where + orchestrate queue avail = do + task <- readChan queue + inst <- readChan avail + _ <- forkIO $ runTask task inst avail + orchestrate queue avail + + runTask (Task (SMT2 cmds cexvars) r) inst availableInstances = do + -- reset solver and send all lines of provided script + out <- sendScript inst (SMT2 ("(reset)" : cmds) cexvars) + case out of + -- if we got an error then return it + Left e -> writeChan r (Error ("error while writing SMT to solver: " <> T.toStrict e)) + -- otherwise call (check-sat), parse the result, and send it down the result channel + Right () -> do + sat <- sendLine inst "(check-sat)" + res <- case sat of + "sat" -> do + calldatamodels <- getVars parseVar (getValue inst) (fmap T.toStrict cexvars.calldataV) + buffermodels <- getBufs (getValue inst) (fmap T.toStrict cexvars.buffersV) + storagemodels <- getStore (getValue inst) cexvars.storeReads + blockctxmodels <- getVars parseBlockCtx (getValue inst) (fmap T.toStrict cexvars.blockContextV) + txctxmodels <- getVars parseFrameCtx (getValue inst) (fmap T.toStrict cexvars.txContextV) + pure $ Sat $ SMTCex + { vars = calldatamodels + , buffers = buffermodels + , store = storagemodels + , blockContext = blockctxmodels + , txContext = txctxmodels + } + "unsat" -> pure Unsat + "timeout" -> pure Unknown + "unknown" -> pure Unknown + _ -> pure . Error $ T.toStrict $ "Unable to parse solver output: " <> sat + writeChan r res + + -- put the instance back in the list of available instances + writeChan availableInstances inst + +-- | Arguments used when spawing a solver instance +solverArgs :: Solver -> Maybe (Natural) -> [Text] +solverArgs solver timeout = case solver of + Bitwuzla -> error "TODO: Bitwuzla args" + Z3 -> + [ "-in" ] + CVC5 -> + [ "--lang=smt" + , "--no-interactive" + , "--produce-models" + , "--tlimit-per=" <> T.pack (show (1000 * fromMaybe 10 timeout)) + ] + Custom _ -> [] + +-- | Spawns a solver instance, and sets the various global config options that we use for our queries +spawnSolver :: Solver -> Maybe (Natural) -> IO SolverInstance +spawnSolver solver timeout = do + let cmd = (proc (show solver) (fmap T.unpack $ solverArgs solver timeout)) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } + (Just stdin, Just stdout, Just stderr, process) <- createProcess cmd + hSetBuffering stdin (BlockBuffering (Just 1000000)) + let solverInstance = SolverInstance solver stdin stdout stderr process + case timeout of + Nothing -> pure solverInstance + Just t -> case solver of + CVC5 -> pure solverInstance + _ -> do + _ <- sendLine' solverInstance $ "(set-option :timeout " <> T.pack (show t) <> ")" + pure solverInstance + +-- | Cleanly shutdown a running solver instnace +stopSolver :: SolverInstance -> IO () +stopSolver (SolverInstance _ stdin stdout stderr process) = cleanupProcess (Just stdin, Just stdout, Just stderr, 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 + sendLine' solver (T.unlines $ fmap toLazyText cmds) + pure $ Right() + +-- | Sends a single command to the solver, returns the first available line from the output buffer +sendCommand :: SolverInstance -> Text -> IO Text +sendCommand inst cmd = do + -- trim leading whitespace + let cmd' = T.dropWhile isSpace cmd + case T.unpack cmd' of + "" -> pure "success" -- ignore blank lines + ';' : _ -> pure "success" -- ignore comments + _ -> sendLine inst cmd' + +-- | Sends a string to the solver and appends a newline, returns the first available line from the output buffer +sendLine :: SolverInstance -> Text -> IO Text +sendLine (SolverInstance _ stdin stdout _ _) cmd = do + T.hPutStr stdin (T.append cmd "\n") + hFlush stdin + T.hGetLine stdout + +-- | Sends a string to the solver and appends a newline, doesn't return stdout +sendLine' :: SolverInstance -> Text -> IO () +sendLine' (SolverInstance _ stdin _ _ _) cmd = do + T.hPutStr stdin (T.append cmd "\n") + hFlush stdin + +-- | Returns a string representation of the model for the requested variable +getValue :: SolverInstance -> Text -> IO Text +getValue (SolverInstance _ stdin stdout _ _) var = do + T.hPutStr stdin (T.append (T.append "(get-value (" var) "))\n") + hFlush stdin + fmap (T.unlines . reverse) (readSExpr stdout) + +-- | Reads lines from h until we have a balanced sexpr +readSExpr :: Handle -> IO [Text] +readSExpr h = go 0 0 [] + where + go 0 0 _ = do + line <- T.hGetLine h + let ls = T.length $ T.filter (== '(') line + rs = T.length $ T.filter (== ')') line + if ls == rs + then pure [line] + else go ls rs [line] + go ls rs prev = do + line <- T.hGetLine h + let ls' = T.length $ T.filter (== '(') line + rs' = T.length $ T.filter (== ')') line + if (ls + ls') == (rs + rs') + then pure $ line : prev + else go (ls + ls') (rs + rs') (line : prev) diff --git a/src/EVM/Stepper.hs b/src/EVM/Stepper.hs --- a/src/EVM/Stepper.hs +++ b/src/EVM/Stepper.hs @@ -99,7 +99,7 @@ runFully :: Stepper EVM.VM runFully = do vm <- run - case EVM._result vm of + case vm._result of Nothing -> error "should not occur" Just (VMFailure (Query q)) -> wait q >> runFully @@ -133,9 +133,9 @@ eval (action :>>= k) = case action of Exec -> - EVM.Exec.exec >>= interpret fetcher . k + (State.state . runState) EVM.Exec.exec >>= interpret fetcher . k Run -> - EVM.Exec.run >>= interpret fetcher . k + (State.state . runState) EVM.Exec.run >>= interpret fetcher . k Wait q -> do m <- liftIO (fetcher q) State.state (runState m) >> interpret fetcher (k ()) diff --git a/src/EVM/StorageLayout.hs b/src/EVM/StorageLayout.hs --- a/src/EVM/StorageLayout.hs +++ b/src/EVM/StorageLayout.hs @@ -2,22 +2,19 @@ -- Figures out the layout of storage slots for Solidity contracts. -import EVM.Dapp (DappInfo, dappAstSrcMap, dappAstIdMap) +import EVM.Dapp (DappInfo(..)) import EVM.Solidity (SolcContract, creationSrcmap, SlotType(..)) import EVM.ABI (AbiType (..), parseTypeName) +import Control.Lens import Data.Aeson (Value (..)) import Data.Aeson.Lens - -import Control.Lens - -import Data.Text (Text, unpack, pack, words) - import Data.Foldable (toList) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map qualified as Map import Data.Maybe (fromMaybe, isJust) -import qualified Data.List.NonEmpty as NonEmpty - -import qualified Data.Sequence as Seq +import Data.Sequence qualified as Seq +import Data.Text (Text, unpack, pack, words) import Prelude hiding (words) @@ -32,9 +29,9 @@ findContractDefinition dapp solc = -- The first source mapping in the contract's creation code -- corresponds to the source field of the contract definition. - case Seq.viewl (view creationSrcmap solc) of + case Seq.viewl solc.creationSrcmap of firstSrcMap Seq.:< _ -> - (view dappAstSrcMap dapp) firstSrcMap + dapp.astSrcMap firstSrcMap _ -> Nothing @@ -57,7 +54,7 @@ (\case Number i -> fromMaybe (error "malformed AST JSON") $ storageVariablesForContract =<< - preview (dappAstIdMap . ix (floor i)) dapp + Map.lookup (floor i) dapp.astIdMap _ -> error "malformed AST JSON") diff --git a/src/EVM/SymExec.hs b/src/EVM/SymExec.hs --- a/src/EVM/SymExec.hs +++ b/src/EVM/SymExec.hs @@ -1,16 +1,19 @@ +{-# Language TupleSections #-} {-# Language DataKinds #-} module EVM.SymExec where import Prelude hiding (Word) +import Data.Tuple (swap) import Control.Lens hiding (pre) -import EVM hiding (Query, Revert, push) +import EVM hiding (Query, Revert, push, bytecode, cache) import qualified EVM import EVM.Exec import qualified EVM.Fetch as Fetch import EVM.ABI import EVM.SMT +import EVM.Solvers import EVM.Traversals import qualified EVM.Expr as Expr import EVM.Stepper (Stepper) @@ -23,11 +26,9 @@ import Data.DoubleWord (Word256) import Control.Concurrent.Async import Data.Maybe -import Data.List (foldl') -import Data.Tuple (swap) +import Data.List (foldl', sortBy) import Data.ByteString (ByteString) -import Data.List (find) -import Data.ByteString (null, pack) +import qualified Data.ByteString as BS import qualified Control.Monad.State.Class as State import Data.Bifunctor (first, second) import Data.Text (Text) @@ -37,20 +38,31 @@ import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL -import EVM.Format (formatExpr, indent, formatBinary) +import EVM.Format (formatExpr) +import Data.Set (Set, isSubsetOf, size) +import qualified Data.Set as Set +import Control.Concurrent.STM (atomically, TVar, readTVarIO, readTVar, newTVarIO, writeTVar) +import Control.Concurrent.Spawn +import GHC.Conc (getNumProcessors) +import EVM.Format (indent, formatBinary) data ProofResult a b c = Qed a | Cex b | Timeout c deriving (Show, Eq) type VerifyResult = ProofResult () (Expr End, SMTCex) (Expr End) -type EquivalenceResult = ProofResult ([VM], [VM]) VM () +type EquivResult = ProofResult () (SMTCex) () +isTimeout :: ProofResult a b c -> Bool +isTimeout (Timeout _) = True +isTimeout _ = False + +isCex :: ProofResult a b c -> Bool +isCex (Cex _) = True +isCex _ = False + isQed :: ProofResult a b c -> Bool isQed (Qed _) = True isQed _ = False -containsA :: Eq a => Eq b => Eq c => ProofResult a b c -> [(d , e, ProofResult a b c)] -> Bool -containsA a lst = isJust $ Data.List.find (\(_, _, c) -> c == a) lst - data VeriOpts = VeriOpts { simp :: Bool , debug :: Bool @@ -165,7 +177,7 @@ abstractVM typesignature concreteArgs contractCode maybepre storagemodel = finalVm where (calldata', calldataProps) = case typesignature of - Nothing -> (AbstractBuf "txdata", []) + Nothing -> (AbstractBuf "txdata", [Expr.bufLength (AbstractBuf "txdata") .< (Lit (2 ^ (64 :: Integer)))]) Just (name, typs) -> symCalldata name typs concreteArgs (AbstractBuf "txdata") store = case storagemodel of SymbolicS -> AbstractStore @@ -232,9 +244,9 @@ eval (action Operational.:>>= k) = case action of Stepper.Exec -> - exec >>= interpret fetcher maxIter askSmtIters . k + (State.state . runState) exec >>= interpret fetcher maxIter askSmtIters . k Stepper.Run -> - run >>= interpret fetcher maxIter askSmtIters . k + (State.state . runState) run >>= interpret fetcher maxIter askSmtIters . k Stepper.IOAct q -> mapStateT liftIO q >>= interpret fetcher maxIter askSmtIters . k Stepper.Ask (EVM.PleaseChoosePath cond continue) -> do @@ -277,9 +289,9 @@ maxIterationsReached _ Nothing = Nothing maxIterationsReached vm (Just maxIter) = let codelocation = getCodeLocation vm - iters = view (iterations . at codelocation . non 0) vm + iters = view (at codelocation . non 0) vm._iterations in if num maxIter <= iters - then view (cache . path . at (codelocation, iters - 1)) vm + then Map.lookup (codelocation, iters - 1) vm._cache._path else Nothing @@ -333,7 +345,7 @@ pruneDeadPaths :: [VM] -> [VM] pruneDeadPaths = - filter $ \vm -> case view result vm of + filter $ \vm -> case vm._result of Just (VMFailure DeadPath) -> False _ -> True @@ -341,10 +353,10 @@ runExpr :: Stepper.Stepper (Expr End) runExpr = do vm <- Stepper.runFully - let asserts = view keccakEqs vm - pure $ case view result vm of + let asserts = vm._keccakEqs + pure $ case vm._result of Nothing -> error "Internal Error: vm in intermediate state after call to runFully" - Just (VMSuccess buf) -> Return asserts buf (view (env . EVM.storage) vm) + Just (VMSuccess buf) -> Return asserts buf vm._env._storage Just (VMFailure e) -> case e of UnrecognizedOpcode _ -> Failure asserts Invalid SelfDestruction -> Failure asserts SelfDestruct @@ -353,6 +365,7 @@ EVM.Revert buf -> EVM.Types.Revert asserts buf EVM.InvalidMemoryAccess -> Failure asserts EVM.Types.InvalidMemoryAccess EVM.BadJumpDestination -> Failure asserts EVM.Types.BadJumpDestination + EVM.StackUnderrun -> Failure asserts EVM.Types.StackUnderrun e' -> Failure asserts $ EVM.Types.TmpErr (show e') -- | Converts a given top level expr into a list of final states and the associated path conditions for each state @@ -457,12 +470,12 @@ verify solvers opts preState maybepost = do putStrLn "Exploring contract" - exprInter <- evalStateT (interpret (Fetch.oracle solvers (rpcInfo opts)) (maxIter opts) (askSmtIters opts) runExpr) preState - when (debug opts) $ T.writeFile "unsimplified.expr" (formatExpr exprInter) + exprInter <- evalStateT (interpret (Fetch.oracle solvers opts.rpcInfo) opts.maxIter opts.askSmtIters runExpr) preState + when opts.debug $ T.writeFile "unsimplified.expr" (formatExpr exprInter) putStrLn "Simplifying expression" - expr <- if (simp opts) then (pure $ Expr.simplify exprInter) else pure exprInter - when (debug opts) $ T.writeFile "simplified.expr" (formatExpr expr) + expr <- if opts.simp then (pure $ Expr.simplify exprInter) else pure exprInter + when opts.debug $ T.writeFile "simplified.expr" (formatExpr expr) putStrLn $ "Explored contract (" <> show (Expr.numBranches expr) <> " branches)" @@ -475,11 +488,11 @@ \(_, leaf) -> case evalProp (post preState leaf) of PBool True -> False _ -> True - assumes = view constraints preState + assumes = preState._constraints withQueries = fmap (\(pcs, leaf) -> (assertProps (PNeg (post preState leaf) : assumes <> extractProps leaf <> pcs), leaf)) canViolate putStrLn $ "Checking for reachability of " <> show (length withQueries) <> " potential property violation(s)" - when (debug opts) $ forM_ (zip [(1 :: Int)..] withQueries) $ \(idx, (q, leaf)) -> do + when opts.debug $ forM_ (zip [(1 :: Int)..] withQueries) $ \(idx, (q, leaf)) -> do TL.writeFile ("query-" <> show idx <> ".smt2") ("; " <> (TL.pack $ show leaf) <> "\n\n" <> formatSMT2 q <> "\n\n(check-sat)") @@ -494,75 +507,138 @@ toVRes :: (CheckSatResult, Expr End) -> VerifyResult toVRes (res, leaf) = case res of Sat model -> Cex (leaf, model) - EVM.SMT.Unknown -> Timeout leaf + EVM.Solvers.Unknown -> Timeout leaf Unsat -> Qed () Error e -> error $ "Internal Error: solver responded with error: " <> show e +type UnsatCache = TVar [Set Prop] + -- | Compares two contract runtimes for trace equivalence by running two VMs and comparing the end states. -equivalenceCheck :: SolverGroup -> ByteString -> ByteString -> VeriOpts -> Maybe (Text, [AbiType]) -> IO [(Maybe SMTCex, Prop, ProofResult () () ())] +-- +-- We do this by asking the solver to find a common input for each pair of endstates that satisfies the path +-- conditions for both sides and produces a differing output. If we can find such an input, then we have a clear +-- equivalence break, and since we run this check for every pair of end states, the check is exhaustive. +equivalenceCheck :: SolverGroup -> ByteString -> ByteString -> VeriOpts -> Maybe (Text, [AbiType]) -> IO [EquivResult] equivalenceCheck solvers bytecodeA bytecodeB opts signature' = do - let - bytecodeA' = if Data.ByteString.null bytecodeA then Data.ByteString.pack [0] else bytecodeA - bytecodeB' = if Data.ByteString.null bytecodeB then Data.ByteString.pack [0] else bytecodeB - preStateA = abstractVM signature' [] bytecodeA' Nothing SymbolicS - preStateB = abstractVM signature' [] bytecodeB' Nothing SymbolicS + case bytecodeA == bytecodeB of + True -> do + putStrLn "bytecodeA and bytecodeB are identical" + pure [Qed ()] + False -> do + branchesA <- getBranches bytecodeA + branchesB <- getBranches bytecodeB + let allPairs = [(a,b) | a <- branchesA, b <- branchesB] + putStrLn $ "Found " <> (show $ length allPairs) <> " total pairs of endstates" - aExpr <- evalStateT (interpret (Fetch.oracle solvers Nothing) (maxIter opts) (askSmtIters opts) runExpr) preStateA - bExpr <- evalStateT (interpret (Fetch.oracle solvers Nothing) (maxIter opts) (askSmtIters opts) runExpr) preStateB - aExprSimp <- if (simp opts) then (pure $ Expr.simplify aExpr) else pure aExpr - bExprSimp <- if (simp opts) then (pure $ Expr.simplify bExpr) else pure bExpr - when (debug opts) $ putStrLn $ "num of aExprSimp endstates:" <> (show $ length $ flattenExpr aExprSimp) <> "\nnum of bExprSimp endstates:" <> (show $ length $ flattenExpr bExprSimp) + when opts.debug $ putStrLn + $ "endstates in bytecodeA: " <> (show $ length branchesA) + <> "\nendstates in bytecodeB: " <> (show $ length branchesB) - -- Check each pair of end states for equality: - let - differingEndStates = uncurry distinct <$> [(a,b) | a <- flattenExpr aExprSimp, b <- flattenExpr bExprSimp] - distinct :: ([Prop], Expr End) -> ([Prop], Expr End) -> Prop - distinct (aProps, aEnd) (bProps, bEnd) = - let - differingResults = case (aEnd, bEnd) of - (Return _ aOut aStore, Return _ bOut bStore) -> - if aOut == bOut && aStore == bStore then PBool False - else aStore ./= bStore .|| aOut ./= bOut - (Return {}, _) -> PBool True - (_, Return {}) -> PBool True - (Revert _ a, Revert _ b) -> if a==b then PBool False else a ./= b - (Revert _ _, _) -> PBool True - (_, Revert _ _) -> PBool True - (Failure _ erra, Failure _ errb) -> if erra==errb then PBool False else PBool True - (GVar _, _) -> error "Expressions cannot contain global vars" - (_ , GVar _) -> error "Expressions cannot contain global vars" - (Failure _ (TmpErr s), _) -> error $ "Unhandled error: " <> s - (_, Failure _ (TmpErr s)) -> error $ "Unhandled error: " <> s - (ITE _ _ _, _ ) -> error "Expressions must be flattened" - (_, ITE _ _ _) -> error "Expressions must be flattened" + let differingEndStates = sortBySize (mapMaybe (uncurry distinct) allPairs) + putStrLn $ "Asking the SMT solver for " <> (show $ length differingEndStates) <> " pairs" + when opts.debug $ forM_ (zip differingEndStates [(1::Integer)..]) (\(x, i) -> + T.writeFile ("prop-checked-" <> show i) (T.pack $ show x)) - -- if the SMT solver can find a common input that satisfies BOTH sets of path conditions - -- AND the output differs, then we are in trouble. We do this for _every_ pair of paths, which - -- makes this exhaustive - in - if differingResults == PBool False - then PBool False - else (foldl PAnd (PBool True) aProps) .&& (foldl PAnd (PBool True) bProps) .&& differingResults - -- If there exists a pair of end states where this is not the case, - -- the following constraint is satisfiable + knownUnsat <- newTVarIO [] + procs <- getNumProcessors + results <- checkAll differingEndStates knownUnsat procs - let diffEndStFilt = filter (/= PBool False) differingEndStates - putStrLn $ "Equivalence checking " <> (show $ length diffEndStFilt) <> " combinations" - when (debug opts) $ forM_ (zip diffEndStFilt [1 :: Integer ..]) (\(x, i) -> T.writeFile ("prop-checked-" <> show i) (T.pack $ show x)) - results <- flip mapConcurrently (zip diffEndStFilt [1 :: Integer ..]) $ \(prop, i) -> do - let assertedProps = assertProps [prop] - let filename = "eq-check-" <> show i <> ".smt2" - when (debug opts) $ T.writeFile (filename) $ (TL.toStrict $ formatSMT2 assertedProps) <> "\n(check-sat)" - res <- case prop of - PBool False -> pure Unsat - _ -> checkSat solvers assertedProps - case res of - Sat a -> return (Just a, prop, Cex ()) - Unsat -> return (Nothing, prop, Qed ()) - EVM.SMT.Unknown -> return (Nothing, prop, Timeout ()) - Error txt -> error $ "Error while running solver: `" <> T.unpack txt <> "` SMT file was: `" <> filename <> "`" - return $ filter (\(_, _, res) -> res /= Qed ()) results + let useful = foldr (\(_, b) n -> if b then n+1 else n) (0::Integer) results + putStrLn $ "Reuse of previous queries was Useful in " <> (show useful) <> " cases" + case all isQed . fmap 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 + -- 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 + + -- decompiles the given bytecode into a list of branches + getBranches :: ByteString -> IO [([Prop], Expr End)] + getBranches bs = do + let + bytecode = if BS.null bs then BS.pack [0] else bs + prestate = abstractVM signature' [] bytecode Nothing SymbolicS + expr <- evalStateT (interpret (Fetch.oracle solvers Nothing) opts.maxIter opts.askSmtIters runExpr) prestate + let simpl = if opts.simp then (Expr.simplify expr) else expr + pure $ flattenExpr simpl + + -- 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 :: UnsatCache -> Set Prop -> IO (EquivResult, Bool) + check knownUnsat props = do + let smt = assertProps $ 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 (Timeout (), False) + (_, Error txt) -> error $ "Error while running solver: `" <> T.unpack txt -- <> "` SMT file was: `" <> filename <> "`" + + -- Allows us to run it 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 :: [(Set Prop)] -> UnsatCache -> Int -> IO [(EquivResult, Bool)] + checkAll input cache numproc = do + wrap <- pool numproc + parMapIO (wrap . (check cache)) input + + -- 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 :: ([Prop], Expr End) -> ([Prop], Expr End) -> Maybe (Set Prop) + distinct (aProps, aEnd) (bProps, bEnd) = + let + differingResults = case (aEnd, bEnd) of + (Return _ aOut aStore, Return _ bOut bStore) -> + if aOut == bOut && aStore == bStore + then PBool False + else aStore ./= bStore .|| aOut ./= bOut + (Return {}, _) -> PBool True + (_, Return {}) -> PBool True + (Revert _ a, Revert _ b) -> if a == b then PBool False else a ./= b + (Revert _ _, _) -> PBool True + (_, Revert _ _) -> PBool True + (Failure _ (TmpErr s), _) -> error $ "Unhandled error: " <> s + (_, Failure _ (TmpErr s)) -> error $ "Unhandled error: " <> s + (Failure _ erra, Failure _ errb) -> if erra==errb then PBool False else PBool True + (ITE _ _ _, _) -> error "Expressions must be flattened" + (_, ITE _ _ _) -> error "Expressions must be flattened" + (a, b) -> if a == b + then PBool False + else error $ "Internal Error: Unimplemented. Left: " <> show a <> " Right: " <> show b + in case differingResults 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 $ aProps <> bProps + -- if we cannot statically determine whether or not the end states + -- differ, then we ask the solver if the end states can differ if both + -- sets of path conditions are satisfiable + _ -> Just . Set.fromList $ differingResults : aProps <> bProps + both' :: (a -> b) -> (a, a) -> (b, b) both' f (x, y) = (f x, f y) @@ -580,7 +656,7 @@ case res of Unsat -> pure () -- ignore unreachable branches Error e -> error $ "Internal error: smt solver returned an error: " <> show e - EVM.SMT.Unknown -> do + EVM.Solvers.Unknown -> do putStrLn "--- Branch ---" putStrLn "" putStrLn "Unable to produce a model for the following end state:" @@ -601,11 +677,12 @@ formatCex :: Expr Buf -> SMTCex -> Text -formatCex cd m@(SMTCex _ _ blockContext txContext) = T.unlines $ +formatCex cd m@(SMTCex _ _ store blockContext txContext) = T.unlines $ [ "Calldata:" , indent 2 cd' , "" ] + <> storeCex <> txCtx <> blockCtx where @@ -618,6 +695,15 @@ -- payable functions). cd' = prettyBuf $ Expr.simplify $ subModel m cd + storeCex :: [Text] + storeCex + | Map.null store = [] + | otherwise = + [ "Storage:" + , indent 2 $ T.unlines $ Map.foldrWithKey (\key val acc -> ("Addr " <> (T.pack $ show key) <> ": " <> (T.pack $ show (Map.toList val))) : acc) mempty store + , "" + ] + txCtx :: [Text] txCtx | Map.null txContext = [] @@ -663,7 +749,7 @@ -- | Takes a buffer and a Cex and replaces all abstract values in the buf with concrete ones from the Cex subModel :: SMTCex -> Expr a -> Expr a -subModel c expr = subBufs (buffers c) . subVars (vars c) . subVars (blockContext c) . subVars (txContext c) $ expr +subModel c expr = subBufs c.buffers . subVars c.vars . subStore c.store . subVars c.blockContext . subVars c.txContext $ expr where subVars model b = Map.foldlWithKey subVar b model subVar :: Expr a -> Expr EWord -> W256 -> Expr a @@ -685,4 +771,12 @@ a@(AbstractBuf _) -> if a == var then ConcreteBuf val else a + e -> e + + subStore :: Map W256 (Map W256 W256) -> Expr a -> Expr a + subStore m b = mapExpr go b + where + go :: Expr a -> Expr a + go = \case + AbstractStore -> ConcreteStore m e -> e diff --git a/src/EVM/TTY.hs b/src/EVM/TTY.hs --- a/src/EVM/TTY.hs +++ b/src/EVM/TTY.hs @@ -1,6 +1,7 @@ {-# Language TemplateHaskell #-} {-# Language ImplicitParams #-} {-# Language DataKinds #-} + module EVM.TTY where import Prelude hiding (lookup, Word) @@ -14,52 +15,44 @@ import EVM.ABI (abiTypeSolidity, decodeAbiValue, AbiType(..), emptyAbi) import EVM.SymExec (maxIterationsReached, symCalldata) import EVM.Expr (simplify) -import EVM.Dapp (DappInfo, dappInfo, Test, extractSig, Test(..), srcMap) -import EVM.Dapp (dappUnitTests, unitTestMethods, dappSolcByName, dappSolcByHash, dappSources) -import EVM.Dapp (dappAstSrcMap) +import EVM.Dapp (DappInfo(..), dappInfo, Test, extractSig, Test(..), srcMap, unitTestMethods) import EVM.Debug -import EVM.Format (showWordExact, showWordExplanation) -import EVM.Format (contractNamePart, contractPathPart, showTraceTree, prettyIfConcreteWord, formatExpr) +import EVM.Fetch (Fetcher) +import EVM.Fetch qualified as Fetch +import EVM.Format (showWordExact, showWordExplanation, contractNamePart, + contractPathPart, showTraceTree, prettyIfConcreteWord, formatExpr) import EVM.Hexdump (prettyHex) -import EVM.SMT (SolverGroup) +import EVM.Solvers (SolverGroup) import EVM.Op import EVM.Solidity hiding (storageLayout) import EVM.Types hiding (padRight) import EVM.UnitTest -import EVM.StorageLayout -import Text.Wrap - import EVM.Stepper (Stepper) -import qualified EVM.Stepper as Stepper -import qualified EVM.Fetch as Fetch -import qualified Control.Monad.Operational as Operational - -import EVM.Fetch (Fetcher) +import EVM.Stepper qualified as Stepper +import EVM.StorageLayout +import EVM.TTYCenteredList qualified as Centered import Control.Lens hiding (List) +import Control.Monad.Operational qualified as Operational import Control.Monad.State.Strict hiding (state) - import Data.Aeson.Lens import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.List (sort, find) import Data.Maybe (isJust, fromJust, fromMaybe, isNothing) import Data.Map (Map, insert, lookupLT, singleton, filter) +import Data.Map qualified as Map import Data.Text (Text, pack) +import Data.Text qualified as T +import Data.Text qualified as Text import Data.Text.Encoding (decodeUtf8) -import Data.List (sort, find) +import Data.Vector qualified as Vec +import Data.Vector.Storable qualified as SVec import Data.Version (showVersion) - -import qualified Data.ByteString as BS -import qualified Data.Text as T -import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified Data.Vector as Vec -import qualified Data.Vector.Storable as SVec -import qualified Graphics.Vty as V -import qualified System.Console.Haskeline as Readline - -import qualified EVM.TTYCenteredList as Centered - -import qualified Paths_hevm as Paths +import Graphics.Vty qualified as V +import System.Console.Haskeline qualified as Readline +import Paths_hevm qualified as Paths +import Text.Wrap data Name = AbiPane @@ -222,7 +215,7 @@ isUnitTestContract :: Text -> DappInfo -> Bool isUnitTestContract name dapp = - elem name (map fst (view dappUnitTests dapp)) + elem name (map fst dapp.unitTests) mkVty :: IO V.Vty mkVty = do @@ -258,7 +251,7 @@ v <- mkVty ui2 <- customMain v mkVty Nothing (app opts) (ViewVm ui0) case ui2 of - ViewVm ui -> return (view uiVm ui) + ViewVm ui -> return ui._uiVm _ -> error "internal error: customMain returned prematurely" @@ -303,7 +296,7 @@ (Vec.fromList (concatMap (debuggableTests opts) - (view dappUnitTests dapp))) + dapp.unitTests)) 1 , _testPickerDapp = dapp , _testOpts = opts @@ -325,7 +318,7 @@ (Continue steps, ui') -> put (ViewVm (ui' & set uiStepper steps)) where - m = interpret mode (view uiStepper ui) + m = interpret mode ui._uiStepper nxt = runStateT m ui backstepUntil @@ -334,21 +327,21 @@ => (UiVmState -> Pred VM) -> EventM n UiState () backstepUntil p = get >>= \case ViewVm s -> - case view uiStep s of + case s._uiStep of 0 -> pure () n -> do s1 <- liftIO $ backstep s let -- find a previous vm that satisfies the predicate - snapshots' = Data.Map.filter (p s1 . fst) (view uiSnapshots s1) + snapshots' = Data.Map.filter (p s1 . fst) s1._uiSnapshots case lookupLT n snapshots' of -- If no such vm exists, go to the beginning Nothing -> let - (step', (vm', stepper')) = fromJust $ lookupLT (n - 1) (view uiSnapshots s) + (step', (vm', stepper')) = fromJust $ lookupLT (n - 1) s._uiSnapshots s2 = s1 & set uiVm vm' - & set (uiVm . cache) (view (uiVm . cache) s1) + & set (uiVm . cache) s1._uiVm._cache & set uiStep step' & set uiStepper stepper' in takeStep s2 (Step 0) @@ -357,7 +350,7 @@ let s2 = s1 & set uiVm vm' - & set (uiVm . cache) (view (uiVm . cache) s1) + & set (uiVm . cache) s1._uiVm._cache & set uiStep step' & set uiStepper stepper' in takeStep s2 (StepUntil (not . p s1)) @@ -368,7 +361,7 @@ ,?maxIter :: Maybe Integer) => UiVmState -> IO UiVmState backstep s = - case view uiStep s of + case s._uiStep of -- We're already at the first step; ignore command. 0 -> pure s -- To step backwards, we revert to the previous snapshot @@ -378,10 +371,10 @@ -- any blocking queries, and also the memory view. n -> let - (step, (vm, stepper)) = fromJust $ lookupLT n (view uiSnapshots s) + (step, (vm, stepper)) = fromJust $ lookupLT n s._uiSnapshots s1 = s & set uiVm vm - & set (uiVm . cache) (view (uiVm . cache) s) + & set (uiVm . cache) s._uiVm._cache & set uiStep step & set uiStepper stepper stepsToTake = n - step - 1 @@ -419,14 +412,14 @@ appEvent (VtyEvent (V.EvKey V.KEsc [])) = get >>= \case ViewVm s -> do let opts = s ^. uiTestOpts - dapp' = dapp opts - tests = concatMap (debuggableTests opts) (dapp' ^. dappUnitTests) + dapp = opts.dapp + tests = concatMap (debuggableTests opts) dapp.unitTests case tests of [] -> halt ts -> put $ ViewPicker $ UiTestPickerState { _testPickerList = list TestPickerPane (Vec.fromList ts) 1 - , _testPickerDapp = dapp' + , _testPickerDapp = dapp , _testOpts = opts } ViewHelp s -> put (ViewVm s) @@ -441,15 +434,15 @@ { _browserContractList = list BrowserPane - (Vec.fromList (Map.toList (view (uiVm . env . contracts) s))) + (Vec.fromList (Map.toList s._uiVm._env._contracts)) 2 , _browserVm = s } ViewPicker s -> - case listSelectedElement (view testPickerList s) of + case listSelectedElement s._testPickerList of Nothing -> error "nothing selected" Just (_, x) -> do - let initVm = initialUiVmStateForTest (view testOpts s) x + let initVm = initialUiVmStateForTest s._testOpts x put (ViewVm initVm) _ -> pure () @@ -514,10 +507,10 @@ -- We keep the current cache so we don't have to redo -- any blocking queries. let - (vm, stepper) = fromJust (Map.lookup 0 (view uiSnapshots s)) + (vm, stepper) = fromJust (Map.lookup 0 s._uiSnapshots) s' = s & set uiVm vm - & set (uiVm . cache) (view (uiVm . cache) s) + & set (uiVm . cache) s._uiVm._cache & set uiStep 0 & set uiStepper stepper @@ -527,7 +520,7 @@ -- Vm Overview: p - backstep appEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) = get >>= \case ViewVm s -> - case view uiStep s of + case s._uiStep of 0 -> -- We're already at the first step; ignore command. pure () @@ -538,10 +531,10 @@ -- We keep the current cache so we don't have to redo -- any blocking queries, and also the memory view. let - (step, (vm, stepper)) = fromJust $ lookupLT n (view uiSnapshots s) + (step, (vm, stepper)) = fromJust $ lookupLT n s._uiSnapshots s1 = s & set uiVm vm -- set the vm to the one from the snapshot - & set (uiVm . cache) (view (uiVm . cache) s) -- persist the cache + & set (uiVm . cache) s._uiVm._cache -- persist the cache & set uiStep step & set uiStepper stepper stepsToTake = n - step - 1 @@ -562,7 +555,7 @@ ViewVm s -> case view (uiVm . result) s of Just (VMFailure (Choose (PleaseChoosePath _ contin))) -> - takeStep (s & set uiStepper (Stepper.evm (contin True) >> (view uiStepper s))) + takeStep (s & set uiStepper (Stepper.evm (contin True) >> s._uiStepper)) (Step 1) _ -> pure () _ -> pure () @@ -570,9 +563,9 @@ -- Vm Overview: 1 - choose jump appEvent (VtyEvent (V.EvKey (V.KChar '1') [])) = get >>= \case ViewVm s -> - case view (uiVm . result) s of + case s._uiVm._result of Just (VMFailure (Choose (PleaseChoosePath _ contin))) -> - takeStep (s & set uiStepper (Stepper.evm (contin False) >> (view uiStepper s))) + takeStep (s & set uiStepper (Stepper.evm (contin False) >> s._uiStepper)) (Step 1) _ -> pure () _ -> pure () @@ -616,7 +609,7 @@ SymbolicTest _ -> symCalldata theTestName types [] (AbstractBuf "txdata") _ -> (error "unreachable", error "unreachable") (test, types) = fromJust $ find (\(test',_) -> extractSig test' == theTestName) $ unitTestMethods testContract - testContract = fromJust $ view (dappSolcByName . at theContractName) dapp + testContract = fromJust $ Map.lookup theContractName dapp.solcByName vm0 = initialUnitTestVm opts testContract script = do @@ -697,7 +690,7 @@ withHighlight selected $ txt " Debug " <+> txt (contractNamePart x) <+> txt "::" <+> txt y) True - (view testPickerList ui) + ui._testPickerList ] drawVmBrowser :: UiBrowserState -> [UiWidget] @@ -708,48 +701,47 @@ renderList (\selected (k, c') -> withHighlight selected . txt . mconcat $ - [ fromMaybe "" . flip preview dapp' $ - ( dappSolcByHash . ix (maybeHash c') - . _2 . contractName ) + [ fromMaybe "" $ + Map.lookup (maybeHash c') dapp.solcByHash <&> (.contractName) . snd , "\n" , " ", pack (show k) ]) True - (view browserContractList ui) - , case flip preview dapp' (dappSolcByHash . ix (maybeHash c) . _2) of + ui._browserContractList + , case snd <$> Map.lookup (maybeHash c) dapp.solcByHash of Nothing -> hBox [ borderWithLabel (txt "Contract information") . padBottom Max . padRight Max $ vBox - [ txt ("Codehash: " <> pack (show (view codehash c))) - , txt ("Nonce: " <> showWordExact (view nonce c)) - , txt ("Balance: " <> showWordExact (view balance c)) + [ txt ("Codehash: " <> pack (show c._codehash)) + , txt ("Nonce: " <> showWordExact c._nonce) + , txt ("Balance: " <> showWordExact c._balance) --, txt ("Storage: " <> storageDisplay (view storage c)) -- TODO: fix this ] ] Just sol -> hBox [ borderWithLabel (txt "Contract information") . padBottom Max . padRight (Pad 2) $ vBox - [ txt "Name: " <+> txt (contractNamePart (view contractName sol)) - , txt "File: " <+> txt (contractPathPart (view contractName sol)) + [ txt "Name: " <+> txt (contractNamePart sol.contractName) + , txt "File: " <+> txt (contractPathPart sol.contractName) , txt " " , txt "Constructor inputs:" - , vBox . flip map (view constructorInputs sol) $ + , vBox . flip map sol.constructorInputs $ \(name, abiType) -> txt (" " <> name <> ": " <> abiTypeSolidity abiType) , txt "Public methods:" - , vBox . flip map (sort (Map.elems (view abiMap sol))) $ - \method -> txt (" " <> view methodSignature method) + , vBox . flip map (sort (Map.elems sol.abiMap)) $ + \method -> txt (" " <> method.methodSignature) --, txt ("Storage:" <> storageDisplay (view storage c)) -- TODO: fix this ] , borderWithLabel (txt "Storage slots") . padBottom Max . padRight Max $ vBox - (map txt (storageLayout dapp' sol)) + (map txt (storageLayout dapp sol)) ] ] ] where - dapp' = dapp (view (browserVm . uiTestOpts) ui) - (_, (_, c)) = fromJust $ listSelectedElement (view browserContractList ui) + dapp = ui._browserVm._uiTestOpts.dapp + (_, (_, c)) = fromJust $ listSelectedElement ui._browserContractList -- currentContract = view (dappSolcByHash . ix ) dapp - maybeHash ch = fromJust (error "Internal error: cannot find concrete codehash for partially symbolic code") (maybeLitWord (view codehash ch)) + maybeHash ch = fromJust (error "Internal error: cannot find concrete codehash for partially symbolic code") (maybeLitWord ch._codehash) drawVm :: UiVmState -> [UiWidget] drawVm ui = @@ -813,35 +805,35 @@ :: UiVmState -> Pred VM isNewTraceAdded ui vm = let - currentTraceTree = length <$> traceForest (view uiVm ui) + currentTraceTree = length <$> traceForest ui._uiVm newTraceTree = length <$> traceForest vm in currentTraceTree /= newTraceTree isNextSourcePosition :: UiVmState -> Pred VM isNextSourcePosition ui vm = - let dapp' = dapp (view uiTestOpts ui) - initialPosition = currentSrcMap dapp' (view uiVm ui) - in currentSrcMap dapp' vm /= initialPosition + let dapp = ui._uiTestOpts.dapp + initialPosition = currentSrcMap dapp ui._uiVm + in currentSrcMap dapp vm /= initialPosition isNextSourcePositionWithoutEntering :: UiVmState -> Pred VM isNextSourcePositionWithoutEntering ui vm = let - dapp' = dapp (view uiTestOpts ui) - vm0 = view uiVm ui - initialPosition = currentSrcMap dapp' vm0 - initialHeight = length (view frames vm0) + dapp = ui._uiTestOpts.dapp + vm0 = ui._uiVm + initialPosition = currentSrcMap dapp vm0 + initialHeight = length vm0._frames in - case currentSrcMap dapp' vm of + case currentSrcMap dapp vm of Nothing -> False Just here -> let moved = Just here /= initialPosition - deeper = length (view frames vm) > initialHeight + deeper = length vm._frames > initialHeight boring = - case srcMapCode (view dappSources dapp') here of + case srcMapCode dapp.sources here of Just bs -> BS.isPrefixOf "contract " bs Nothing -> @@ -850,20 +842,20 @@ moved && not deeper && not boring isExecutionHalted :: UiVmState -> Pred VM -isExecutionHalted _ vm = isJust (view result vm) +isExecutionHalted _ vm = isJust vm._result currentSrcMap :: DappInfo -> VM -> Maybe SrcMap currentSrcMap dapp vm = do this <- currentContract vm - i <- (view opIxMap this) SVec.!? (view (state . pc) vm) + i <- this._opIxMap SVec.!? vm._state._pc srcMap dapp this i drawStackPane :: UiVmState -> UiWidget drawStackPane ui = let - gasText = showWordExact (num $ view (uiVm . state . gas) ui) + gasText = showWordExact (num ui._uiVm._state._gas) labelText = txt ("Gas available: " <> gasText <> "; stack:") - stackList = list StackPane (Vec.fromList $ zip [(1 :: Int)..] (fmap simplify $ view (uiVm . state . stack) ui)) 2 + stackList = list StackPane (Vec.fromList $ zip [(1 :: Int)..] (simplify <$> ui._uiVm._state._stack)) 2 in hBorderWithLabel labelText <=> renderList (\_ (i, w) -> @@ -872,14 +864,14 @@ <+> ourWrap (Text.unpack $ prettyIfConcreteWord w) , dim (txt (" " <> case unlit w of Nothing -> "" - Just u -> showWordExplanation u $ dapp (view uiTestOpts ui))) + Just u -> showWordExplanation u ui._uiTestOpts.dapp)) ]) False stackList message :: VM -> String message vm = - case view result vm of + case vm._result of Just (VMSuccess (ConcreteBuf msg)) -> "VMSuccess: " <> (show $ ByteStringS msg) Just (VMSuccess (msg)) -> @@ -889,13 +881,13 @@ Just (VMFailure err) -> "VMFailure: " <> show err Nothing -> - "Executing EVM code in " <> show (view (state . contract) vm) + "Executing EVM code in " <> show vm._state._contract drawBytecodePane :: UiVmState -> UiWidget drawBytecodePane ui = let - vm = view uiVm ui + vm = ui._uiVm move = maybe id listMoveTo $ vmOpIx vm in hBorderWithLabel (str $ message vm) <=> @@ -905,7 +897,7 @@ else withDefAttr boldAttr (opWidget x)) False (move $ list BytecodePane - (maybe mempty (view codeOps) (currentContract vm)) + (maybe mempty (._codeOps) (currentContract vm)) 1) @@ -922,31 +914,31 @@ drawTracePane :: UiVmState -> UiWidget drawTracePane s = - let vm = view uiVm s - dapp' = dapp (view uiTestOpts s) + let vm = s._uiVm + dapp = s._uiTestOpts.dapp traceList = list TracePane (Vec.fromList . Text.lines - . showTraceTree dapp' + . showTraceTree dapp $ vm) 1 - in case view uiShowMemory s of + in case s._uiShowMemory of True -> viewport TracePane Vertical $ hBorderWithLabel (txt "Calldata") - <=> ourWrap (prettyIfConcrete (view (state . calldata) vm)) + <=> ourWrap (prettyIfConcrete vm._state._calldata) <=> hBorderWithLabel (txt "Returndata") - <=> ourWrap (prettyIfConcrete (view (state . returndata) vm)) + <=> ourWrap (prettyIfConcrete vm._state._returndata) <=> hBorderWithLabel (txt "Output") - <=> ourWrap (maybe "" show (view result vm)) + <=> ourWrap (maybe "" show vm._result) <=> hBorderWithLabel (txt "Cache") - <=> ourWrap (show (view (cache . path) vm)) + <=> ourWrap (show vm._cache._path) <=> hBorderWithLabel (txt "Path Conditions") - <=> (ourWrap $ show $ view constraints vm) + <=> (ourWrap $ show $ vm._constraints) <=> hBorderWithLabel (txt "Memory") - <=> (ourWrap (prettyIfConcrete (view (state . memory) vm))) + <=> (ourWrap (prettyIfConcrete vm._state._memory)) False -> hBorderWithLabel (txt "Trace") <=> renderList @@ -965,45 +957,40 @@ } solidityList :: VM -> DappInfo -> List Name (Int, ByteString) -solidityList vm dapp' = +solidityList vm dapp = list SolidityPane - (case currentSrcMap dapp' vm of + (case currentSrcMap dapp vm of Nothing -> mempty Just x -> - view (dappSources - . sourceLines - . ix (srcMapFile x) + view ( + ix x.srcMapFile . to (Vec.imap (,))) - dapp') + dapp.sources.lines) 1 drawSolidityPane :: UiVmState -> UiWidget drawSolidityPane ui = - let dapp' = dapp (view uiTestOpts ui) - dappSrcs = view dappSources dapp' - vm = view uiVm ui - in case currentSrcMap dapp' vm of + let dapp = ui._uiTestOpts.dapp + dappSrcs = dapp.sources + vm = ui._uiVm + in case currentSrcMap dapp vm of Nothing -> padBottom Max (hBorderWithLabel (txt "")) Just sm -> let - rows = (_sourceLines dappSrcs) !! srcMapFile sm - subrange = lineSubrange rows (srcMapOffset sm, srcMapLength sm) + rows = dappSrcs.lines !! sm.srcMapFile + subrange = lineSubrange rows (sm.srcMapOffset, sm.srcMapLength) fileName :: Maybe Text - fileName = preview (dappSources . sourceFiles . ix (srcMapFile sm) . _1) dapp' + fileName = preview (ix sm.srcMapFile . _1) dapp.sources.files lineNo :: Maybe Int - lineNo = maybe Nothing (\a -> Just (a - 1)) - (snd <$> - (srcMapCodePos - (view dappSources dapp') - sm)) + lineNo = ((\a -> Just (a - 1)) . snd) =<< srcMapCodePos dapp.sources sm in vBox [ hBorderWithLabel $ txt (fromMaybe "" fileName) - <+> str (":" ++ show lineNo) + <+> str (":" ++ (maybe "?" show lineNo)) -- Show the AST node type if present <+> txt (" (" <> fromMaybe "?" - ((view dappAstSrcMap dapp') sm + (dapp.astSrcMap sm >>= preview (key "name" . _String)) <> ")") , Centered.renderList (\_ (i, line) -> @@ -1021,7 +1008,7 @@ ]) False ((maybe id listMoveTo lineNo) - (solidityList vm dapp')) + (solidityList vm dapp)) ] ifTallEnough :: Int -> Widget n -> Widget n -> Widget n diff --git a/src/EVM/Transaction.hs b/src/EVM/Transaction.hs --- a/src/EVM/Transaction.hs +++ b/src/EVM/Transaction.hs @@ -52,94 +52,94 @@ -- | utility function for getting a more useful representation of accesslistentries -- duplicates only matter for gas computation txAccessMap :: Transaction -> Map Addr [W256] -txAccessMap tx = ((Map.fromListWith (++)) . makeTups) $ txAccessList tx - where makeTups = map (\ale -> (accessAddress ale, accessStorageKeys ale)) +txAccessMap tx = ((Map.fromListWith (++)) . makeTups) tx.txAccessList + where makeTups = map (\ale -> (ale.accessAddress , ale.accessStorageKeys )) ecrec :: W256 -> W256 -> W256 -> W256 -> Maybe Addr ecrec v r s e = num . word <$> EVM.Precompiled.execute 1 input 32 where input = BS.concat (word256Bytes <$> [e, v, r, s]) sender :: Int -> Transaction -> Maybe Addr -sender chainId tx = ecrec v' (txR tx) (txS tx) hash +sender chainId tx = ecrec v' tx.txR tx.txS hash where hash = keccak' (signingData chainId tx) - v = txV tx + v = tx.txV v' = if v == 27 || v == 28 then v else 27 + v signingData :: Int -> Transaction -> ByteString signingData chainId tx = - case txType tx of + case tx.txType of LegacyTransaction -> if v == (chainId * 2 + 35) || v == (chainId * 2 + 36) then eip155Data else normalData AccessListTransaction -> eip2930Data EIP1559Transaction -> eip1559Data - where v = fromIntegral (txV tx) - to' = case txToAddr tx of + where v = fromIntegral tx.txV + to' = case tx.txToAddr of Just a -> BS $ word160Bytes a Nothing -> BS mempty - maxFee = fromJust $ txMaxFeePerGas tx - maxPrio = fromJust $ txMaxPriorityFeeGas tx - gasPrice = fromJust $ txGasPrice tx - accessList = txAccessList tx + maxFee = fromJust tx.txMaxFeePerGas + maxPrio = fromJust tx.txMaxPriorityFeeGas + gasPrice = fromJust tx.txGasPrice + accessList = tx.txAccessList rlpAccessList = EVM.RLP.List $ map (\accessEntry -> - EVM.RLP.List [BS $ word160Bytes (accessAddress accessEntry), - EVM.RLP.List $ map rlpWordFull $ accessStorageKeys accessEntry] + EVM.RLP.List [BS $ word160Bytes accessEntry.accessAddress, + EVM.RLP.List $ map rlpWordFull accessEntry.accessStorageKeys] ) accessList - normalData = rlpList [rlpWord256 (txNonce tx), + normalData = rlpList [rlpWord256 tx.txNonce, rlpWord256 gasPrice, - rlpWord256 (num $ txGasLimit tx), + rlpWord256 (num tx.txGasLimit), to', - rlpWord256 (txValue tx), - BS (txData tx)] - eip155Data = rlpList [rlpWord256 (txNonce tx), + rlpWord256 tx.txValue, + BS tx.txData] + eip155Data = rlpList [rlpWord256 tx.txNonce, rlpWord256 gasPrice, - rlpWord256 (num $ txGasLimit tx), + rlpWord256 (num tx.txGasLimit), to', - rlpWord256 (txValue tx), - BS (txData tx), + rlpWord256 tx.txValue, + BS tx.txData, rlpWord256 (fromIntegral chainId), rlpWord256 0x0, rlpWord256 0x0] eip1559Data = cons 0x02 $ rlpList [ rlpWord256 (fromIntegral chainId), - rlpWord256 (txNonce tx), + rlpWord256 tx.txNonce, rlpWord256 maxPrio, rlpWord256 maxFee, - rlpWord256 (num $ txGasLimit tx), + rlpWord256 (num tx.txGasLimit), to', - rlpWord256 (txValue tx), - BS (txData tx), + rlpWord256 tx.txValue, + BS tx.txData, rlpAccessList] eip2930Data = cons 0x01 $ rlpList [ rlpWord256 (fromIntegral chainId), - rlpWord256 (txNonce tx), + rlpWord256 tx.txNonce, rlpWord256 gasPrice, - rlpWord256 (num $ txGasLimit tx), + rlpWord256 (num tx.txGasLimit), to', - rlpWord256 (txValue tx), - BS (txData tx), + rlpWord256 tx.txValue, + BS tx.txData, rlpAccessList] accessListPrice :: FeeSchedule Word64 -> [AccessListEntry] -> Word64 accessListPrice fs al = sum (map (\ale -> - g_access_list_address fs + - (g_access_list_storage_key fs * (fromIntegral . length) (accessStorageKeys ale))) + fs.g_access_list_address + + (fs.g_access_list_storage_key * (fromIntegral . length) ale.accessStorageKeys)) al) txGasCost :: FeeSchedule Word64 -> Transaction -> Word64 txGasCost fs tx = - let calldata = txData tx + let calldata = tx.txData zeroBytes = BS.count 0 calldata nonZeroBytes = BS.length calldata - zeroBytes - baseCost = g_transaction fs - + (if isNothing (txToAddr tx) then g_txcreate fs else 0) - + (accessListPrice fs $ txAccessList tx) - zeroCost = g_txdatazero fs - nonZeroCost = g_txdatanonzero fs + baseCost = fs.g_transaction + + (if isNothing tx.txToAddr then fs.g_txcreate else 0) + + (accessListPrice fs tx.txAccessList ) + zeroCost = fs.g_txdatazero + nonZeroCost = fs.g_txdatanonzero in baseCost + zeroCost * (fromIntegral zeroBytes) + nonZeroCost * (fromIntegral nonZeroBytes) instance FromJSON AccessListEntry where @@ -200,16 +200,16 @@ -- and pay receiving address initTx :: EVM.VM -> EVM.VM initTx vm = let - toAddr = view (EVM.state . EVM.contract) vm - origin = view (EVM.tx . EVM.origin) vm - gasPrice = view (EVM.tx . EVM.gasprice) vm - gasLimit = view (EVM.tx . EVM.txgaslimit) vm - coinbase = view (EVM.block . EVM.coinbase) vm - value = view (EVM.state . EVM.callvalue) vm - toContract = initialContract (view (EVM.state . EVM.code) vm) - preState = setupTx origin coinbase gasPrice gasLimit $ view (EVM.env . EVM.contracts) vm + toAddr = vm._state._contract + origin = vm._tx._origin + gasPrice = vm._tx._gasprice + gasLimit = vm._tx._txgaslimit + coinbase = vm._block._coinbase + value = vm._state._callvalue + toContract = initialContract vm._state._code + preState = setupTx origin coinbase gasPrice gasLimit vm._env._contracts oldBalance = view (accountAt toAddr . balance) preState - creation = view (EVM.tx . EVM.isCreate) vm + creation = vm._tx._isCreate initState = (case unlit value of Just v -> ((Map.adjust (over balance (subtract v))) origin) . (Map.adjust (over balance (+ v))) toAddr diff --git a/src/EVM/Types.hs b/src/EVM/Types.hs --- a/src/EVM/Types.hs +++ b/src/EVM/Types.hs @@ -5,7 +5,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} -{-# OPTIONS_GHC -Wno-error=inline-rule-shadowing #-} +{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} module EVM.Types where @@ -16,7 +16,7 @@ import Data.Map (Map) import Data.Bifunctor (first) import Data.Char -import Data.List (isPrefixOf) +import Data.List (isPrefixOf, foldl') import Data.ByteString (ByteString) import Data.ByteString.Base16 as BS16 import Data.ByteString.Builder (byteStringHex, toLazyByteString) @@ -124,6 +124,7 @@ | StackLimitExceeded | InvalidMemoryAccess | BadJumpDestination + | StackUnderrun | SelfDestruct | TmpErr String deriving (Show, Eq, Ord) @@ -410,6 +411,12 @@ (./=) :: (Typeable a) => Expr a -> Expr a -> Prop x ./= y = PNeg (PEq x y) +pand :: [Prop] -> Prop +pand = foldl' PAnd (PBool True) + +por :: [Prop] -> Prop +por = foldl' POr (PBool False) + instance Eq Prop where PBool a == PBool b = a == b PEq (a :: Expr x) (b :: Expr x) == PEq (c :: Expr y) (d :: Expr y) @@ -639,7 +646,7 @@ word256Bytes x = BS.pack [byteAt x (31 - i) | i <- [0..31]] word160Bytes :: Addr -> ByteString -word160Bytes x = BS.pack [byteAt (addressWord160 x) (19 - i) | i <- [0..19]] +word160Bytes x = BS.pack [byteAt x.addressWord160 (19 - i) | i <- [0..19]] newtype Nibble = Nibble Word8 deriving ( Num, Integral, Real, Ord, Enum, Eq, Bounded, Generic) diff --git a/src/EVM/UnitTest.hs b/src/EVM/UnitTest.hs --- a/src/EVM/UnitTest.hs +++ b/src/EVM/UnitTest.hs @@ -9,65 +9,57 @@ import EVM.ABI import EVM.Concrete import EVM.SMT +import EVM.Solvers import EVM.Dapp import EVM.Debug (srcMapCodePos) import EVM.Exec import EVM.Expr (litAddr, readStorage', simplify) +import EVM.Expr qualified as Expr +import EVM.Facts qualified as Facts +import EVM.Facts.Git qualified as Git +import EVM.FeeSchedule qualified as FeeSchedule +import EVM.Fetch qualified as Fetch import EVM.Format import EVM.Solidity -import qualified EVM.SymExec as SymExec +import EVM.SymExec qualified as SymExec import EVM.SymExec (defaultVeriOpts, symCalldata, verify, isQed, extractCex, runExpr, subModel, VeriOpts) import EVM.Types hiding (Failure) import EVM.Transaction (initTx) import EVM.RLP -import qualified EVM.Facts as Facts -import qualified EVM.Facts.Git as Git -import qualified EVM.Fetch as Fetch -import qualified EVM.Expr as Expr - -import qualified EVM.FeeSchedule as FeeSchedule - import EVM.Stepper (Stepper, interpret) -import qualified EVM.Stepper as Stepper -import qualified Control.Monad.Operational as Operational +import EVM.Stepper qualified as Stepper +import Control.Monad.Operational qualified as Operational import Control.Lens hiding (Indexed, elements, List, passing) -import Control.Monad.State.Strict hiding (state) -import qualified Control.Monad.State.Strict as State - import Control.Monad.Par.Class (spawn_) +import Control.Monad.Par.Class qualified as Par import Control.Monad.Par.IO (runParIO) - -import qualified Data.ByteString.Lazy as BSLazy -import Data.Binary.Get (runGet) -import Data.ByteString (ByteString) -import Data.Decimal (DecimalRaw(..)) -import Data.Either (isRight) -import Data.Foldable (toList) -import Data.Map (Map) -import Data.Maybe (fromMaybe, catMaybes, fromJust, isJust, fromMaybe, mapMaybe, isNothing) -import Data.Text (isPrefixOf, stripSuffix, intercalate, Text, pack, unpack) -import Data.Word (Word32, Word64) -import Data.Text.Encoding (encodeUtf8) -import System.Environment (lookupEnv) -import System.IO (hFlush, stdout) -import GHC.Natural - -import qualified Control.Monad.Par.Class as Par -import qualified Data.ByteString as BS -import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified Data.Text.IO as Text - +import Control.Monad.State.Strict hiding (state) +import Control.Monad.State.Strict qualified as State +import Data.ByteString.Lazy qualified as BSLazy +import Data.Binary.Get (runGet) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Decimal (DecimalRaw(..)) +import Data.Either (isRight) +import Data.Foldable (toList) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe, catMaybes, fromJust, isJust, fromMaybe, mapMaybe, isNothing) import Data.MultiSet (MultiSet) -import qualified Data.MultiSet as MultiSet - +import Data.MultiSet qualified as MultiSet import Data.Set (Set) -import qualified Data.Set as Set - +import Data.Set qualified as Set +import Data.Text (isPrefixOf, stripSuffix, intercalate, Text, pack, unpack) +import Data.Text qualified as Text +import Data.Text.Encoding (encodeUtf8) +import Data.Text.IO qualified as Text import Data.Vector (Vector) -import qualified Data.Vector as Vector - +import Data.Vector qualified as Vector +import Data.Word (Word32, Word64) +import GHC.Natural +import System.Environment (lookupEnv) +import System.IO (hFlush, stdout) import Test.QuickCheck hiding (verbose) data UnitTestOptions = UnitTestOptions @@ -127,10 +119,10 @@ -- | Generate VeriOpts from UnitTestOptions makeVeriOpts :: UnitTestOptions -> VeriOpts makeVeriOpts opts = - defaultVeriOpts { SymExec.debug = smtDebug opts - , SymExec.maxIter = maxIter opts - , SymExec.askSmtIters = askSmtIters opts - , SymExec.rpcInfo = rpcInfo opts + defaultVeriOpts { SymExec.debug = opts.smtDebug + , SymExec.maxIter = opts.maxIter + , SymExec.askSmtIters = opts.askSmtIters + , SymExec.rpcInfo = opts.rpcInfo } -- | Top level CLI endpoint for dapp-test @@ -139,7 +131,7 @@ out <- liftIO $ readSolc solcFile case out of Just (contractMap, _) -> do - let unitTests = findUnitTests (EVM.UnitTest.match opts) $ Map.elems contractMap + let unitTests = findUnitTests opts.match $ Map.elems contractMap results <- concatMapM (runUnitTestContract opts contractMap) unitTests let (passing, vms) = unzip results case cache' of @@ -148,13 +140,11 @@ Just path -> -- merge all of the post-vm caches and save into the state let - evmcache = mconcat [view EVM.cache vm | vm <- vms] + evmcache = mconcat [vm._cache | vm <- vms] in liftIO $ Git.saveFacts (Git.RepoAt path) (Facts.cacheFacts evmcache) - if and passing - then return True - else return False + return $ and passing Nothing -> error ("Failed to read Solidity JSON for `" ++ solcFile ++ "'") @@ -164,7 +154,7 @@ initializeUnitTest :: UnitTestOptions -> SolcContract -> Stepper () initializeUnitTest UnitTestOptions { .. } theContract = do - let addr = testAddress testParams + let addr = testParams.testAddress Stepper.evm $ do -- Maybe modify the initial VM, e.g. to load library code @@ -177,10 +167,10 @@ Stepper.evm $ do -- Give a balance to the test target - env . contracts . ix addr . balance += testBalanceCreate testParams + env . contracts . ix addr . balance += testParams.testBalanceCreate -- call setUp(), if it exists, to initialize the test contract - let theAbi = view abiMap theContract + let theAbi = theContract.abiMap setUp = abiKeccak (encodeUtf8 "setUp()") when (isJust (Map.lookup setUp theAbi)) $ do @@ -218,11 +208,11 @@ Stepper.evm $ do cs <- use (env . contracts) abiCall testParams (Right bs) - let (Method _ inputs sig _ _) = fromMaybe (error "unknown abi call") $ Map.lookup (num $ word $ BS.take 4 bs) (view dappAbiMap dapp) + let (Method _ inputs sig _ _) = fromMaybe (error "unknown abi call") $ Map.lookup (num $ word $ BS.take 4 bs) dapp.abiMap types = snd <$> inputs let ?context = DappContext dapp cs - this <- fromMaybe (error "unknown target") <$> (use (env . contracts . at (testAddress testParams))) - let name = maybe "" (contractNamePart . view contractName) $ lookupCode (view contractcode this) dapp + this <- fromMaybe (error "unknown target") <$> (use (env . contracts . at testParams.testAddress)) + let name = maybe "" (contractNamePart . (.contractName)) $ lookupCode this._contractcode dapp pushTrace (EntryTrace (name <> "." <> sig <> "(" <> intercalate "," ((pack . show) <$> types) <> ")" <> showCall types (ConcreteBuf bs))) -- Try running the test method Stepper.execFully >>= \case @@ -266,10 +256,10 @@ } deriving (Show) instance Eq OpLocation where - (==) (OpLocation a b) (OpLocation a' b') = b == b' && view contractcode a == view contractcode a' + (==) (OpLocation a b) (OpLocation a' b') = b == b' && a._contractcode == a'._contractcode instance Ord OpLocation where - compare (OpLocation a b) (OpLocation a' b') = compare (view contractcode a, b) (view contractcode a', b') + compare (OpLocation a b) (OpLocation a' b') = compare (a._contractcode, b) (a'._contractcode, b') srcMapForOpLocation :: DappInfo -> OpLocation -> Maybe SrcMap srcMapForOpLocation dapp (OpLocation contr opIx) = srcMap dapp contr opIx @@ -295,7 +285,7 @@ -- This is just like `exec` except for every instruction evaluated, -- we also increment a counter indexed by the current code location. vm0 <- use _1 - case view result vm0 of + case vm0._result of Nothing -> do vm1 <- zoom _1 (State.state (runState exec1) >> get) zoom _2 (modify (MultiSet.insert (currentOpLocation vm1))) @@ -341,7 +331,7 @@ coverageReport dapp cov = let sources :: SourceCache - sources = view dappSources dapp + sources = dapp.sources allPositions :: Set (Text, Int) allPositions = @@ -349,9 +339,9 @@ . mapMaybe (srcMapCodePos sources) . toList $ mconcat - ( view dappSolcByName dapp + ( dapp.solcByName & Map.elems - & map (\x -> view runtimeSrcmap x <> view creationSrcmap x) + & map (\x -> x.runtimeSrcmap <> x.creationSrcmap) ) ) @@ -362,8 +352,8 @@ linesByName = Map.fromList $ zipWith (\(name, _) lines' -> (name, lines')) - (view sourceFiles sources) - (view sourceLines sources) + sources.files + sources.lines f :: Text -> Vector ByteString -> Vector (Int, ByteString) f name = @@ -388,7 +378,7 @@ opts@(UnitTestOptions {..}) contractMap _ (name, testNames) = do -- Look for the wanted contract by name from the Solidity info - case preview (ix name) contractMap of + case Map.lookup name contractMap of Nothing -> -- Fail if there's no such contract error $ "Contract " ++ unpack name ++ " not found" @@ -432,7 +422,7 @@ ++ unpack name -- Look for the wanted contract by name from the Solidity info - case preview (ix name) contractMap of + case Map.lookup name contractMap of Nothing -> -- Fail if there's no such contract error $ "Contract " ++ unpack name ++ " not found" @@ -446,7 +436,7 @@ (Stepper.enter name >> initializeUnitTest opts theContract)) vm0 - case view result vm1 of + case vm1._result of Nothing -> error "internal error: setUp() did not end with a result" Just (VMFailure _) -> liftIO $ do Text.putStrLn "\x1b[31m[BAIL]\x1b[0m setUp() " @@ -461,7 +451,7 @@ runCache (results, vm) (test, types) = do (t, r, vm') <- runTest opts vm (test, types) liftIO $ Text.putStrLn t - let vmCached = vm & set cache (view cache vm') + let vmCached = vm { _cache = vm'._cache } pure (((r, vm'): results), vmCached) -- Run all the test cases and print their status updates, @@ -527,31 +517,33 @@ Nothing -> Stepper.evmIO $ do vm <- get - let cs = view (env . contracts) vm - noCode c = case view contractcode c of + let cs = vm._env._contracts + noCode c = case c._contractcode of RuntimeCode (ConcreteRuntimeCode "") -> True RuntimeCode (SymbolicRuntimeCode c') -> null c' _ -> False - mutable m = view methodMutability m `elem` [NonPayable, Payable] + mutable m = m.mutability `elem` [NonPayable, Payable] knownAbis :: Map Addr SolcContract knownAbis = -- exclude contracts without code - Map.filter (not . BS.null . view runtimeCode) $ + Map.filter (not . BS.null . (.runtimeCode)) $ -- exclude contracts without state changing functions - Map.filter (not . null . Map.filter mutable . view abiMap) $ + Map.filter (not . null . Map.filter mutable . (.abiMap)) $ -- exclude testing abis - Map.filter (isNothing . preview (abiMap . ix unitTestMarkerAbi)) $ + Map.filter (isNothing . preview (ix unitTestMarkerAbi) . (.abiMap)) $ -- pick all contracts with known compiler artifacts - fmap fromJust (Map.filter isJust $ Map.fromList [(addr, lookupCode (view contractcode c) dapp) | (addr, c) <- Map.toList cs]) + fmap fromJust (Map.filter isJust $ Map.fromList [(addr, lookupCode c._contractcode dapp) | (addr, c) <- Map.toList cs]) selected = [(addr, - fromMaybe (error ("no src found for: " <> show addr)) $ lookupCode (view contractcode (fromMaybe (error $ "contract not found: " <> show addr) $ Map.lookup addr cs)) dapp) + fromMaybe (error ("no src found for: " <> show addr)) $ + lookupCode (fromMaybe (error $ "contract not found: " <> show addr) $ + Map.lookup addr cs)._contractcode dapp) | addr <- targets] -- go to IO and generate a random valid call to any known contract liftIO $ do -- select random contract (target, solcInfo) <- generate $ elements (if null targets then Map.toList knownAbis else selected) -- choose a random mutable method - (_, (Method _ inputs sig _ _)) <- generate (elements $ Map.toList $ Map.filter mutable $ view abiMap solcInfo) + (_, (Method _ inputs sig _ _)) <- generate (elements $ Map.toList $ Map.filter mutable solcInfo.abiMap) let types = snd <$> inputs -- set the caller to a random address with 90% probability, 10% known EOA address let knownEOAs = Map.keys $ Map.filter noCode cs @@ -567,7 +559,7 @@ let cd = abiMethod (sig <> "(" <> intercalate "," ((pack . show) <$> types) <> ")") args -- increment timestamp with random amount timepassed <- num <$> generate (arbitrarySizedNatural :: Gen Word32) - let ts = fromMaybe (error "symbolic timestamp not supported here") $ maybeLitWord $ view (block . timestamp) vm + let ts = fromMaybe (error "symbolic timestamp not supported here") $ maybeLitWord vm._block._timestamp return (caller', target, cd, num ts + timepassed) let opts' = opts { testParams = testParams {testAddress = target, testCaller = caller', testTimestamp = timestamp'}} thisCallRLP = List [BS $ word160Bytes caller', BS $ word160Bytes target, BS cd, BS $ word256Bytes timestamp'] @@ -593,7 +585,7 @@ getTargetContracts UnitTestOptions{..} = do vm <- Stepper.evm get let contract' = fromJust $ currentContract vm - theAbi = view abiMap $ fromJust $ lookupCode (view contractcode contract') dapp + theAbi = (fromJust $ lookupCode contract'._contractcode dapp).abiMap setUp = abiKeccak (encodeUtf8 "targetContracts()") case Map.lookup setUp theAbi of Nothing -> return [] @@ -653,7 +645,7 @@ (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) (checkFailures opts testName bailed)) vm' if success then - let gasSpent = num (testGasCall testParams) - view (state . gas) vm' + let gasSpent = num testParams.testGasCall - vm'._state._gas gasText = pack $ show (fromIntegral gasSpent :: Integer) in pure @@ -721,7 +713,7 @@ symRun opts@UnitTestOptions{..} vm testName types = do let cd = symCalldata testName types [] (AbstractBuf "txdata") shouldFail = "proveFail" `isPrefixOf` testName - testContract = view (state . contract) vm + testContract = vm._state._contract -- define postcondition depending on `shouldFail` -- We directly encode the failure conditions from failed() in ds-test since this is easier to encode than a call into failed() @@ -764,7 +756,7 @@ , intercalate "\n" $ indentLines 2 . mkMsg <$> failures' ] where - ctx = DappContext { _contextInfo = dapp, _contextEnv = mempty } + ctx = DappContext { info = dapp, env = mempty } showRes = \case Return _ _ _ -> if "proveFail" `isPrefixOf` testName then "Successful execution" @@ -835,7 +827,7 @@ passOutput :: VM -> UnitTestOptions -> Text -> Text passOutput vm UnitTestOptions { .. } testName = - let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env . EVM.contracts } + let ?context = DappContext { info = dapp, env = vm._env._contracts } in let v = fromMaybe 0 verbose in if (v > 1) then mconcat @@ -843,7 +835,7 @@ , fromMaybe "" (stripSuffix "()" testName) , "\n" , if (v > 2) then indentLines 2 (showTraceTree dapp vm) else "" - , indentLines 2 (formatTestLogs (view dappEventMap dapp) (view logs vm)) + , indentLines 2 (formatTestLogs dapp.eventMap vm._logs) , "\n" ] else "" @@ -851,7 +843,7 @@ -- TODO failOutput :: VM -> UnitTestOptions -> Text -> Text failOutput vm UnitTestOptions { .. } testName = - let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env . EVM.contracts} + let ?context = DappContext { info = dapp, env = vm._env._contracts} in mconcat [ "Failure: " , fromMaybe "" (stripSuffix "()" testName) @@ -859,7 +851,7 @@ , case verbose of Just _ -> indentLines 2 (showTraceTree dapp vm) _ -> "" - , indentLines 2 (formatTestLogs (view dappEventMap dapp) (view logs vm)) + , indentLines 2 (formatTestLogs dapp.eventMap vm._logs) , "\n" ] @@ -955,7 +947,7 @@ assign (state . caller) (litAddr testCaller) assign (state . gas) testGasCall origin' <- fromMaybe (initialContract (RuntimeCode (ConcreteRuntimeCode ""))) <$> use (env . contracts . at testOrigin) - let originBal = view balance origin' + let originBal = origin'._balance when (originBal < testGasprice * (num testGasCall)) $ error "insufficient balance for gas cost" vm <- get put $ initTx vm @@ -965,7 +957,7 @@ let TestVMParams {..} = testParams vm = makeVm $ VMOpts - { vmoptContract = initialContract (InitCode (view creationCode theContract) mempty) + { vmoptContract = initialContract (InitCode theContract.creationCode mempty) , vmoptCalldata = mempty , vmoptValue = Lit 0 , vmoptAddress = testAddress diff --git a/test/BlockchainTests.hs b/test/BlockchainTests.hs --- a/test/BlockchainTests.hs +++ b/test/BlockchainTests.hs @@ -13,7 +13,7 @@ import EVM.FeeSchedule qualified import EVM.Fetch qualified import EVM.Stepper qualified -import EVM.SMT (withSolvers, Solver(Z3)) +import EVM.Solvers (withSolvers, Solver(Z3)) import EVM.Transaction import EVM.TTY qualified as TTY import EVM.Types @@ -104,11 +104,7 @@ -- CI has issues with some heaver tests, disable in bulk ciIgnoredFiles :: [String] -ciIgnoredFiles = - [ "BlockchainTests/GeneralStateTests/VMTests/vmPerformance" - , "BlockchainTests/GeneralStateTests/stQuadraticComplexityTest" - , "BlockchainTests/GeneralStateTests/stStaticCall" - ] +ciIgnoredFiles = [] commonProblematicTests :: Map String (TestTree -> TestTree) commonProblematicTests = Map.fromList @@ -186,8 +182,8 @@ , ("bad-storage", not okData || okMoney || okNonce || okCode) , ("bad-code", not okCode || okMoney || okNonce || okData) ]) - check = checkContracts x - expected = testExpectation x + check = x.checkContracts + expected = x.testExpectation actual = Map.map (,mempty) $ view (EVM.env . EVM.contracts) vm -- . to (fmap (clearZeroStorage.clearOrigStorage))) vm printStorage = show -- TODO: fixme @@ -203,7 +199,7 @@ checkExpectation :: Bool -> Case -> EVM.VM -> IO (Maybe String) checkExpectation diff x vm = do - let expectation = testExpectation x + let expectation = x.testExpectation (okState, b2, b3, b4, b5) = checkExpectedContracts vm expectation if okState then pure Nothing @@ -260,7 +256,7 @@ clearCode :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) clearCode (c, s) = (set contractcode (EVM.RuntimeCode (EVM.ConcreteRuntimeCode "")) c, s) -newtype ContractWithStorage = ContractWithStorage { unContractWithStorage :: (EVM.Contract, Storage) } +newtype ContractWithStorage = ContractWithStorage (EVM.Contract, Storage) instance FromJSON ContractWithStorage where parseJSON (JSON.Object v) = do @@ -302,10 +298,11 @@ parseContracts :: Which -> JSON.Object -> JSON.Parser (Map Addr (EVM.Contract, Storage)) parseContracts w v = - (Map.map unContractWithStorage) <$> (v .: which >>= parseJSON) + (Map.map unwrap) <$> (v .: which >>= parseJSON) where which = case w of Pre -> "pre" Post -> "postState" + unwrap (ContractWithStorage x) = x parseBCSuite :: Lazy.ByteString -> Either String (Map String Case) @@ -343,7 +340,7 @@ fromBlockchainCase :: BlockchainCase -> Either BlockchainError Case fromBlockchainCase (BlockchainCase blocks preState postState network) = case (blocks, network) of - ([block], "London") -> case blockTxs block of + ([block], "London") -> case block.blockTxs of [tx] -> fromBlockchainCase' block tx preState postState [] -> Left NoTxs _ -> Left TooManyTxs @@ -354,7 +351,7 @@ -> Map Addr (EVM.Contract, Storage) -> Map Addr (EVM.Contract, Storage) -> Either BlockchainError Case fromBlockchainCase' block tx preState postState = - let isCreate = isNothing (txToAddr tx) in + let isCreate = isNothing tx.txToAddr in case (sender 1 tx, checkTx tx block preState) of (Nothing, _) -> Left SignatureUnverified (_, Nothing) -> Left (if isCreate then FailedCreate else InvalidTx) @@ -362,21 +359,21 @@ (EVM.VMOpts { vmoptContract = EVM.initialContract theCode , vmoptCalldata = (cd, []) - , vmoptValue = Lit (txValue tx) + , vmoptValue = Lit tx.txValue , vmoptAddress = toAddr , vmoptCaller = litAddr origin , vmoptStorageBase = Concrete , vmoptOrigin = origin - , vmoptGas = txGasLimit tx - fromIntegral (txGasCost feeSchedule tx) - , vmoptBaseFee = blockBaseFee block - , vmoptPriorityFee = priorityFee tx (blockBaseFee block) - , vmoptGaslimit = txGasLimit tx - , vmoptNumber = blockNumber block - , vmoptTimestamp = Lit $ blockTimestamp block - , vmoptCoinbase = blockCoinbase block - , vmoptPrevRandao = blockDifficulty block + , vmoptGas = tx.txGasLimit - fromIntegral (txGasCost feeSchedule tx) + , vmoptBaseFee = block.blockBaseFee + , vmoptPriorityFee = priorityFee tx block.blockBaseFee + , vmoptGaslimit = tx.txGasLimit + , vmoptNumber = block.blockNumber + , vmoptTimestamp = Lit block.blockTimestamp + , vmoptCoinbase = block.blockCoinbase + , vmoptPrevRandao = block.blockDifficulty , vmoptMaxCodeSize = 24576 - , vmoptBlockGaslimit = blockGasLimit block + , vmoptBlockGaslimit = block.blockGasLimit , vmoptGasprice = effectiveGasPrice , vmoptSchedule = feeSchedule , vmoptChainId = 1 @@ -387,38 +384,38 @@ checkState postState where - toAddr = fromMaybe (EVM.createAddress origin senderNonce) (txToAddr tx) + toAddr = fromMaybe (EVM.createAddress origin senderNonce) tx.txToAddr senderNonce = view (accountAt origin . nonce) (Map.map fst preState) feeSchedule = EVM.FeeSchedule.berlin toCode = Map.lookup toAddr preState theCode = if isCreate - then EVM.InitCode (txData tx) mempty + then EVM.InitCode tx.txData mempty else maybe (EVM.RuntimeCode (EVM.ConcreteRuntimeCode "")) (view contractcode . fst) toCode - effectiveGasPrice = effectiveprice tx (blockBaseFee block) + effectiveGasPrice = effectiveprice tx block.blockBaseFee cd = if isCreate then mempty - else ConcreteBuf $ txData tx + else ConcreteBuf tx.txData effectiveprice :: Transaction -> W256 -> W256 effectiveprice tx baseFee = priorityFee tx baseFee + baseFee priorityFee :: Transaction -> W256 -> W256 priorityFee tx baseFee = let - (txPrioMax, txMaxFee) = case txType tx of + (txPrioMax, txMaxFee) = case tx.txType of EIP1559Transaction -> - let maxPrio = fromJust $ txMaxPriorityFeeGas tx - maxFee = fromJust $ txMaxFeePerGas tx + let maxPrio = fromJust tx.txMaxPriorityFeeGas + maxFee = fromJust tx.txMaxFeePerGas in (maxPrio, maxFee) _ -> - let gasPrice = fromJust $ txGasPrice tx + let gasPrice = fromJust tx.txGasPrice in (gasPrice, gasPrice) in min txPrioMax (txMaxFee - baseFee) maxBaseFee :: Transaction -> W256 maxBaseFee tx = - case txType tx of - EIP1559Transaction -> fromJust $ txMaxFeePerGas tx - _ -> fromJust $ txGasPrice tx + case tx.txType of + EIP1559Transaction -> fromJust tx.txMaxFeePerGas + _ -> fromJust tx.txGasPrice validateTx :: Transaction -> Block -> Map Addr (EVM.Contract, Storage) -> Maybe () validateTx tx block cs = do @@ -426,9 +423,9 @@ origin <- sender 1 tx originBalance <- (view balance) <$> view (at origin) cs' originNonce <- (view nonce) <$> view (at origin) cs' - let gasDeposit = (effectiveprice tx (blockBaseFee block)) * (num $ txGasLimit tx) - if gasDeposit + (txValue tx) <= originBalance - && txNonce tx == originNonce && blockBaseFee block <= maxBaseFee tx + let gasDeposit = (effectiveprice tx block.blockBaseFee) * (num tx.txGasLimit) + if gasDeposit + tx.txValue <= originBalance + && tx.txNonce == originNonce && block.blockBaseFee <= maxBaseFee tx then Just () else Nothing @@ -436,9 +433,9 @@ checkTx tx block prestate = do origin <- sender 1 tx validateTx tx block prestate - let isCreate = isNothing (txToAddr tx) + let isCreate = isNothing tx.txToAddr senderNonce = view (accountAt origin . nonce) (Map.map fst prestate) - toAddr = fromMaybe (EVM.createAddress origin senderNonce) (txToAddr tx) + toAddr = fromMaybe (EVM.createAddress origin senderNonce) tx.txToAddr prevCode = view (accountAt toAddr . contractcode) (Map.map fst prestate) prevNonce = view (accountAt toAddr . nonce) (Map.map fst prestate) if isCreate && ((case prevCode of {EVM.RuntimeCode (EVM.ConcreteRuntimeCode b) -> not (BS.null b); _ -> True}) || (prevNonce /= 0)) @@ -449,10 +446,10 @@ vmForCase :: Case -> EVM.VM vmForCase x = let - a = checkContracts x + a = x.checkContracts cs = Map.map fst a st = Map.mapKeys num $ Map.map snd a - vm = EVM.makeVm (testVmOpts x) + vm = EVM.makeVm x.testVmOpts & set (EVM.env . EVM.contracts) cs & set (EVM.env . EVM.storage) (ConcreteStore st) & set (EVM.env . EVM.origStorage) st diff --git a/test/EVM/TestUtils.hs b/test/EVM/TestUtils.hs --- a/test/EVM/TestUtils.hs +++ b/test/EVM/TestUtils.hs @@ -13,7 +13,7 @@ import System.Process (readProcess) import EVM.Solidity -import EVM.SMT +import EVM.Solvers import EVM.Dapp import EVM.UnitTest import EVM.Fetch (RpcInfo) diff --git a/test/contracts/pass/cheatCodes.sol b/test/contracts/pass/cheatCodes.sol --- a/test/contracts/pass/cheatCodes.sol +++ b/test/contracts/pass/cheatCodes.sol @@ -10,12 +10,19 @@ function sign(uint256,bytes32) external returns (uint8,bytes32,bytes32); function addr(uint256) external returns (address); function ffi(string[] calldata) external returns (bytes memory); + function prank(address) external; } contract HasStorage { uint slot0 = 10; } +contract Prankster { + function prankme() public returns (address) { + return msg.sender; + } +} + contract CheatCodes is DSTest { address store = address(new HasStorage()); Hevm hevm = Hevm(HEVM_ADDRESS); @@ -85,5 +92,13 @@ (string memory output) = abi.decode(hevm.ffi(inputs), (string)); assertEq(output, "acab"); + } + + function test_prank() public { + Prankster prankster = new Prankster(); + assertEq(prankster.prankme(), address(this)); + hevm.prank(address(0xdeadbeef)); + assertEq(prankster.prankme(), address(0xdeadbeef)); + assertEq(prankster.prankme(), address(this)); } } diff --git a/test/rpc.hs b/test/rpc.hs --- a/test/rpc.hs +++ b/test/rpc.hs @@ -16,6 +16,7 @@ import EVM import EVM.ABI import EVM.SMT +import EVM.Solvers import EVM.Fetch import EVM.SymExec import EVM.TestUtils diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -43,7 +43,7 @@ import Data.Binary.Put (runPut) import Data.Binary.Get (runGetOrFail) -import EVM hiding (Query, allowFFI) +import EVM import EVM.SymExec import EVM.ABI import EVM.Exec @@ -53,11 +53,14 @@ import EVM.Solidity import EVM.Types import EVM.Traversals +import EVM.Concrete (createAddress) import EVM.SMT hiding (one) +import EVM.Solvers import qualified EVM.Expr as Expr import qualified Data.Text as T import Data.List (isSubsequenceOf) import EVM.TestUtils +import GHC.Conc (getNumProcessors) main :: IO () main = defaultMain tests @@ -87,6 +90,29 @@ (SLoad (Lit 0x0) (Lit 0x0) (SStore (Var "1312") (Lit 0x0) (Lit 0x0) (ConcreteStore $ Map.fromList [(0x0, Map.fromList [(0x0, 0xab)])]))) (Expr.readStorage' (Lit 0x0) (Lit 0x0) (SStore (Lit 0xacab) (Lit 0xdead) (Lit 0x0) (SStore (Var "1312") (Lit 0x0) (Lit 0x0) (ConcreteStore $ Map.fromList [(0x0, Map.fromList [(0x0, 0xab)])])))) + + , testCase "accessStorage uses fetchedStorage" $ do + let dummyContract = + (initialContract (RuntimeCode (ConcreteRuntimeCode mempty))) + { _external = True } + vm = vmForEthrunCreation "" + -- perform the initial access + vm1 = execState (EVM.accessStorage 0 (Lit 0) (pure . pure ())) vm + -- it should fetch the contract first + vm2 = case vm1._result of + Just (VMFailure (Query (PleaseFetchContract _addr continue))) -> + execState (continue dummyContract) vm1 + _ -> error "unexpected result" + -- then it should fetch the slow + vm3 = case vm2._result of + Just (VMFailure (Query (PleaseFetchSlot _addr _slot continue))) -> + execState (continue 1337) vm2 + _ -> error "unexpected result" + -- perform the same access as for vm1 + vm4 = execState (EVM.accessStorage 0 (Lit 0) (pure . pure ())) vm3 + + -- there won't be query now as accessStorage uses fetch cache + assertBool (show vm4._result) (isNothing vm4._result) ] -- These tests fuzz the simplifier by generating a random expression, -- applying some simplification rules, and then using the smt encoding to @@ -149,6 +175,10 @@ let simplified = Expr.writeWord idx val buf full = WriteWord idx val buf checkEquiv simplified full + , testProperty "arith-simplification" $ \(_ :: Int) -> ioProperty $ do + expr <- generate . sized $ genWordArith 15 + let simplified = Expr.simplify expr + checkEquiv expr simplified , testProperty "readByte-equivalance" $ \(buf, idx) -> ioProperty $ do let simplified = Expr.readByte idx buf full = ReadByte idx buf @@ -426,7 +456,7 @@ (json, path') <- solidity' srccode let (solc', _, _) = fromJust $ readJSON json initCode :: ByteString - initCode = fromJust $ solc' ^? ix (path' <> ":A") . creationCode + initCode = (fromJust $ solc' ^? ix (path' <> ":A")).creationCode -- add constructor arguments assertEqual "constructor args screwed up metadata stripping" (stripBytecodeMetadata (initCode <> encodeAbiValue (AbiUInt 256 1))) (stripBytecodeMetadata initCode) ] @@ -649,7 +679,6 @@ putStrLn "Require works as expected" , testCase "ITE-with-bitwise-AND" $ do - --- using ignore to suppress huge output Just c <- solcRuntime "C" [i| contract C { @@ -670,7 +699,6 @@ putStrLn "expected counterexample found" , testCase "ITE-with-bitwise-OR" $ do - --- using ignore to suppress huge output Just c <- solcRuntime "C" [i| contract C { @@ -988,6 +1016,29 @@ (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts putStrLn "XOR works as expected" , + testCase "opcode-addmod-no-overflow" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint8 a, uint8 b, uint8 c) external pure { + require(a < 4); + require(b < 4); + require(c < 4); + uint16 r1; + uint16 r2; + uint16 g2; + assembly { + r1 := add(a,b) + r2 := mod(r1, c) + g2 := addmod (a, b, c) + } + assert (r2 == g2); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint8,uint8,uint8)", [AbiUIntType 8, AbiUIntType 8, AbiUIntType 8])) [] defaultVeriOpts + putStrLn "ADDMOD is fine on NON overflow values" + , testCase "opcode-mulmod-no-overflow" $ do Just c <- solcRuntime "MyContract" [i| @@ -1589,8 +1640,7 @@ (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" , - ignoreTest $ testCase "keccak soundness" $ do - --- using ignore to suppress huge output + testCase "keccak soundness" $ do Just c <- solcRuntime "C" [i| contract C { @@ -1625,17 +1675,26 @@ aAddr = Addr 0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B Just c <- solcRuntime "C" code' Just a <- solcRuntime "A" code' - (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> do + (_, [Cex (_, cex)]) <- withSolvers Z3 1 Nothing $ \s -> do let vm0 = abstractVM (Just ("call_A()", [])) [] c Nothing SymbolicS let vm = vm0 & set (state . callvalue) (Lit 0) & over (env . contracts) (Map.insert aAddr (initialContract (RuntimeCode (ConcreteRuntimeCode a)))) - -- NOTE: this used to as follows, but there is no _storage field in Contract record - -- (Map.insert aAddr (initialContract (RuntimeCode $ ConcreteBuffer a) & - -- set EVM.storage (EVM.Symbolic [] store))) verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) - putStrLn "found counterexample:" + + let storeCex = cex.store + addrC = W256 $ num $ createAddress ethrunAddress 1 + addrA = W256 0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B + testCex = Map.size storeCex == 2 && + case (Map.lookup addrC storeCex, Map.lookup addrA storeCex) of + (Just sC, Just sA) -> Map.size sC == 1 && Map.size sA == 1 && + case (Map.lookup 0 sC, Map.lookup 0 sA) of + (Just x, Just y) -> x /= y + _ -> False + _ -> False + assertBool "Did not find expected storage cex" testCex + putStrLn "expected counterexample found" , expectFail $ testCase "calling unique contracts (read from storage)" $ do Just c <- solcRuntime "C" @@ -1713,6 +1772,69 @@ (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("distributivity(uint256,uint256,uint256)", [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts putStrLn "Proven" + , + testCase "storage-cex-1" $ do + Just c <- solcRuntime "C" + [i| + contract C { + uint x; + uint y; + function fun(uint256 a) external{ + assert (x == y); + } + } + |] + (_, [(Cex (_, cex))]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x01] c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + let addr = W256 $ num $ createAddress ethrunAddress 1 + 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 + assertBool "Did not find expected storage cex" testCex + putStrLn "Expected counterexample found" + , + testCase "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))]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x01] c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + let addr = W256 $ num $ createAddress ethrunAddress 1 + a = getVar cex "arg1" + 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 (10 + a) s) of + (Just x, Just y) -> x >= y + _ -> False + _ -> False + assertBool "Did not find expected storage cex" testCex + putStrLn "Expected counterexample found" + , + testCase "storage-cex-concrete" $ do + Just c <- solcRuntime "C" + [i| + contract C { + uint x; + uint y; + function fun(uint256 a) external{ + assert (x != y); + } + } + |] + (_, [Cex (_, cex)]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts ConcreteS Nothing (Just $ checkAssertions [0x01]) + let testCex = Map.null cex.store + assertBool "Did not find expected storage cex" testCex + putStrLn "Expected counterexample found" ] , testGroup "Equivalence checking" [ @@ -1739,7 +1861,7 @@ |] withSolvers Z3 3 Nothing $ \s -> do a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts Nothing - assertBool "Must have a difference" (not (null a)) + assertBool "Must have a difference" (any isCex a) , testCase "eq-sol-exp-qed" $ do Just aPrgm <- solcRuntime "C" @@ -1764,7 +1886,7 @@ |] withSolvers Z3 3 Nothing $ \s -> do a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts Nothing - assertEqual "Must have no difference" [] a + assertEqual "Must have no difference" [Qed ()] a return () , testCase "eq-sol-exp-cex" $ do @@ -1792,70 +1914,31 @@ withSolvers Z3 3 Nothing $ \s -> do let myVeriOpts = VeriOpts{ simp = True, debug = False, maxIter = Just 2, askSmtIters = Just 2, rpcInfo = Nothing} a <- equivalenceCheck s aPrgm bPrgm myVeriOpts Nothing - assertEqual "Must be different" (containsA (Cex ()) a) True + assertEqual "Must be different" (any isCex a) True return () , testCase "eq-all-yul-optimization-tests" $ do let myVeriOpts = VeriOpts{ simp = True, debug = False, maxIter = Just 5, askSmtIters = Just 20, rpcInfo = Nothing } ignoredTests = [ - "controlFlowSimplifier/terminating_for_nested.yul" - , "controlFlowSimplifier/terminating_for_nested_reversed.yul" - -- unbounded loop -- - , "commonSubexpressionEliminator/branches_for.yul" - , "commonSubexpressionEliminator/loop.yul" - , "conditionalSimplifier/clear_after_if_continue.yul" + "commonSubexpressionEliminator/branches_for.yul" , "conditionalSimplifier/no_opt_if_break_is_not_last.yul" - , "conditionalUnsimplifier/clear_after_if_continue.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/devcon_example.yul" - , "fullSuite/loopInvariantCodeMotion.yul" , "fullSuite/no_move_loop_orig.yul" - , "loadResolver/loop.yul" , "loopInvariantCodeMotion/multi.yul" - , "loopInvariantCodeMotion/recursive.yul" - , "loopInvariantCodeMotion/simple.yul" - , "redundantAssignEliminator/for_branch.yul" - , "redundantAssignEliminator/for_break.yul" - , "redundantAssignEliminator/for_continue.yul" - , "redundantAssignEliminator/for_decl_inside_break_continue.yul" - , "redundantAssignEliminator/for_deep_noremove.yul" , "redundantAssignEliminator/for_deep_simple.yul" - , "redundantAssignEliminator/for_multi_break.yul" - , "redundantAssignEliminator/for_nested.yul" - , "redundantAssignEliminator/for_rerun.yul" - , "redundantAssignEliminator/for_stmnts_after_break_continue.yul" - , "rematerialiser/branches_for1.yul" - , "rematerialiser/branches_for2.yul" - , "rematerialiser/for_break.yul" - , "rematerialiser/for_continue.yul" - , "rematerialiser/for_continue_2.yul" - , "rematerialiser/for_continue_with_assignment_in_post.yul" - , "rematerialiser/no_remat_in_loop.yul" - , "ssaTransform/for_reassign_body.yul" - , "ssaTransform/for_reassign_init.yul" - , "ssaTransform/for_reassign_post.yul" - , "ssaTransform/for_simple.yul" - , "loopInvariantCodeMotion/nonMovable.yul" - , "unusedAssignEliminator/for_rerun.yul" - , "unusedAssignEliminator/for_continue_3.yul" + , "unusedAssignEliminator/for_deep_noremove.yul" , "unusedAssignEliminator/for_deep_simple.yul" , "ssaTransform/for_def_in_init.yul" - , "rematerialiser/many_refs_small_cost_loop.yul" + , "loopInvariantCodeMotion/simple_state.yul" + , "loopInvariantCodeMotion/simple.yul" + , "loopInvariantCodeMotion/recursive.yul" + , "loopInvariantCodeMotion/no_move_staticall_returndatasize.yul" , "loopInvariantCodeMotion/no_move_state_loop.yul" - , "loopInvariantCodeMotion/dependOnVarInLoop.yul" - , "forLoopInitRewriter/empty_pre.yul" - , "loadResolver/keccak_crash.yul" - , "blockFlattener/for_stmt.yul" -- symb input can loop it forever - , "unusedAssignEliminator/for.yul" -- not infinite, just 2**256-3 , "loopInvariantCodeMotion/no_move_state.yul" -- not infinite, but rollaround on a large int - , "loopInvariantCodeMotion/non-ssavar.yul" -- same as above - , "forLoopInitRewriter/complex_pre.yul" - , "rematerialiser/some_refs_small_cost_loop.yul" -- not infinite but 100 long - , "forLoopInitRewriter/simple.yul" , "loopInvariantCodeMotion/no_move_loop.yul" -- unexpected symbolic arg -- @@ -1905,11 +1988,15 @@ , "fullSuite/ssaReverse.yul" , "rematerialiser/cheap_caller.yul" , "rematerialiser/non_movable_instruction.yul" + , "rematerialiser/for_break.yul" + , "rematerialiser/for_continue.yul" + , "rematerialiser/for_continue_2.yul" , "ssaAndBack/multi_assign.yul" , "ssaAndBack/multi_assign_if.yul" , "ssaAndBack/multi_assign_switch.yul" , "ssaAndBack/simple.yul" , "ssaReverser/simple.yul" + , "loopInvariantCodeMotion/simple_storage.yul" -- OpMstore8 , "loadResolver/memory_with_different_kinds_of_invalidation.yul" @@ -1924,7 +2011,6 @@ , "commonSubexpressionEliminator/object_access.yul" , "expressionSplitter/object_access.yul" , "fullSuite/stack_compressor_msize.yul" - , "varNameCleaner/function_names.yul" -- stack too deep -- , "fullSuite/abi2.yul" @@ -2021,20 +2107,16 @@ , "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" -- Takes too long, would timeout on most test setups. -- We could probably fix these by "bunching together" queries - , "fullSuite/clear_after_if_continue.yul" - , "reasoningBasedSimplifier/smod.yul" , "reasoningBasedSimplifier/mulmod.yul" -- TODO check what's wrong with these! - , "unusedStoreEliminator/create_inside_function.yul" - , "fullSimplify/not_applied_removes_non_constant_and_not_movable.yul" -- create bug? - , "unusedStoreEliminator/create.yul" -- create bug? - , "fullSuite/extcodelength.yul" -- extcodecopy bug? - , "loadResolver/keccak_short.yul" -- keccak bug - , "reasoningBasedSimplifier/signed_division.yul" -- ACTUAL bug, SDIV I think? + , "loadResolver/keccak_short.yul" -- ACTUAL bug -- keccak + , "reasoningBasedSimplifier/signed_division.yul" -- ACTUAL bug, SDIV ] solcRepo <- fromMaybe (error "cannot find solidity repo") <$> (lookupEnv "HEVM_SOLIDITY_REPO") @@ -2053,9 +2135,8 @@ False -> recursiveList ax (a:b) recursiveList [] b = pure b files <- recursiveList fullpaths [] - -- let filesFiltered = filter (\file -> not $ any (\filt -> Data.List.isSubsequenceOf filt 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 @@ -2083,7 +2164,7 @@ filteredBSym = symbolicMem [ replaceAll "" $ x *=~[re|^//|] | x <- onlyAfter [re|^// step:|] unfiltered, not $ x =~ [re|^$|] ] start <- getCurrentTime putStrLn $ "Checking file: " <> f - when (debug myVeriOpts) $ do + when myVeriOpts.debug $ do putStrLn "-------------Original Below-----------------" mapM_ putStrLn unfiltered putStrLn "------------- Filtered A + Symb below-----------------" @@ -2093,14 +2174,17 @@ putStrLn "------------- END -----------------" Just aPrgm <- yul "" $ T.pack $ unlines filteredASym Just bPrgm <- yul "" $ T.pack $ unlines filteredBSym - withSolvers CVC5 6 (Just 3) $ \s -> do + procs <- getNumProcessors + withSolvers CVC5 (num procs) (Just 100) $ \s -> do res <- equivalenceCheck s aPrgm bPrgm myVeriOpts Nothing end <- getCurrentTime - case containsA (Cex()) res of + case any isCex res of False -> do print $ "OK. Took " <> (show $ diffUTCTime end start) <> " seconds" - let timeouts = filter (\(_, _, c) -> c == EVM.SymExec.Timeout()) res - unless (null timeouts) $ putStrLn $ "But " <> (show $ length timeouts) <> " timeout(s) occurred" + let timeouts = filter isTimeout res + unless (null timeouts) $ do + putStrLn $ "But " <> (show $ length timeouts) <> " timeout(s) occurred" + error "Encountered timeouts, error" True -> do putStrLn $ "Not OK: " <> show f <> " Got: " <> show res error "Was NOT equivalent, error" @@ -2123,7 +2207,7 @@ print res pure $ case res of Unsat -> True - EVM.SMT.Unknown -> True + EVM.Solvers.Unknown -> True Sat _ -> False Error _ -> False @@ -2132,7 +2216,7 @@ runSimpleVM x ins = case loadVM x of Nothing -> Nothing Just vm -> let calldata' = (ConcreteBuf ins) - in case runState (assign (state.calldata) calldata' >> exec) vm of + in case runState (assign (state . calldata) calldata' >> exec) vm of (VMSuccess (ConcreteBuf bs), _) -> Just bs _ -> Nothing @@ -2429,6 +2513,46 @@ subBuf = defaultBuf (sz `div` 10) subStore = genStorage (sz `div` 10) subByte = genByte (sz `div` 10) + +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) defaultBuf :: Int -> Gen (Expr Buf) defaultBuf = genBuf (4_000_000)