diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,119 @@ 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.52.0] - 2023-10-26 + +This is a major breaking release that removes several user facing features and includes non trivial +breakage for library users. These changes mean the code is significantly simpler, more performant, +and allow support for new features like fully symbolic addresses. + +In addition to the changes below, this release includes significant work on performance +optimization for symbolic execution. + +## Added + +The major new user facing feature in this release is support for fully symbolic addresses (including +fully symbolic addresses for deployed contracts). This allows tests to be writen that call +`vm.prank` with a symbolic value, making some tests (e.g. access control, token transfer logic) much +more comprehensive. + +Some restrictions around reading balances from and transfering value between symbolic addresses are +currently in place. Currently, if the address is symbolic, then you will only be able to read it's +balance, or transfer value to/from it, if it is the address of a contract that is actually deployed. +This is required to ensure soundness in the face of aliasing between symbolic addresses. We intend +to lift this restriction in a future release. + +### Other + +- Support for `vm.deal` +- Support for `vm.assume` (this is semantically identical to using `require`, but does simplify the + process of porting exisitng fuzz tests to be symbolic) +- the `check` prefix now recognized for symbolic tests +- `hevm test` now takes a `--number` argument to specify which block should be used when making rpc queries + +## Changed + +### Revert Semantics in Solidity Tests + +solidity tests no longer consider reverts to be a failure, and check only for the ds-test failed bit +or user defined assertion failures (i.e. `Panic(0x01)`). This makes writing tests much easier as +users no longer have to consider trivial reverts (e.g. arithmetic overflow). + +A positive (i.e. `prove`/`check`) test with no rechable assertion violations that does not have any +succesful branches will still be considered a failure. + +## Removed + +hevm has been around for a while, and over time has accumulated many features. We decided to remove +some of these features in the interest of focusing our attention, increasing our iteration speed and +simplifying maintainance. The following user facing features have been removed from this release: + +- The visual debugger has been removed +- All concrete ds-test executors have been removed (i.e. plain, fuzzer, invariant) +- Rpc caching and state serialization has been removed (i.e. all `--cache` / `--state` flags) +- The various `DAPP_TEST` variables are no longer observed +- The `--initial-storage` flag no longer accepts a concrete prestore (valid values are now `Empty` or `Abstract`) + +## Fixed + +This release also includes many small bugfixes: + +- CopySlice wraparound issue especially during CopyCallBytesToMemory +- Contracts deployed during symbolic execution are created with an empty storage (instead of abstract in previous versions) +- EVM.Solidity.toCode to include contractName in error string +- Better cex reconstruction in cases where branches do not refer to all input variables in calldata +- Correctly handle empty bytestring compiled contracts' JSON +- No more false positives when keccak is called with inputs of different sizes +- `test` now falls back to displaying an unecoded bytestring for calldata when the model returned by the solver has a different length the length of the arguments in the test signature. +- we now generate correct counterexamples for branches where only a subset of input variables are referenced by the path conditions +- `vm.prank` now works correctly when passed a symbolic address +- storage layout information will now be parsed from the output of `forge build` if it is available + +## API Changes + +### Reworked Storage Model / Symbolic Addresses + +Adding symbolic addresses required some fairly significant changes to the way that we model storage. +We introduced a new address type to `Expr` (`Expr EAddr`), that allows us to model fully symbolic +addresses. Instead of modelling storage as a global symbolic 2D map (`address -> word -> word`) in +`vm.env`, each contract now has it's own symbolic 1D map (`word -> word`), that is stored in the +`vm.contracts` mapping. `vm.contracts` is now keyed on `Expr EAddr` instead of `Addr`. Addresses +that are keys to the `vm.contracts` mapping are asserted to be distinct in our smt encoding. This +allows us to support symbolic addresses in a fully static manner (i.e. we do not currently need to +make any extra smt queries when looking up storage for a symbolic address). + +### Mutable Memory & ST + +We now use a mutable representation of memory if it is currently completely concrete. This is a +significant performance improvement, and fixed a particulary egregious memory leak. It does entail +the use of the `ST` monad, and introduces a new type parameter to the `VM` type that tags a given +instance with it's thread local state. Library users will now need to either use the ST moand and +`runST` or `stToIO` to compose and sequence vm executions. + +## GHC 9.4 + +Hevm is now built with ghc9.4. While earlier compiler versions may continue to work for now, they +are no longer explicitly tested or supported. + +### Other + +- Contract balances can now be fully symbolic +- Contract code can now be fully abstract. Calls into contracts with unknown code will fail with `UnexpectedSymbolicArg`. +- Run expression simplification on branch conditions +- SLoad/SStore simplifications based on assumptions regarding Keccak non-collision&preimage +- Improved Prop simplification +- CopySlice+WriteWord+ConcreteBuf now truncates ConcreteBuf in special cases +- Better simplification of Eq IR elements +- Run a toplevel constant folding reasoning system on branch conditions +- `evalProp` is renamed to `simplifyProp` for consistency +- Mem explosion in `writeWord` function was possible in case `offset` was close to 2^256. Fixed. +- BufLength was not simplified via bufLength function. Fixed. +- `VMOpts` no longer takes an initial store, and instead takes a `baseState` + which can be either `EmptyBase` or `AbstractBase`. This controls whether + storage should be inialized as empty or fully abstract. Regardless of this + setting contracts that are deployed at runtime via a call to + `CREATE`/`CREATE2` have zero initialized storage. + ## [0.51.3] - 2023-07-14 ## Fixed @@ -16,6 +129,7 @@ ## Changed - Removed sha3Crack which has been deprecated for keccakEqs +- Abstraction-refinement for more complicated expressions such as MULMOD ## Added diff --git a/bench/bench.hs b/bench/bench.hs --- a/bench/bench.hs +++ b/bench/bench.hs @@ -3,30 +3,23 @@ import GHC.Natural import Control.Monad import Data.Maybe -import System.Environment (lookupEnv, getEnv) +import System.Environment (getEnv) import qualified Paths_hevm as Paths import Test.Tasty (localOption, withResource) import Test.Tasty.Bench -import Data.Functor -import Data.String.Here import Data.ByteString (ByteString) import System.FilePath.Posix -import Control.Monad.State.Strict import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified System.FilePath.Find as Find import qualified Data.ByteString.Lazy as LazyByteString -import EVM (StorageModel(..)) import EVM.SymExec import EVM.Solidity import EVM.Solvers -import EVM.ABI -import EVM.Dapp -import EVM.Types -import qualified EVM.TTY as TTY +import EVM.Format (hexByteString) import qualified EVM.Stepper as Stepper import qualified EVM.Fetch as Fetch @@ -34,10 +27,10 @@ main :: IO () main = defaultMain - [ mkbench erc20 "erc20" Nothing [1] - , mkbench (pure vat) "vat" Nothing [4] - , mkbench (pure deposit) "deposit" (Just 32) [4] - , mkbench (pure uniV2Pair) "uniV2" (Just 10) [4] + [ mkbench erc20 "erc20" 0 [1] + , mkbench (pure vat) "vat" 0 [4] + , mkbench (pure deposit) "deposit" 32 [4] + , mkbench (pure uniV2Pair) "uniV2" 10 [4] , withResource bcjsons (pure . const ()) blockchainTests ] @@ -59,7 +52,7 @@ parseSuite path = do contents <- LazyByteString.readFile path case BCTests.parseBCSuite contents of - Left e -> pure (path, mempty) + Left _ -> pure (path, mempty) Right tests -> pure (path, tests) -- | executes all provided bc tests in sequence and accumulates a boolean value representing their success. @@ -67,7 +60,7 @@ blockchainTests :: IO (Map.Map FilePath (Map.Map String BCTests.Case)) -> Benchmark blockchainTests ts = bench "blockchain-tests" $ nfIO $ do tests <- ts - putStrLn "\n executing tests:" + putStrLn " executing blockchain tests" let cases = concat . Map.elems . (fmap Map.toList) $ tests ignored = Map.keys BCTests.commonProblematicTests foldM (\acc (n, c) -> @@ -75,7 +68,6 @@ then pure True else do res <- runBCTest c - putStrLn $ " " <> n pure $ acc && res ) True cases @@ -83,8 +75,8 @@ runBCTest :: BCTests.Case -> IO Bool runBCTest x = do - let vm0 = BCTests.vmForCase x - result <- execStateT (Stepper.interpret (Fetch.zero 0 (Just 0)) . void $ Stepper.execFully) vm0 + vm0 <- BCTests.vmForCase x + result <- Stepper.interpret (Fetch.zero 0 Nothing) vm0 Stepper.runFully maybeReason <- BCTests.checkExpectation False x result pure $ isNothing maybeReason @@ -92,17 +84,12 @@ --- Helpers ---------------------------------------------------------------------------------------- -debugContract :: ByteString -> IO () -debugContract c = withSolvers CVC5 4 Nothing $ \solvers -> do - let prestate = abstractVM (mkCalldata Nothing []) c Nothing SymbolicS - void $ TTY.runFromVM solvers Nothing Nothing emptyDapp prestate - -findPanics :: Solver -> Natural -> Maybe Integer -> ByteString -> IO () +findPanics :: Solver -> Natural -> Integer -> ByteString -> IO () findPanics solver count iters c = do - (_, res) <- withSolvers solver count Nothing $ \s -> do + _ <- withSolvers solver count Nothing $ \s -> do let opts = defaultVeriOpts - { maxIter = iters - , askSmtIters = (+ 1) <$> iters + { maxIter = Just iters + , askSmtIters = iters + 1 } checkAssert s allPanicCodes c Nothing [] opts putStrLn "done" @@ -112,7 +99,7 @@ -- 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 :: IO ByteString -> String -> Integer -> [Natural] -> Benchmark mkbench c name iters counts = localOption WallTime $ env c (bgroup name . bmarks) where bmarks c' = concat $ [ diff --git a/bench/contracts/deposit.sol b/bench/contracts/deposit.sol new file mode 100644 --- /dev/null +++ b/bench/contracts/deposit.sol @@ -0,0 +1,182 @@ +/** + *Submitted for verification at Etherscan.io on 2020-10-14 +*/ + +// ┏━━━┓━┏┓━┏┓━━┏━━━┓━━┏━━━┓━━━━┏━━━┓━━━━━━━━━━━━━━━━━━━┏┓━━━━━┏━━━┓━━━━━━━━━┏┓━━━━━━━━━━━━━━┏┓━ +// ┃┏━━┛┏┛┗┓┃┃━━┃┏━┓┃━━┃┏━┓┃━━━━┗┓┏┓┃━━━━━━━━━━━━━━━━━━┏┛┗┓━━━━┃┏━┓┃━━━━━━━━┏┛┗┓━━━━━━━━━━━━┏┛┗┓ +// ┃┗━━┓┗┓┏┛┃┗━┓┗┛┏┛┃━━┃┃━┃┃━━━━━┃┃┃┃┏━━┓┏━━┓┏━━┓┏━━┓┏┓┗┓┏┛━━━━┃┃━┗┛┏━━┓┏━┓━┗┓┏┛┏━┓┏━━┓━┏━━┓┗┓┏┛ +// ┃┏━━┛━┃┃━┃┏┓┃┏━┛┏┛━━┃┃━┃┃━━━━━┃┃┃┃┃┏┓┃┃┏┓┃┃┏┓┃┃━━┫┣┫━┃┃━━━━━┃┃━┏┓┃┏┓┃┃┏┓┓━┃┃━┃┏┛┗━┓┃━┃┏━┛━┃┃━ +// ┃┗━━┓━┃┗┓┃┃┃┃┃┃┗━┓┏┓┃┗━┛┃━━━━┏┛┗┛┃┃┃━┫┃┗┛┃┃┗┛┃┣━━┃┃┃━┃┗┓━━━━┃┗━┛┃┃┗┛┃┃┃┃┃━┃┗┓┃┃━┃┗┛┗┓┃┗━┓━┃┗┓ +// ┗━━━┛━┗━┛┗┛┗┛┗━━━┛┗┛┗━━━┛━━━━┗━━━┛┗━━┛┃┏━┛┗━━┛┗━━┛┗┛━┗━┛━━━━┗━━━┛┗━━┛┗┛┗┛━┗━┛┗┛━┗━━━┛┗━━┛━┗━┛ +// ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┃┃━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ +// ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┗┛━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ + +// SPDX-License-Identifier: CC0-1.0 + +pragma solidity 0.6.11; + +// This interface is designed to be compatible with the Vyper version. +/// @notice This is the Ethereum 2.0 deposit contract interface. +/// For more information see the Phase 0 specification under https://github.com/ethereum/eth2.0-specs +interface IDepositContract { + /// @notice A processed deposit event. + event DepositEvent( + bytes pubkey, + bytes withdrawal_credentials, + bytes amount, + bytes signature, + bytes index + ); + + /// @notice Submit a Phase 0 DepositData object. + /// @param pubkey A BLS12-381 public key. + /// @param withdrawal_credentials Commitment to a public key for withdrawals. + /// @param signature A BLS12-381 signature. + /// @param deposit_data_root The SHA-256 hash of the SSZ-encoded DepositData object. + /// Used as a protection against malformed input. + function deposit( + bytes calldata pubkey, + bytes calldata withdrawal_credentials, + bytes calldata signature, + bytes32 deposit_data_root + ) external payable; + + /// @notice Query the current deposit root hash. + /// @return The deposit root hash. + function get_deposit_root() external view returns (bytes32); + + /// @notice Query the current deposit count. + /// @return The deposit count encoded as a little endian 64-bit number. + function get_deposit_count() external view returns (bytes memory); +} + +// Based on official specification in https://eips.ethereum.org/EIPS/eip-165 +interface ERC165 { + /// @notice Query if a contract implements an interface + /// @param interfaceId The interface identifier, as specified in ERC-165 + /// @dev Interface identification is specified in ERC-165. This function + /// uses less than 30,000 gas. + /// @return `true` if the contract implements `interfaceId` and + /// `interfaceId` is not 0xffffffff, `false` otherwise + function supportsInterface(bytes4 interfaceId) external pure returns (bool); +} + +// This is a rewrite of the Vyper Eth2.0 deposit contract in Solidity. +// It tries to stay as close as possible to the original source code. +/// @notice This is the Ethereum 2.0 deposit contract interface. +/// For more information see the Phase 0 specification under https://github.com/ethereum/eth2.0-specs +contract DepositContract is IDepositContract, ERC165 { + uint constant DEPOSIT_CONTRACT_TREE_DEPTH = 32; + // NOTE: this also ensures `deposit_count` will fit into 64-bits + uint constant MAX_DEPOSIT_COUNT = 2**DEPOSIT_CONTRACT_TREE_DEPTH - 1; + + bytes32[DEPOSIT_CONTRACT_TREE_DEPTH] branch; + uint256 deposit_count; + + bytes32[DEPOSIT_CONTRACT_TREE_DEPTH] zero_hashes; + + constructor() public { + // Compute hashes in empty sparse Merkle tree + for (uint height = 0; height < DEPOSIT_CONTRACT_TREE_DEPTH - 1; height++) + zero_hashes[height + 1] = sha256(abi.encodePacked(zero_hashes[height], zero_hashes[height])); + } + + function get_deposit_root() override external view returns (bytes32) { + bytes32 node; + uint size = deposit_count; + for (uint height = 0; height < DEPOSIT_CONTRACT_TREE_DEPTH; height++) { + if ((size & 1) == 1) + node = sha256(abi.encodePacked(branch[height], node)); + else + node = sha256(abi.encodePacked(node, zero_hashes[height])); + size /= 2; + } + return sha256(abi.encodePacked( + node, + to_little_endian_64(uint64(deposit_count)), + bytes24(0) + )); + } + + function get_deposit_count() override external view returns (bytes memory) { + return to_little_endian_64(uint64(deposit_count)); + } + + function deposit( + bytes calldata pubkey, + bytes calldata withdrawal_credentials, + bytes calldata signature, + bytes32 deposit_data_root + ) override external payable { + // Extended ABI length checks since dynamic types are used. + require(pubkey.length == 48, "DepositContract: invalid pubkey length"); + require(withdrawal_credentials.length == 32, "DepositContract: invalid withdrawal_credentials length"); + require(signature.length == 96, "DepositContract: invalid signature length"); + + // Check deposit amount + require(msg.value >= 1 ether, "DepositContract: deposit value too low"); + require(msg.value % 1 gwei == 0, "DepositContract: deposit value not multiple of gwei"); + uint deposit_amount = msg.value / 1 gwei; + require(deposit_amount <= type(uint64).max, "DepositContract: deposit value too high"); + + // Emit `DepositEvent` log + bytes memory amount = to_little_endian_64(uint64(deposit_amount)); + emit DepositEvent( + pubkey, + withdrawal_credentials, + amount, + signature, + to_little_endian_64(uint64(deposit_count)) + ); + + // Compute deposit data root (`DepositData` hash tree root) + bytes32 pubkey_root = sha256(abi.encodePacked(pubkey, bytes16(0))); + bytes32 signature_root = sha256(abi.encodePacked( + sha256(abi.encodePacked(signature[:64])), + sha256(abi.encodePacked(signature[64:], bytes32(0))) + )); + bytes32 node = sha256(abi.encodePacked( + sha256(abi.encodePacked(pubkey_root, withdrawal_credentials)), + sha256(abi.encodePacked(amount, bytes24(0), signature_root)) + )); + + // Verify computed and expected deposit data roots match + require(node == deposit_data_root, "DepositContract: reconstructed DepositData does not match supplied deposit_data_root"); + + // Avoid overflowing the Merkle tree (and prevent edge case in computing `branch`) + require(deposit_count < MAX_DEPOSIT_COUNT, "DepositContract: merkle tree full"); + + // Add deposit data root to Merkle tree (update a single `branch` node) + deposit_count += 1; + uint size = deposit_count; + for (uint height = 0; height < DEPOSIT_CONTRACT_TREE_DEPTH; height++) { + if ((size & 1) == 1) { + branch[height] = node; + return; + } + node = sha256(abi.encodePacked(branch[height], node)); + size /= 2; + } + // As the loop should always end prematurely with the `return` statement, + // this code should be unreachable. We assert `false` just to be safe. + assert(false); + } + + function supportsInterface(bytes4 interfaceId) override external pure returns (bool) { + return interfaceId == type(ERC165).interfaceId || interfaceId == type(IDepositContract).interfaceId; + } + + function to_little_endian_64(uint64 value) internal pure returns (bytes memory ret) { + ret = new bytes(8); + bytes8 bytesValue = bytes8(value); + // Byteswapping during copying to bytes. + ret[0] = bytesValue[7]; + ret[1] = bytesValue[6]; + ret[2] = bytesValue[5]; + ret[3] = bytesValue[4]; + ret[4] = bytesValue[3]; + ret[5] = bytesValue[2]; + ret[6] = bytesValue[1]; + ret[7] = bytesValue[0]; + } +} diff --git a/bench/contracts/vat.sol b/bench/contracts/vat.sol new file mode 100644 --- /dev/null +++ b/bench/contracts/vat.sol @@ -0,0 +1,246 @@ +// SPDX-License-Identifier: AGPL-3.0-or-later + +/// vat.sol -- Dai CDP database + +// Copyright (C) 2018 Rain +// +// This program is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// This program is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with this program. If not, see . + +pragma solidity ^0.6.12; + +// FIXME: This contract was altered compared to the production version. +// It doesn't use LibNote anymore. +// New deployments of this contract will need to include custom events (TO DO). + +contract Vat { + // --- Auth --- + mapping (address => uint) public wards; + function rely(address usr) external auth { require(live == 1, "Vat/not-live"); wards[usr] = 1; } + function deny(address usr) external auth { require(live == 1, "Vat/not-live"); wards[usr] = 0; } + modifier auth { + require(wards[msg.sender] == 1, "Vat/not-authorized"); + _; + } + + mapping(address => mapping (address => uint)) public can; + function hope(address usr) external { can[msg.sender][usr] = 1; } + function nope(address usr) external { can[msg.sender][usr] = 0; } + function wish(address bit, address usr) internal view returns (bool) { + return either(bit == usr, can[bit][usr] == 1); + } + + // --- Data --- + struct Ilk { + uint256 Art; // Total Normalised Debt [wad] + uint256 rate; // Accumulated Rates [ray] + uint256 spot; // Price with Safety Margin [ray] + uint256 line; // Debt Ceiling [rad] + uint256 dust; // Urn Debt Floor [rad] + } + struct Urn { + uint256 ink; // Locked Collateral [wad] + uint256 art; // Normalised Debt [wad] + } + + mapping (bytes32 => Ilk) public ilks; + mapping (bytes32 => mapping (address => Urn )) public urns; + mapping (bytes32 => mapping (address => uint)) public gem; // [wad] + mapping (address => uint256) public dai; // [rad] + mapping (address => uint256) public sin; // [rad] + + uint256 public debt; // Total Dai Issued [rad] + uint256 public vice; // Total Unbacked Dai [rad] + uint256 public Line; // Total Debt Ceiling [rad] + uint256 public live; // Active Flag + + // --- Init --- + constructor() public { + wards[msg.sender] = 1; + live = 1; + } + + // --- Math --- + function _add(uint x, int y) internal pure returns (uint z) { + z = x + uint(y); + require(y >= 0 || z <= x); + require(y <= 0 || z >= x); + } + function _sub(uint x, int y) internal pure returns (uint z) { + z = x - uint(y); + require(y <= 0 || z <= x); + require(y >= 0 || z >= x); + } + function _mul(uint x, int y) internal pure returns (int z) { + z = int(x) * y; + require(int(x) >= 0); + require(y == 0 || z / y == int(x)); + } + function _add(uint x, uint y) internal pure returns (uint z) { + require((z = x + y) >= x); + } + function _sub(uint x, uint y) internal pure returns (uint z) { + require((z = x - y) <= x); + } + function _mul(uint x, uint y) internal pure returns (uint z) { + require(y == 0 || (z = x * y) / y == x); + } + + // --- Administration --- + function init(bytes32 ilk) external auth { + require(ilks[ilk].rate == 0, "Vat/ilk-already-init"); + ilks[ilk].rate = 10 ** 27; + } + function file(bytes32 what, uint data) external auth { + require(live == 1, "Vat/not-live"); + if (what == "Line") Line = data; + else revert("Vat/file-unrecognized-param"); + } + function file(bytes32 ilk, bytes32 what, uint data) external auth { + require(live == 1, "Vat/not-live"); + if (what == "spot") ilks[ilk].spot = data; + else if (what == "line") ilks[ilk].line = data; + else if (what == "dust") ilks[ilk].dust = data; + else revert("Vat/file-unrecognized-param"); + } + function cage() external auth { + live = 0; + } + + // --- Fungibility --- + function slip(bytes32 ilk, address usr, int256 wad) external auth { + gem[ilk][usr] = _add(gem[ilk][usr], wad); + } + function flux(bytes32 ilk, address src, address dst, uint256 wad) external { + require(wish(src, msg.sender), "Vat/not-allowed"); + gem[ilk][src] = _sub(gem[ilk][src], wad); + gem[ilk][dst] = _add(gem[ilk][dst], wad); + } + function move(address src, address dst, uint256 rad) external { + require(wish(src, msg.sender), "Vat/not-allowed"); + dai[src] = _sub(dai[src], rad); + dai[dst] = _add(dai[dst], rad); + } + + function either(bool x, bool y) internal pure returns (bool z) { + assembly{ z := or(x, y)} + } + function both(bool x, bool y) internal pure returns (bool z) { + assembly{ z := and(x, y)} + } + + // --- CDP Manipulation --- + function frob(bytes32 i, address u, address v, address w, int dink, int dart) external { + // system is live + require(live == 1, "Vat/not-live"); + + Urn memory urn = urns[i][u]; + Ilk memory ilk = ilks[i]; + // ilk has been initialised + require(ilk.rate != 0, "Vat/ilk-not-init"); + + urn.ink = _add(urn.ink, dink); + urn.art = _add(urn.art, dart); + ilk.Art = _add(ilk.Art, dart); + + int dtab = _mul(ilk.rate, dart); + uint tab = _mul(ilk.rate, urn.art); + debt = _add(debt, dtab); + + // either debt has decreased, or debt ceilings are not exceeded + require(either(dart <= 0, both(_mul(ilk.Art, ilk.rate) <= ilk.line, debt <= Line)), "Vat/ceiling-exceeded"); + // urn is either less risky than before, or it is safe + require(either(both(dart <= 0, dink >= 0), tab <= _mul(urn.ink, ilk.spot)), "Vat/not-safe"); + + // urn is either more safe, or the owner consents + require(either(both(dart <= 0, dink >= 0), wish(u, msg.sender)), "Vat/not-allowed-u"); + // collateral src consents + require(either(dink <= 0, wish(v, msg.sender)), "Vat/not-allowed-v"); + // debt dst consents + require(either(dart >= 0, wish(w, msg.sender)), "Vat/not-allowed-w"); + + // urn has no debt, or a non-dusty amount + require(either(urn.art == 0, tab >= ilk.dust), "Vat/dust"); + + gem[i][v] = _sub(gem[i][v], dink); + dai[w] = _add(dai[w], dtab); + + urns[i][u] = urn; + ilks[i] = ilk; + } + // --- CDP Fungibility --- + function fork(bytes32 ilk, address src, address dst, int dink, int dart) external { + Urn storage u = urns[ilk][src]; + Urn storage v = urns[ilk][dst]; + Ilk storage i = ilks[ilk]; + + u.ink = _sub(u.ink, dink); + u.art = _sub(u.art, dart); + v.ink = _add(v.ink, dink); + v.art = _add(v.art, dart); + + uint utab = _mul(u.art, i.rate); + uint vtab = _mul(v.art, i.rate); + + // both sides consent + require(both(wish(src, msg.sender), wish(dst, msg.sender)), "Vat/not-allowed"); + + // both sides safe + require(utab <= _mul(u.ink, i.spot), "Vat/not-safe-src"); + require(vtab <= _mul(v.ink, i.spot), "Vat/not-safe-dst"); + + // both sides non-dusty + require(either(utab >= i.dust, u.art == 0), "Vat/dust-src"); + require(either(vtab >= i.dust, v.art == 0), "Vat/dust-dst"); + } + // --- CDP Confiscation --- + function grab(bytes32 i, address u, address v, address w, int dink, int dart) external auth { + Urn storage urn = urns[i][u]; + Ilk storage ilk = ilks[i]; + + urn.ink = _add(urn.ink, dink); + urn.art = _add(urn.art, dart); + ilk.Art = _add(ilk.Art, dart); + + int dtab = _mul(ilk.rate, dart); + + gem[i][v] = _sub(gem[i][v], dink); + sin[w] = _sub(sin[w], dtab); + vice = _sub(vice, dtab); + } + + // --- Settlement --- + function heal(uint rad) external { + address u = msg.sender; + sin[u] = _sub(sin[u], rad); + dai[u] = _sub(dai[u], rad); + vice = _sub(vice, rad); + debt = _sub(debt, rad); + } + function suck(address u, address v, uint rad) external auth { + sin[u] = _add(sin[u], rad); + dai[v] = _add(dai[v], rad); + vice = _add(vice, rad); + debt = _add(debt, rad); + } + + // --- Rates --- + function fold(bytes32 i, address u, int rate) external auth { + require(live == 1, "Vat/not-live"); + Ilk storage ilk = ilks[i]; + ilk.rate = _add(ilk.rate, rate); + int rad = _mul(ilk.Art, rate); + dai[u] = _add(dai[u], rad); + debt = _add(debt, rad); + } +} diff --git a/cli/cli.hs b/cli/cli.hs new file mode 100644 --- /dev/null +++ b/cli/cli.hs @@ -0,0 +1,599 @@ +-- Main file of the hevm CLI program + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Control.Monad (when, forM_, unless) +import Control.Monad.ST (RealWorld, stToIO) +import Data.ByteString (ByteString) +import Data.DoubleWord (Word256) +import Data.List (intersperse) +import Data.Maybe (fromMaybe, mapMaybe, fromJust) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Version (showVersion) +import Data.Word (Word64) +import GHC.Conc (getNumProcessors) +import Numeric.Natural (Natural) +import Optics.Core ((&), set) +import Witch (unsafeInto) +import Options.Generic as Options +import Paths_hevm qualified as Paths +import System.IO (stderr) +import System.Directory (withCurrentDirectory, getCurrentDirectory, doesDirectoryExist) +import System.FilePath (()) +import System.Exit (exitFailure, exitWith, ExitCode(..)) + +import EVM (initialContract, abstractContract, makeVm) +import EVM.ABI (Sig(..)) +import EVM.Dapp (dappInfo, DappInfo, emptyDapp) +import EVM.Expr qualified as Expr +import EVM.Concrete qualified as Concrete +import GitHash +import EVM.FeeSchedule (feeSchedule) +import EVM.Fetch qualified as Fetch +import EVM.Format (hexByteString, strip0x, showTraceTree, formatExpr) +import EVM.Solidity +import EVM.Solvers +import EVM.Stepper qualified +import EVM.SymExec +import EVM.Transaction qualified +import EVM.Types hiding (word) +import EVM.UnitTest + +-- This record defines the program's command-line options +-- automatically via the `optparse-generic` package. +data Command w + = Symbolic -- Symbolically explore an abstract program, or specialized with specified env & calldata + -- vm opts + { code :: w ::: Maybe ByteString "Program bytecode" + , calldata :: w ::: Maybe ByteString "Tx: calldata" + , address :: w ::: Maybe Addr "Tx: address" + , caller :: w ::: Maybe Addr "Tx: caller" + , origin :: w ::: Maybe Addr "Tx: origin" + , coinbase :: w ::: Maybe Addr "Block: coinbase" + , value :: w ::: Maybe W256 "Tx: Eth amount" + , nonce :: w ::: Maybe Word64 "Nonce of origin" + , gas :: w ::: Maybe Word64 "Tx: gas amount" + , number :: w ::: Maybe W256 "Block: number" + , timestamp :: w ::: Maybe W256 "Block: timestamp" + , basefee :: w ::: Maybe W256 "Block: base fee" + , priorityFee :: w ::: Maybe W256 "Tx: priority fee" + , gaslimit :: w ::: Maybe Word64 "Tx: gas limit" + , gasprice :: w ::: Maybe W256 "Tx: gas price" + , create :: w ::: Bool "Tx: creation" + , maxcodesize :: w ::: Maybe W256 "Block: max code size" + , prevRandao :: w ::: Maybe W256 "Block: prevRandao" + , chainid :: w ::: Maybe W256 "Env: chainId" + -- remote state opts + , rpc :: w ::: Maybe URL "Fetch state from a remote node" + , block :: w ::: Maybe W256 "Block state is be fetched from" + + -- symbolic execution opts + , root :: w ::: Maybe String "Path to project root directory (default: . )" + , projectType :: w ::: Maybe ProjectType "Is this a Foundry or DappTools project (default: Foundry)" + , initialStorage :: w ::: Maybe (InitialStorage) "Starting state for storage: Empty, Abstract (default Abstract)" + , sig :: w ::: Maybe Text "Signature of types to decode / encode" + , arg :: w ::: [String] "Values to encode" + , getModels :: w ::: Bool "Print example testcase for each execution path" + , showTree :: w ::: Bool "Print branches explored in tree view" + , showReachableTree :: w ::: Bool "Print only reachable branches explored in tree view" + , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in seconds (default: 300)" + , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" + , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc5" + , smtdebug :: w ::: Bool "Print smt queries sent to the solver" + , assertions :: w ::: Maybe [Word256] "Comma separated list of solc panic codes to check for (default: user defined assertion violations only)" + , askSmtIterations :: w ::: Integer "1" "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 1)" + , numSolvers :: w ::: Maybe Natural "Number of solver instances to use (default: number of cpu cores)" + , loopDetectionHeuristic :: w ::: LoopHeuristic "StackBased" "Which heuristic should be used to determine if we are in a loop: StackBased (default) or Naive" + , abstractArithmetic :: w ::: Bool "Use abstraction-refinement for complicated arithmetic functions such as MulMod. This runs the solver first with abstraction turned on, and if it returns a potential counterexample, the counterexample is refined to make sure it is a counterexample for the actual (not the abstracted) problem" + , abstractMemory :: w ::: Bool "Use abstraction-refinement for Memory. This runs the solver first with abstraction turned on, and if it returns a potential counterexample, the counterexample is refined to make sure it is a counterexample for the actual (not the abstracted) problem" + } + | Equivalence -- prove equivalence between two programs + { codeA :: w ::: ByteString "Bytecode of the first program" + , codeB :: w ::: ByteString "Bytecode of the second program" + , sig :: w ::: Maybe Text "Signature of types to decode / encode" + , arg :: w ::: [String] "Values to encode" + , calldata :: w ::: Maybe ByteString "Tx: calldata" + , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in seconds (default: 300)" + , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" + , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc5" + , smtoutput :: w ::: Bool "Print verbose smt output" + , smtdebug :: w ::: Bool "Print smt queries sent to the solver" + , askSmtIterations :: w ::: Integer "1" "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 1)" + , loopDetectionHeuristic :: w ::: LoopHeuristic "StackBased" "Which heuristic should be used to determine if we are in a loop: StackBased (default) or Naive" + , abstractArithmetic :: w ::: Bool "Use abstraction-refinement for complicated arithmetic functions such as MulMod. This runs the solver first with abstraction turned on, and if it returns a potential counterexample, the counterexample is refined to make sure it is a counterexample for the actual (not the abstracted) problem" + , abstractMemory :: w ::: Bool "Use abstraction-refinement for Memory. This runs the solver first with abstraction turned on, and if it returns a potential counterexample, the counterexample is refined to make sure it is a counterexample for the actual (not the abstracted) problem" + } + | Exec -- Execute a given program with specified env & calldata + { code :: w ::: Maybe ByteString "Program bytecode" + , calldata :: w ::: Maybe ByteString "Tx: calldata" + , address :: w ::: Maybe Addr "Tx: address" + , caller :: w ::: Maybe Addr "Tx: caller" + , origin :: w ::: Maybe Addr "Tx: origin" + , coinbase :: w ::: Maybe Addr "Block: coinbase" + , value :: w ::: Maybe W256 "Tx: Eth amount" + , nonce :: w ::: Maybe Word64 "Nonce of origin" + , gas :: w ::: Maybe Word64 "Tx: gas amount" + , number :: w ::: Maybe W256 "Block: number" + , timestamp :: w ::: Maybe W256 "Block: timestamp" + , basefee :: w ::: Maybe W256 "Block: base fee" + , priorityFee :: w ::: Maybe W256 "Tx: priority fee" + , gaslimit :: w ::: Maybe Word64 "Tx: gas limit" + , gasprice :: w ::: Maybe W256 "Tx: gas price" + , create :: w ::: Bool "Tx: creation" + , maxcodesize :: w ::: Maybe W256 "Block: max code size" + , prevRandao :: w ::: Maybe W256 "Block: prevRandao" + , chainid :: w ::: Maybe W256 "Env: chainId" + , trace :: w ::: Bool "Dump trace" + , rpc :: w ::: Maybe URL "Fetch state from a remote node" + , block :: w ::: Maybe W256 "Block state is be fetched from" + , root :: w ::: Maybe String "Path to project root directory (default: . )" + , projectType :: w ::: Maybe ProjectType "Is this a Foundry or DappTools project (default: Foundry)" + } + | Test -- Run DSTest unit tests + { root :: w ::: Maybe String "Path to project root directory (default: . )" + , projectType :: w ::: Maybe ProjectType "Is this a Foundry or DappTools project (default: Foundry)" + , rpc :: w ::: Maybe URL "Fetch state from a remote node" + , number :: w ::: Maybe W256 "Block: number" + , verbose :: w ::: Maybe Int "Append call trace: {1} failures {2} all" + , coverage :: w ::: Bool "Coverage analysis" + , match :: w ::: Maybe String "Test case filter - only run methods matching regex" + , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc5" + , smtdebug :: w ::: Bool "Print smt queries sent to the solver" + , ffi :: w ::: Bool "Allow the usage of the hevm.ffi() cheatcode (WARNING: this allows test authors to execute arbitrary code on your machine)" + , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in seconds (default: 300)" + , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" + , loopDetectionHeuristic :: w ::: LoopHeuristic "StackBased" "Which heuristic should be used to determine if we are in a loop: StackBased (default) or Naive" + , abstractArithmetic :: w ::: Bool "Use abstraction-refinement for complicated arithmetic functions such as MulMod. This runs the solver first with abstraction turned on, and if it returns a potential counterexample, the counterexample is refined to make sure it is a counterexample for the actual (not the abstracted) problem" + , abstractMemory :: w ::: Bool "Use abstraction-refinement for Memory. This runs the solver first with abstraction turned on, and if it returns a potential counterexample, the counterexample is refined to make sure it is a counterexample for the actual (not the abstracted) problem" + , askSmtIterations :: w ::: Integer "1" "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 1)" + } + | Version + + deriving (Options.Generic) + +type URL = Text + + +-- For some reason haskell can't derive a +-- parseField instance for (Text, ByteString) +instance Options.ParseField (Text, ByteString) + +deriving instance Options.ParseField Word256 +deriving instance Options.ParseField [Word256] + +instance Options.ParseRecord (Command Options.Wrapped) where + parseRecord = + Options.parseRecordWithModifiers Options.lispCaseModifiers + +data InitialStorage + = Empty + | Abstract + deriving (Show, Read, Options.ParseField) + +getFullVersion :: [Char] +getFullVersion = showVersion Paths.version <> " [" <> gitVersion <> "]" + where + gitInfo = $$tGitInfoCwdTry + gitVersion = case gitInfo of + Right val -> "git rev " <> giBranch val <> "@" <> giHash val + Left _ -> "no git revision present" + +main :: IO () +main = do + cmd <- Options.unwrapRecord "hevm -- Ethereum evaluator" + case cmd of + Version {} ->putStrLn getFullVersion + Symbolic {} -> do + root <- getRoot cmd + withCurrentDirectory root $ assert cmd + Equivalence {} -> equivalence cmd + Exec {} -> + launchExec cmd + Test {} -> do + root <- getRoot cmd + withCurrentDirectory root $ do + cores <- unsafeInto <$> getNumProcessors + solver <- getSolver cmd + withSolvers solver cores cmd.smttimeout $ \solvers -> do + buildOut <- readBuildOutput root (getProjectType cmd) + case buildOut of + Left e -> do + putStrLn $ "Error: " <> e + exitFailure + Right out -> do + -- TODO: which functions here actually require a BuildOutput, and which can take it as a Maybe? + testOpts <- unitTestOptions cmd solvers (Just out) + res <- unitTest testOpts out.contracts + unless res exitFailure + +equivalence :: Command Options.Unwrapped -> IO () +equivalence cmd = do + let bytecodeA = hexByteString "--code" . strip0x $ cmd.codeA + bytecodeB = hexByteString "--code" . strip0x $ cmd.codeB + veriOpts = VeriOpts { simp = True + , debug = False + , maxIter = cmd.maxIterations + , askSmtIters = cmd.askSmtIterations + , loopHeuristic = cmd.loopDetectionHeuristic + , abstRefineConfig = AbstRefineConfig cmd.abstractArithmetic cmd.abstractMemory + , rpcInfo = Nothing + } + calldata <- buildCalldata cmd + solver <- getSolver cmd + withSolvers solver 3 Nothing $ \s -> do + res <- equivalenceCheck s bytecodeA bytecodeB veriOpts calldata + case any isCex res of + False -> do + putStrLn "No discrepancies found" + when (any isTimeout res) $ do + putStrLn "But timeout(s) occurred" + exitFailure + True -> do + let cexs = mapMaybe getCex res + T.putStrLn . T.unlines $ + [ "Not equivalent. The following inputs result in differing behaviours:" + , "" , "-----", "" + ] <> (intersperse (T.unlines [ "", "-----" ]) $ fmap (formatCex (AbstractBuf "txdata") Nothing) cexs) + exitFailure + +getSolver :: Command Options.Unwrapped -> IO Solver +getSolver cmd = case cmd.solver of + Nothing -> pure Z3 + Just s -> case T.unpack s of + "z3" -> pure Z3 + "cvc5" -> pure CVC5 + input -> do + putStrLn $ "unrecognised solver: " <> input + exitFailure + +getSrcInfo :: Command Options.Unwrapped -> IO DappInfo +getSrcInfo cmd = do + root <- getRoot cmd + withCurrentDirectory root $ do + outExists <- doesDirectoryExist (root "out") + if outExists + then do + buildOutput <- readBuildOutput root (getProjectType cmd) + case buildOutput of + Left _ -> pure emptyDapp + Right o -> pure $ dappInfo root o + else pure emptyDapp + +getProjectType :: Command Options.Unwrapped -> ProjectType +getProjectType cmd = fromMaybe Foundry cmd.projectType + +getRoot :: Command Options.Unwrapped -> IO FilePath +getRoot cmd = maybe getCurrentDirectory pure (cmd.root) + + +-- | Builds a buffer representing calldata based on the given cli arguments +buildCalldata :: Command Options.Unwrapped -> IO (Expr Buf, [Prop]) +buildCalldata cmd = case (cmd.calldata, cmd.sig) of + -- fully abstract calldata + (Nothing, Nothing) -> pure $ mkCalldata Nothing [] + -- fully concrete calldata + (Just c, Nothing) -> pure (ConcreteBuf (hexByteString "bytes" . strip0x $ c), []) + -- calldata according to given abi with possible specializations from the `arg` list + (Nothing, Just sig') -> do + method' <- functionAbi sig' + pure $ mkCalldata (Just (Sig method'.methodSignature (snd <$> method'.inputs))) cmd.arg + -- both args provided + (_, _) -> do + putStrLn "incompatible options provided: --calldata and --sig" + exitFailure + + +-- If function signatures are known, they should always be given for best results. +assert :: Command Options.Unwrapped -> IO () +assert cmd = do + let block' = maybe Fetch.Latest Fetch.BlockNumber cmd.block + rpcinfo = (,) block' <$> cmd.rpc + calldata <- buildCalldata cmd + preState <- symvmFromCommand cmd calldata + let errCodes = fromMaybe defaultPanicCodes cmd.assertions + cores <- unsafeInto <$> getNumProcessors + let solverCount = fromMaybe cores cmd.numSolvers + solver <- getSolver cmd + withSolvers solver solverCount cmd.smttimeout $ \solvers -> do + let opts = VeriOpts { simp = True + , debug = cmd.smtdebug + , maxIter = cmd.maxIterations + , askSmtIters = cmd.askSmtIterations + , loopHeuristic = cmd.loopDetectionHeuristic + , abstRefineConfig = AbstRefineConfig cmd.abstractArithmetic cmd.abstractMemory + , rpcInfo = rpcinfo + } + (expr, res) <- verify solvers opts preState (Just $ checkAssertions errCodes) + case res of + [Qed _] -> do + putStrLn "\nQED: No reachable property violations discovered\n" + showExtras solvers cmd calldata expr + _ -> do + let cexs = snd <$> mapMaybe getCex res + timeouts = mapMaybe getTimeout res + counterexamples + | null cexs = [] + | otherwise = + [ "" + , "Discovered the following counterexamples:" + , "" + ] <> fmap (formatCex (fst calldata) Nothing) cexs + unknowns + | null timeouts = [] + | otherwise = + [ "" + , "Could not determine reachability of the following end states:" + , "" + ] <> fmap (formatExpr) timeouts + T.putStrLn $ T.unlines (counterexamples <> unknowns) + showExtras solvers cmd calldata expr + exitFailure + +showExtras :: SolverGroup -> Command Options.Unwrapped -> (Expr Buf, [Prop]) -> Expr End -> IO () +showExtras solvers cmd calldata expr = do + when cmd.showTree $ do + putStrLn "=== Expression ===\n" + T.putStrLn $ formatExpr expr + putStrLn "" + when cmd.showReachableTree $ do + reached <- reachable solvers expr + putStrLn "=== Reachable Expression ===\n" + T.putStrLn (formatExpr . snd $ reached) + putStrLn "" + when cmd.getModels $ do + putStrLn $ "=== Models for " <> show (Expr.numBranches expr) <> " branches ===\n" + ms <- produceModels solvers expr + forM_ ms (showModel (fst calldata)) + +isTestOrLib :: Text -> Bool +isTestOrLib file = T.isSuffixOf ".t.sol" file || areAnyPrefixOf ["src/test/", "src/tests/", "lib/"] file + +areAnyPrefixOf :: [Text] -> Text -> Bool +areAnyPrefixOf prefixes t = any (flip T.isPrefixOf t) prefixes + +launchExec :: Command Options.Unwrapped -> IO () +launchExec cmd = do + dapp <- getSrcInfo cmd + vm <- vmFromCommand cmd + let + block = maybe Fetch.Latest Fetch.BlockNumber cmd.block + rpcinfo = (,) block <$> cmd.rpc + + -- TODO: we shouldn't need solvers to execute this code + withSolvers Z3 0 Nothing $ \solvers -> do + vm' <- EVM.Stepper.interpret (Fetch.oracle solvers rpcinfo) vm EVM.Stepper.runFully + when cmd.trace $ T.hPutStr stderr (showTraceTree dapp vm') + case vm'.result of + Just (VMFailure (Revert msg)) -> do + let res = case msg of + ConcreteBuf bs -> bs + _ -> "" + putStrLn $ "Revert: " <> (show $ ByteStringS res) + exitWith (ExitFailure 2) + Just (VMFailure err) -> do + putStrLn $ "Error: " <> show err + exitWith (ExitFailure 2) + Just (Unfinished p) -> do + putStrLn $ "Could not continue execution: " <> show p + exitWith (ExitFailure 2) + Just (VMSuccess buf) -> do + let msg = case buf of + ConcreteBuf msg' -> msg' + _ -> "" + print $ "Return: " <> (show $ ByteStringS msg) + _ -> + internalError "no EVM result" + +-- | Creates a (concrete) VM from command line options +vmFromCommand :: Command Options.Unwrapped -> IO (VM RealWorld) +vmFromCommand cmd = do + (miner,ts,baseFee,blockNum,prevRan) <- case cmd.rpc of + Nothing -> pure (LitAddr 0,Lit 0,0,0,0) + Just url -> Fetch.fetchBlockFrom block url >>= \case + Nothing -> error "Error: Could not fetch block" + Just Block{..} -> pure ( coinbase + , timestamp + , baseFee + , number + , prevRandao + ) + + contract <- case (cmd.rpc, cmd.address, cmd.code) of + (Just url, Just addr', Just c) -> do + Fetch.fetchContractFrom block url addr' >>= \case + Nothing -> + error $ "Error: contract not found: " <> show address + Just contract -> + -- if both code and url is given, + -- fetch the contract and overwrite the code + pure $ + initialContract (mkCode $ hexByteString "--code" $ strip0x c) + & set #balance (contract.balance) + & set #nonce (contract.nonce) + & set #external (contract.external) + + (Just url, Just addr', Nothing) -> + Fetch.fetchContractFrom block url addr' >>= \case + Nothing -> + error $ "Error: contract not found: " <> show address + Just contract -> pure contract + + (_, _, Just c) -> + pure $ + initialContract (mkCode $ hexByteString "--code" $ strip0x c) + + (_, _, Nothing) -> + error "Error: must provide at least (rpc + address) or code" + + let ts' = case maybeLitWord ts of + Just t -> t + Nothing -> internalError "unexpected symbolic timestamp when executing vm test" + + vm <- stToIO $ vm0 baseFee miner ts' blockNum prevRan contract + pure $ EVM.Transaction.initTx vm + where + block = maybe Fetch.Latest Fetch.BlockNumber cmd.block + value = word (.value) 0 + caller = addr (.caller) (LitAddr 0) + origin = addr (.origin) (LitAddr 0) + calldata = ConcreteBuf $ bytes (.calldata) "" + decipher = hexByteString "bytes" . strip0x + mkCode bs = if cmd.create + then InitCode bs mempty + else RuntimeCode (ConcreteRuntimeCode bs) + address = if cmd.create + then addr (.address) (Concrete.createAddress (fromJust $ maybeLitAddr origin) (W64 $ word64 (.nonce) 0)) + else addr (.address) (LitAddr 0xacab) + + vm0 baseFee miner ts blockNum prevRan c = makeVm $ VMOpts + { contract = c + , otherContracts = [] + , calldata = (calldata, []) + , value = Lit value + , address = address + , caller = caller + , origin = origin + , gas = word64 (.gas) 0xffffffffffffffff + , baseFee = baseFee + , priorityFee = word (.priorityFee) 0 + , gaslimit = word64 (.gaslimit) 0xffffffffffffffff + , coinbase = addr (.coinbase) miner + , number = word (.number) blockNum + , timestamp = Lit $ word (.timestamp) ts + , blockGaslimit = word64 (.gaslimit) 0xffffffffffffffff + , gasprice = word (.gasprice) 0 + , maxCodeSize = word (.maxcodesize) 0xffffffff + , prevRandao = word (.prevRandao) prevRan + , schedule = feeSchedule + , chainId = word (.chainid) 1 + , create = (.create) cmd + , baseState = EmptyBase + , txAccessList = mempty -- TODO: support me soon + , allowFFI = False + } + word f def = fromMaybe def (f cmd) + word64 f def = fromMaybe def (f cmd) + addr f def = maybe def LitAddr (f cmd) + bytes f def = maybe def decipher (f cmd) + +symvmFromCommand :: Command Options.Unwrapped -> (Expr Buf, [Prop]) -> IO (VM RealWorld) +symvmFromCommand cmd calldata = do + (miner,blockNum,baseFee,prevRan) <- case cmd.rpc of + Nothing -> pure (SymAddr "miner",0,0,0) + Just url -> Fetch.fetchBlockFrom block url >>= \case + Nothing -> error "Error: Could not fetch block" + Just Block{..} -> pure ( coinbase + , number + , baseFee + , prevRandao + ) + + let + caller = SymAddr "caller" + ts = maybe Timestamp Lit cmd.timestamp + callvalue = maybe TxValue Lit cmd.value + + contract <- case (cmd.rpc, cmd.address, cmd.code) of + (Just url, Just addr', _) -> + Fetch.fetchContractFrom block url addr' >>= \case + Nothing -> + error "Error: contract not found." + Just contract' -> pure contract'' + where + contract'' = case cmd.code of + Nothing -> contract' + -- if both code and url is given, + -- fetch the contract and overwrite the code + Just c -> initialContract (mkCode $ decipher c) + & set #origStorage (contract'.origStorage) + & set #balance (contract'.balance) + & set #nonce (contract'.nonce) + & set #external (contract'.external) + + (_, _, Just c) -> + pure ((`abstractContract` address) . mkCode $ decipher c) + (_, _, Nothing) -> + error "Error: must provide at least (rpc + address) or code" + + vm <- stToIO $ vm0 baseFee miner ts blockNum prevRan calldata callvalue caller contract + pure $ EVM.Transaction.initTx vm + + where + decipher = hexByteString "bytes" . strip0x + block = maybe Fetch.Latest Fetch.BlockNumber cmd.block + origin = eaddr (.origin) (SymAddr "origin") + mkCode bs = if cmd.create + then InitCode bs mempty + else RuntimeCode (ConcreteRuntimeCode bs) + address = eaddr (.address) (SymAddr "entrypoint") + vm0 baseFee miner ts blockNum prevRan cd callvalue caller c = makeVm $ VMOpts + { contract = c + , otherContracts = [] + , calldata = cd + , value = callvalue + , address = address + , caller = caller + , origin = origin + , gas = word64 (.gas) 0xffffffffffffffff + , gaslimit = word64 (.gaslimit) 0xffffffffffffffff + , baseFee = baseFee + , priorityFee = word (.priorityFee) 0 + , coinbase = eaddr (.coinbase) miner + , number = word (.number) blockNum + , timestamp = ts + , blockGaslimit = word64 (.gaslimit) 0xffffffffffffffff + , gasprice = word (.gasprice) 0 + , maxCodeSize = word (.maxcodesize) 0xffffffff + , prevRandao = word (.prevRandao) prevRan + , schedule = feeSchedule + , chainId = word (.chainid) 1 + , create = (.create) cmd + , baseState = maybe AbstractBase parseInitialStorage (cmd.initialStorage) + , txAccessList = mempty + , allowFFI = False + } + word f def = fromMaybe def (f cmd) + word64 f def = fromMaybe def (f cmd) + eaddr f def = maybe def LitAddr (f cmd) + +unitTestOptions :: Command Options.Unwrapped -> SolverGroup -> Maybe BuildOutput -> IO (UnitTestOptions RealWorld) +unitTestOptions cmd solvers buildOutput = do + root <- getRoot cmd + let srcInfo = maybe emptyDapp (dappInfo root) buildOutput + + let rpcinfo = case (cmd.number, cmd.rpc) of + (Just block, Just url) -> Just (Fetch.BlockNumber block, url) + (Nothing, Just url) -> Just (Fetch.Latest, url) + _ -> Nothing + params <- paramsFromRpc rpcinfo + + let + testn = params.number + block' = if 0 == testn + then Fetch.Latest + else Fetch.BlockNumber testn + + pure UnitTestOptions + { solvers = solvers + , rpcInfo = case cmd.rpc of + Just url -> Just (block', url) + Nothing -> Nothing + , maxIter = cmd.maxIterations + , askSmtIters = cmd.askSmtIterations + , smtDebug = cmd.smtdebug + , smtTimeout = cmd.smttimeout + , solver = cmd.solver + , verbose = cmd.verbose + , match = T.pack $ fromMaybe ".*" cmd.match + , testParams = params + , dapp = srcInfo + , ffiAllowed = cmd.ffi + } +parseInitialStorage :: InitialStorage -> BaseState +parseInitialStorage Empty = EmptyBase +parseInitialStorage Abstract = AbstractBase diff --git a/hevm-cli/hevm-cli.hs b/hevm-cli/hevm-cli.hs deleted file mode 100644 --- a/hevm-cli/hevm-cli.hs +++ /dev/null @@ -1,716 +0,0 @@ --- Main file of the hevm CLI program - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE TemplateHaskell #-} - -module Main where - -import Control.Monad (void, when, forM_, unless) -import Control.Monad.State.Strict (liftIO) -import Data.Bifunctor (second) -import Data.ByteString (ByteString) -import Data.ByteString qualified as ByteString -import Data.ByteString.Char8 qualified as Char8 -import Data.ByteString.Lazy qualified as LazyByteString -import Data.DoubleWord (Word256) -import Data.List (intersperse) -import Data.Map qualified as Map -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Text (pack) -import Data.Text qualified as T -import Data.Text.IO qualified as T -import Data.Version (showVersion) -import Data.Word (Word64) -import GHC.Conc (getNumProcessors) -import Numeric.Natural (Natural) -import Optics.Core ((&), (%), set) -import Witch (unsafeInto) -import Options.Generic as Options -import Paths_hevm qualified as Paths -import System.IO (stderr) -import System.Directory (withCurrentDirectory, getCurrentDirectory, doesDirectoryExist) -import System.FilePath (()) -import System.Exit (exitFailure, exitWith, ExitCode(..)) - -import EVM (initialContract, makeVm) -import EVM.Concrete (createAddress) -import EVM.Dapp (findUnitTests, dappInfo, DappInfo, emptyDapp) -import EVM.Debug (Mode(..)) -import EVM.Expr qualified as Expr -import EVM.Facts qualified as Facts -import EVM.Facts.Git qualified as Git -import GitHash -import EVM.FeeSchedule qualified as FeeSchedule -import EVM.Fetch qualified -import EVM.Format (hexByteString, strip0x, showTraceTree, formatExpr) -import EVM.Solidity -import EVM.Solvers -import EVM.Stepper qualified -import EVM.SymExec -import EVM.Transaction qualified -import EVM.TTY qualified as TTY -import EVM.Types hiding (word) -import EVM.UnitTest - --- This record defines the program's command-line options --- automatically via the `optparse-generic` package. -data Command w - = Symbolic -- Symbolically explore an abstract program, or specialized with specified env & calldata - -- vm opts - { code :: w ::: Maybe ByteString "Program bytecode" - , calldata :: w ::: Maybe ByteString "Tx: calldata" - , address :: w ::: Maybe Addr "Tx: address" - , caller :: w ::: Maybe Addr "Tx: caller" - , origin :: w ::: Maybe Addr "Tx: origin" - , coinbase :: w ::: Maybe Addr "Block: coinbase" - , value :: w ::: Maybe W256 "Tx: Eth amount" - , nonce :: w ::: Maybe W256 "Nonce of origin" - , gas :: w ::: Maybe Word64 "Tx: gas amount" - , number :: w ::: Maybe W256 "Block: number" - , timestamp :: w ::: Maybe W256 "Block: timestamp" - , basefee :: w ::: Maybe W256 "Block: base fee" - , priorityFee :: w ::: Maybe W256 "Tx: priority fee" - , gaslimit :: w ::: Maybe Word64 "Tx: gas limit" - , gasprice :: w ::: Maybe W256 "Tx: gas price" - , create :: w ::: Bool "Tx: creation" - , maxcodesize :: w ::: Maybe W256 "Block: max code size" - , prevRandao :: w ::: Maybe W256 "Block: prevRandao" - , chainid :: w ::: Maybe W256 "Env: chainId" - -- remote state opts - , rpc :: w ::: Maybe URL "Fetch state from a remote node" - , block :: w ::: Maybe W256 "Block state is be fetched from" - , state :: w ::: Maybe String "Path to state repository" - , cache :: w ::: Maybe String "Path to rpc cache repository" - - -- symbolic execution opts - , root :: w ::: Maybe String "Path to project root directory (default: . )" - , projectType :: w ::: Maybe ProjectType "Is this a Foundry or DappTools project (default: Foundry)" - , initialStorage :: w ::: Maybe (InitialStorage) "Starting state for storage: Empty, Abstract, Concrete (default Abstract)" - , sig :: w ::: Maybe Text "Signature of types to decode / encode" - , arg :: w ::: [String] "Values to encode" - , debug :: w ::: Bool "Run interactively" - , getModels :: w ::: Bool "Print example testcase for each execution path" - , showTree :: w ::: Bool "Print branches explored in tree view" - , showReachableTree :: w ::: Bool "Print only reachable branches explored in tree view" - , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in seconds (default: 300)" - , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" - , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc5" - , smtdebug :: w ::: Bool "Print smt queries sent to the solver" - , assertions :: w ::: Maybe [Word256] "Comma seperated list of solc panic codes to check for (default: everything except arithmetic overflow)" - , askSmtIterations :: w ::: Integer "1" "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 1)" - , numSolvers :: w ::: Maybe Natural "Number of solver instances to use (default: number of cpu cores)" - , loopDetectionHeuristic :: w ::: LoopHeuristic "StackBased" "Which heuristic should be used to determine if we are in a loop: StackBased (default) or Naive" - } - | Equivalence -- prove equivalence between two programs - { codeA :: w ::: ByteString "Bytecode of the first program" - , codeB :: w ::: ByteString "Bytecode of the second program" - , sig :: w ::: Maybe Text "Signature of types to decode / encode" - , arg :: w ::: [String] "Values to encode" - , calldata :: w ::: Maybe ByteString "Tx: calldata" - , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in seconds (default: 300)" - , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" - , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc5" - , smtoutput :: w ::: Bool "Print verbose smt output" - , smtdebug :: w ::: Bool "Print smt queries sent to the solver" - , askSmtIterations :: w ::: Integer "1" "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 1)" - , loopDetectionHeuristic :: w ::: LoopHeuristic "StackBased" "Which heuristic should be used to determine if we are in a loop: StackBased (default) or Naive" - } - | Exec -- Execute a given program with specified env & calldata - { code :: w ::: Maybe ByteString "Program bytecode" - , calldata :: w ::: Maybe ByteString "Tx: calldata" - , address :: w ::: Maybe Addr "Tx: address" - , caller :: w ::: Maybe Addr "Tx: caller" - , origin :: w ::: Maybe Addr "Tx: origin" - , coinbase :: w ::: Maybe Addr "Block: coinbase" - , value :: w ::: Maybe W256 "Tx: Eth amount" - , nonce :: w ::: Maybe W256 "Nonce of origin" - , gas :: w ::: Maybe Word64 "Tx: gas amount" - , number :: w ::: Maybe W256 "Block: number" - , timestamp :: w ::: Maybe W256 "Block: timestamp" - , basefee :: w ::: Maybe W256 "Block: base fee" - , priorityFee :: w ::: Maybe W256 "Tx: priority fee" - , gaslimit :: w ::: Maybe Word64 "Tx: gas limit" - , gasprice :: w ::: Maybe W256 "Tx: gas price" - , create :: w ::: Bool "Tx: creation" - , maxcodesize :: w ::: Maybe W256 "Block: max code size" - , prevRandao :: w ::: Maybe W256 "Block: prevRandao" - , chainid :: w ::: Maybe W256 "Env: chainId" - , debug :: w ::: Bool "Run interactively" - , jsontrace :: w ::: Bool "Print json trace output at every step" - , trace :: w ::: Bool "Dump trace" - , state :: w ::: Maybe String "Path to state repository" - , cache :: w ::: Maybe String "Path to rpc cache repository" - , rpc :: w ::: Maybe URL "Fetch state from a remote node" - , block :: w ::: Maybe W256 "Block state is be fetched from" - , root :: w ::: Maybe String "Path to project root directory (default: . )" - , projectType :: w ::: Maybe ProjectType "Is this a Foundry or DappTools project (default: Foundry)" - } - | Test -- Run DSTest unit tests - { root :: w ::: Maybe String "Path to project root directory (default: . )" - , projectType :: w ::: Maybe ProjectType "Is this a Foundry or DappTools project (default: Foundry)" - , debug :: w ::: Bool "Run interactively" - , jsontrace :: w ::: Bool "Print json trace output at every step" - , fuzzRuns :: w ::: Maybe Int "Number of times to run fuzz tests" - , depth :: w ::: Maybe Int "Number of transactions to explore" - , replay :: w ::: Maybe (Text, ByteString) "Custom fuzz case to run/debug" - , rpc :: w ::: Maybe URL "Fetch state from a remote node" - , verbose :: w ::: Maybe Int "Append call trace: {1} failures {2} all" - , coverage :: w ::: Bool "Coverage analysis" - , state :: w ::: Maybe String "Path to state repository" - , cache :: w ::: Maybe String "Path to rpc cache repository" - , match :: w ::: Maybe String "Test case filter - only run methods matching regex" - , covMatch :: w ::: Maybe String "Coverage filter - only print coverage for files matching regex" - , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc5" - , smtdebug :: w ::: Bool "Print smt queries sent to the solver" - , ffi :: w ::: Bool "Allow the usage of the hevm.ffi() cheatcode (WARNING: this allows test authors to execute arbitrary code on your machine)" - , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in seconds (default: 300)" - , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" - , loopDetectionHeuristic :: w ::: LoopHeuristic "StackBased" "Which heuristic should be used to determine if we are in a loop: StackBased (default) or Naive" - , askSmtIterations :: w ::: Integer "1" "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 1)" - } - | Version - - deriving (Options.Generic) - -type URL = Text - - --- For some reason haskell can't derive a --- parseField instance for (Text, ByteString) -instance Options.ParseField (Text, ByteString) - -deriving instance Options.ParseField Word256 -deriving instance Options.ParseField [Word256] - -instance Options.ParseRecord (Command Options.Wrapped) where - parseRecord = - Options.parseRecordWithModifiers Options.lispCaseModifiers - -data InitialStorage - = Empty - | Concrete [(W256, [(W256, W256)])] - | Abstract - deriving (Show, Read, Options.ParseField) - -optsMode :: Command Options.Unwrapped -> Mode -optsMode x - | x.debug = Debug - | x.jsontrace = JsonTrace - | otherwise = Run - -applyCache :: (Maybe String, Maybe String) -> IO (VM -> VM) -applyCache (state, cache) = - let applyState = flip Facts.apply - applyCache' = flip Facts.applyCache - in case (state, cache) of - (Nothing, Nothing) -> do - pure id - (Nothing, Just cachePath) -> do - facts <- Git.loadFacts (Git.RepoAt cachePath) - pure $ applyCache' facts - (Just statePath, Nothing) -> do - facts <- Git.loadFacts (Git.RepoAt statePath) - pure $ applyState facts - (Just statePath, Just cachePath) -> do - cacheFacts <- Git.loadFacts (Git.RepoAt cachePath) - stateFacts <- Git.loadFacts (Git.RepoAt statePath) - pure $ (applyState stateFacts) . (applyCache' cacheFacts) - -unitTestOptions :: Command Options.Unwrapped -> SolverGroup -> Maybe BuildOutput -> IO UnitTestOptions -unitTestOptions cmd solvers buildOutput = do - root <- getRoot cmd - let srcInfo = maybe emptyDapp (dappInfo root) buildOutput - - vmModifier <- applyCache (cmd.state, cmd.cache) - - params <- getParametersFromEnvironmentVariables cmd.rpc - - let - testn = params.number - block' = if 0 == testn - then EVM.Fetch.Latest - else EVM.Fetch.BlockNumber testn - - pure UnitTestOptions - { solvers = solvers - , rpcInfo = case cmd.rpc of - Just url -> Just (block', url) - Nothing -> Nothing - , 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 - pure (fst arg', LazyByteString.fromStrict (hexByteString "--replay" $ strip0x $ snd arg')) - , vmModifier = vmModifier - , testParams = params - , dapp = srcInfo - , ffiAllowed = cmd.ffi - } - -getFullVersion :: [Char] -getFullVersion = showVersion Paths.version <> " [" <> gitVersion <> "]" - where - gitInfo = $$tGitInfoCwdTry - gitVersion = case gitInfo of - Right val -> "git rev " <> giBranch val <> "@" <> giHash val - Left _ -> "no git revision present" - -main :: IO () -main = do - cmd <- Options.unwrapRecord "hevm -- Ethereum evaluator" - case cmd of - Version {} ->putStrLn getFullVersion - Symbolic {} -> do - root <- getRoot cmd - withCurrentDirectory root $ assert cmd - Equivalence {} -> equivalence cmd - Exec {} -> - launchExec cmd - Test {} -> do - root <- getRoot cmd - withCurrentDirectory root $ do - cores <- unsafeInto <$> getNumProcessors - solver <- getSolver cmd - withSolvers solver cores cmd.smttimeout $ \solvers -> do - buildOut <- readBuildOutput root (getProjectType cmd) - case buildOut of - Left e -> do - putStrLn $ "Error: " <> e - exitFailure - Right out -> do - -- TODO: which functions here actually require a BuildOutput, and which can take it as a Maybe? - testOpts <- unitTestOptions cmd solvers (Just out) - case (cmd.coverage, optsMode cmd) of - (False, Run) -> do - res <- unitTest testOpts out.contracts cmd.cache - unless res exitFailure - (False, Debug) -> liftIO $ TTY.main testOpts root (Just out) - (False, JsonTrace) -> internalError "json traces not implemented for dappTest" - (True, _) -> liftIO $ dappCoverage testOpts (optsMode cmd) out - - -equivalence :: Command Options.Unwrapped -> IO () -equivalence cmd = do - let bytecodeA = hexByteString "--code" . strip0x $ cmd.codeA - bytecodeB = hexByteString "--code" . strip0x $ cmd.codeB - veriOpts = VeriOpts { simp = True - , debug = False - , maxIter = cmd.maxIterations - , askSmtIters = cmd.askSmtIterations - , loopHeuristic = cmd.loopDetectionHeuristic - , rpcInfo = Nothing - } - calldata <- buildCalldata cmd - solver <- getSolver cmd - withSolvers solver 3 Nothing $ \s -> do - res <- equivalenceCheck s bytecodeA bytecodeB veriOpts calldata - case any isCex res of - False -> do - putStrLn "No discrepancies found" - when (any isTimeout res) $ do - putStrLn "But timeout(s) occurred" - exitFailure - True -> do - let cexs = mapMaybe getCex res - T.putStrLn . T.unlines $ - [ "Not equivalent. The following inputs result in differing behaviours:" - , "" , "-----", "" - ] <> (intersperse (T.unlines [ "", "-----" ]) $ fmap (formatCex (AbstractBuf "txdata")) cexs) - exitFailure - -getSolver :: Command Options.Unwrapped -> IO Solver -getSolver cmd = case cmd.solver of - Nothing -> pure Z3 - Just s -> case T.unpack s of - "z3" -> pure Z3 - "cvc5" -> pure CVC5 - input -> do - putStrLn $ "unrecognised solver: " <> input - exitFailure - -getSrcInfo :: Command Options.Unwrapped -> IO DappInfo -getSrcInfo cmd = do - root <- getRoot cmd - withCurrentDirectory root $ do - outExists <- doesDirectoryExist (root "out") - if outExists - then do - buildOutput <- readBuildOutput root (getProjectType cmd) - case buildOutput of - Left _ -> pure emptyDapp - Right o -> pure $ dappInfo root o - else pure emptyDapp - -getProjectType :: Command Options.Unwrapped -> ProjectType -getProjectType cmd = fromMaybe Foundry cmd.projectType - -getRoot :: Command Options.Unwrapped -> IO FilePath -getRoot cmd = maybe getCurrentDirectory pure (cmd.root) - - --- | Builds a buffer representing calldata based on the given cli arguments -buildCalldata :: Command Options.Unwrapped -> IO (Expr Buf, [Prop]) -buildCalldata cmd = case (cmd.calldata, cmd.sig) of - -- fully abstract calldata - (Nothing, Nothing) -> pure $ mkCalldata Nothing [] - -- fully concrete calldata - (Just c, Nothing) -> pure (ConcreteBuf (hexByteString "bytes" . strip0x $ c), []) - -- calldata according to given abi with possible specializations from the `arg` list - (Nothing, Just sig') -> do - method' <- functionAbi sig' - pure $ mkCalldata (Just (Sig method'.methodSignature (snd <$> method'.inputs))) cmd.arg - -- both args provided - (_, _) -> do - putStrLn "incompatible options provided: --calldata and --sig" - exitFailure - - --- 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 cmd.block - rpcinfo = (,) block' <$> cmd.rpc - calldata <- buildCalldata cmd - preState <- symvmFromCommand cmd calldata - let errCodes = fromMaybe defaultPanicCodes cmd.assertions - cores <- unsafeInto <$> getNumProcessors - let solverCount = fromMaybe cores cmd.numSolvers - solver <- getSolver cmd - withSolvers solver solverCount cmd.smttimeout $ \solvers -> do - if cmd.debug then do - srcInfo <- getSrcInfo cmd - void $ TTY.runFromVM - solvers - rpcinfo - cmd.maxIterations - srcInfo - preState - else do - let opts = VeriOpts { - simp = True, - debug = cmd.smtdebug, - maxIter = cmd.maxIterations, - askSmtIters = cmd.askSmtIterations, - loopHeuristic = cmd.loopDetectionHeuristic, - rpcInfo = rpcinfo - } - (expr, res) <- verify solvers opts preState (Just $ checkAssertions errCodes) - case res of - [Qed _] -> do - putStrLn "\nQED: No reachable property violations discovered\n" - showExtras solvers cmd calldata expr - _ -> do - let cexs = snd <$> mapMaybe getCex res - timeouts = mapMaybe getTimeout res - counterexamples - | null cexs = [] - | otherwise = - [ "" - , "Discovered the following counterexamples:" - , "" - ] <> fmap (formatCex (fst calldata)) cexs - unknowns - | null timeouts = [] - | otherwise = - [ "" - , "Could not determine reachability of the following end states:" - , "" - ] <> fmap (formatExpr) timeouts - T.putStrLn $ T.unlines (counterexamples <> unknowns) - showExtras solvers cmd calldata expr - exitFailure - -showExtras :: SolverGroup -> Command Options.Unwrapped -> (Expr Buf, [Prop]) -> Expr End -> IO () -showExtras solvers cmd calldata expr = do - when cmd.showTree $ do - putStrLn "=== Expression ===\n" - T.putStrLn $ formatExpr expr - putStrLn "" - when cmd.showReachableTree $ do - reached <- reachable solvers expr - putStrLn "=== Reachable Expression ===\n" - T.putStrLn (formatExpr . snd $ reached) - putStrLn "" - when cmd.getModels $ do - putStrLn $ "=== Models for " <> show (Expr.numBranches expr) <> " branches ===\n" - ms <- produceModels solvers expr - forM_ ms (showModel (fst calldata)) - -getCex :: ProofResult a b c -> Maybe b -getCex (Cex c) = Just c -getCex _ = Nothing - -getTimeout :: ProofResult a b c -> Maybe c -getTimeout (Timeout c) = Just c -getTimeout _ = Nothing - -dappCoverage :: UnitTestOptions -> Mode -> BuildOutput -> IO () -dappCoverage opts _ bo@(BuildOutput (Contracts cs) cache) = do - let unitTests = findUnitTests opts.match $ Map.elems cs - covs <- mconcat <$> mapM - (coverageForUnitTestContract opts cs cache) unitTests - let - dapp = dappInfo "." bo - f (k, vs) = do - when (shouldPrintCoverage opts.covMatch (T.pack k)) $ do - putStr ("\x1b[0m" ++ "————— hevm coverage for ") -- Prefixed with color reset - putStrLn (k ++ " —————") - putStrLn "" - forM_ vs $ \(n, bs) -> do - case ByteString.find (\x -> x /= 0x9 && x /= 0x20 && x /= 0x7d) bs of - Nothing -> putStr "\x1b[38;5;240m" -- Gray (Coverage status isn't relevant) - Just _ -> - case n of - -1 -> putStr "\x1b[38;5;240m" -- Gray (Coverage status isn't relevant) - 0 -> putStr "\x1b[31m" -- Red (Uncovered) - _ -> putStr "\x1b[32m" -- Green (Covered) - Char8.putStrLn bs - putStrLn "" - mapM_ f (Map.toList (coverageReport dapp covs)) - -shouldPrintCoverage :: Maybe Text -> Text -> Bool -shouldPrintCoverage (Just covMatch) file = regexMatches covMatch file -shouldPrintCoverage Nothing file = not (isTestOrLib file) - -isTestOrLib :: Text -> Bool -isTestOrLib file = T.isSuffixOf ".t.sol" file || areAnyPrefixOf ["src/test/", "src/tests/", "lib/"] file - -areAnyPrefixOf :: [Text] -> Text -> Bool -areAnyPrefixOf prefixes t = any (flip T.isPrefixOf t) prefixes - -launchExec :: Command Options.Unwrapped -> IO () -launchExec cmd = do - dapp <- getSrcInfo cmd - vm <- vmFromCommand cmd - -- TODO: we shouldn't need solvers to execute this code - withSolvers Z3 0 Nothing $ \solvers -> do - case optsMode cmd of - Run -> do - vm' <- EVM.Stepper.interpret (EVM.Fetch.oracle solvers rpcinfo) vm EVM.Stepper.runFully - when cmd.trace $ T.hPutStr stderr (showTraceTree dapp vm') - case vm'.result of - Just (VMFailure (Revert msg)) -> do - let res = case msg of - ConcreteBuf bs -> bs - _ -> "" - putStrLn $ "Revert: " <> (show $ ByteStringS res) - exitWith (ExitFailure 2) - Just (VMFailure err) -> do - putStrLn $ "Error: " <> show err - exitWith (ExitFailure 2) - Just (Unfinished p) -> do - putStrLn $ "Could not continue execution: " <> show p - exitWith (ExitFailure 2) - Just (VMSuccess buf) -> do - let msg = case buf of - ConcreteBuf msg' -> msg' - _ -> "" - print $ "Return: " <> (show $ ByteStringS msg) - case cmd.state of - Nothing -> pure () - Just path -> - Git.saveFacts (Git.RepoAt path) (Facts.vmFacts vm') - case cmd.cache of - Nothing -> pure () - Just path -> - Git.saveFacts (Git.RepoAt path) (Facts.cacheFacts vm'.cache) - _ -> - internalError "no EVM result" - - Debug -> void $ TTY.runFromVM solvers rpcinfo Nothing dapp vm - --JsonTrace -> void $ execStateT (interpretWithTrace fetcher EVM.Stepper.runFully) vm - _ -> internalError "TODO" - 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 VM -vmFromCommand cmd = do - withCache <- applyCache (cmd.state, cmd.cache) - - (miner,ts,baseFee,blockNum,prevRan) <- case cmd.rpc of - Nothing -> pure (0,Lit 0,0,0,0) - Just url -> EVM.Fetch.fetchBlockFrom block url >>= \case - Nothing -> error "Error: Could not fetch block" - Just Block{..} -> pure ( coinbase - , timestamp - , baseFee - , number - , prevRandao - ) - - contract <- case (cmd.rpc, cmd.address, cmd.code) of - (Just url, Just addr', Just c) -> do - EVM.Fetch.fetchContractFrom block url addr' >>= \case - Nothing -> - error $ "Error: contract not found: " <> show address - Just contract -> - -- if both code and url is given, - -- fetch the contract and overwrite the code - pure $ - initialContract (mkCode $ hexByteString "--code" $ strip0x c) - & set #balance (contract.balance) - & set #nonce (contract.nonce) - & set #external (contract.external) - - (Just url, Just addr', Nothing) -> - EVM.Fetch.fetchContractFrom block url addr' >>= \case - Nothing -> - error $ "Error: contract not found: " <> show address - Just contract -> pure contract - - (_, _, Just c) -> - pure $ - initialContract (mkCode $ hexByteString "--code" $ strip0x c) - - (_, _, Nothing) -> - error "Error: must provide at least (rpc + address) or code" - - let ts' = case maybeLitWord ts of - Just t -> t - Nothing -> internalError "unexpected symbolic timestamp when executing vm test" - - pure $ EVM.Transaction.initTx $ withCache (vm0 baseFee miner ts' blockNum prevRan contract) - where - block = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block - value = word (.value) 0 - caller = addr (.caller) 0 - origin = addr (.origin) 0 - calldata = ConcreteBuf $ bytes (.calldata) "" - decipher = hexByteString "bytes" . strip0x - mkCode bs = if cmd.create - then InitCode bs mempty - else RuntimeCode (ConcreteRuntimeCode bs) - address = if cmd.create - then addr (.address) (createAddress origin (word (.nonce) 0)) - else addr (.address) 0xacab - - vm0 baseFee miner ts blockNum prevRan c = makeVm $ VMOpts - { contract = c - , calldata = (calldata, []) - , value = Lit value - , address = address - , caller = Expr.litAddr caller - , origin = origin - , gas = word64 (.gas) 0xffffffffffffffff - , baseFee = baseFee - , priorityFee = word (.priorityFee) 0 - , gaslimit = word64 (.gaslimit) 0xffffffffffffffff - , coinbase = addr (.coinbase) miner - , number = word (.number) blockNum - , timestamp = Lit $ word (.timestamp) ts - , blockGaslimit = word64 (.gaslimit) 0xffffffffffffffff - , gasprice = word (.gasprice) 0 - , maxCodeSize = word (.maxcodesize) 0xffffffff - , prevRandao = word (.prevRandao) prevRan - , schedule = FeeSchedule.berlin - , chainId = word (.chainid) 1 - , create = (.create) cmd - , initialStorage = EmptyStore - , txAccessList = mempty -- TODO: support me soon - , allowFFI = False - } - word f def = fromMaybe def (f cmd) - word64 f def = fromMaybe def (f cmd) - addr f def = fromMaybe def (f cmd) - bytes f def = maybe def decipher (f cmd) - -symvmFromCommand :: Command Options.Unwrapped -> (Expr Buf, [Prop]) -> IO (VM) -symvmFromCommand cmd calldata = do - (miner,blockNum,baseFee,prevRan) <- case cmd.rpc of - Nothing -> pure (0,0,0,0) - Just url -> EVM.Fetch.fetchBlockFrom block url >>= \case - Nothing -> error "Error: Could not fetch block" - Just Block{..} -> pure ( coinbase - , number - , baseFee - , prevRandao - ) - - let - caller = Caller 0 - ts = maybe Timestamp Lit cmd.timestamp - callvalue = maybe (CallValue 0) Lit cmd.value - -- TODO: rework this, ConcreteS not needed anymore - let store = maybe AbstractStore parseInitialStorage (cmd.initialStorage) - withCache <- applyCache (cmd.state, cmd.cache) - - contract <- case (cmd.rpc, cmd.address, cmd.code) of - (Just url, Just addr', _) -> - EVM.Fetch.fetchContractFrom block url addr' >>= \case - Nothing -> - error "Error: contract not found." - Just contract' -> pure contract'' - where - contract'' = case cmd.code of - Nothing -> contract' - -- if both code and url is given, - -- fetch the contract and overwrite the code - Just c -> initialContract (mkCode $ decipher c) - -- TODO: fix this - -- & set EVM.origStorage (view EVM.origStorage contract') - & set #balance (contract'.balance) - & set #nonce (contract'.nonce) - & set #external (contract'.external) - - (_, _, Just c) -> - pure (initialContract . mkCode $ decipher c) - (_, _, Nothing) -> - error "Error: must provide at least (rpc + address) or code" - - pure $ (EVM.Transaction.initTx $ withCache $ vm0 baseFee miner ts blockNum prevRan calldata callvalue caller contract) - & set (#env % #storage) store - - where - decipher = hexByteString "bytes" . strip0x - block = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block - origin = addr (.origin) 0 - mkCode bs = if cmd.create - then InitCode bs mempty - else RuntimeCode (ConcreteRuntimeCode bs) - 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 = makeVm $ VMOpts - { contract = c - , calldata = cd - , value = callvalue - , address = address - , caller = caller - , origin = origin - , gas = word64 (.gas) 0xffffffffffffffff - , gaslimit = word64 (.gaslimit) 0xffffffffffffffff - , baseFee = baseFee - , priorityFee = word (.priorityFee) 0 - , coinbase = addr (.coinbase) miner - , number = word (.number) blockNum - , timestamp = ts - , blockGaslimit = word64 (.gaslimit) 0xffffffffffffffff - , gasprice = word (.gasprice) 0 - , maxCodeSize = word (.maxcodesize) 0xffffffff - , prevRandao = word (.prevRandao) prevRan - , schedule = FeeSchedule.berlin - , chainId = word (.chainid) 1 - , create = (.create) cmd - , initialStorage = maybe AbstractStore parseInitialStorage (cmd.initialStorage) - , txAccessList = mempty - , allowFFI = False - } - word f def = fromMaybe def (f cmd) - addr f def = fromMaybe def (f cmd) - word64 f def = fromMaybe def (f cmd) - -parseInitialStorage :: InitialStorage -> Expr Storage -parseInitialStorage = \case - Empty -> EmptyStore - Concrete s -> ConcreteStore (Map.fromList $ fmap (second Map.fromList) s) - Abstract -> AbstractStore diff --git a/hevm.cabal b/hevm.cabal --- a/hevm.cabal +++ b/hevm.cabal @@ -2,44 +2,24 @@ name: hevm version: - 0.51.3 + 0.52.0 synopsis: - Ethereum virtual machine evaluator -description: - Hevm implements the Ethereum virtual machine semantics. - . - It can be used as a library, and it also comes with an executable - that can run unit test suites, optionally with a visual TTY debugger. + Symbolic EVM Evaluator homepage: - https://github.com/dapphub/dapptools + https://github.com/ethereum/hevm license: AGPL-3.0-only author: - Mikael Brockman, Martin Lundfall, dxo + dxo, Martin Lundfall, Mikael Brockman maintainer: - mikael@brockman.se, martin.lundfall@gmail.com, git@d-xo.org + git@d-xo.org category: Ethereum build-type: 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 - test/contracts/pass/abstract.sol - test/contracts/pass/cheatCodes.sol - test/contracts/pass/constantinople.sol - test/contracts/pass/dsProvePass.sol - test/contracts/pass/invariants.sol - test/contracts/pass/libraries.sol - test/contracts/pass/loops.sol - test/contracts/pass/rpc.sol - test/contracts/fail/trivial.sol - test/contracts/fail/cheatCodes.sol - test/contracts/fail/dsProveFail.sol - test/contracts/fail/invariantFail.sol + bench/contracts/*.sol test/scripts/convert_trace_to_json.sh flag ci @@ -78,6 +58,7 @@ -Wno-unticked-promoted-constructors -Wno-orphans -Wno-ambiguous-fields + -optc-Wno-ignored-attributes default-language: GHC2021 default-extensions: DuplicateRecordFields @@ -89,6 +70,7 @@ RecordWildCards TypeFamilies ViewPatterns + DataKinds library import: shared @@ -98,25 +80,18 @@ EVM.Assembler, EVM.Concrete, EVM.Dapp, - EVM.Debug, - EVM.Dev, EVM.Expr, EVM.SMT, EVM.Solvers, EVM.Exec, - EVM.Facts, - EVM.Facts.Git, EVM.Format, EVM.Fetch, EVM.FeeSchedule, - EVM.Hexdump, EVM.Op, - EVM.Patricia, EVM.Precompiled, EVM.RLP, EVM.Solidity, EVM.Stepper, - EVM.StorageLayout, EVM.SymExec, EVM.Traversals, EVM.CSE, @@ -125,16 +100,21 @@ EVM.Types, EVM.UnitTest, EVM.Sign, - if !os(windows) - exposed-modules: - EVM.TTY, - EVM.TTYCenteredList other-modules: Paths_hevm autogen-modules: Paths_hevm - if os(linux) || os(windows) + if impl(ghc >= 9.4) && !os(darwin) + -- darwin is skipped because it produces this error when building + -- > ghc: loadArchive: Neither an archive, nor a fat archive: `/nix/store/l3lkdfm7sg1wwc850451cikqds766h15-clang-wrapper-11.1.0/bin/clang++' + build-depends: system-cxx-std-lib + elif !os(darwin) extra-libraries: stdc++ + else + -- extra-libraries: c++ + -- https://gitlab.haskell.org/ghc/ghc/-/issues/11829 + ld-options: -Wl,-keep_dwarf_unwind + ghc-options: -fcompact-unwind extra-libraries: secp256k1, ff, gmp c-sources: @@ -161,7 +141,6 @@ text >= 1.2.3 && < 2.1, unordered-containers >= 0.2.10 && < 0.3, vector >= 0.12.1 && < 0.14, - ansi-wl-pprint >= 0.6.9 && < 0.7, base16 >= 0.3.2.0 && < 0.3.3.0, megaparsec >= 9.0.0 && < 10.0, mtl >= 2.2.2 && < 2.3, @@ -183,6 +162,7 @@ multiset >= 0.3.4 && < 0.4, operational >= 0.2.3 && < 0.3, optparse-generic >= 1.3.1 && < 1.5, + pretty-hex >= 1.1 && < 1.2, quickcheck-text >= 0.1.2 && < 0.2, restless-git >= 0.7 && < 0.8, rosezipper >= 0.2 && < 0.3, @@ -192,7 +172,6 @@ regex-tdfa >= 1.2.3 && < 1.4, base >= 4.9 && < 5, here >= 1.2.13 && < 1.3, - tuple >= 0.3.0.2 && < 0.4, smt2-parser >= 0.1.0.1, word-wrap >= 0.5 && < 0.6, spool >= 0.1 && < 0.2, @@ -210,22 +189,17 @@ executable hevm import: shared hs-source-dirs: - hevm-cli + cli main-is: - hevm-cli.hs + cli.hs ghc-options: -threaded -with-rtsopts=-N other-modules: Paths_hevm if os(darwin) extra-libraries: c++ - ld-options: -Wl,-keep_dwarf_unwind - ghc-options: -fcompact-unwind - else - extra-libraries: stdc++ build-depends: QuickCheck, aeson, - ansi-wl-pprint, async, base, base16, @@ -266,8 +240,6 @@ import: shared hs-source-dirs: test - extra-libraries: - secp256k1 other-modules: Paths_hevm autogen-modules: @@ -336,11 +308,6 @@ buildable: False if os(darwin) extra-libraries: c++ - -- https://gitlab.haskell.org/ghc/ghc/-/issues/11829 - ld-options: -Wl,-keep_dwarf_unwind - ghc-options: -fcompact-unwind - else - extra-libraries: stdc++ --- Test Suites --- @@ -383,9 +350,7 @@ ghc-options: -O2 if os(darwin) - extra-libraries: c++ - else - extra-libraries: stdc++ + extra-libraries: c++ other-modules: Paths_hevm autogen-modules: diff --git a/src/EVM.hs b/src/EVM.hs --- a/src/EVM.hs +++ b/src/EVM.hs @@ -12,2319 +12,2630 @@ import Optics.Operators.Unsafe import EVM.ABI -import EVM.Concrete (createAddress, create2Address) -import EVM.Expr (readStorage, writeStorage, readByte, readWord, writeWord, - writeByte, bufLength, indexWord, litAddr, readBytes, word256At, copySlice) -import EVM.Expr qualified as Expr -import EVM.FeeSchedule (FeeSchedule (..)) -import EVM.Op -import EVM.Precompiled qualified -import EVM.Solidity -import EVM.Types -import EVM.Sign qualified - -import Control.Monad.State.Strict hiding (state) -import Data.Bits (FiniteBits, countLeadingZeros, finiteBitSize) -import Data.ByteArray qualified as BA -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Lazy (fromStrict) -import Data.ByteString.Lazy qualified as LS -import Data.ByteString.Char8 qualified as Char8 -import Data.Foldable (toList) -import Data.List (find) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe, fromJust) -import Data.Set (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.Typeable -import Data.Vector qualified as V -import Data.Vector.Storable qualified as SV -import Data.Vector.Storable.Mutable qualified as SV -import Data.Word (Word8, Word32, Word64) -import Witch (into, unsafeInto) - -import Crypto.Hash (Digest, SHA256, RIPEMD160) -import Crypto.Hash qualified as Crypto -import Crypto.Number.ModArithmetic (expFast) - -blankState :: FrameState -blankState = FrameState - { contract = 0 - , codeContract = 0 - , code = RuntimeCode (ConcreteRuntimeCode "") - , pc = 0 - , stack = mempty - , memory = mempty - , memorySize = 0 - , calldata = mempty - , callvalue = Lit 0 - , caller = Lit 0 - , gas = 0 - , returndata = mempty - , static = False - } - --- | An "external" view of a contract's bytecode, appropriate for --- e.g. @EXTCODEHASH@. -bytecode :: Getter Contract (Expr Buf) -bytecode = #contractcode % to f - where f (InitCode _ _) = mempty - f (RuntimeCode (ConcreteRuntimeCode bs)) = ConcreteBuf bs - f (RuntimeCode (SymbolicRuntimeCode ops)) = Expr.fromList ops - --- * Data accessors - -currentContract :: VM -> Maybe Contract -currentContract vm = - Map.lookup vm.state.codeContract vm.env.contracts - --- * Data constructors - -makeVm :: VMOpts -> VM -makeVm o = - let txaccessList = o.txAccessList - txorigin = o.origin - txtoAddr = o.address - initialAccessedAddrs = fromList $ [txorigin, txtoAddr, o.coinbase] ++ [1..9] ++ (Map.keys txaccessList) - initialAccessedStorageKeys = fromList $ foldMap (uncurry (map . (,))) (Map.toList txaccessList) - touched = if o.create then [txorigin] else [txorigin, txtoAddr] - in - VM - { result = Nothing - , frames = mempty - , tx = TxState - { gasprice = o.gasprice - , gaslimit = o.gaslimit - , priorityFee = o.priorityFee - , origin = txorigin - , toAddr = txtoAddr - , value = o.value - , substate = SubState mempty touched initialAccessedAddrs initialAccessedStorageKeys mempty - --, _accessList = txaccessList - , isCreate = o.create - , txReversion = Map.fromList - [(o.address , o.contract )] - } - , logs = [] - , traces = Zipper.fromForest [] - , block = Block - { coinbase = o.coinbase - , timestamp = o.timestamp - , number = o.number - , prevRandao = o.prevRandao - , maxCodeSize = o.maxCodeSize - , gaslimit = o.blockGaslimit - , baseFee = o.baseFee - , schedule = o.schedule - } - , state = FrameState - { pc = 0 - , stack = mempty - , memory = mempty - , memorySize = 0 - , code = o.contract.contractcode - , contract = o.address - , codeContract = o.address - , calldata = fst o.calldata - , callvalue = o.value - , caller = o.caller - , gas = o.gas - , returndata = mempty - , static = False - } - , env = Env - { chainId = o.chainId - , storage = o.initialStorage - , origStorage = mempty - , contracts = Map.fromList - [(o.address, o.contract )] - } - , cache = Cache mempty mempty mempty - , burned = 0 - , constraints = snd o.calldata - , keccakEqs = mempty - , iterations = mempty - , allowFFI = o.allowFFI - , overrideCaller = Nothing - } - --- | Initialize empty contract with given code -initialContract :: ContractCode -> Contract -initialContract contractCode = Contract - { contractcode = contractCode - , codehash = hashcode contractCode - , balance = 0 - , nonce = if creation then 1 else 0 - , opIxMap = mkOpIxMap contractCode - , codeOps = mkCodeOps contractCode - , external = False - } where - creation = case contractCode of - InitCode _ _ -> True - RuntimeCode _ -> False - --- * Opcode dispatch (exec1) - --- | Update program counter -next :: (?op :: Word8) => EVM () -next = modifying (#state % #pc) (+ (opSize ?op)) - --- | Executes the EVM one step -exec1 :: EVM () -exec1 = do - vm <- get - - let - -- Convenient aliases - mem = vm.state.memory - stk = vm.state.stack - self = vm.state.contract - this = fromMaybe (internalError "state contract") (Map.lookup self vm.env.contracts) - - fees@FeeSchedule {..} = vm.block.schedule - - doStop = finishFrame (FrameReturned mempty) - - if self > 0x0 && self <= 0x9 then do - -- call to precompile - let ?op = 0x00 -- dummy value - case bufLength vm.state.calldata of - Lit calldatasize -> do - copyBytesToMemory vm.state.calldata (Lit calldatasize) (Lit 0) (Lit 0) - executePrecompile self vm.state.gas 0 calldatasize 0 0 [] - vmx <- get - case vmx.state.stack of - x:_ -> case x of - Lit 0 -> - fetchAccount self $ \_ -> do - touchAccount self - vmError PrecompileFailure - Lit _ -> - fetchAccount self $ \_ -> do - touchAccount self - out <- use (#state % #returndata) - finishFrame (FrameReturned out) - e -> partial $ - UnexpectedSymbolicArg vmx.state.pc "precompile returned a symbolic value" (wrap [e]) - _ -> - underrun - e -> partial $ - UnexpectedSymbolicArg vm.state.pc "cannot call precompiles with symbolic data" (wrap [e]) - - else if vm.state.pc >= opslen vm.state.code - then doStop - - else do - let ?op = case vm.state.code of - InitCode conc _ -> BS.index conc vm.state.pc - RuntimeCode (ConcreteRuntimeCode bs) -> BS.index bs vm.state.pc - RuntimeCode (SymbolicRuntimeCode ops) -> - fromMaybe (internalError "could not analyze symbolic code") $ - maybeLitByte $ ops V.! vm.state.pc - - case getOp (?op) of - - OpPush0 -> do - limitStack 1 $ - burn g_base $ do - next - pushSym (Lit 0) - - OpPush n' -> do - let n = into n' - !xs = case vm.state.code of - InitCode conc _ -> Lit $ word $ padRight n $ BS.take n (BS.drop (1 + vm.state.pc) conc) - RuntimeCode (ConcreteRuntimeCode bs) -> Lit $ word $ BS.take n $ BS.drop (1 + vm.state.pc) bs - RuntimeCode (SymbolicRuntimeCode ops) -> - let bytes = V.take n $ V.drop (1 + vm.state.pc) ops - in readWord (Lit 0) $ Expr.fromList $ padLeft' 32 bytes - limitStack 1 $ - burn g_verylow $ do - next - pushSym xs - - OpDup i -> - case preview (ix (into i - 1)) stk of - Nothing -> underrun - Just y -> - limitStack 1 $ - burn g_verylow $ do - next - pushSym y - - OpSwap i -> - if length stk < (into i) + 1 - then underrun - else - burn g_verylow $ do - next - zoom (#state % #stack) $ do - assign (ix 0) (stk ^?! ix (into i)) - assign (ix (into i)) (stk ^?! ix 0) - - OpLog n -> - notStatic $ - case stk of - (xOffset':xSize':xs) -> - if length xs < (into n) - then underrun - else - forceConcrete2 (xOffset', xSize') "LOG" $ \(xOffset, xSize) -> do - let (topics, xs') = splitAt (into n) xs - bytes = readMemory xOffset' xSize' vm - logs' = (LogEntry (litAddr self) bytes topics) : vm.logs - burn (g_log + g_logdata * (unsafeInto xSize) + into n * g_logtopic) $ - accessMemoryRange xOffset xSize $ do - traceTopLog logs' - next - assign (#state % #stack) xs' - assign #logs logs' - _ -> - underrun - - OpStop -> doStop - - OpAdd -> stackOp2 g_verylow (uncurry Expr.add) - OpMul -> stackOp2 g_low (uncurry Expr.mul) - OpSub -> stackOp2 g_verylow (uncurry Expr.sub) - - OpDiv -> stackOp2 g_low (uncurry Expr.div) - - OpSdiv -> stackOp2 g_low (uncurry Expr.sdiv) - - OpMod -> stackOp2 g_low (uncurry Expr.mod) - - OpSmod -> stackOp2 g_low (uncurry Expr.smod) - OpAddmod -> stackOp3 g_mid (uncurryN Expr.addmod) - OpMulmod -> stackOp3 g_mid (uncurryN Expr.mulmod) - - OpLt -> stackOp2 g_verylow (uncurry Expr.lt) - OpGt -> stackOp2 g_verylow (uncurry Expr.gt) - OpSlt -> stackOp2 g_verylow (uncurry Expr.slt) - OpSgt -> stackOp2 g_verylow (uncurry Expr.sgt) - - OpEq -> stackOp2 g_verylow (uncurry Expr.eq) - OpIszero -> stackOp1 g_verylow Expr.iszero - - OpAnd -> stackOp2 g_verylow (uncurry Expr.and) - OpOr -> stackOp2 g_verylow (uncurry Expr.or) - OpXor -> stackOp2 g_verylow (uncurry Expr.xor) - OpNot -> stackOp1 g_verylow Expr.not - - OpByte -> stackOp2 g_verylow (\(i, w) -> Expr.padByte $ Expr.indexWord i w) - - OpShl -> stackOp2 g_verylow (uncurry Expr.shl) - OpShr -> stackOp2 g_verylow (uncurry Expr.shr) - OpSar -> stackOp2 g_verylow (uncurry Expr.sar) - - -- more accurately refered to as KECCAK - OpSha3 -> - case stk of - xOffset':xSize':xs -> - forceConcrete xOffset' "sha3 offset must be concrete" $ - \xOffset -> forceConcrete xSize' "sha3 size must be concrete" $ \xSize -> - burn (g_sha3 + g_sha3word * ceilDiv (unsafeInto xSize) 32) $ - accessMemoryRange xOffset xSize $ do - hash <- case readMemory xOffset' xSize' vm of - ConcreteBuf bs -> do - let hash' = keccak' bs - eqs <- use #keccakEqs - assign #keccakEqs $ - PEq (Lit hash') (Keccak (ConcreteBuf bs)):eqs - pure $ Lit hash' - buf -> pure $ Keccak buf - next - assign (#state % #stack) (hash : xs) - _ -> underrun - - OpAddress -> - limitStack 1 $ - burn g_base (next >> push (into self)) - - OpBalance -> - case stk of - x':xs -> forceConcrete x' "BALANCE" $ \x -> - accessAndBurn (unsafeInto x) $ - fetchAccount (unsafeInto x) $ \c -> do - next - assign (#state % #stack) xs - push c.balance - [] -> - underrun - - OpOrigin -> - limitStack 1 . burn g_base $ - next >> push (into vm.tx.origin) - - OpCaller -> - limitStack 1 . burn g_base $ - next >> pushSym vm.state.caller - - OpCallvalue -> - limitStack 1 . burn g_base $ - next >> pushSym vm.state.callvalue - - OpCalldataload -> stackOp1 g_verylow $ - \ind -> Expr.readWord ind vm.state.calldata - - OpCalldatasize -> - limitStack 1 . burn g_base $ - next >> pushSym (bufLength vm.state.calldata) - - OpCalldatacopy -> - case stk of - xTo':xFrom:xSize':xs -> - forceConcrete2 (xTo', xSize') "CALLDATACOPY" $ - \(xTo, xSize) -> - burn (g_verylow + g_copy * ceilDiv (unsafeInto xSize) 32) $ - accessMemoryRange xTo xSize $ do - next - assign (#state % #stack) xs - copyBytesToMemory vm.state.calldata xSize' xFrom xTo' - _ -> underrun - - OpCodesize -> - limitStack 1 . burn g_base $ - next >> pushSym (codelen vm.state.code) - - OpCodecopy -> - case stk of - memOffset':codeOffset:n':xs -> - forceConcrete2 (memOffset', n') "CODECOPY" $ - \(memOffset,n) -> do - case toWord64 n of - Nothing -> vmError IllegalOverflow - Just n'' -> - if n'' <= ( (maxBound :: Word64) - g_verylow ) `div` g_copy * 32 then - burn (g_verylow + g_copy * ceilDiv (unsafeInto n) 32) $ - accessMemoryRange memOffset n $ do - next - assign (#state % #stack) xs - copyBytesToMemory (toBuf vm.state.code) n' codeOffset memOffset' - else vmError IllegalOverflow - _ -> underrun - - OpGasprice -> - limitStack 1 . burn g_base $ - next >> push vm.tx.gasprice - - OpExtcodesize -> - case stk of - x':xs -> case x' of - Lit x -> if x == into cheatCode - then do - next - assign (#state % #stack) xs - pushSym (Lit 1) - else - accessAndBurn (unsafeInto x) $ - fetchAccount (unsafeInto x) $ \c -> do - next - assign (#state % #stack) xs - pushSym (bufLength (view bytecode c)) - _ -> do - assign (#state % #stack) xs - pushSym (CodeSize x') - next - [] -> - underrun - - OpExtcodecopy -> - case stk of - extAccount':memOffset':codeOffset:codeSize':xs -> - forceConcrete3 (extAccount', memOffset', codeSize') "EXTCODECOPY" $ - \(extAccount, memOffset, codeSize) -> do - acc <- accessAccountForGas (unsafeInto extAccount) - let cost = if acc then g_warm_storage_read else g_cold_account_access - burn (cost + g_copy * ceilDiv (unsafeInto codeSize) 32) $ - accessMemoryRange memOffset codeSize $ - fetchAccount (unsafeInto extAccount) $ \c -> do - next - assign (#state % #stack) xs - copyBytesToMemory (view bytecode c) codeSize' codeOffset memOffset' - _ -> underrun - - OpReturndatasize -> - limitStack 1 . burn g_base $ - next >> pushSym (bufLength vm.state.returndata) - - OpReturndatacopy -> - case stk of - xTo':xFrom:xSize':xs -> forceConcrete2 (xTo', xSize') "RETURNDATACOPY" $ - \(xTo, xSize) -> - burn (g_verylow + g_copy * ceilDiv (unsafeInto xSize) 32) $ - accessMemoryRange xTo xSize $ do - next - assign (#state % #stack) xs - - let jump True = vmError ReturnDataOutOfBounds - jump False = copyBytesToMemory vm.state.returndata xSize' xFrom xTo' - - case (xFrom, bufLength vm.state.returndata) of - (Lit f, Lit l) -> - jump $ l < f + xSize || f + xSize < f - _ -> do - let oob = Expr.lt (bufLength vm.state.returndata) (Expr.add xFrom xSize') - overflow = Expr.lt (Expr.add xFrom xSize') (xFrom) - loc <- codeloc - branch loc (Expr.or oob overflow) jump - _ -> underrun - - OpExtcodehash -> - case stk of - x':xs -> forceConcrete x' "EXTCODEHASH" $ \x -> - accessAndBurn (unsafeInto x) $ do - next - assign (#state % #stack) xs - fetchAccount (unsafeInto x) $ \c -> - if accountEmpty c - then push 0 - else pushSym $ keccak (view bytecode c) - [] -> - underrun - - OpBlockhash -> do - -- We adopt the fake block hash scheme of the VMTests, - -- so that blockhash(i) is the hash of i as decimal ASCII. - stackOp1 g_blockhash $ \case - Lit i -> if i + 256 < vm.block.number || i >= vm.block.number - then Lit 0 - else (into i :: Integer) & show & Char8.pack & keccak' & Lit - i -> BlockHash i - - OpCoinbase -> - limitStack 1 . burn g_base $ - next >> push (into vm.block.coinbase) - - OpTimestamp -> - limitStack 1 . burn g_base $ - next >> pushSym vm.block.timestamp - - OpNumber -> - limitStack 1 . burn g_base $ - next >> push vm.block.number - - OpPrevRandao -> do - limitStack 1 . burn g_base $ - next >> push vm.block.prevRandao - - OpGaslimit -> - limitStack 1 . burn g_base $ - next >> push (into vm.block.gaslimit) - - OpChainid -> - limitStack 1 . burn g_base $ - next >> push vm.env.chainId - - OpSelfbalance -> - limitStack 1 . burn g_low $ - next >> push this.balance - - OpBaseFee -> - limitStack 1 . burn g_base $ - next >> push vm.block.baseFee - - OpPop -> - case stk of - _:xs -> burn g_base (next >> assign (#state % #stack) xs) - _ -> underrun - - OpMload -> - case stk of - x':xs -> forceConcrete x' "MLOAD" $ \x -> - burn g_verylow $ - accessMemoryWord x $ do - next - assign (#state % #stack) (readWord (Lit x) mem : xs) - _ -> underrun - - OpMstore -> - case stk of - x':y:xs -> forceConcrete x' "MSTORE index" $ \x -> - burn g_verylow $ - accessMemoryWord x $ do - next - assign (#state % #memory) (writeWord (Lit x) y mem) - assign (#state % #stack) xs - _ -> underrun - - OpMstore8 -> - case stk of - x':y:xs -> forceConcrete x' "MSTORE8" $ \x -> - burn g_verylow $ - accessMemoryRange x 1 $ do - let yByte = indexWord (Lit 31) y - next - modifying (#state % #memory) (writeByte (Lit x) yByte) - assign (#state % #stack) xs - _ -> underrun - - OpSload -> - case stk of - x:xs -> do - acc <- accessStorageForGas self x - let cost = if acc then g_warm_storage_read else g_cold_sload - burn cost $ - accessStorage self x $ \y -> do - next - assign (#state % #stack) (y:xs) - _ -> underrun - - OpSstore -> - notStatic $ - case stk of - x:new:xs -> - accessStorage self x $ \current -> do - availableGas <- use (#state % #gas) - - if availableGas <= g_callstipend then - finishFrame (FrameErrored (OutOfGas availableGas g_callstipend)) - else do - let - original = - case readStorage (litAddr self) x (ConcreteStore vm.env.origStorage) of - Just (Lit v) -> v - _ -> 0 - storage_cost = - case (maybeLitWord current, maybeLitWord new) of - (Just current', Just new') -> - if (current' == new') then g_sload - else if (current' == original) && (original == 0) then g_sset - else if (current' == original) then g_sreset - else g_sload - - -- if any of the arguments are symbolic, - -- assume worst case scenario - _ -> g_sset - - acc <- accessStorageForGas self x - let cold_storage_cost = if acc then 0 else g_cold_sload - burn (storage_cost + cold_storage_cost) $ do - next - assign (#state % #stack) xs - modifying (#env % #storage) (writeStorage (litAddr self) x new) - - case (maybeLitWord current, maybeLitWord new) of - (Just current', Just new') -> - unless (current' == new') $ - if current' == original then - when (original /= 0 && new' == 0) $ - refund (g_sreset + g_access_list_storage_key) - else do - when (original /= 0) $ - if current' == 0 - then unRefund (g_sreset + g_access_list_storage_key) - else when (new' == 0) $ refund (g_sreset + g_access_list_storage_key) - when (original == new') $ - if original == 0 - then refund (g_sset - g_sload) - else refund (g_sreset - g_sload) - -- if any of the arguments are symbolic, - -- don't change the refund counter - _ -> noop - _ -> underrun - - OpJump -> - case stk of - x:xs -> - burn g_mid $ forceConcrete x "JUMP: symbolic jumpdest" $ \x' -> - case toInt x' of - Nothing -> vmError BadJumpDestination - Just i -> checkJump i xs - _ -> underrun - - OpJumpi -> do - case stk of - (x:y:xs) -> forceConcrete x "JUMPI: symbolic jumpdest" $ \x' -> - burn g_high $ - let jump :: Bool -> EVM () - jump False = assign (#state % #stack) xs >> next - jump _ = case toInt x' of - Nothing -> vmError BadJumpDestination - Just i -> checkJump i xs - in do - loc <- codeloc - branch loc y jump - _ -> underrun - - OpPc -> - limitStack 1 . burn g_base $ - next >> push (unsafeInto vm.state.pc) - - OpMsize -> - limitStack 1 . burn g_base $ - next >> push (into vm.state.memorySize) - - OpGas -> - limitStack 1 . burn g_base $ - next >> push (into (vm.state.gas - g_base)) - - OpJumpdest -> burn g_jumpdest next - - OpExp -> - -- NOTE: this can be done symbolically using unrolling like this: - -- https://hackage.haskell.org/package/sbv-9.0/docs/src/Data.SBV.Core.Model.html#.%5E - -- However, it requires symbolic gas, since the gas depends on the exponent - case stk of - base:exponent':xs -> forceConcrete exponent' "EXP: symbolic exponent" $ \exponent -> - let cost = if exponent == 0 - then g_exp - else g_exp + g_expbyte * unsafeInto (ceilDiv (1 + log2 exponent) 8) - in burn cost $ do - next - (#state % #stack) .= Expr.exp base exponent' : xs - _ -> underrun - - OpSignextend -> stackOp2 g_low (uncurry Expr.sex) - - OpCreate -> - notStatic $ - case stk of - xValue':xOffset':xSize':xs -> forceConcrete3 (xValue', xOffset', xSize') "CREATE" $ - \(xValue, xOffset, xSize) -> do - accessMemoryRange xOffset xSize $ do - availableGas <- use (#state % #gas) - let - newAddr = createAddress self this.nonce - (cost, gas') = costOfCreate fees availableGas xSize False - _ <- accessAccountForGas newAddr - burn cost $ do - let initCode = readMemory xOffset' xSize' vm - create self this xSize gas' xValue xs newAddr initCode - _ -> underrun - - OpCall -> - case stk of - xGas':xTo:xValue':xInOffset':xInSize':xOutOffset':xOutSize':xs -> - forceConcrete6 (xGas', xValue', xInOffset', xInSize', xOutOffset', xOutSize') "CALL" $ - \(xGas, xValue, xInOffset, xInSize, xOutOffset, xOutSize) -> - (if xValue > 0 then notStatic else id) $ - delegateCall this (unsafeInto xGas) xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ \callee -> do - let from' = fromMaybe self vm.overrideCaller - zoom #state $ do - assign #callvalue (Lit xValue) - assign #caller (litAddr from') - assign #contract callee - assign #overrideCaller Nothing - touchAccount from' - touchAccount callee - transfer from' callee xValue - _ -> - underrun - - OpCallcode -> - case stk of - xGas':xTo:xValue':xInOffset':xInSize':xOutOffset':xOutSize':xs -> - forceConcrete6 (xGas', xValue', xInOffset', xInSize', xOutOffset', xOutSize') "CALLCODE" $ - \(xGas, xValue, xInOffset, xInSize, xOutOffset, xOutSize) -> - delegateCall this (unsafeInto xGas) xTo (litAddr self) xValue xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do - zoom #state $ do - assign #callvalue (Lit xValue) - assign #caller $ litAddr $ fromMaybe self vm.overrideCaller - assign #overrideCaller Nothing - touchAccount self - _ -> - underrun - - OpReturn -> - case stk of - xOffset':xSize':_ -> forceConcrete2 (xOffset', xSize') "RETURN" $ \(xOffset, xSize) -> - accessMemoryRange xOffset xSize $ do - let - output = readMemory xOffset' xSize' vm - codesize = fromMaybe (internalError "processing opcode RETURN. Cannot return dynamically sized abstract data") - . maybeLitWord . bufLength $ output - maxsize = vm.block.maxCodeSize - creation = case vm.frames of - [] -> vm.tx.isCreate - frame:_ -> case frame.context of - CreationContext {} -> True - CallContext {} -> False - if creation - then - if codesize > maxsize - then - finishFrame (FrameErrored (MaxCodeSizeExceeded maxsize codesize)) - else do - let frameReturned = burn (g_codedeposit * unsafeInto codesize) $ - finishFrame (FrameReturned output) - frameErrored = finishFrame $ FrameErrored InvalidFormat - case readByte (Lit 0) output of - LitByte 0xef -> frameErrored - LitByte _ -> frameReturned - y -> do - loc <- codeloc - branch loc (Expr.eqByte y (LitByte 0xef)) $ \case - True -> frameErrored - False -> frameReturned - else - finishFrame (FrameReturned output) - _ -> underrun - - OpDelegatecall -> - case stk of - xGas':xTo:xInOffset':xInSize':xOutOffset':xOutSize':xs -> - forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') "DELEGATECALL" $ - \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> - delegateCall this (unsafeInto xGas) xTo (litAddr self) 0 xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do - touchAccount self - _ -> underrun - - OpCreate2 -> notStatic $ - case stk of - xValue':xOffset':xSize':xSalt':xs -> - forceConcrete4 (xValue', xOffset', xSize', xSalt') "CREATE2" $ - \(xValue, xOffset, xSize, xSalt) -> - accessMemoryRange xOffset xSize $ do - availableGas <- use (#state % #gas) - - forceConcreteBuf (readMemory xOffset' xSize' vm) "CREATE2" $ - \initCode -> do - let - newAddr = create2Address self xSalt initCode - (cost, gas') = costOfCreate fees availableGas xSize True - _ <- accessAccountForGas newAddr - burn cost $ - create self this xSize gas' xValue xs newAddr (ConcreteBuf initCode) - _ -> underrun - - OpStaticcall -> - case stk of - xGas':xTo:xInOffset':xInSize':xOutOffset':xOutSize':xs -> - forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') "STATICCALL" $ - \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> do - delegateCall this (unsafeInto xGas) xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs $ \callee -> do - zoom #state $ do - assign #callvalue (Lit 0) - assign #caller $ litAddr $ fromMaybe self (vm.overrideCaller) - assign #contract callee - assign #static True - assign #overrideCaller Nothing - touchAccount self - touchAccount callee - _ -> - underrun - - OpSelfdestruct -> - notStatic $ - case stk of - [] -> underrun - (xTo':_) -> forceConcrete xTo' "SELFDESTRUCT" $ \(unsafeInto -> xTo) -> do - acc <- accessAccountForGas xTo - let cost = if acc then 0 else g_cold_account_access - funds = this.balance - recipientExists = accountExists xTo vm - c_new = if not recipientExists && funds /= 0 - then g_selfdestruct_newaccount - else 0 - burn (g_selfdestruct + c_new + cost) $ do - selfdestruct self - touchAccount xTo - - if funds /= 0 - then fetchAccount xTo $ \_ -> do - #env % #contracts % ix xTo % #balance %= (+ funds) - assign (#env % #contracts % ix self % #balance) 0 - doStop - else doStop - - OpRevert -> - case stk of - xOffset':xSize':_ -> forceConcrete2 (xOffset', xSize') "REVERT" $ \(xOffset, xSize) -> - accessMemoryRange xOffset xSize $ do - let output = readMemory xOffset' xSize' vm - finishFrame (FrameReverted output) - _ -> underrun - - OpUnknown xxx -> - vmError $ UnrecognizedOpcode xxx - -transfer :: Addr -> Addr -> W256 -> EVM () -transfer _ _ 0 = pure () -transfer xFrom xTo xValue = do - sb <- preuse $ #env % #contracts % ix xFrom % #balance - case sb of - Just srcBal -> - if xValue > srcBal - then vmError $ BalanceTooLow xValue srcBal - else do - (#env % #contracts % ix xFrom % #balance) %= (subtract xValue) - (#env % #contracts % ix xTo % #balance) %= (+ xValue) - Nothing -> vmError $ BalanceTooLow xValue 0 - --- | Checks a *CALL for failure; OOG, too many callframes, memory access etc. -callChecks - :: (?op :: Word8) - => Contract -> Word64 -> Addr -> Addr -> W256 -> W256 -> W256 -> W256 -> W256 -> [Expr EWord] - -- continuation with gas available for call - -> (Word64 -> EVM ()) - -> EVM () -callChecks this xGas xContext xTo xValue xInOffset xInSize xOutOffset xOutSize xs continue = do - vm <- get - let fees = vm.block.schedule - accessMemoryRange xInOffset xInSize $ - accessMemoryRange xOutOffset xOutSize $ do - availableGas <- use (#state % #gas) - let recipientExists = accountExists xContext vm - (cost, gas') <- costOfCall fees recipientExists xValue availableGas xGas xTo - burn (cost - gas') $ do - if xValue > this.balance - then do - assign (#state % #stack) (Lit 0 : xs) - assign (#state % #returndata) mempty - pushTrace $ ErrorTrace (BalanceTooLow xValue this.balance) - next - else if length vm.frames >= 1024 - then do - assign (#state % #stack) (Lit 0 : xs) - assign (#state % #returndata) mempty - pushTrace $ ErrorTrace CallDepthLimitReached - next - else continue gas' - -precompiledContract - :: (?op :: Word8) - => Contract - -> Word64 - -> Addr - -> Addr - -> W256 - -> W256 -> W256 -> W256 -> W256 - -> [Expr EWord] - -> EVM () -precompiledContract this xGas precompileAddr recipient xValue inOffset inSize outOffset outSize xs = - callChecks this xGas recipient precompileAddr xValue inOffset inSize outOffset outSize xs $ \gas' -> - do - executePrecompile precompileAddr gas' inOffset inSize outOffset outSize xs - self <- use (#state % #contract) - stk <- use (#state % #stack) - pc' <- use (#state % #pc) - result' <- use #result - case result' of - Nothing -> case stk of - x:_ -> case maybeLitWord x of - Just 0 -> - pure () - Just 1 -> - fetchAccount recipient $ \_ -> do - transfer self recipient xValue - touchAccount self - touchAccount recipient - _ -> partial $ UnexpectedSymbolicArg pc' "unexpected return value from precompile" (wrap [x]) - _ -> underrun - _ -> pure () - -executePrecompile - :: (?op :: Word8) - => Addr - -> Word64 -> W256 -> W256 -> W256 -> W256 -> [Expr EWord] - -> EVM () -executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = do - vm <- get - let input = readMemory (Lit inOffset) (Lit inSize) vm - fees = vm.block.schedule - cost = costOfPrecompile fees preCompileAddr input - notImplemented = internalError $ "precompile at address " <> show preCompileAddr <> " not yet implemented" - precompileFail = burn (gasCap - cost) $ do - assign (#state % #stack) (Lit 0 : xs) - pushTrace $ ErrorTrace PrecompileFailure - next - if cost > gasCap then - burn gasCap $ do - assign (#state % #stack) (Lit 0 : xs) - next - else burn cost $ - case preCompileAddr of - -- ECRECOVER - 0x1 -> - -- TODO: support symbolic variant - forceConcreteBuf input "ECRECOVER" $ \input' -> do - case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of - Nothing -> do - -- return no output for invalid signature - assign (#state % #stack) (Lit 1 : xs) - assign (#state % #returndata) mempty - next - Just output -> do - assign (#state % #stack) (Lit 1 : xs) - assign (#state % #returndata) (ConcreteBuf output) - copyBytesToMemory (ConcreteBuf output) (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- SHA2-256 - 0x2 -> - forceConcreteBuf input "SHA2-256" $ \input' -> do - let - hash = sha256Buf input' - sha256Buf x = ConcreteBuf $ BA.convert (Crypto.hash x :: Digest SHA256) - assign (#state % #stack) (Lit 1 : xs) - assign (#state % #returndata) hash - copyBytesToMemory hash (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- RIPEMD-160 - 0x3 -> - -- TODO: support symbolic variant - forceConcreteBuf input "RIPEMD160" $ \input' -> do - let - padding = BS.pack $ replicate 12 0 - hash' = BA.convert (Crypto.hash input' :: Digest RIPEMD160) - hash = ConcreteBuf $ padding <> hash' - assign (#state % #stack) (Lit 1 : xs) - assign (#state % #returndata) hash - copyBytesToMemory hash (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- IDENTITY - 0x4 -> do - assign (#state % #stack) (Lit 1 : xs) - assign (#state % #returndata) input - copyCallBytesToMemory input (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- MODEXP - 0x5 -> - -- TODO: support symbolic variant - forceConcreteBuf input "MODEXP" $ \input' -> do - let - (lenb, lene, lenm) = parseModexpLength input' - - output = ConcreteBuf $ - if isZero (96 + lenb + lene) lenm input' - then truncpadlit (unsafeInto lenm) (asBE (0 :: Int)) - else - let - b = asInteger $ lazySlice 96 lenb input' - e = asInteger $ lazySlice (96 + lenb) lene input' - m = asInteger $ lazySlice (96 + lenb + lene) lenm input' - in - padLeft (unsafeInto lenm) (asBE (expFast b e m)) - assign (#state % #stack) (Lit 1 : xs) - assign (#state % #returndata) output - copyBytesToMemory output (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- ECADD - 0x6 -> - -- TODO: support symbolic variant - forceConcreteBuf input "ECADD" $ \input' -> - case EVM.Precompiled.execute 0x6 (truncpadlit 128 input') 64 of - Nothing -> precompileFail - Just output -> do - let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output - assign (#state % #stack) (Lit 1 : xs) - assign (#state % #returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- ECMUL - 0x7 -> - -- TODO: support symbolic variant - forceConcreteBuf input "ECMUL" $ \input' -> - case EVM.Precompiled.execute 0x7 (truncpadlit 96 input') 64 of - Nothing -> precompileFail - Just output -> do - let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output - assign (#state % #stack) (Lit 1 : xs) - assign (#state % #returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- ECPAIRING - 0x8 -> - -- TODO: support symbolic variant - forceConcreteBuf input "ECPAIR" $ \input' -> - case EVM.Precompiled.execute 0x8 input' 32 of - Nothing -> precompileFail - Just output -> do - let truncpaddedOutput = ConcreteBuf $ truncpadlit 32 output - assign (#state % #stack) (Lit 1 : xs) - assign (#state % #returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) - next - - -- BLAKE2 - 0x9 -> - -- TODO: support symbolic variant - forceConcreteBuf input "BLAKE2" $ \input' -> do - case (BS.length input', 1 >= BS.last input') of - (213, True) -> case EVM.Precompiled.execute 0x9 input' 64 of - Just output -> do - let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output - assign (#state % #stack) (Lit 1 : xs) - assign (#state % #returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) - next - Nothing -> precompileFail - _ -> precompileFail - - _ -> notImplemented - -truncpadlit :: Int -> ByteString -> ByteString -truncpadlit n xs = if m > n then BS.take n xs - else BS.append xs (BS.replicate (n - m) 0) - where m = BS.length xs - -lazySlice :: W256 -> W256 -> ByteString -> LS.ByteString -lazySlice offset size bs = - let bs' = LS.take (unsafeInto size) (LS.drop (unsafeInto offset) (fromStrict bs)) - in bs' <> LS.replicate (unsafeInto size - LS.length bs') 0 - -parseModexpLength :: ByteString -> (W256, W256, W256) -parseModexpLength input = - let lenb = word $ LS.toStrict $ lazySlice 0 32 input - lene = word $ LS.toStrict $ lazySlice 32 64 input - lenm = word $ LS.toStrict $ lazySlice 64 96 input - in (lenb, lene, lenm) - ---- checks if a range of ByteString bs starting at offset and length size is all zeros. -isZero :: W256 -> W256 -> ByteString -> Bool -isZero offset size bs = - LS.all (== 0) $ - LS.take (unsafeInto size) $ - LS.drop (unsafeInto offset) $ - fromStrict bs - -asInteger :: LS.ByteString -> Integer -asInteger xs = if xs == mempty then 0 - else 256 * asInteger (LS.init xs) - + into (LS.last xs) - --- * Opcode helper actions - -noop :: Monad m => m () -noop = pure () - -pushTo :: MonadState s m => Lens s s [a] [a] -> a -> m () -pushTo f x = f %= (x :) - -pushToSequence :: MonadState s m => Setter s s (Seq a) (Seq a) -> a -> m () -pushToSequence f x = f %= (Seq.|> x) - -getCodeLocation :: VM -> CodeLocation -getCodeLocation vm = (vm.state.contract, vm.state.pc) - -query :: Query -> EVM () -query = assign #result . Just . HandleEffect . Query - -choose :: Choose -> EVM () -choose = assign #result . Just . HandleEffect . Choose - -branch :: CodeLocation -> Expr EWord -> (Bool -> EVM ()) -> EVM () -branch loc cond continue = do - pathconds <- use #constraints - query $ PleaseAskSMT cond pathconds choosePath - where - choosePath (Case v) = do - assign #result Nothing - pushTo #constraints $ if v then (cond ./= Lit 0) else (cond .== Lit 0) - (iteration, _) <- use (#iterations % at loc % non (0,[])) - stack <- use (#state % #stack) - assign (#cache % #path % at (loc, iteration)) (Just v) - assign (#iterations % at loc) (Just (iteration + 1, stack)) - continue v - -- Both paths are possible; we ask for more input - choosePath Unknown = - choose . PleaseChoosePath cond $ choosePath . Case - --- | Construct RPC Query and halt execution until resolved -fetchAccount :: Addr -> (Contract -> EVM ()) -> EVM () -fetchAccount addr continue = - use (#env % #contracts % at addr) >>= \case - Just c -> continue c - Nothing -> - use (#cache % #fetchedContracts % at addr) >>= \case - Just c -> do - assign (#env % #contracts % at addr) (Just c) - continue c - Nothing -> do - assign (#result) . Just . HandleEffect . Query $ - PleaseFetchContract addr - (\c -> do assign (#cache % #fetchedContracts % at addr) (Just c) - assign (#env % #contracts % at addr) (Just c) - assign #result Nothing - continue c) - -accessStorage - :: Addr - -> Expr EWord - -> (Expr EWord -> EVM ()) - -> EVM () -accessStorage addr slot continue = do - store <- (.env.storage) <$> get - use (#env % #contracts % at addr) >>= \case - Just c -> - case readStorage (litAddr addr) slot store of - -- Notice that if storage is symbolic, we always continue straight away - Just x -> - continue x - Nothing -> - if c.external then - forceConcrete slot "cannot read symbolic slots via RPC" $ \litSlot -> do - -- check if the slot is cached - cachedStore <- (.cache.fetchedStorage) <$> get - case Map.lookup (into addr) cachedStore >>= Map.lookup litSlot of - Nothing -> mkQuery litSlot - Just val -> continue (Lit val) - else do - -- TODO: is this actually needed? - modifying (#env % #storage) (writeStorage (litAddr addr) slot (Lit 0)) - continue $ Lit 0 - Nothing -> - fetchAccount addr $ \_ -> - accessStorage addr slot continue - where - mkQuery s = query $ - PleaseFetchSlot addr s - (\x -> do - modifying (#cache % #fetchedStorage % ix (into addr)) (Map.insert s x) - modifying (#env % #storage) (writeStorage (litAddr addr) slot (Lit x)) - assign #result Nothing - continue (Lit x)) - -accountExists :: Addr -> VM -> Bool -accountExists addr vm = - case Map.lookup addr vm.env.contracts of - Just c -> not (accountEmpty c) - Nothing -> False - --- EIP 161 -accountEmpty :: Contract -> Bool -accountEmpty c = - case c.contractcode of - RuntimeCode (ConcreteRuntimeCode "") -> True - RuntimeCode (SymbolicRuntimeCode b) -> null b - _ -> False - && c.nonce == 0 - && c.balance == 0 - --- * How to finalize a transaction -finalize :: EVM () -finalize = do - let - revertContracts = use (#tx % #txReversion) >>= assign (#env % #contracts) - revertSubstate = assign (#tx % #substate) (SubState mempty mempty mempty mempty mempty) - - use #result >>= \case - Just (VMFailure (Revert _)) -> do - revertContracts - revertSubstate - Just (VMFailure _) -> do - -- burn remaining gas - assign (#state % #gas) 0 - revertContracts - revertSubstate - Just (VMSuccess output) -> do - -- deposit the code from a creation tx - pc' <- use (#state % #pc) - creation <- use (#tx % #isCreate) - createe <- use (#state % #contract) - createeExists <- (Map.member createe) <$> use (#env % #contracts) - let onContractCode contractCode = - when (creation && createeExists) $ replaceCode createe contractCode - case output of - ConcreteBuf bs -> - onContractCode $ RuntimeCode (ConcreteRuntimeCode bs) - _ -> - case Expr.toList output of - Nothing -> - partial $ - UnexpectedSymbolicArg pc' "runtime code cannot have an abstract lentgh" (wrap [output]) - Just ops -> - onContractCode $ RuntimeCode (SymbolicRuntimeCode ops) - _ -> - internalError "Finalising an unfinished tx." - - -- compute and pay the refund to the caller and the - -- corresponding payment to the miner - block <- use #block - tx <- use #tx - gasRemaining <- use (#state % #gas) - - let - sumRefunds = sum (snd <$> tx.substate.refunds) - gasUsed = tx.gaslimit - gasRemaining - cappedRefund = min (quot gasUsed 5) sumRefunds - originPay = (into $ gasRemaining + cappedRefund) * tx.gasprice - minerPay = tx.priorityFee * (into gasUsed) - - modifying (#env % #contracts) - (Map.adjust (over #balance (+ originPay)) tx.origin) - modifying (#env % #contracts) - (Map.adjust (over #balance (+ minerPay)) block.coinbase) - touchAccount block.coinbase - - -- perform state trie clearing (EIP 161), of selfdestructs - -- and touched accounts. addresses are cleared if they have - -- a) selfdestructed, or - -- b) been touched and - -- c) are empty. - -- (see Yellow Paper "Accrued Substate") - -- - -- remove any destructed addresses - destroyedAddresses <- use (#tx % #substate % #selfdestructs) - modifying (#env % #contracts) - (Map.filterWithKey (\k _ -> (k `notElem` destroyedAddresses))) - -- then, clear any remaining empty and touched addresses - touchedAddresses <- use (#tx % #substate % #touchedAccounts) - modifying (#env % #contracts) - (Map.filterWithKey - (\k a -> not ((k `elem` touchedAddresses) && accountEmpty a))) - --- | Loads the selected contract as the current contract to execute -loadContract :: Addr -> EVM () -loadContract target = - preuse (#env % #contracts % ix target % #contractcode) >>= - \case - Nothing -> - internalError "Call target doesn't exist" - Just targetCode -> do - assign (#state % #contract) target - assign (#state % #code) targetCode - assign (#state % #codeContract) target - -limitStack :: Int -> EVM () -> EVM () -limitStack n continue = do - stk <- use (#state % #stack) - if length stk + n > 1024 - then vmError StackLimitExceeded - else continue - -notStatic :: EVM () -> EVM () -notStatic continue = do - bad <- use (#state % #static) - if bad - then vmError StateChangeWhileStatic - else continue - --- | Burn gas, failing if insufficient gas is available -burn :: Word64 -> EVM () -> EVM () -burn n continue = do - available <- use (#state % #gas) - if n <= available - then do - #state % #gas %= (subtract n) - #burned %= (+ n) - continue - else - vmError (OutOfGas available n) - -forceConcrete :: Expr EWord -> String -> (W256 -> EVM ()) -> EVM () -forceConcrete n msg continue = case maybeLitWord n of - Nothing -> do - vm <- get - partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [n]) - Just c -> continue c - -forceConcrete2 :: (Expr EWord, Expr EWord) -> String -> ((W256, W256) -> EVM ()) -> EVM () -forceConcrete2 (n,m) msg continue = case (maybeLitWord n, maybeLitWord m) of - (Just c, Just d) -> continue (c, d) - _ -> do - vm <- get - partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [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 - partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [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 - partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [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 - partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [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 - partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [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 - partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [b]) - --- * Substate manipulation -refund :: Word64 -> EVM () -refund n = do - self <- use (#state % #contract) - pushTo (#tx % #substate % #refunds) (self, n) - -unRefund :: Word64 -> EVM () -unRefund n = do - self <- use (#state % #contract) - refs <- use (#tx % #substate % #refunds) - assign (#tx % #substate % #refunds) - (filter (\(a,b) -> not (a == self && b == n)) refs) - -touchAccount :: Addr -> EVM() -touchAccount = pushTo ((#tx % #substate) % #touchedAccounts) - -selfdestruct :: Addr -> EVM() -selfdestruct = pushTo ((#tx % #substate) % #selfdestructs) - -accessAndBurn :: Addr -> EVM () -> EVM () -accessAndBurn x cont = do - FeeSchedule {..} <- use (#block % #schedule) - acc <- accessAccountForGas x - let cost = if acc then g_warm_storage_read else g_cold_account_access - burn cost cont - --- | returns a wrapped boolean- if true, this address has been touched before in the txn (warm gas cost as in EIP 2929) --- otherwise cold -accessAccountForGas :: Addr -> EVM Bool -accessAccountForGas addr = do - accessedAddrs <- use (#tx % #substate % #accessedAddresses) - let accessed = member addr accessedAddrs - assign (#tx % #substate % #accessedAddresses) (insert addr accessedAddrs) - pure accessed - --- | returns a wrapped boolean- if true, this slot has been touched before in the txn (warm gas cost as in EIP 2929) --- otherwise cold -accessStorageForGas :: Addr -> Expr EWord -> EVM Bool -accessStorageForGas addr key = do - accessedStrkeys <- use (#tx % #substate % #accessedStorageKeys) - case maybeLitWord key of - Just litword -> do - let accessed = member (addr, litword) accessedStrkeys - assign (#tx % #substate % #accessedStorageKeys) (insert (addr, litword) accessedStrkeys) - pure accessed - _ -> return False - --- * Cheat codes - --- The cheat code is 7109709ecfa91a80626ff3989d68f67f5b1dd12d. --- Call this address using one of the cheatActions below to do --- special things, e.g. changing the block timestamp. Beware that --- these are necessarily hevm specific. -cheatCode :: Addr -cheatCode = unsafeInto (keccak' "hevm cheat code") - -cheat - :: (?op :: Word8) - => (W256, W256) -> (W256, W256) - -> EVM () -cheat (inOffset, inSize) (outOffset, outSize) = do - mem <- use (#state % #memory) - vm <- get - let - abi = readBytes 4 (Lit inOffset) mem - input = readMemory (Lit $ inOffset + 4) (Lit $ inSize - 4) vm - pushTrace $ FrameTrace (CallContext cheatCode cheatCode inOffset inSize (Lit 0) (maybeLitWord abi) input (vm.env.contracts, vm.env.storage) vm.tx.substate) - case maybeLitWord abi of - Nothing -> partial $ UnexpectedSymbolicArg vm.state.pc "symbolic cheatcode selector" (wrap [abi]) - Just (unsafeInto -> abi') -> - case Map.lookup abi' cheatActions of - Nothing -> - vmError (BadCheatCode abi') - Just action -> do - action (Lit outOffset) (Lit outSize) input - popTrace - next - push 1 - -type CheatAction = Expr EWord -> Expr EWord -> Expr Buf -> EVM () - -cheatActions :: Map FunctionSelector CheatAction -cheatActions = - Map.fromList - [ action "ffi(string[])" $ - \sig outOffset outSize input -> do - vm <- get - if vm.allowFFI then - case decodeBuf [AbiArrayDynamicType AbiStringType] input of - CAbi valsArr -> case valsArr of - [AbiArrayDynamic AbiStringType strsV] -> - let - cmd = fmap - (\case - (AbiString a) -> unpack $ decodeUtf8 a - _ -> "") - (V.toList strsV) - cont bs = do - let encoded = ConcreteBuf bs - assign (#state % #returndata) encoded - copyBytesToMemory encoded outSize (Lit 0) outOffset - assign #result Nothing - in query (PleaseDoFFI cmd cont) - _ -> vmError (BadCheatCode sig) - _ -> vmError (BadCheatCode sig) - else - let msg = encodeUtf8 "ffi disabled: run again with --ffi if you want to allow tests to call external scripts" - in vmError . Revert . ConcreteBuf $ - abiMethod "Error(string)" (AbiTuple . V.fromList $ [AbiString msg]), - - action "warp(uint256)" $ - \sig _ _ input -> case decodeStaticArgs 0 1 input of - [x] -> assign (#block % #timestamp) x - _ -> vmError (BadCheatCode sig), - - action "roll(uint256)" $ - \sig _ _ input -> case decodeStaticArgs 0 1 input of - [x] -> forceConcrete x "cannot roll to a symbolic block number" (assign (#block % #number)) - _ -> vmError (BadCheatCode sig), - - action "store(address,bytes32,bytes32)" $ - \sig _ _ input -> case decodeStaticArgs 0 3 input of - [a, slot, new] -> - forceConcrete a "cannot store at a symbolic address" $ \(unsafeInto -> a') -> - fetchAccount a' $ \_ -> do - modifying (#env % #storage) (writeStorage (litAddr a') slot new) - _ -> vmError (BadCheatCode sig), - - action "load(address,bytes32)" $ - \sig outOffset _ input -> case decodeStaticArgs 0 2 input of - [a, slot] -> - forceConcrete a "cannot load from a symbolic address" $ \(unsafeInto -> a') -> - accessStorage a' slot $ \res -> do - assign (#state % #returndata % word256At (Lit 0)) res - assign (#state % #memory % word256At outOffset) res - _ -> vmError (BadCheatCode sig), - - action "sign(uint256,bytes32)" $ - \sig outOffset _ input -> case decodeStaticArgs 0 2 input of - [sk, hash] -> - forceConcrete2 (sk, hash) "cannot sign symbolic data" $ \(sk', hash') -> do - let (v,r,s) = EVM.Sign.sign hash' (toInteger sk') - encoded = encodeAbiValue $ - AbiTuple (V.fromList - [ AbiUInt 8 $ into v - , AbiBytes 32 (word256Bytes r) - , AbiBytes 32 (word256Bytes s) - ]) - assign (#state % #returndata) (ConcreteBuf encoded) - copyBytesToMemory (ConcreteBuf encoded) (Lit . unsafeInto . BS.length $ encoded) (Lit 0) outOffset - _ -> vmError (BadCheatCode sig), - - action "addr(uint256)" $ - \sig outOffset _ input -> case decodeStaticArgs 0 1 input of - [sk] -> forceConcrete sk "cannot derive address for a symbolic key" $ \sk' -> do - let a = EVM.Sign.deriveAddr $ into sk' - case a of - Nothing -> vmError (BadCheatCode sig) - Just address -> do - let expAddr = litAddr address - assign (#state % #returndata % word256At (Lit 0)) expAddr - assign (#state % #memory % word256At outOffset) expAddr - _ -> vmError (BadCheatCode sig), - - action "prank(address)" $ - \sig _ _ input -> case decodeStaticArgs 0 1 input of - [addr] -> assign #overrideCaller (Expr.exprToAddr addr) - _ -> vmError (BadCheatCode sig) - - ] - where - action s f = (abiKeccak s, f (abiKeccak s)) - --- * General call implementation ("delegateCall") --- note that the continuation is ignored in the precompile case -delegateCall - :: (?op :: Word8) - => Contract -> Word64 -> Expr EWord -> Expr EWord -> W256 -> W256 -> W256 -> W256 -> W256 - -> [Expr EWord] - -> (Addr -> EVM ()) - -> EVM () -delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue = - forceConcrete2 (xTo, xContext) "cannot delegateCall with symbolic target or context" $ - \((unsafeInto -> xTo'), (unsafeInto -> xContext')) -> - if xTo' > 0 && xTo' <= 9 - then precompiledContract this gasGiven xTo' xContext' xValue xInOffset xInSize xOutOffset xOutSize xs - else if xTo' == cheatCode then - do - assign (#state % #stack) xs - cheat (xInOffset, xInSize) (xOutOffset, xOutSize) - else - callChecks this gasGiven xContext' xTo' xValue xInOffset xInSize xOutOffset xOutSize xs $ - \xGas -> do - vm0 <- get - fetchAccount xTo' $ \target -> - burn xGas $ do - let newContext = CallContext - { target = xTo' - , context = xContext' - , offset = xOutOffset - , size = xOutSize - , codehash = target.codehash - , callreversion = (vm0.env.contracts, vm0.env.storage) - , subState = vm0.tx.substate - , abi = - if xInSize >= 4 - then (maybeLitWord $ readBytes 4 (Lit xInOffset) vm0.state.memory) - else Nothing - , calldata = (readMemory (Lit xInOffset) (Lit xInSize) vm0) - } - - pushTrace (FrameTrace newContext) - next - vm1 <- get - - pushTo #frames $ Frame - { state = vm1.state { stack = xs } - , context = newContext - } - - let clearInitCode = \case - (InitCode _ _) -> InitCode mempty mempty - a -> a - - zoom #state $ do - assign #gas xGas - assign #pc 0 - assign #code (clearInitCode target.contractcode) - assign #codeContract xTo' - assign #stack mempty - assign #memory mempty - assign #memorySize 0 - assign #returndata mempty - assign #calldata (copySlice (Lit xInOffset) (Lit 0) (Lit xInSize) vm0.state.memory mempty) - - continue xTo' - --- -- * Contract creation - --- EIP 684 -collision :: Maybe Contract -> Bool -collision c' = case c' of - Just c -> c.nonce /= 0 || case c.contractcode of - RuntimeCode (ConcreteRuntimeCode "") -> False - RuntimeCode (SymbolicRuntimeCode b) -> not $ null b - _ -> True - Nothing -> False - -create :: (?op :: Word8) - => Addr -> Contract - -> W256 -> Word64 -> W256 -> [Expr EWord] -> Addr -> Expr Buf -> EVM () -create self this xSize xGas xValue xs newAddr initCode = do - vm0 <- get - if this.nonce == into (maxBound :: Word64) - then do - assign (#state % #stack) (Lit 0 : xs) - assign (#state % #returndata) mempty - pushTrace $ ErrorTrace NonceOverflow - next - else if xValue > this.balance - then do - assign (#state % #stack) (Lit 0 : xs) - assign (#state % #returndata) mempty - pushTrace $ ErrorTrace $ BalanceTooLow xValue this.balance - next - else if xSize > vm0.block.maxCodeSize * 2 - then do - assign (#state % #stack) (Lit 0 : xs) - assign (#state % #returndata) mempty - vmError $ MaxInitCodeSizeExceeded (vm0.block.maxCodeSize * 2) xSize - else if length vm0.frames >= 1024 - then do - assign (#state % #stack) (Lit 0 : xs) - assign (#state % #returndata) mempty - pushTrace $ ErrorTrace CallDepthLimitReached - next - else if collision $ Map.lookup newAddr vm0.env.contracts - then burn xGas $ do - assign (#state % #stack) (Lit 0 : xs) - assign (#state % #returndata) mempty - modifying (#env % #contracts % ix self % #nonce) succ - next - else burn xGas $ do - touchAccount self - touchAccount newAddr - let - -- unfortunately we have to apply some (pretty hacky) - -- heuristics here to parse the unstructured buffer read - -- from memory into a code and data section - let contract' = do - prefixLen <- Expr.concPrefix initCode - prefix <- Expr.toList $ Expr.take (unsafeInto prefixLen) initCode - let sym = Expr.drop (unsafeInto prefixLen) initCode - conc <- mapM maybeLitByte prefix - pure $ InitCode (BS.pack $ V.toList conc) sym - case contract' of - Nothing -> - partial $ UnexpectedSymbolicArg vm0.state.pc "initcode must have a concrete prefix" [] - Just c -> do - let - newContract = initialContract c - newContext = - CreationContext { address = newAddr - , codehash = newContract.codehash - , createreversion = vm0.env.contracts - , substate = vm0.tx.substate - } - - zoom (#env % #contracts) $ do - oldAcc <- use (at newAddr) - let oldBal = maybe 0 (.balance) oldAcc - - assign (at newAddr) (Just (newContract & #balance .~ oldBal)) - modifying (ix self % #nonce) succ - - let resetStorage = \case - ConcreteStore s -> ConcreteStore (Map.delete (into newAddr) s) - AbstractStore -> AbstractStore - EmptyStore -> EmptyStore - SStore {} -> internalError "trying to reset symbolic storage with writes in create" - GVar _ -> internalError "unexpected global variable" - - modifying (#env % #storage) resetStorage - modifying (#env % #origStorage) (Map.delete (into newAddr)) - - transfer self newAddr xValue - - pushTrace (FrameTrace newContext) - next - vm1 <- get - pushTo #frames $ Frame - { context = newContext - , state = vm1.state { stack = xs } - } - - assign #state $ - blankState - & set #contract newAddr - & set #codeContract newAddr - & set #code c - & set #callvalue (Lit xValue) - & set #caller (litAddr self) - & set #gas xGas - --- | Replace a contract's code, like when CREATE returns --- from the constructor code. -replaceCode :: Addr -> ContractCode -> EVM () -replaceCode target newCode = - zoom (#env % #contracts % at target) $ - get >>= \case - Just now -> case now.contractcode of - InitCode _ _ -> - put . Just $ - (initialContract newCode) - { balance = now.balance - , nonce = now.nonce - } - RuntimeCode _ -> - internalError $ "can't replace code of deployed contract " <> show target - Nothing -> - internalError "can't replace code of nonexistent contract" - -replaceCodeOfSelf :: ContractCode -> EVM () -replaceCodeOfSelf newCode = do - vm <- get - replaceCode vm.state.contract newCode - -resetState :: EVM () -resetState = - modify' $ \vm -> vm { result = Nothing - , frames = [] - , state = blankState } - --- * VM error implementation - -vmError :: EvmError -> EVM () -vmError e = finishFrame (FrameErrored e) - -partial :: PartialExec -> EVM () -partial e = assign #result (Just (Unfinished e)) - -wrap :: Typeable a => [Expr a] -> [SomeExpr] -wrap = fmap SomeExpr - -underrun :: EVM () -underrun = vmError StackUnderrun - --- | A stack frame can be popped in three ways. -data FrameResult - = FrameReturned (Expr Buf) -- ^ STOP, RETURN, or no more code - | FrameReverted (Expr Buf) -- ^ REVERT - | FrameErrored EvmError -- ^ Any other error - deriving Show - --- | This function defines how to pop the current stack frame in either of --- the ways specified by 'FrameResult'. --- --- It also handles the case when the current stack frame is the only one; --- in this case, we set the final '_result' of the VM execution. -finishFrame :: FrameResult -> EVM () -finishFrame how = do - oldVm <- get - - case oldVm.frames of - -- Is the current frame the only one? - [] -> do - case how of - FrameReturned output -> assign #result . Just $ VMSuccess output - FrameReverted buffer -> assign #result . Just $ VMFailure (Revert buffer) - FrameErrored e -> assign #result . Just $ VMFailure e - finalize - - -- Are there some remaining frames? - nextFrame : remainingFrames -> do - - -- Insert a debug trace. - insertTrace $ - case how of - FrameErrored e -> - ErrorTrace e - FrameReverted e -> - ErrorTrace (Revert e) - FrameReturned output -> - ReturnTrace output nextFrame.context - -- Pop to the previous level of the debug trace stack. - popTrace - - -- Pop the top frame. - assign #frames remainingFrames - -- Install the state of the frame to which we shall return. - assign #state nextFrame.state - - -- When entering a call, the gas allowance is counted as burned - -- in advance; this unburns the remainder and adds it to the - -- parent frame. - let remainingGas = oldVm.state.gas - reclaimRemainingGasAllowance = do - modifying #burned (subtract remainingGas) - modifying (#state % #gas) (+ remainingGas) - - -- Now dispatch on whether we were creating or calling, - -- and whether we shall return, revert, or internalError(six cases). - case nextFrame.context of - - -- Were we calling? - CallContext _ _ (Lit -> outOffset) (Lit -> outSize) _ _ _ reversion substate' -> do - - -- Excerpt K.1. from the yellow paper: - -- K.1. Deletion of an Account Despite Out-of-gas. - -- At block 2675119, in the transaction 0xcf416c536ec1a19ed1fb89e4ec7ffb3cf73aa413b3aa9b77d60e4fd81a4296ba, - -- an account at address 0x03 was called and an out-of-gas occurred during the call. - -- Against the equation (197), this added 0x03 in the set of touched addresses, and this transaction turned σ[0x03] into ∅. - - -- In other words, we special case address 0x03 and keep it in the set of touched accounts during revert - touched <- use (#tx % #substate % #touchedAccounts) - - let - substate'' = over #touchedAccounts (maybe id cons (find (3 ==) touched)) substate' - (contractsReversion, storageReversion) = reversion - revertContracts = assign (#env % #contracts) contractsReversion - revertStorage = assign (#env % #storage) storageReversion - revertSubstate = assign (#tx % #substate) substate'' - - case how of - -- Case 1: Returning from a call? - FrameReturned output -> do - assign (#state % #returndata) output - copyCallBytesToMemory output outSize (Lit 0) outOffset - reclaimRemainingGasAllowance - push 1 - - -- Case 2: Reverting during a call? - FrameReverted output -> do - revertContracts - revertStorage - revertSubstate - assign (#state % #returndata) output - copyCallBytesToMemory output outSize (Lit 0) outOffset - reclaimRemainingGasAllowance - push 0 - - -- Case 3: Error during a call? - FrameErrored _ -> do - revertContracts - revertStorage - revertSubstate - assign (#state % #returndata) mempty - push 0 - -- Or were we creating? - CreationContext _ _ reversion substate' -> do - creator <- use (#state % #contract) - let - createe = oldVm.state.contract - revertContracts = assign (#env % #contracts) reversion' - revertSubstate = assign (#tx % #substate) substate' - - -- persist the nonce through the reversion - reversion' = (Map.adjust (over #nonce (+ 1)) creator) reversion - - case how of - -- Case 4: Returning during a creation? - FrameReturned output -> do - let onContractCode contractCode = do - replaceCode createe contractCode - assign (#state % #returndata) mempty - reclaimRemainingGasAllowance - push (into createe) - case output of - ConcreteBuf bs -> - onContractCode $ RuntimeCode (ConcreteRuntimeCode bs) - _ -> - case Expr.toList output of - Nothing -> partial $ - UnexpectedSymbolicArg - oldVm.state.pc - "runtime code cannot have an abstract length" - (wrap [output]) - Just newCode -> do - onContractCode $ RuntimeCode (SymbolicRuntimeCode newCode) - - -- Case 5: Reverting during a creation? - FrameReverted output -> do - revertContracts - revertSubstate - assign (#state % #returndata) output - reclaimRemainingGasAllowance - push 0 - - -- Case 6: Error during a creation? - FrameErrored _ -> do - revertContracts - revertSubstate - assign (#state % #returndata) mempty - push 0 - - --- * Memory helpers - -accessUnboundedMemoryRange - :: Word64 - -> Word64 - -> EVM () - -> EVM () -accessUnboundedMemoryRange _ 0 continue = continue -accessUnboundedMemoryRange f l continue = do - m0 <- use (#state % #memorySize) - fees <- gets (.block.schedule) - let m1 = 32 * ceilDiv (max m0 (f + l)) 32 - burn (memoryCost fees m1 - memoryCost fees m0) $ do - assign (#state % #memorySize) m1 - continue - -accessMemoryRange - :: W256 - -> W256 - -> EVM () - -> EVM () -accessMemoryRange _ 0 continue = continue -accessMemoryRange f l continue = - case (,) <$> toWord64 f <*> toWord64 l of - Nothing -> vmError IllegalOverflow - Just (f64, l64) -> - if f64 + l64 < l64 - then vmError IllegalOverflow - else accessUnboundedMemoryRange f64 l64 continue - -accessMemoryWord - :: W256 -> EVM () -> EVM () -accessMemoryWord x = accessMemoryRange x 32 - -copyBytesToMemory - :: Expr Buf -> Expr EWord -> Expr EWord -> Expr EWord -> EVM () -copyBytesToMemory bs size xOffset yOffset = - if size == Lit 0 then noop - else do - mem <- use (#state % #memory) - assign (#state % #memory) $ - copySlice xOffset yOffset size bs mem - -copyCallBytesToMemory - :: Expr Buf -> Expr EWord -> Expr EWord -> Expr EWord -> EVM () -copyCallBytesToMemory bs size xOffset yOffset = - if size == Lit 0 then noop - else do - mem <- use (#state % #memory) - assign (#state % #memory) $ - copySlice xOffset yOffset (Expr.min size (bufLength bs)) bs mem - -readMemory :: Expr EWord -> Expr EWord -> VM -> Expr Buf -readMemory offset size vm = copySlice offset (Lit 0) size vm.state.memory mempty - --- * Tracing - -withTraceLocation :: TraceData -> EVM Trace -withTraceLocation x = do - vm <- get - let this = fromJust $ currentContract vm - pure Trace - { tracedata = x - , contract = this - , opIx = fromMaybe 0 $ this.opIxMap SV.!? vm.state.pc - } - -pushTrace :: TraceData -> EVM () -pushTrace x = do - trace <- withTraceLocation x - modifying #traces $ - \t -> Zipper.children $ Zipper.insert (Node trace []) t - -insertTrace :: TraceData -> EVM () -insertTrace x = do - trace <- withTraceLocation x - modifying #traces $ - \t -> Zipper.nextSpace $ Zipper.insert (Node trace []) t - -popTrace :: EVM () -popTrace = - modifying #traces $ - \t -> case Zipper.parent t of - Nothing -> internalError "internal internalError(trace root)" - Just t' -> Zipper.nextSpace t' - -zipperRootForest :: Zipper.TreePos Zipper.Empty a -> Forest a -zipperRootForest z = - case Zipper.parent z of - Nothing -> Zipper.toForest z - Just z' -> zipperRootForest (Zipper.nextSpace z') - -traceForest :: VM -> Forest Trace -traceForest vm = zipperRootForest vm.traces - -traceForest' :: Expr End -> Forest Trace -traceForest' (Success _ (Traces f _) _ _) = f -traceForest' (Partial _ (Traces f _) _) = f -traceForest' (Failure _ (Traces f _) _) = f -traceForest' (ITE {}) = internalError"Internal Error: ITE does not contain a trace" -traceForest' (GVar {}) = internalError"Internal Error: Unexpected GVar" - -traceContext :: Expr End -> Map Addr Contract -traceContext (Success _ (Traces _ c) _ _) = c -traceContext (Partial _ (Traces _ c) _) = c -traceContext (Failure _ (Traces _ c) _) = c -traceContext (ITE {}) = internalError"Internal Error: ITE does not contain a trace" -traceContext (GVar {}) = internalError"Internal Error: Unexpected GVar" - -traceTopLog :: [Expr Log] -> EVM () -traceTopLog [] = noop -traceTopLog ((LogEntry addr bytes topics) : _) = do - trace <- withTraceLocation (EventTrace addr bytes topics) - modifying #traces $ - \t -> Zipper.nextSpace (Zipper.insert (Node trace []) t) -traceTopLog ((GVar _) : _) = internalError "unexpected global variable" - --- * Stack manipulation - -push :: W256 -> EVM () -push = pushSym . Lit - -pushSym :: Expr EWord -> EVM () -pushSym x = #state % #stack %= (x :) - -stackOp1 - :: (?op :: Word8) - => Word64 - -> ((Expr EWord) -> (Expr EWord)) - -> EVM () -stackOp1 cost f = - use (#state % #stack) >>= \case - x:xs -> - burn cost $ do - next - let !y = f x - (#state % #stack) .= y : xs - _ -> - underrun - -stackOp2 - :: (?op :: Word8) - => Word64 - -> (((Expr EWord), (Expr EWord)) -> (Expr EWord)) - -> EVM () -stackOp2 cost f = - use (#state % #stack) >>= \case - x:y:xs -> - burn cost $ do - next - (#state % #stack) .= f (x, y) : xs - _ -> - underrun - -stackOp3 - :: (?op :: Word8) - => Word64 - -> (((Expr EWord), (Expr EWord), (Expr EWord)) -> (Expr EWord)) - -> EVM () -stackOp3 cost f = - use (#state % #stack) >>= \case - x:y:z:xs -> - burn cost $ do - next - (#state % #stack) .= f (x, y, z) : xs - _ -> - underrun - --- * Bytecode data functions - -use' :: (VM -> a) -> EVM a -use' f = do - vm <- get - pure (f vm) - -checkJump :: Int -> [Expr EWord] -> EVM () -checkJump x xs = do - vm <- get - case isValidJumpDest vm x of - True -> do - #state % #stack .= xs - #state % #pc .= x - False -> vmError BadJumpDestination - -isValidJumpDest :: VM -> Int -> Bool -isValidJumpDest vm x = let - code = vm.state.code - self = vm.state.codeContract - contract = fromMaybe - (internalError "self not found in current contracts") - (Map.lookup self vm.env.contracts) - op = case code of - InitCode ops _ -> BS.indexMaybe ops x - RuntimeCode (ConcreteRuntimeCode ops) -> BS.indexMaybe ops x - RuntimeCode (SymbolicRuntimeCode ops) -> ops V.!? x >>= maybeLitByte - in case op of - Nothing -> False - Just b -> 0x5b == b && OpJumpdest == snd (contract.codeOps V.! (contract.opIxMap SV.! x)) - -opSize :: Word8 -> Int -opSize x | x >= 0x60 && x <= 0x7f = into x - 0x60 + 2 -opSize _ = 1 - --- i of the resulting vector contains the operation index for --- the program counter value i. This is needed because source map --- entries are per operation, not per byte. -mkOpIxMap :: ContractCode -> SV.Vector Int -mkOpIxMap (InitCode conc _) - = SV.create $ SV.new (BS.length conc) >>= \v -> - -- Loop over the byte string accumulating a vector-mutating action. - -- This is somewhat obfuscated, but should be fast. - let (_, _, _, m) = BS.foldl' (go v) (0 :: Word8, 0, 0, pure ()) conc - in m >> pure v - where - -- concrete case - go v (0, !i, !j, !m) x | x >= 0x60 && x <= 0x7f = - {- Start of PUSH op. -} (x - 0x60 + 1, i + 1, j, m >> SV.write v i j) - go v (1, !i, !j, !m) _ = - {- End of PUSH op. -} (0, i + 1, j + 1, m >> SV.write v i j) - go v (0, !i, !j, !m) _ = - {- Other op. -} (0, i + 1, j + 1, m >> SV.write v i j) - go v (n, !i, !j, !m) _ = - {- PUSH data. -} (n - 1, i + 1, j, m >> SV.write v i j) - -mkOpIxMap (RuntimeCode (ConcreteRuntimeCode ops)) = - mkOpIxMap (InitCode ops mempty) -- a bit hacky - -mkOpIxMap (RuntimeCode (SymbolicRuntimeCode ops)) - = SV.create $ SV.new (length ops) >>= \v -> - let (_, _, _, m) = foldl (go v) (0, 0, 0, pure ()) (stripBytecodeMetadataSym $ V.toList ops) - in m >> pure v - where - go v (0, !i, !j, !m) x = case maybeLitByte x of - Just x' -> if x' >= 0x60 && x' <= 0x7f - -- start of PUSH op -- - then (x' - 0x60 + 1, i + 1, j, m >> SV.write v i j) - -- other data -- - else (0, i + 1, j + 1, m >> SV.write v i j) - _ -> internalError $ "cannot analyze symbolic code:\nx: " <> show x <> " i: " <> show i <> " j: " <> show j - - go v (1, !i, !j, !m) _ = - {- End of PUSH op. -} (0, i + 1, j + 1, m >> SV.write v i j) - go v (n, !i, !j, !m) _ = - {- PUSH data. -} (n - 1, i + 1, j, m >> SV.write v i j) - - -vmOp :: VM -> Maybe Op -vmOp vm = - let i = vm ^. #state % #pc - code' = vm ^. #state % #code - (op, pushdata) = case code' of - InitCode xs' _ -> - (BS.index xs' i, fmap LitByte $ BS.unpack $ BS.drop i xs') - RuntimeCode (ConcreteRuntimeCode xs') -> - (BS.index xs' i, fmap LitByte $ BS.unpack $ BS.drop i xs') - RuntimeCode (SymbolicRuntimeCode xs') -> - ( fromMaybe (internalError "unexpected symbolic code") . maybeLitByte $ xs' V.! i , V.toList $ V.drop i xs') - in if (opslen code' < i) - then Nothing - else Just (readOp op pushdata) - -vmOpIx :: VM -> Maybe Int -vmOpIx vm = - do self <- currentContract vm - self.opIxMap SV.!? vm.state.pc - --- Maps operation indicies into a pair of (bytecode index, operation) -mkCodeOps :: ContractCode -> V.Vector (Int, Op) -mkCodeOps contractCode = - let l = case contractCode of - InitCode bytes _ -> - LitByte <$> (BS.unpack bytes) - RuntimeCode (ConcreteRuntimeCode ops) -> - LitByte <$> (BS.unpack $ stripBytecodeMetadata ops) - RuntimeCode (SymbolicRuntimeCode ops) -> - stripBytecodeMetadataSym $ V.toList ops - in V.fromList . toList $ go 0 l - where - go !i !xs = - case uncons xs of - Nothing -> - mempty - Just (x, xs') -> - let x' = fromMaybe (internalError "unexpected symbolic code argument") $ maybeLitByte x - j = opSize x' - in (i, readOp x' xs') Seq.<| go (i + j) (drop j xs) - --- * Gas cost calculation helpers - --- Gas cost function for CALL, transliterated from the Yellow Paper. -costOfCall - :: FeeSchedule Word64 - -> Bool -> W256 -> Word64 -> Word64 -> Addr - -> EVM (Word64, Word64) -costOfCall (FeeSchedule {..}) recipientExists xValue availableGas xGas target = do - acc <- accessAccountForGas target - let call_base_gas = if acc then g_warm_storage_read else g_cold_account_access - c_new = if not recipientExists && xValue /= 0 - then g_newaccount - else 0 - c_xfer = if xValue /= 0 then g_callvalue else 0 - c_extra = call_base_gas + c_xfer + c_new - c_gascap = if availableGas >= c_extra - then min xGas (allButOne64th (availableGas - c_extra)) - else xGas - c_callgas = if xValue /= 0 then c_gascap + g_callstipend else c_gascap - pure (c_gascap + c_extra, c_callgas) - --- Gas cost of create, including hash cost if needed -costOfCreate - :: FeeSchedule Word64 - -> Word64 -> W256 -> Bool -> (Word64, Word64) -costOfCreate (FeeSchedule {..}) availableGas size hashNeeded = (createCost, initGas) - where - byteCost = if hashNeeded then g_sha3word + g_initcodeword else g_initcodeword - createCost = g_create + codeCost - codeCost = byteCost * (ceilDiv (unsafeInto size) 32) - initGas = allButOne64th (availableGas - createCost) - -concreteModexpGasFee :: ByteString -> Word64 -concreteModexpGasFee input = - if lenb < into (maxBound :: Word32) && - (lene < into (maxBound :: Word32) || (lenb == 0 && lenm == 0)) && - lenm < into (maxBound :: Word64) - then - max 200 ((multiplicationComplexity * iterCount) `div` 3) - else - maxBound -- TODO: this is not 100% correct, return Nothing on overflow - where - (lenb, lene, lenm) = parseModexpLength input - ez = isZero (96 + lenb) lene input - e' = word $ LS.toStrict $ - lazySlice (96 + lenb) (min 32 lene) input - nwords :: Word64 - nwords = ceilDiv (unsafeInto $ max lenb lenm) 8 - multiplicationComplexity = nwords * nwords - iterCount' :: Word64 - iterCount' | lene <= 32 && ez = 0 - | lene <= 32 = unsafeInto (log2 e') - | e' == 0 = 8 * (unsafeInto lene - 32) - | otherwise = unsafeInto (log2 e') + 8 * (unsafeInto lene - 32) - iterCount = max iterCount' 1 - --- Gas cost of precompiles -costOfPrecompile :: FeeSchedule Word64 -> Addr -> Expr Buf -> Word64 -costOfPrecompile (FeeSchedule {..}) precompileAddr input = - let errorDynamicSize = internalError "precompile input cannot have a dynamic size" - inputLen = case input of - ConcreteBuf bs -> unsafeInto $ BS.length bs - AbstractBuf _ -> errorDynamicSize - buf -> case bufLength buf of - Lit l -> unsafeInto l -- TODO: overflow - _ -> errorDynamicSize - in case precompileAddr of - -- ECRECOVER - 0x1 -> 3000 - -- SHA2-256 - 0x2 -> (((inputLen + 31) `div` 32) * 12) + 60 - -- RIPEMD-160 - 0x3 -> (((inputLen + 31) `div` 32) * 120) + 600 - -- IDENTITY - 0x4 -> (((inputLen + 31) `div` 32) * 3) + 15 - -- MODEXP - 0x5 -> case input of - ConcreteBuf i -> concreteModexpGasFee i - _ -> internalError "Unsupported symbolic modexp gas calc " - -- ECADD - 0x6 -> g_ecadd - -- ECMUL - 0x7 -> g_ecmul - -- ECPAIRING - 0x8 -> (inputLen `div` 192) * g_pairing_point + g_pairing_base - -- BLAKE2 - 0x9 -> case input of - ConcreteBuf i -> g_fround * (unsafeInto $ asInteger $ lazySlice 0 4 i) - _ -> internalError "Unsupported symbolic blake2 gas calc" - _ -> internalError $ "unimplemented precompiled contract " ++ show precompileAddr - --- Gas cost of memory expansion -memoryCost :: FeeSchedule Word64 -> Word64 -> Word64 -memoryCost FeeSchedule{..} byteCount = - let - wordCount = ceilDiv byteCount 32 - linearCost = g_memory * wordCount - quadraticCost = div (wordCount * wordCount) 512 - in - linearCost + quadraticCost - -hashcode :: ContractCode -> Expr EWord -hashcode (InitCode ops args) = keccak $ (ConcreteBuf ops) <> args -hashcode (RuntimeCode (ConcreteRuntimeCode ops)) = keccak (ConcreteBuf ops) -hashcode (RuntimeCode (SymbolicRuntimeCode ops)) = keccak . Expr.fromList $ ops - --- | The length of the code ignoring any constructor args. --- This represents the region that can contain executable opcodes -opslen :: ContractCode -> Int -opslen (InitCode ops _) = BS.length ops -opslen (RuntimeCode (ConcreteRuntimeCode ops)) = BS.length ops -opslen (RuntimeCode (SymbolicRuntimeCode ops)) = length ops - --- | The length of the code including any constructor args. --- This can return an abstract value -codelen :: ContractCode -> Expr EWord -codelen c@(InitCode {}) = bufLength $ toBuf c -codelen (RuntimeCode (ConcreteRuntimeCode ops)) = Lit . unsafeInto $ BS.length ops -codelen (RuntimeCode (SymbolicRuntimeCode ops)) = Lit . unsafeInto $ length ops - -toBuf :: ContractCode -> Expr Buf -toBuf (InitCode ops args) = ConcreteBuf ops <> args -toBuf (RuntimeCode (ConcreteRuntimeCode ops)) = ConcreteBuf ops -toBuf (RuntimeCode (SymbolicRuntimeCode ops)) = Expr.fromList ops - -codeloc :: EVM CodeLocation -codeloc = do - vm <- get - pure (vm.state.contract, vm.state.pc) - --- * Arithmetic - -ceilDiv :: (Num a, Integral a) => a -> a -> a -ceilDiv m n = div (m + n - 1) n - -allButOne64th :: (Num a, Integral a) => a -> a -allButOne64th n = n - div n 64 - -log2 :: FiniteBits b => b -> Int -log2 x = finiteBitSize x - 1 - countLeadingZeros x +import EVM.Expr (readStorage, writeStorage, readByte, readWord, writeWord, + writeByte, bufLength, indexWord, litAddr, readBytes, word256At, copySlice, wordToAddr) +import EVM.Expr qualified as Expr +import EVM.FeeSchedule (FeeSchedule (..)) +import EVM.Op +import EVM.Precompiled qualified +import EVM.Solidity +import EVM.Types +import EVM.Sign qualified +import EVM.Concrete qualified as Concrete + +import Control.Monad.ST (ST) +import Control.Monad.State.Strict hiding (state) +import Data.Bits (FiniteBits, countLeadingZeros, finiteBitSize) +import Data.ByteArray qualified as BA +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy (fromStrict) +import Data.ByteString.Lazy qualified as LS +import Data.ByteString.Char8 qualified as Char8 +import Data.Foldable (toList) +import Data.List (find) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, fromJust, isJust) +import Data.Set (insert, member, fromList) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Text (unpack, pack) +import Data.Text.Encoding (decodeUtf8) +import Data.Tree +import Data.Tree.Zipper qualified as Zipper +import Data.Typeable +import Data.Vector qualified as V +import Data.Vector.Storable qualified as SV +import Data.Vector.Storable.Mutable qualified as SV +import Data.Vector.Unboxed qualified as VUnboxed +import Data.Vector.Unboxed.Mutable qualified as VUnboxed.Mutable +import Data.Word (Word8, Word32, Word64) +import Witch (into, tryFrom, unsafeInto) + +import Crypto.Hash (Digest, SHA256, RIPEMD160) +import Crypto.Hash qualified as Crypto +import Crypto.Number.ModArithmetic (expFast) + +blankState :: ST s (FrameState s) +blankState = do + memory <- ConcreteMemory <$> VUnboxed.Mutable.new 0 + pure $ FrameState + { contract = LitAddr 0 + , codeContract = LitAddr 0 + , code = RuntimeCode (ConcreteRuntimeCode "") + , pc = 0 + , stack = mempty + , memory + , memorySize = 0 + , calldata = mempty + , callvalue = Lit 0 + , caller = LitAddr 0 + , gas = 0 + , returndata = mempty + , static = False + } + +-- | An "external" view of a contract's bytecode, appropriate for +-- e.g. @EXTCODEHASH@. +bytecode :: Getter Contract (Maybe (Expr Buf)) +bytecode = #code % to f + where f (InitCode _ _) = Just mempty + f (RuntimeCode (ConcreteRuntimeCode bs)) = Just $ ConcreteBuf bs + f (RuntimeCode (SymbolicRuntimeCode ops)) = Just $ Expr.fromList ops + f (UnknownCode _) = Nothing + +-- * Data accessors + +currentContract :: VM s -> Maybe Contract +currentContract vm = + Map.lookup vm.state.codeContract vm.env.contracts + +-- * Data constructors + +makeVm :: VMOpts -> ST s (VM s) +makeVm o = do + let txaccessList = o.txAccessList + txorigin = o.origin + txtoAddr = o.address + initialAccessedAddrs = fromList $ + [txorigin, txtoAddr, o.coinbase] + ++ (fmap LitAddr [1..9]) + ++ (Map.keys txaccessList) + initialAccessedStorageKeys = fromList $ foldMap (uncurry (map . (,))) (Map.toList txaccessList) + touched = if o.create then [txorigin] else [txorigin, txtoAddr] + memory <- ConcreteMemory <$> VUnboxed.Mutable.new 0 + pure $ VM + { result = Nothing + , frames = mempty + , tx = TxState + { gasprice = o.gasprice + , gaslimit = o.gaslimit + , priorityFee = o.priorityFee + , origin = txorigin + , toAddr = txtoAddr + , value = o.value + , substate = SubState mempty touched initialAccessedAddrs initialAccessedStorageKeys mempty + , isCreate = o.create + , txReversion = Map.fromList ((o.address,o.contract):o.otherContracts) + } + , logs = [] + , traces = Zipper.fromForest [] + , block = Block + { coinbase = o.coinbase + , timestamp = o.timestamp + , number = o.number + , prevRandao = o.prevRandao + , maxCodeSize = o.maxCodeSize + , gaslimit = o.blockGaslimit + , baseFee = o.baseFee + , schedule = o.schedule + } + , state = FrameState + { pc = 0 + , stack = mempty + , memory + , memorySize = 0 + , code = o.contract.code + , contract = o.address + , codeContract = o.address + , calldata = fst o.calldata + , callvalue = o.value + , caller = o.caller + , gas = o.gas + , returndata = mempty + , static = False + } + , env = Env + { chainId = o.chainId + , contracts = Map.fromList ((o.address,o.contract):o.otherContracts) + , freshAddresses = 0 + } + , cache = Cache mempty mempty + , burned = 0 + , constraints = snd o.calldata + , keccakEqs = mempty + , iterations = mempty + , config = RuntimeConfig + { allowFFI = o.allowFFI + , overrideCaller = Nothing + , baseState = o.baseState + } + } + +-- | Initialize an abstract contract with unknown code +unknownContract :: Expr EAddr -> Contract +unknownContract addr = Contract + { code = UnknownCode addr + , storage = AbstractStore addr + , origStorage = AbstractStore addr + , balance = Balance addr + , nonce = Nothing + , codehash = hashcode (UnknownCode addr) + , opIxMap = mempty + , codeOps = mempty + , external = False + } + +-- | Initialize an abstract contract with known code +abstractContract :: ContractCode -> Expr EAddr -> Contract +abstractContract code addr = Contract + { code = code + , storage = AbstractStore addr + , origStorage = AbstractStore addr + , balance = Balance addr + , nonce = if isCreation code then Just 1 else Just 0 + , codehash = hashcode code + , opIxMap = mkOpIxMap code + , codeOps = mkCodeOps code + , external = False + } + +-- | Initialize an empty contract without code +emptyContract :: Contract +emptyContract = initialContract (RuntimeCode (ConcreteRuntimeCode "")) + +-- | Initialize empty contract with given code +initialContract :: ContractCode -> Contract +initialContract code = Contract + { code = code + , storage = ConcreteStore mempty + , origStorage = ConcreteStore mempty + , balance = Lit 0 + , nonce = if isCreation code then Just 1 else Just 0 + , codehash = hashcode code + , opIxMap = mkOpIxMap code + , codeOps = mkCodeOps code + , external = False + } + +isCreation :: ContractCode -> Bool +isCreation = \case + InitCode _ _ -> True + RuntimeCode _ -> False + UnknownCode _ -> False + +-- * Opcode dispatch (exec1) + +-- | Update program counter +next :: (?op :: Word8) => EVM s () +next = modifying (#state % #pc) (+ (opSize ?op)) + +-- | Executes the EVM one step +exec1 :: EVM s () +exec1 = do + vm <- get + + let + -- Convenient aliases + stk = vm.state.stack + self = vm.state.contract + this = fromMaybe (internalError "state contract") (Map.lookup self vm.env.contracts) + + fees@FeeSchedule {..} = vm.block.schedule + + doStop = finishFrame (FrameReturned mempty) + + litSelf = maybeLitAddr self + + if isJust litSelf && (fromJust litSelf) > 0x0 && (fromJust litSelf) <= 0x9 then do + -- call to precompile + let ?op = 0x00 -- dummy value + case bufLength vm.state.calldata of + Lit calldatasize -> do + copyBytesToMemory vm.state.calldata (Lit calldatasize) (Lit 0) (Lit 0) + executePrecompile (fromJust litSelf) vm.state.gas 0 calldatasize 0 0 [] + vmx <- get + case vmx.state.stack of + x:_ -> case x of + Lit 0 -> + fetchAccount self $ \_ -> do + touchAccount self + vmError PrecompileFailure + Lit _ -> + fetchAccount self $ \_ -> do + touchAccount self + out <- use (#state % #returndata) + finishFrame (FrameReturned out) + e -> partial $ + UnexpectedSymbolicArg vmx.state.pc "precompile returned a symbolic value" (wrap [e]) + _ -> + underrun + e -> partial $ + UnexpectedSymbolicArg vm.state.pc "cannot call precompiles with symbolic data" (wrap [e]) + + else if vm.state.pc >= opslen vm.state.code + then doStop + + else do + let ?op = case vm.state.code of + UnknownCode _ -> internalError "Cannot execute unknown code" + InitCode conc _ -> BS.index conc vm.state.pc + RuntimeCode (ConcreteRuntimeCode bs) -> BS.index bs vm.state.pc + RuntimeCode (SymbolicRuntimeCode ops) -> + fromMaybe (internalError "could not analyze symbolic code") $ + maybeLitByte $ ops V.! vm.state.pc + + case getOp (?op) of + + OpPush0 -> do + limitStack 1 $ + burn g_base $ do + next + pushSym (Lit 0) + + OpPush n' -> do + let n = into n' + !xs = case vm.state.code of + UnknownCode _ -> internalError "Cannot execute unknown code" + InitCode conc _ -> Lit $ word $ padRight n $ BS.take n (BS.drop (1 + vm.state.pc) conc) + RuntimeCode (ConcreteRuntimeCode bs) -> Lit $ word $ BS.take n $ BS.drop (1 + vm.state.pc) bs + RuntimeCode (SymbolicRuntimeCode ops) -> + let bytes = V.take n $ V.drop (1 + vm.state.pc) ops + in readWord (Lit 0) $ Expr.fromList $ padLeft' 32 bytes + limitStack 1 $ + burn g_verylow $ do + next + pushSym xs + + OpDup i -> + case preview (ix (into i - 1)) stk of + Nothing -> underrun + Just y -> + limitStack 1 $ + burn g_verylow $ do + next + pushSym y + + OpSwap i -> + if length stk < (into i) + 1 + then underrun + else + burn g_verylow $ do + next + zoom (#state % #stack) $ do + assign (ix 0) (stk ^?! ix (into i)) + assign (ix (into i)) (stk ^?! ix 0) + + OpLog n -> + notStatic $ + case stk of + (xOffset':xSize':xs) -> + if length xs < (into n) + then underrun + else + forceConcrete2 (xOffset', xSize') "LOG" $ \(xOffset, xSize) -> do + bytes <- readMemory xOffset' xSize' + let (topics, xs') = splitAt (into n) xs + logs' = (LogEntry (WAddr self) bytes topics) : vm.logs + case (tryFrom xSize) of + (Right sz) -> + burn (g_log + g_logdata * sz + (into n) * g_logtopic) $ + accessMemoryRange xOffset xSize $ do + traceTopLog logs' + next + assign (#state % #stack) xs' + assign #logs logs' + _ -> vmError IllegalOverflow + _ -> + underrun + + OpStop -> doStop + + OpAdd -> stackOp2 g_verylow Expr.add + OpMul -> stackOp2 g_low Expr.mul + OpSub -> stackOp2 g_verylow Expr.sub + + OpDiv -> stackOp2 g_low Expr.div + + OpSdiv -> stackOp2 g_low Expr.sdiv + + OpMod -> stackOp2 g_low Expr.mod + + OpSmod -> stackOp2 g_low Expr.smod + OpAddmod -> stackOp3 g_mid Expr.addmod + OpMulmod -> stackOp3 g_mid Expr.mulmod + + OpLt -> stackOp2 g_verylow Expr.lt + OpGt -> stackOp2 g_verylow Expr.gt + OpSlt -> stackOp2 g_verylow Expr.slt + OpSgt -> stackOp2 g_verylow Expr.sgt + + OpEq -> stackOp2 g_verylow Expr.eq + OpIszero -> stackOp1 g_verylow Expr.iszero + + OpAnd -> stackOp2 g_verylow Expr.and + OpOr -> stackOp2 g_verylow Expr.or + OpXor -> stackOp2 g_verylow Expr.xor + OpNot -> stackOp1 g_verylow Expr.not + + OpByte -> stackOp2 g_verylow (\i w -> Expr.padByte $ Expr.indexWord i w) + + OpShl -> stackOp2 g_verylow Expr.shl + OpShr -> stackOp2 g_verylow Expr.shr + OpSar -> stackOp2 g_verylow Expr.sar + + -- more accurately refered to as KECCAK + OpSha3 -> + case stk of + xOffset':xSize':xs -> + forceConcrete xOffset' "sha3 offset must be concrete" $ + \xOffset -> forceConcrete xSize' "sha3 size must be concrete" $ \xSize -> + burn (g_sha3 + g_sha3word * ceilDiv (unsafeInto xSize) 32) $ + accessMemoryRange xOffset xSize $ do + hash <- readMemory xOffset' xSize' >>= \case + ConcreteBuf bs -> do + let hash' = keccak' bs + eqs <- use #keccakEqs + assign #keccakEqs $ + PEq (Lit hash') (Keccak (ConcreteBuf bs)):eqs + pure $ Lit hash' + buf -> pure $ Keccak buf + next + assign (#state % #stack) (hash : xs) + _ -> underrun + + OpAddress -> + limitStack 1 $ + burn g_base (next >> pushAddr self) + + OpBalance -> + case stk of + x:xs -> forceAddr x "BALANCE" $ \a -> + accessAndBurn a $ + fetchAccount a $ \c -> do + next + assign (#state % #stack) xs + pushSym c.balance + [] -> + underrun + + OpOrigin -> + limitStack 1 . burn g_base $ + next >> pushAddr vm.tx.origin + + OpCaller -> + limitStack 1 . burn g_base $ + next >> pushAddr vm.state.caller + + OpCallvalue -> + limitStack 1 . burn g_base $ + next >> pushSym vm.state.callvalue + + OpCalldataload -> stackOp1 g_verylow $ + \ind -> Expr.readWord ind vm.state.calldata + + OpCalldatasize -> + limitStack 1 . burn g_base $ + next >> pushSym (bufLength vm.state.calldata) + + OpCalldatacopy -> + case stk of + xTo':xFrom:xSize':xs -> + forceConcrete2 (xTo', xSize') "CALLDATACOPY" $ + \(xTo, xSize) -> + burn (g_verylow + g_copy * ceilDiv (unsafeInto xSize) 32) $ + accessMemoryRange xTo xSize $ do + next + assign (#state % #stack) xs + copyBytesToMemory vm.state.calldata xSize' xFrom xTo' + _ -> underrun + + OpCodesize -> + limitStack 1 . burn g_base $ + next >> pushSym (codelen vm.state.code) + + OpCodecopy -> + case stk of + memOffset':codeOffset:n':xs -> + forceConcrete2 (memOffset', n') "CODECOPY" $ + \(memOffset,n) -> do + case toWord64 n of + Nothing -> vmError IllegalOverflow + Just n'' -> + if n'' <= ( (maxBound :: Word64) - g_verylow ) `div` g_copy * 32 then + burn (g_verylow + g_copy * ceilDiv (unsafeInto n) 32) $ + accessMemoryRange memOffset n $ do + next + assign (#state % #stack) xs + case toBuf vm.state.code of + Just b -> copyBytesToMemory b n' codeOffset memOffset' + Nothing -> internalError "Cannot produce a buffer from UnknownCode" + else vmError IllegalOverflow + _ -> underrun + + OpGasprice -> + limitStack 1 . burn g_base $ + next >> push vm.tx.gasprice + + OpExtcodesize -> + case stk of + x':xs -> forceAddr x' "EXTCODESIZE" $ \x -> do + let impl = accessAndBurn x $ + fetchAccount x $ \c -> do + next + assign (#state % #stack) xs + case view bytecode c of + Just b -> pushSym (bufLength b) + Nothing -> pushSym $ CodeSize x + case x of + a@(LitAddr _) -> if a == cheatCode + then do + next + assign (#state % #stack) xs + pushSym (Lit 1) + else impl + _ -> impl + [] -> + underrun + + OpExtcodecopy -> + case stk of + extAccount':memOffset':codeOffset:codeSize':xs -> + forceConcrete2 (memOffset', codeSize') "EXTCODECOPY" $ \(memOffset, codeSize) -> do + forceAddr extAccount' "EXTCODECOPY" $ \extAccount -> do + acc <- accessAccountForGas extAccount + let cost = if acc then g_warm_storage_read else g_cold_account_access + burn (cost + g_copy * ceilDiv (unsafeInto codeSize) 32) $ + accessMemoryRange memOffset codeSize $ + fetchAccount extAccount $ \c -> do + next + assign (#state % #stack) xs + case view bytecode c of + Just b -> copyBytesToMemory b codeSize' codeOffset memOffset' + Nothing -> do + pc <- use (#state % #pc) + partial $ UnexpectedSymbolicArg pc "Cannot copy from unknown code at" (wrap [extAccount]) + _ -> underrun + + OpReturndatasize -> + limitStack 1 . burn g_base $ + next >> pushSym (bufLength vm.state.returndata) + + OpReturndatacopy -> + case stk of + xTo':xFrom:xSize':xs -> forceConcrete2 (xTo', xSize') "RETURNDATACOPY" $ + \(xTo, xSize) -> + burn (g_verylow + g_copy * ceilDiv (unsafeInto xSize) 32) $ + accessMemoryRange xTo xSize $ do + next + assign (#state % #stack) xs + + let jump True = vmError ReturnDataOutOfBounds + jump False = copyBytesToMemory vm.state.returndata xSize' xFrom xTo' + + case (xFrom, bufLength vm.state.returndata) of + (Lit f, Lit l) -> + jump $ l < f + xSize || f + xSize < f + _ -> do + let oob = Expr.lt (bufLength vm.state.returndata) (Expr.add xFrom xSize') + overflow = Expr.lt (Expr.add xFrom xSize') (xFrom) + branch (Expr.or oob overflow) jump + _ -> underrun + + OpExtcodehash -> + case stk of + x':xs -> forceAddr x' "EXTCODEHASH" $ \x -> + accessAndBurn x $ do + next + assign (#state % #stack) xs + fetchAccount x $ \c -> + if accountEmpty c + then push (W256 0) + else case view bytecode c of + Just b -> pushSym $ keccak b + Nothing -> pushSym $ CodeHash x + [] -> + underrun + + OpBlockhash -> do + -- We adopt the fake block hash scheme of the VMTests, + -- so that blockhash(i) is the hash of i as decimal ASCII. + stackOp1 g_blockhash $ \case + Lit i -> if i + 256 < vm.block.number || i >= vm.block.number + then Lit 0 + else (into i :: Integer) & show & Char8.pack & keccak' & Lit + i -> BlockHash i + + OpCoinbase -> + limitStack 1 . burn g_base $ + next >> pushAddr vm.block.coinbase + + OpTimestamp -> + limitStack 1 . burn g_base $ + next >> pushSym vm.block.timestamp + + OpNumber -> + limitStack 1 . burn g_base $ + next >> push vm.block.number + + OpPrevRandao -> do + limitStack 1 . burn g_base $ + next >> push vm.block.prevRandao + + OpGaslimit -> + limitStack 1 . burn g_base $ + next >> push (into vm.block.gaslimit) + + OpChainid -> + limitStack 1 . burn g_base $ + next >> push vm.env.chainId + + OpSelfbalance -> + limitStack 1 . burn g_low $ + next >> pushSym this.balance + + OpBaseFee -> + limitStack 1 . burn g_base $ + next >> push vm.block.baseFee + + OpPop -> + case stk of + _:xs -> burn g_base (next >> assign (#state % #stack) xs) + _ -> underrun + + OpMload -> + case stk of + x':xs -> forceConcrete x' "MLOAD" $ \x -> + burn g_verylow $ + accessMemoryWord x $ do + next + buf <- readMemory (Lit x) (Lit 32) + let w = Expr.readWordFromBytes (Lit 0) buf + assign (#state % #stack) (w : xs) + _ -> underrun + + OpMstore -> + case stk of + x':y:xs -> forceConcrete x' "MSTORE index" $ \x -> + burn g_verylow $ + accessMemoryWord x $ do + next + gets (.state.memory) >>= \case + ConcreteMemory mem -> do + case y of + Lit w -> + writeMemory mem (unsafeInto x) (word256Bytes w) + _ -> do + -- copy out and move to symbolic memory + buf <- freezeMemory mem + assign (#state % #memory) (SymbolicMemory $ writeWord (Lit x) y buf) + SymbolicMemory mem -> + assign (#state % #memory) (SymbolicMemory $ writeWord (Lit x) y mem) + assign (#state % #stack) xs + _ -> underrun + + OpMstore8 -> + case stk of + x':y:xs -> forceConcrete x' "MSTORE8" $ \x -> + burn g_verylow $ + accessMemoryRange x 1 $ do + let yByte = indexWord (Lit 31) y + next + gets (.state.memory) >>= \case + ConcreteMemory mem -> do + case yByte of + LitByte byte -> + writeMemory mem (unsafeInto x) (BS.pack [byte]) + _ -> do + -- copy out and move to symbolic memory + buf <- freezeMemory mem + assign (#state % #memory) (SymbolicMemory $ writeByte (Lit x) yByte buf) + SymbolicMemory mem -> + assign (#state % #memory) (SymbolicMemory $ writeByte (Lit x) yByte mem) + + assign (#state % #stack) xs + _ -> underrun + + OpSload -> + case stk of + x:xs -> do + acc <- accessStorageForGas self x + let cost = if acc then g_warm_storage_read else g_cold_sload + burn cost $ + accessStorage self x $ \y -> do + next + assign (#state % #stack) (y:xs) + _ -> underrun + + OpSstore -> + notStatic $ + case stk of + x:new:xs -> + accessStorage self x $ \current -> do + availableGas <- use (#state % #gas) + + if availableGas <= g_callstipend then + finishFrame (FrameErrored (OutOfGas availableGas g_callstipend)) + else do + let + original = + case Expr.simplify $ SLoad x this.origStorage of + Lit v -> v + _ -> 0 + storage_cost = + case (maybeLitWord current, maybeLitWord new) of + (Just current', Just new') -> + if (current' == new') then g_sload + else if (current' == original) && (original == 0) then g_sset + else if (current' == original) then g_sreset + else g_sload + + -- if any of the arguments are symbolic, + -- assume worst case scenario + _-> g_sset + + acc <- accessStorageForGas self x + let cold_storage_cost = if acc then 0 else g_cold_sload + burn (storage_cost + cold_storage_cost) $ do + next + assign (#state % #stack) xs + modifying (#env % #contracts % ix self % #storage) (writeStorage x new) + + case (maybeLitWord current, maybeLitWord new) of + (Just current', Just new') -> + unless (current' == new') $ + if current' == original then + when (original /= 0 && new' == 0) $ + refund (g_sreset + g_access_list_storage_key) + else do + when (original /= 0) $ + if current' == 0 + then unRefund (g_sreset + g_access_list_storage_key) + else when (new' == 0) $ refund (g_sreset + g_access_list_storage_key) + when (original == new') $ + if original == 0 + then refund (g_sset - g_sload) + else refund (g_sreset - g_sload) + -- if any of the arguments are symbolic, + -- don't change the refund counter + _ -> noop + _ -> underrun + + OpJump -> + case stk of + x:xs -> + burn g_mid $ forceConcrete x "JUMP: symbolic jumpdest" $ \x' -> + case toInt x' of + Nothing -> vmError BadJumpDestination + Just i -> checkJump i xs + _ -> underrun + + OpJumpi -> do + case stk of + (x:y:xs) -> forceConcrete x "JUMPI: symbolic jumpdest" $ \x' -> + burn g_high $ + let jump :: Bool -> EVM s () + jump False = assign (#state % #stack) xs >> next + jump _ = case toInt x' of + Nothing -> vmError BadJumpDestination + Just i -> checkJump i xs + in branch y jump + _ -> underrun + + OpPc -> + limitStack 1 . burn g_base $ + next >> push (unsafeInto vm.state.pc) + + OpMsize -> + limitStack 1 . burn g_base $ + next >> push (into vm.state.memorySize) + + OpGas -> + limitStack 1 . burn g_base $ + next >> push (into (vm.state.gas - g_base)) + + OpJumpdest -> burn g_jumpdest next + + OpExp -> + -- NOTE: this can be done symbolically using unrolling like this: + -- https://hackage.haskell.org/package/sbv-9.0/docs/src/Data.SBV.Core.Model.html#.%5E + -- However, it requires symbolic gas, since the gas depends on the exponent + case stk of + base:exponent':xs -> forceConcrete exponent' "EXP: symbolic exponent" $ \exponent -> + let cost = if exponent == 0 + then g_exp + else g_exp + g_expbyte * unsafeInto (ceilDiv (1 + log2 exponent) 8) + in burn cost $ do + next + (#state % #stack) .= Expr.exp base exponent' : xs + _ -> underrun + + OpSignextend -> stackOp2 g_low Expr.sex + + OpCreate -> + notStatic $ + case stk of + xValue:xOffset':xSize':xs -> forceConcrete2 (xOffset', xSize') "CREATE" $ + \(xOffset, xSize) -> do + accessMemoryRange xOffset xSize $ do + availableGas <- use (#state % #gas) + let + (cost, gas') = costOfCreate fees availableGas xSize False + newAddr <- createAddress self this.nonce + _ <- accessAccountForGas newAddr + burn cost $ do + initCode <- readMemory xOffset' xSize' + create self this xSize gas' xValue xs newAddr initCode + _ -> underrun + + OpCall -> + case stk of + xGas':xTo':xValue:xInOffset':xInSize':xOutOffset':xOutSize':xs -> + forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') "CALL" $ + \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> + branch (Expr.gt xValue (Lit 0)) $ \gt0 -> do + (if gt0 then notStatic else id) $ + forceAddr xTo' "unable to determine a call target" $ \xTo -> + case tryFrom xGas of + Left _ -> vmError IllegalOverflow + Right gas -> + delegateCall this gas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ + \callee -> do + let from' = fromMaybe self vm.config.overrideCaller + zoom #state $ do + assign #callvalue xValue + assign #caller from' + assign #contract callee + assign (#config % #overrideCaller) Nothing + touchAccount from' + touchAccount callee + transfer from' callee xValue + _ -> + underrun + + OpCallcode -> + case stk of + xGas':xTo':xValue:xInOffset':xInSize':xOutOffset':xOutSize':xs -> + forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') "CALLCODE" $ + \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> + forceAddr xTo' "unable to determine a call target" $ \xTo -> + case tryFrom xGas of + Left _ -> vmError IllegalOverflow + Right gas -> + delegateCall this gas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do + zoom #state $ do + assign #callvalue xValue + assign #caller $ fromMaybe self vm.config.overrideCaller + assign (#config % #overrideCaller) Nothing + touchAccount self + _ -> + underrun + + OpReturn -> + case stk of + xOffset':xSize':_ -> forceConcrete2 (xOffset', xSize') "RETURN" $ \(xOffset, xSize) -> + accessMemoryRange xOffset xSize $ do + output <- readMemory xOffset' xSize' + let + codesize = fromMaybe (internalError "processing opcode RETURN. Cannot return dynamically sized abstract data") + . maybeLitWord . bufLength $ output + maxsize = vm.block.maxCodeSize + creation = case vm.frames of + [] -> vm.tx.isCreate + frame:_ -> case frame.context of + CreationContext {} -> True + CallContext {} -> False + if creation + then + if codesize > maxsize + then + finishFrame (FrameErrored (MaxCodeSizeExceeded maxsize codesize)) + else do + let frameReturned = burn (g_codedeposit * unsafeInto codesize) $ + finishFrame (FrameReturned output) + frameErrored = finishFrame $ FrameErrored InvalidFormat + case readByte (Lit 0) output of + LitByte 0xef -> frameErrored + LitByte _ -> frameReturned + y -> branch (Expr.eqByte y (LitByte 0xef)) $ \case + True -> frameErrored + False -> frameReturned + else + finishFrame (FrameReturned output) + _ -> underrun + + OpDelegatecall -> + case stk of + xGas':xTo:xInOffset':xInSize':xOutOffset':xOutSize':xs -> + forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') "DELEGATECALL" $ + \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> + case wordToAddr xTo of + Nothing -> do + loc <- codeloc + let msg = "Unable to determine a call target" + partial $ UnexpectedSymbolicArg (snd loc) msg [SomeExpr xTo] + Just xTo' -> + case tryFrom xGas of + Left _ -> vmError IllegalOverflow + Right gas -> + delegateCall this gas xTo' self (Lit 0) xInOffset xInSize xOutOffset xOutSize xs $ + \_ -> touchAccount self + _ -> underrun + + OpCreate2 -> notStatic $ + case stk of + xValue:xOffset':xSize':xSalt':xs -> + forceConcrete3 (xOffset', xSize', xSalt') "CREATE2" $ + \(xOffset, xSize, xSalt) -> + accessMemoryRange xOffset xSize $ do + availableGas <- use (#state % #gas) + buf <- readMemory xOffset' xSize' + forceConcreteBuf buf "CREATE2" $ + \initCode -> do + let + (cost, gas') = costOfCreate fees availableGas xSize True + newAddr <- create2Address self xSalt initCode + _ <- accessAccountForGas newAddr + burn cost $ + create self this xSize gas' xValue xs newAddr (ConcreteBuf initCode) + _ -> underrun + + OpStaticcall -> + case stk of + xGas':xTo:xInOffset':xInSize':xOutOffset':xOutSize':xs -> + forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') "STATICCALL" $ + \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> do + case wordToAddr xTo of + Nothing -> do + loc <- codeloc + let msg = "Unable to determine a call target" + partial $ UnexpectedSymbolicArg (snd loc) msg [SomeExpr xTo] + Just xTo' -> + case tryFrom xGas of + Left _ -> vmError IllegalOverflow + Right gas -> + delegateCall this gas xTo' xTo' (Lit 0) xInOffset xInSize xOutOffset xOutSize xs $ + \callee -> do + zoom #state $ do + assign #callvalue (Lit 0) + assign #caller $ fromMaybe self (vm.config.overrideCaller) + assign #contract callee + assign #static True + assign (#config % #overrideCaller) Nothing + touchAccount self + touchAccount callee + _ -> + underrun + + OpSelfdestruct -> + notStatic $ + case stk of + [] -> underrun + (xTo':_) -> forceAddr xTo' "SELFDESTRUCT" $ \case + xTo@(LitAddr _) -> do + acc <- accessAccountForGas xTo + let cost = if acc then 0 else g_cold_account_access + funds = this.balance + recipientExists = accountExists xTo vm + branch (Expr.iszero $ Expr.eq funds (Lit 0)) $ \hasFunds -> do + let c_new = if (not recipientExists) && hasFunds + then g_selfdestruct_newaccount + else 0 + burn (g_selfdestruct + c_new + cost) $ do + selfdestruct self + touchAccount xTo + + if hasFunds + then fetchAccount xTo $ \_ -> do + #env % #contracts % ix xTo % #balance %= (Expr.add funds) + assign (#env % #contracts % ix self % #balance) (Lit 0) + doStop + else do + doStop + a -> do + pc <- use (#state % #pc) + partial $ UnexpectedSymbolicArg pc "trying to self destruct to a symbolic address" (wrap [a]) + + OpRevert -> + case stk of + xOffset':xSize':_ -> forceConcrete2 (xOffset', xSize') "REVERT" $ \(xOffset, xSize) -> + accessMemoryRange xOffset xSize $ do + output <- readMemory xOffset' xSize' + finishFrame (FrameReverted output) + _ -> underrun + + OpUnknown xxx -> + vmError $ UnrecognizedOpcode xxx + +transfer :: Expr EAddr -> Expr EAddr -> Expr EWord -> EVM s () +transfer _ _ (Lit 0) = pure () +transfer src dst val = do + sb <- preuse $ #env % #contracts % ix src % #balance + db <- preuse $ #env % #contracts % ix dst % #balance + baseState <- use (#config % #baseState) + let mkc = case baseState of + AbstractBase -> unknownContract + EmptyBase -> const emptyContract + case (sb, db) of + -- both sender and recipient in state + (Just srcBal, Just _) -> + branch (Expr.gt val srcBal) $ \case + True -> vmError $ BalanceTooLow val srcBal + False -> do + (#env % #contracts % ix src % #balance) %= (`Expr.sub` val) + (#env % #contracts % ix dst % #balance) %= (`Expr.add` val) + -- sender not in state + (Nothing, Just _) -> do + case src of + LitAddr _ -> do + (#env % #contracts) %= (Map.insert src (mkc src)) + transfer src dst val + SymAddr _ -> do + pc <- use (#state % #pc) + partial $ UnexpectedSymbolicArg pc "Attempting to transfer eth from a symbolic address that is not present in the state" (wrap [src]) + GVar _ -> internalError "Unexpected GVar" + -- recipient not in state + (_ , Nothing) -> do + case dst of + LitAddr _ -> do + (#env % #contracts) %= (Map.insert dst (mkc dst)) + transfer src dst val + SymAddr _ -> do + pc <- use (#state % #pc) + partial $ UnexpectedSymbolicArg pc "Attempting to transfer eth to a symbolic address that is not present in the state" (wrap [dst]) + GVar _ -> internalError "Unexpected GVar" + +-- | Checks a *CALL for failure; OOG, too many callframes, memory access etc. +callChecks + :: (?op :: Word8) + => Contract -> Word64 -> Expr EAddr -> Expr EAddr -> Expr EWord -> W256 -> W256 -> W256 -> W256 -> [Expr EWord] + -- continuation with gas available for call + -> (Word64 -> EVM s ()) + -> EVM s () +callChecks this xGas xContext xTo xValue xInOffset xInSize xOutOffset xOutSize xs continue = do + vm <- get + let fees = vm.block.schedule + accessMemoryRange xInOffset xInSize $ + accessMemoryRange xOutOffset xOutSize $ do + availableGas <- use (#state % #gas) + let recipientExists = accountExists xContext vm + (cost, gas') <- costOfCall fees recipientExists xValue availableGas xGas xTo + burn (cost - gas') $ + branch (Expr.gt xValue this.balance) $ \case + True -> do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + pushTrace $ ErrorTrace (BalanceTooLow xValue this.balance) + next + False -> + if length vm.frames >= 1024 + then do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + pushTrace $ ErrorTrace CallDepthLimitReached + next + else continue gas' + +precompiledContract + :: (?op :: Word8) + => Contract + -> Word64 + -> Addr + -> Addr + -> Expr EWord + -> W256 -> W256 -> W256 -> W256 + -> [Expr EWord] + -> EVM s () +precompiledContract this xGas precompileAddr recipient xValue inOffset inSize outOffset outSize xs + = callChecks this xGas (LitAddr recipient) (LitAddr precompileAddr) xValue inOffset inSize outOffset outSize xs $ \gas' -> + do + executePrecompile precompileAddr gas' inOffset inSize outOffset outSize xs + self <- use (#state % #contract) + stk <- use (#state % #stack) + pc' <- use (#state % #pc) + result' <- use #result + case result' of + Nothing -> case stk of + x:_ -> case maybeLitWord x of + Just 0 -> + pure () + Just 1 -> + fetchAccount (LitAddr recipient) $ \_ -> do + touchAccount self + touchAccount (LitAddr recipient) + transfer self (LitAddr recipient) xValue + _ -> partial $ + UnexpectedSymbolicArg pc' "unexpected return value from precompile" (wrap [x]) + _ -> underrun + _ -> pure () + +executePrecompile + :: (?op :: Word8) + => Addr + -> Word64 -> W256 -> W256 -> W256 -> W256 -> [Expr EWord] + -> EVM s () +executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = do + vm <- get + input <- readMemory (Lit inOffset) (Lit inSize) + let fees = vm.block.schedule + cost = costOfPrecompile fees preCompileAddr input + notImplemented = internalError $ "precompile at address " <> show preCompileAddr <> " not yet implemented" + precompileFail = burn (gasCap - cost) $ do + assign (#state % #stack) (Lit 0 : xs) + pushTrace $ ErrorTrace PrecompileFailure + next + if cost > gasCap then + burn gasCap $ do + assign (#state % #stack) (Lit 0 : xs) + next + else burn cost $ + case preCompileAddr of + -- ECRECOVER + 0x1 -> + -- TODO: support symbolic variant + forceConcreteBuf input "ECRECOVER" $ \input' -> do + case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of + Nothing -> do + -- return no output for invalid signature + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) mempty + next + Just output -> do + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) (ConcreteBuf output) + copyBytesToMemory (ConcreteBuf output) (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- SHA2-256 + 0x2 -> + forceConcreteBuf input "SHA2-256" $ \input' -> do + let + hash = sha256Buf input' + sha256Buf x = ConcreteBuf $ BA.convert (Crypto.hash x :: Digest SHA256) + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) hash + copyBytesToMemory hash (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- RIPEMD-160 + 0x3 -> + -- TODO: support symbolic variant + forceConcreteBuf input "RIPEMD160" $ \input' -> do + let + padding = BS.pack $ replicate 12 0 + hash' = BA.convert (Crypto.hash input' :: Digest RIPEMD160) + hash = ConcreteBuf $ padding <> hash' + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) hash + copyBytesToMemory hash (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- IDENTITY + 0x4 -> do + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) input + copyCallBytesToMemory input (Lit outSize) (Lit outOffset) + next + + -- MODEXP + 0x5 -> + -- TODO: support symbolic variant + forceConcreteBuf input "MODEXP" $ \input' -> do + let + (lenb, lene, lenm) = parseModexpLength input' + + output = ConcreteBuf $ + if isZero (96 + lenb + lene) lenm input' + then truncpadlit (unsafeInto lenm) (asBE (0 :: Int)) + else + let + b = asInteger $ lazySlice 96 lenb input' + e = asInteger $ lazySlice (96 + lenb) lene input' + m = asInteger $ lazySlice (96 + lenb + lene) lenm input' + in + padLeft (unsafeInto lenm) (asBE (expFast b e m)) + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) output + copyBytesToMemory output (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- ECADD + 0x6 -> + -- TODO: support symbolic variant + forceConcreteBuf input "ECADD" $ \input' -> + case EVM.Precompiled.execute 0x6 (truncpadlit 128 input') 64 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- ECMUL + 0x7 -> + -- TODO: support symbolic variant + forceConcreteBuf input "ECMUL" $ \input' -> + case EVM.Precompiled.execute 0x7 (truncpadlit 96 input') 64 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- ECPAIRING + 0x8 -> + -- TODO: support symbolic variant + forceConcreteBuf input "ECPAIR" $ \input' -> + case EVM.Precompiled.execute 0x8 input' 32 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuf $ truncpadlit 32 output + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- BLAKE2 + 0x9 -> + -- TODO: support symbolic variant + forceConcreteBuf input "BLAKE2" $ \input' -> do + case (BS.length input', 1 >= BS.last input') of + (213, True) -> case EVM.Precompiled.execute 0x9 input' 64 of + Just output -> do + let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output + assign (#state % #stack) (Lit 1 : xs) + assign (#state % #returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) + next + Nothing -> precompileFail + _ -> precompileFail + + _ -> notImplemented + +truncpadlit :: Int -> ByteString -> ByteString +truncpadlit n xs = if m > n then BS.take n xs + else BS.append xs (BS.replicate (n - m) 0) + where m = BS.length xs + +lazySlice :: W256 -> W256 -> ByteString -> LS.ByteString +lazySlice offset size bs = + let bs' = LS.take (unsafeInto size) (LS.drop (unsafeInto offset) (fromStrict bs)) + in bs' <> LS.replicate (unsafeInto size - LS.length bs') 0 + +parseModexpLength :: ByteString -> (W256, W256, W256) +parseModexpLength input = + let lenb = word $ LS.toStrict $ lazySlice 0 32 input + lene = word $ LS.toStrict $ lazySlice 32 64 input + lenm = word $ LS.toStrict $ lazySlice 64 96 input + in (lenb, lene, lenm) + +--- checks if a range of ByteString bs starting at offset and length size is all zeros. +isZero :: W256 -> W256 -> ByteString -> Bool +isZero offset size bs = + LS.all (== 0) $ + LS.take (unsafeInto size) $ + LS.drop (unsafeInto offset) $ + fromStrict bs + +asInteger :: LS.ByteString -> Integer +asInteger xs = if xs == mempty then 0 + else 256 * asInteger (LS.init xs) + + into (LS.last xs) + +-- * Opcode helper actions + +noop :: Monad m => m () +noop = pure () + +pushTo :: MonadState s m => Lens s s [a] [a] -> a -> m () +pushTo f x = f %= (x :) + +pushToSequence :: MonadState s m => Setter s s (Seq a) (Seq a) -> a -> m () +pushToSequence f x = f %= (Seq.|> x) + +getCodeLocation :: VM s -> CodeLocation +getCodeLocation vm = (vm.state.contract, vm.state.pc) + +query :: Query s -> EVM s () +query = assign #result . Just . HandleEffect . Query + +choose :: Choose s -> EVM s () +choose = assign #result . Just . HandleEffect . Choose + +branch :: forall s. Expr EWord -> (Bool -> EVM s ()) -> EVM s () +branch cond continue = do + loc <- codeloc + pathconds <- use #constraints + query $ PleaseAskSMT cond pathconds (choosePath loc) + where + condSimp = Expr.simplify cond + choosePath :: CodeLocation -> BranchCondition -> EVM s () + choosePath loc (Case v) = do + assign #result Nothing + pushTo #constraints $ if v then Expr.simplifyProp (condSimp ./= Lit 0) else Expr.simplifyProp (condSimp .== Lit 0) + (iteration, _) <- use (#iterations % at loc % non (0,[])) + stack <- use (#state % #stack) + assign (#cache % #path % at (loc, iteration)) (Just v) + assign (#iterations % at loc) (Just (iteration + 1, stack)) + continue v + -- Both paths are possible; we ask for more input + choosePath loc Unknown = + choose . PleaseChoosePath condSimp $ choosePath loc . Case + +-- | Construct RPC Query and halt execution until resolved +fetchAccount :: Expr EAddr -> (Contract -> EVM s ()) -> EVM s () +fetchAccount addr continue = + use (#env % #contracts % at addr) >>= \case + Just c -> continue c + Nothing -> case addr of + SymAddr _ -> do + pc <- use (#state % #pc) + partial $ UnexpectedSymbolicArg pc "trying to access a symbolic address that isn't already present in storage" (wrap [addr]) + LitAddr a -> do + use (#cache % #fetched % at a) >>= \case + Just c -> do + assign (#env % #contracts % at addr) (Just c) + continue c + Nothing -> do + base <- use (#config % #baseState) + assign (#result) . Just . HandleEffect . Query $ + PleaseFetchContract a base + (\c -> do assign (#cache % #fetched % at a) (Just c) + assign (#env % #contracts % at addr) (Just c) + assign #result Nothing + continue c) + GVar _ -> internalError "Unexpected GVar" + +accessStorage + :: Expr EAddr + -> Expr EWord + -> (Expr EWord -> EVM s ()) + -> EVM s () +accessStorage addr slot continue = do + use (#env % #contracts % at addr) >>= \case + Just c -> + case readStorage slot c.storage of + Just x -> + continue x + Nothing -> + if c.external then + forceConcreteAddr addr "cannot read storage from symbolic addresses via rpc" $ \addr' -> + forceConcrete slot "cannot read symbolic slots via RPC" $ \slot' -> do + -- check if the slot is cached + contract <- preuse (#cache % #fetched % ix addr') + case contract of + Nothing -> internalError "contract marked external not found in cache" + Just fetched -> case readStorage (Lit slot') fetched.storage of + Nothing -> mkQuery addr' slot' + Just val -> continue val + else do + modifying (#env % #contracts % ix addr % #storage) (writeStorage slot (Lit 0)) + continue $ Lit 0 + Nothing -> + fetchAccount addr $ \_ -> + accessStorage addr slot continue + where + mkQuery a s = query $ + PleaseFetchSlot a s + (\x -> do + modifying (#cache % #fetched % ix a % #storage) (writeStorage (Lit s) (Lit x)) + modifying (#env % #contracts % ix (LitAddr a) % #storage) (writeStorage (Lit s) (Lit x)) + assign #result Nothing + continue (Lit x)) + +accountExists :: Expr EAddr -> VM s -> Bool +accountExists addr vm = + case Map.lookup addr vm.env.contracts of + Just c -> not (accountEmpty c) + Nothing -> False + +-- EIP 161 +accountEmpty :: Contract -> Bool +accountEmpty c = + case c.code of + RuntimeCode (ConcreteRuntimeCode "") -> True + RuntimeCode (SymbolicRuntimeCode b) -> null b + _ -> False + && c.nonce == (Just 0) + -- TODO: handle symbolic balance... + && c.balance == Lit 0 + +-- * How to finalize a transaction +finalize :: EVM s () +finalize = do + let + revertContracts = use (#tx % #txReversion) >>= assign (#env % #contracts) + revertSubstate = assign (#tx % #substate) (SubState mempty mempty mempty mempty mempty) + + use #result >>= \case + Just (VMFailure (Revert _)) -> do + revertContracts + revertSubstate + Just (VMFailure _) -> do + -- burn remaining gas + assign (#state % #gas) 0 + revertContracts + revertSubstate + Just (VMSuccess output) -> do + -- deposit the code from a creation tx + pc' <- use (#state % #pc) + creation <- use (#tx % #isCreate) + createe <- use (#state % #contract) + createeExists <- (Map.member createe) <$> use (#env % #contracts) + let onContractCode contractCode = + when (creation && createeExists) $ replaceCode createe contractCode + case output of + ConcreteBuf bs -> + onContractCode $ RuntimeCode (ConcreteRuntimeCode bs) + _ -> + case Expr.toList output of + Nothing -> + partial $ + UnexpectedSymbolicArg pc' "runtime code cannot have an abstract lentgh" (wrap [output]) + Just ops -> + onContractCode $ RuntimeCode (SymbolicRuntimeCode ops) + _ -> + internalError "Finalising an unfinished tx." + + -- compute and pay the refund to the caller and the + -- corresponding payment to the miner + block <- use #block + tx <- use #tx + gasRemaining <- use (#state % #gas) + + let + sumRefunds = sum (snd <$> tx.substate.refunds) + gasUsed = tx.gaslimit - gasRemaining + cappedRefund = min (quot gasUsed 5) sumRefunds + originPay = (into $ gasRemaining + cappedRefund) * tx.gasprice + minerPay = tx.priorityFee * (into gasUsed) + + modifying (#env % #contracts) + (Map.adjust (over #balance (Expr.add (Lit originPay))) tx.origin) + modifying (#env % #contracts) + (Map.adjust (over #balance (Expr.add (Lit minerPay))) block.coinbase) + touchAccount block.coinbase + + -- perform state trie clearing (EIP 161), of selfdestructs + -- and touched accounts. addresses are cleared if they have + -- a) selfdestructed, or + -- b) been touched and + -- c) are empty. + -- (see Yellow Paper "Accrued Substate") + -- + -- remove any destructed addresses + destroyedAddresses <- use (#tx % #substate % #selfdestructs) + modifying (#env % #contracts) + (Map.filterWithKey (\k _ -> (k `notElem` destroyedAddresses))) + -- then, clear any remaining empty and touched addresses + touchedAddresses <- use (#tx % #substate % #touchedAccounts) + modifying (#env % #contracts) + (Map.filterWithKey + (\k a -> not ((k `elem` touchedAddresses) && accountEmpty a))) + +-- | Loads the selected contract as the current contract to execute +loadContract :: Expr EAddr -> State (VM s) () +loadContract target = + preuse (#env % #contracts % ix target % #code) >>= + \case + Nothing -> + internalError "Call target doesn't exist" + Just targetCode -> do + assign (#state % #contract) target + assign (#state % #code) targetCode + assign (#state % #codeContract) target + +limitStack :: Int -> EVM s () -> EVM s () +limitStack n continue = do + stk <- use (#state % #stack) + if length stk + n > 1024 + then vmError StackLimitExceeded + else continue + +notStatic :: EVM s () -> EVM s () +notStatic continue = do + bad <- use (#state % #static) + if bad + then vmError StateChangeWhileStatic + else continue + +-- | Burn gas, failing if insufficient gas is available +burn :: Word64 -> EVM s () -> EVM s () +burn n continue = do + available <- use (#state % #gas) + if n <= available + then do + #state % #gas %= (subtract n) + #burned %= (+ n) + continue + else + vmError (OutOfGas available n) + +forceAddr :: Expr EWord -> String -> (Expr EAddr -> EVM s ()) -> EVM s () +forceAddr n msg continue = case wordToAddr n of + Nothing -> do + vm <- get + partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [n]) + Just c -> continue c + +forceConcrete :: Expr EWord -> String -> (W256 -> EVM s ()) -> EVM s () +forceConcrete n msg continue = case maybeLitWord n of + Nothing -> do + vm <- get + partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [n]) + Just c -> continue c + +forceConcreteAddr :: Expr EAddr -> String -> (Addr -> EVM s ()) -> EVM s () +forceConcreteAddr n msg continue = case maybeLitAddr n of + Nothing -> do + vm <- get + partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [n]) + Just c -> continue c + +forceConcreteAddr2 :: (Expr EAddr, Expr EAddr) -> String -> ((Addr, Addr) -> EVM s ()) -> EVM s () +forceConcreteAddr2 (n,m) msg continue = case (maybeLitAddr n, maybeLitAddr m) of + (Just c, Just d) -> continue (c,d) + _ -> do + vm <- get + partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [n, m]) + +forceConcrete2 :: (Expr EWord, Expr EWord) -> String -> ((W256, W256) -> EVM s ()) -> EVM s () +forceConcrete2 (n,m) msg continue = case (maybeLitWord n, maybeLitWord m) of + (Just c, Just d) -> continue (c, d) + _ -> do + vm <- get + partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [n, m]) + +forceConcrete3 :: (Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256) -> EVM s ()) -> EVM s () +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 + partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [k, n, m]) + +forceConcrete4 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256) -> EVM s ()) -> EVM s () +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 + partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [k, l, n, m]) + +forceConcrete5 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256, W256) -> EVM s ()) -> EVM s () +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 + partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [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 s ()) -> EVM s () +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 + partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [k, l, m, n, o, p]) + +forceConcreteBuf :: Expr Buf -> String -> (ByteString -> EVM s ()) -> EVM s () +forceConcreteBuf (ConcreteBuf b) _ continue = continue b +forceConcreteBuf b msg _ = do + vm <- get + partial $ UnexpectedSymbolicArg vm.state.pc msg (wrap [b]) + +-- * Substate manipulation +refund :: Word64 -> EVM s () +refund n = do + self <- use (#state % #contract) + pushTo (#tx % #substate % #refunds) (self, n) + +unRefund :: Word64 -> EVM s () +unRefund n = do + self <- use (#state % #contract) + refs <- use (#tx % #substate % #refunds) + assign (#tx % #substate % #refunds) + (filter (\(a,b) -> not (a == self && b == n)) refs) + +touchAccount :: Expr EAddr -> EVM s () +touchAccount = pushTo ((#tx % #substate) % #touchedAccounts) + +selfdestruct :: Expr EAddr -> EVM s () +selfdestruct = pushTo ((#tx % #substate) % #selfdestructs) + +accessAndBurn :: Expr EAddr -> EVM s () -> EVM s () +accessAndBurn x cont = do + FeeSchedule {..} <- use (#block % #schedule) + acc <- accessAccountForGas x + let cost = if acc then g_warm_storage_read else g_cold_account_access + burn cost cont + +-- | returns a wrapped boolean- if true, this address has been touched before in the txn (warm gas cost as in EIP 2929) +-- otherwise cold +accessAccountForGas :: Expr EAddr -> EVM s Bool +accessAccountForGas addr = do + accessedAddrs <- use (#tx % #substate % #accessedAddresses) + let accessed = member addr accessedAddrs + assign (#tx % #substate % #accessedAddresses) (insert addr accessedAddrs) + pure accessed + +-- | returns a wrapped boolean- if true, this slot has been touched before in the txn (warm gas cost as in EIP 2929) +-- otherwise cold +accessStorageForGas :: Expr EAddr -> Expr EWord -> EVM s Bool +accessStorageForGas addr key = do + accessedStrkeys <- use (#tx % #substate % #accessedStorageKeys) + case maybeLitWord key of + Just litword -> do + let accessed = member (addr, litword) accessedStrkeys + assign (#tx % #substate % #accessedStorageKeys) (insert (addr, litword) accessedStrkeys) + pure accessed + _ -> return False + +-- * Cheat codes + +-- The cheat code is 7109709ecfa91a80626ff3989d68f67f5b1dd12d. +-- Call this address using one of the cheatActions below to do +-- special things, e.g. changing the block timestamp. Beware that +-- these are necessarily hevm specific. +cheatCode :: Expr EAddr +cheatCode = LitAddr $ unsafeInto (keccak' "hevm cheat code") + +cheat + :: (?op :: Word8) + => (W256, W256) -> (W256, W256) + -> EVM s () +cheat (inOffset, inSize) (outOffset, outSize) = do + vm <- get + input <- readMemory (Lit $ inOffset + 4) (Lit $ inSize - 4) + abi <- readBytes 4 (Lit 0) <$> readMemory (Lit inOffset) (Lit 4) + pushTrace $ FrameTrace (CallContext cheatCode cheatCode inOffset inSize (Lit 0) (maybeLitWord abi) input vm.env.contracts vm.tx.substate) + case maybeLitWord abi of + Nothing -> partial $ UnexpectedSymbolicArg vm.state.pc "symbolic cheatcode selector" (wrap [abi]) + Just (unsafeInto -> abi') -> + case Map.lookup abi' cheatActions of + Nothing -> + vmError (BadCheatCode abi') + Just action -> do + action (Lit outOffset) (Lit outSize) input + popTrace + next + push 1 + +type CheatAction s = Expr EWord -> Expr EWord -> Expr Buf -> EVM s () + +cheatActions :: Map FunctionSelector (CheatAction s) +cheatActions = + Map.fromList + [ action "ffi(string[])" $ + \sig outOffset outSize input -> do + vm <- get + if vm.config.allowFFI then + case decodeBuf [AbiArrayDynamicType AbiStringType] input of + CAbi valsArr -> case valsArr of + [AbiArrayDynamic AbiStringType strsV] -> + let + cmd = fmap + (\case + (AbiString a) -> unpack $ decodeUtf8 a + _ -> "") + (V.toList strsV) + cont bs = do + let encoded = ConcreteBuf bs + assign (#state % #returndata) encoded + copyBytesToMemory encoded outSize (Lit 0) outOffset + assign #result Nothing + in query (PleaseDoFFI cmd cont) + _ -> vmError (BadCheatCode sig) + _ -> vmError (BadCheatCode sig) + else + let msg = "ffi disabled: run again with --ffi if you want to allow tests to call external scripts" + in partial $ UnexpectedSymbolicArg vm.state.pc msg [], + + action "warp(uint256)" $ + \sig _ _ input -> case decodeStaticArgs 0 1 input of + [x] -> assign (#block % #timestamp) x + _ -> vmError (BadCheatCode sig), + + action "deal(address,uint256)" $ + \sig _ _ input -> case decodeStaticArgs 0 2 input of + [a, amt] -> + forceAddr a "vm.deal: cannot decode target into an address" $ \usr -> + fetchAccount usr $ \_ -> do + assign (#env % #contracts % ix usr % #balance) amt + _ -> vmError (BadCheatCode sig), + + action "assume(bool)" $ + \sig _ _ input -> case decodeStaticArgs 0 1 input of + [c] -> modifying #constraints ((:) (PEq c (Lit 1))) + _ -> vmError (BadCheatCode sig), + + action "roll(uint256)" $ + \sig _ _ input -> case decodeStaticArgs 0 1 input of + [x] -> forceConcrete x "cannot roll to a symbolic block number" (assign (#block % #number)) + _ -> vmError (BadCheatCode sig), + + action "store(address,bytes32,bytes32)" $ + \sig _ _ input -> case decodeStaticArgs 0 3 input of + [a, slot, new] -> case wordToAddr a of + Just a'@(LitAddr _) -> fetchAccount a' $ \_ -> + modifying (#env % #contracts % ix a' % #storage) (writeStorage slot new) + _ -> vmError (BadCheatCode sig) + _ -> vmError (BadCheatCode sig), + + action "load(address,bytes32)" $ + \sig outOffset _ input -> case decodeStaticArgs 0 2 input of + [a, slot] -> case wordToAddr a of + Just a'@(LitAddr _) -> fetchAccount a' $ \_ -> + accessStorage a' slot $ \res -> do + assign (#state % #returndata % word256At (Lit 0)) res + let buf = writeWord (Lit 0) res (ConcreteBuf "") + copyBytesToMemory buf (Lit 32) (Lit 0) outOffset + _ -> vmError (BadCheatCode sig) + _ -> vmError (BadCheatCode sig), + + action "sign(uint256,bytes32)" $ + \sig outOffset _ input -> case decodeStaticArgs 0 2 input of + [sk, hash] -> + forceConcrete2 (sk, hash) "cannot sign symbolic data" $ \(sk', hash') -> do + let (v,r,s) = EVM.Sign.sign hash' (toInteger sk') + encoded = encodeAbiValue $ + AbiTuple (V.fromList + [ AbiUInt 8 $ into v + , AbiBytes 32 (word256Bytes r) + , AbiBytes 32 (word256Bytes s) + ]) + assign (#state % #returndata) (ConcreteBuf encoded) + copyBytesToMemory (ConcreteBuf encoded) (Lit . unsafeInto . BS.length $ encoded) (Lit 0) outOffset + _ -> vmError (BadCheatCode sig), + + action "addr(uint256)" $ + \sig outOffset _ input -> case decodeStaticArgs 0 1 input of + [sk] -> forceConcrete sk "cannot derive address for a symbolic key" $ \sk' -> do + let a = EVM.Sign.deriveAddr $ into sk' + case a of + Nothing -> vmError (BadCheatCode sig) + Just address -> do + let expAddr = litAddr address + assign (#state % #returndata % word256At (Lit 0)) expAddr + let buf = ConcreteBuf $ word256Bytes (into address) + copyBytesToMemory buf (Lit 32) (Lit 0) outOffset + _ -> vmError (BadCheatCode sig), + + action "prank(address)" $ + \sig _ _ input -> case decodeStaticArgs 0 1 input of + [addr] -> case wordToAddr addr of + Just a -> assign (#config % #overrideCaller) (Just a) + Nothing -> vmError (BadCheatCode sig) + _ -> vmError (BadCheatCode sig) + + ] + where + action s f = (abiKeccak s, f (abiKeccak s)) + +-- * General call implementation ("delegateCall") +-- note that the continuation is ignored in the precompile case +delegateCall + :: (?op :: Word8) + => Contract -> Word64 -> Expr EAddr -> Expr EAddr -> Expr EWord -> W256 -> W256 -> W256 -> W256 + -> [Expr EWord] + -> (Expr EAddr -> EVM s ()) + -> EVM s () +delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue + | isPrecompileAddr xTo + = forceConcreteAddr2 (xTo, xContext) "Cannot call precompile with symbolic addresses" $ + \(xTo', xContext') -> + precompiledContract this gasGiven xTo' xContext' xValue xInOffset xInSize xOutOffset xOutSize xs + | xTo == cheatCode = do + assign (#state % #stack) xs + cheat (xInOffset, xInSize) (xOutOffset, xOutSize) + | otherwise = + callChecks this gasGiven xContext xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ + \xGas -> do + vm0 <- get + fetchAccount xTo $ \target -> case target.code of + UnknownCode _ -> do + pc <- use (#state % #pc) + partial $ UnexpectedSymbolicArg pc "call target has unknown code" (wrap [xTo]) + _ -> do + burn xGas $ do + calldata <- readMemory (Lit xInOffset) (Lit xInSize) + abi <- maybeLitWord . readBytes 4 (Lit 0) <$> readMemory (Lit xInOffset) (Lit 4) + let newContext = CallContext + { target = xTo + , context = xContext + , offset = xOutOffset + , size = xOutSize + , codehash = target.codehash + , callreversion = vm0.env.contracts + , subState = vm0.tx.substate + , abi + , calldata + } + pushTrace (FrameTrace newContext) + next + vm1 <- get + + pushTo #frames $ Frame + { state = vm1.state { stack = xs } + , context = newContext + } + + let clearInitCode = \case + (InitCode _ _) -> InitCode mempty mempty + a -> a + + newMemory <- ConcreteMemory <$> VUnboxed.Mutable.new 0 + zoom #state $ do + assign #gas xGas + assign #pc 0 + assign #code (clearInitCode target.code) + assign #codeContract xTo + assign #stack mempty + assign #memory newMemory + assign #memorySize 0 + assign #returndata mempty + assign #calldata calldata + continue xTo + +-- -- * Contract creation + +-- EIP 684 +collision :: Maybe Contract -> Bool +collision c' = case c' of + Just c -> c.nonce /= Just 0 || case c.code of + RuntimeCode (ConcreteRuntimeCode "") -> False + RuntimeCode (SymbolicRuntimeCode b) -> not $ null b + _ -> True + Nothing -> False + +create :: (?op :: Word8) + => Expr EAddr -> Contract + -> W256 -> Word64 -> Expr EWord -> [Expr EWord] -> Expr EAddr -> Expr Buf -> EVM s () +create self this xSize xGas xValue xs newAddr initCode = do + vm0 <- get + if xSize > vm0.block.maxCodeSize * 2 + then do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + vmError $ MaxInitCodeSizeExceeded (vm0.block.maxCodeSize * 2) xSize + else if this.nonce == Just maxBound + then do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + pushTrace $ ErrorTrace NonceOverflow + next + else if length vm0.frames >= 1024 + then do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + pushTrace $ ErrorTrace CallDepthLimitReached + next + else if collision $ Map.lookup newAddr vm0.env.contracts + then burn xGas $ do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + modifying (#env % #contracts % ix self % #nonce) (fmap ((+) 1)) + next + -- do we have enough balance + else branch (Expr.gt xValue this.balance) $ \case + True -> do + assign (#state % #stack) (Lit 0 : xs) + assign (#state % #returndata) mempty + pushTrace $ ErrorTrace $ BalanceTooLow xValue this.balance + next + touchAccount self + touchAccount newAddr + -- are we overflowing the nonce + False -> burn xGas $ do + case parseInitCode initCode of + Nothing -> + partial $ UnexpectedSymbolicArg vm0.state.pc "initcode must have a concrete prefix" [] + Just c -> do + let + newContract = initialContract c + newContext = + CreationContext { address = newAddr + , codehash = newContract.codehash + , createreversion = vm0.env.contracts + , substate = vm0.tx.substate + } + + zoom (#env % #contracts) $ do + oldAcc <- use (at newAddr) + let oldBal = maybe (Lit 0) (.balance) oldAcc + + assign (at newAddr) (Just (newContract & #balance .~ oldBal)) + modifying (ix self % #nonce) (fmap ((+) 1)) + + let + resetStorage :: Expr Storage -> Expr Storage + resetStorage = \case + ConcreteStore _ -> ConcreteStore mempty + AbstractStore a -> AbstractStore a + SStore _ _ p -> resetStorage p + GVar _ -> error "unexpected global variable" + + modifying (#env % #contracts % ix newAddr % #storage) resetStorage + modifying (#env % #contracts % ix newAddr % #origStorage) resetStorage + + transfer self newAddr xValue + + pushTrace (FrameTrace newContext) + next + vm1 <- get + pushTo #frames $ Frame + { context = newContext + , state = vm1.state { stack = xs } + } + + state <- lift blankState + assign #state $ state + { contract = newAddr + , codeContract = newAddr + , code = c + , callvalue = xValue + , caller = self + , gas = xGas + } + +-- | Parses a raw Buf into an InitCode +-- +-- solidity implements constructor args by appending them to the end of +-- the initcode. we support this internally by treating initCode as a +-- concrete region (initCode) followed by a potentially symbolic region +-- (arguments). +-- +-- when constructing a contract that has symbolic construcor args, we +-- need to apply some heuristics to convert the (unstructured) initcode +-- in memory into this structured representation. The (unsound, bad, +-- hacky) way that we do this, is by: looking for the first potentially +-- symbolic byte in the input buffer and then splitting it there into code / data. +parseInitCode :: Expr Buf -> Maybe ContractCode +parseInitCode (ConcreteBuf b) = Just (InitCode b mempty) +parseInitCode buf = if V.null conc + then Nothing + else Just $ InitCode (BS.pack $ V.toList conc) sym + where + conc = Expr.concretePrefix buf + -- unsafeInto: findIndex will always be positive + sym = Expr.drop (unsafeInto (V.length conc)) buf + +-- | Replace a contract's code, like when CREATE returns +-- from the constructor code. +replaceCode :: Expr EAddr -> ContractCode -> EVM s () +replaceCode target newCode = + zoom (#env % #contracts % at target) $ + get >>= \case + Just now -> case now.code of + InitCode _ _ -> + put . Just $ + ((initialContract newCode) :: Contract) + { balance = now.balance + , nonce = now.nonce + , storage = now.storage + } + RuntimeCode _ -> + internalError $ "Can't replace code of deployed contract " <> show target + UnknownCode _ -> + internalError "Can't replace unknown code" + Nothing -> + internalError "Can't replace code of nonexistent contract" + +replaceCodeOfSelf :: ContractCode -> EVM s () +replaceCodeOfSelf newCode = do + vm <- get + replaceCode vm.state.contract newCode + +resetState :: EVM s () +resetState = do + state <- lift blankState + modify' $ \vm -> vm { result = Nothing, frames = [], state } + +-- * VM error implementation + +vmError :: EvmError -> EVM s () +vmError e = finishFrame (FrameErrored e) + +partial :: PartialExec -> EVM s () +partial e = assign #result (Just (Unfinished e)) + +wrap :: Typeable a => [Expr a] -> [SomeExpr] +wrap = fmap SomeExpr + +underrun :: EVM s () +underrun = vmError StackUnderrun + +-- | A stack frame can be popped in three ways. +data FrameResult + = FrameReturned (Expr Buf) -- ^ STOP, RETURN, or no more code + | FrameReverted (Expr Buf) -- ^ REVERT + | FrameErrored EvmError -- ^ Any other error + deriving Show + +-- | This function defines how to pop the current stack frame in either of +-- the ways specified by 'FrameResult'. +-- +-- It also handles the case when the current stack frame is the only one; +-- in this case, we set the final '_result' of the VM execution. +finishFrame :: FrameResult -> EVM s () +finishFrame how = do + oldVm <- get + + case oldVm.frames of + -- Is the current frame the only one? + [] -> do + case how of + FrameReturned output -> assign #result . Just $ VMSuccess output + FrameReverted buffer -> assign #result . Just $ VMFailure (Revert buffer) + FrameErrored e -> assign #result . Just $ VMFailure e + finalize + + -- Are there some remaining frames? + nextFrame : remainingFrames -> do + + -- Insert a debug trace. + insertTrace $ + case how of + FrameErrored e -> + ErrorTrace e + FrameReverted e -> + ErrorTrace (Revert e) + FrameReturned output -> + ReturnTrace output nextFrame.context + -- Pop to the previous level of the debug trace stack. + popTrace + + -- Pop the top frame. + assign #frames remainingFrames + -- Install the state of the frame to which we shall return. + assign #state nextFrame.state + + -- When entering a call, the gas allowance is counted as burned + -- in advance; this unburns the remainder and adds it to the + -- parent frame. + let remainingGas = oldVm.state.gas + reclaimRemainingGasAllowance = do + modifying #burned (subtract remainingGas) + modifying (#state % #gas) (+ remainingGas) + + -- Now dispatch on whether we were creating or calling, + -- and whether we shall return, revert, or internalError(six cases). + case nextFrame.context of + + -- Were we calling? + CallContext _ _ (Lit -> outOffset) (Lit -> outSize) _ _ _ reversion substate' -> do + + -- Excerpt K.1. from the yellow paper: + -- K.1. Deletion of an Account Despite Out-of-gas. + -- At block 2675119, in the transaction 0xcf416c536ec1a19ed1fb89e4ec7ffb3cf73aa413b3aa9b77d60e4fd81a4296ba, + -- an account at address 0x03 was called and an out-of-gas occurred during the call. + -- Against the equation (197), this added 0x03 in the set of touched addresses, and this transaction turned σ[0x03] into ∅. + + -- In other words, we special case address 0x03 and keep it in the set of touched accounts during revert + touched <- use (#tx % #substate % #touchedAccounts) + + let + substate'' = over #touchedAccounts (maybe id cons (find (LitAddr 3 ==) touched)) substate' + revertContracts = assign (#env % #contracts) reversion + revertSubstate = assign (#tx % #substate) substate'' + + case how of + -- Case 1: Returning from a call? + FrameReturned output -> do + assign (#state % #returndata) output + copyCallBytesToMemory output outSize outOffset + reclaimRemainingGasAllowance + push 1 + + -- Case 2: Reverting during a call? + FrameReverted output -> do + revertContracts + revertSubstate + assign (#state % #returndata) output + copyCallBytesToMemory output outSize outOffset + reclaimRemainingGasAllowance + push 0 + + -- Case 3: Error during a call? + FrameErrored _ -> do + revertContracts + revertSubstate + assign (#state % #returndata) mempty + push 0 + -- Or were we creating? + CreationContext _ _ reversion substate' -> do + creator <- use (#state % #contract) + let + createe = oldVm.state.contract + revertContracts = assign (#env % #contracts) reversion' + revertSubstate = assign (#tx % #substate) substate' + + -- persist the nonce through the reversion + reversion' = (Map.adjust (over #nonce (fmap ((+) 1))) creator) reversion + + case how of + -- Case 4: Returning during a creation? + FrameReturned output -> do + let onContractCode contractCode = do + replaceCode createe contractCode + assign (#state % #returndata) mempty + reclaimRemainingGasAllowance + pushAddr createe + case output of + ConcreteBuf bs -> + onContractCode $ RuntimeCode (ConcreteRuntimeCode bs) + _ -> + case Expr.toList output of + Nothing -> partial $ + UnexpectedSymbolicArg + oldVm.state.pc + "runtime code cannot have an abstract length" + (wrap [output]) + Just newCode -> do + onContractCode $ RuntimeCode (SymbolicRuntimeCode newCode) + + -- Case 5: Reverting during a creation? + FrameReverted output -> do + revertContracts + revertSubstate + assign (#state % #returndata) output + reclaimRemainingGasAllowance + push 0 + + -- Case 6: Error during a creation? + FrameErrored _ -> do + revertContracts + revertSubstate + assign (#state % #returndata) mempty + push 0 + + +-- * Memory helpers + +accessUnboundedMemoryRange + :: Word64 + -> Word64 + -> EVM s () + -> EVM s () +accessUnboundedMemoryRange _ 0 continue = continue +accessUnboundedMemoryRange f l continue = do + m0 <- use (#state % #memorySize) + fees <- gets (.block.schedule) + let m1 = 32 * ceilDiv (max m0 (f + l)) 32 + burn (memoryCost fees m1 - memoryCost fees m0) $ do + assign (#state % #memorySize) m1 + continue + +accessMemoryRange + :: W256 + -> W256 + -> EVM s () + -> EVM s () +accessMemoryRange _ 0 continue = continue +accessMemoryRange offs sz continue = + case (,) <$> toWord64 offs <*> toWord64 sz of + Nothing -> vmError IllegalOverflow + Just (offs64, sz64) -> + if offs64 + sz64 < sz64 + then vmError IllegalOverflow + else accessUnboundedMemoryRange offs64 sz64 continue + +accessMemoryWord + :: W256 -> EVM s () -> EVM s () +accessMemoryWord x = accessMemoryRange x 32 + +copyBytesToMemory + :: Expr Buf -> Expr EWord -> Expr EWord -> Expr EWord -> EVM s () +copyBytesToMemory bs size srcOffset memOffset = + if size == Lit 0 then noop + else do + gets (.state.memory) >>= \case + ConcreteMemory mem -> + case (bs, size, srcOffset, memOffset) of + (ConcreteBuf b, Lit size', Lit srcOffset', Lit memOffset') -> do + let src = + if srcOffset' >= unsafeInto (BS.length b) then + BS.replicate (unsafeInto size') 0 + else + BS.take (unsafeInto size') $ + padRight (unsafeInto size') $ + BS.drop (unsafeInto srcOffset') b + + writeMemory mem (unsafeInto memOffset') src + _ -> do + -- copy out and move to symbolic memory + buf <- freezeMemory mem + assign (#state % #memory) $ + SymbolicMemory $ copySlice srcOffset memOffset size bs buf + SymbolicMemory mem -> + assign (#state % #memory) $ + SymbolicMemory $ copySlice srcOffset memOffset size bs mem + +copyCallBytesToMemory + :: Expr Buf -> Expr EWord -> Expr EWord -> EVM s () +copyCallBytesToMemory bs size yOffset = + copyBytesToMemory bs (Expr.min size (bufLength bs)) (Lit 0) yOffset + +readMemory :: Expr EWord -> Expr EWord -> EVM s (Expr Buf) +readMemory offset' size' = do + vm <- get + case vm.state.memory of + ConcreteMemory mem -> do + case (offset', size') of + (Lit offset, Lit size) -> do + let memSize :: Word64 = unsafeInto (VUnboxed.Mutable.length mem) + if size > Expr.maxBytes || + offset + size > Expr.maxBytes || + offset >= into memSize then + -- reads past memory are all zeros + pure $ ConcreteBuf $ BS.replicate (unsafeInto size) 0 + else do + let pastEnd = (unsafeInto offset + unsafeInto size) - unsafeInto memSize + let fromMemSize = if pastEnd > 0 then unsafeInto size - pastEnd else unsafeInto size + + buf <- VUnboxed.freeze $ VUnboxed.Mutable.slice (unsafeInto offset) fromMemSize mem + let dataFromMem = BS.pack $ VUnboxed.toList buf + pure $ ConcreteBuf $ dataFromMem <> BS.replicate pastEnd 0 + _ -> do + buf <- freezeMemory mem + pure $ copySlice offset' (Lit 0) size' buf mempty + SymbolicMemory mem -> + pure $ copySlice offset' (Lit 0) size' mem mempty + +-- * Tracing + +withTraceLocation :: TraceData -> EVM s Trace +withTraceLocation x = do + vm <- get + let this = fromJust $ currentContract vm + pure Trace + { tracedata = x + , contract = this + , opIx = fromMaybe 0 $ this.opIxMap SV.!? vm.state.pc + } + +pushTrace :: TraceData -> EVM s () +pushTrace x = do + trace <- withTraceLocation x + modifying #traces $ + \t -> Zipper.children $ Zipper.insert (Node trace []) t + +insertTrace :: TraceData -> EVM s () +insertTrace x = do + trace <- withTraceLocation x + modifying #traces $ + \t -> Zipper.nextSpace $ Zipper.insert (Node trace []) t + +popTrace :: EVM s () +popTrace = + modifying #traces $ + \t -> case Zipper.parent t of + Nothing -> internalError "internal internalError(trace root)" + Just t' -> Zipper.nextSpace t' + +zipperRootForest :: Zipper.TreePos Zipper.Empty a -> Forest a +zipperRootForest z = + case Zipper.parent z of + Nothing -> Zipper.toForest z + Just z' -> zipperRootForest (Zipper.nextSpace z') + +traceForest :: VM s -> Forest Trace +traceForest vm = zipperRootForest vm.traces + +traceForest' :: Expr End -> Forest Trace +traceForest' (Success _ (Traces f _) _ _) = f +traceForest' (Partial _ (Traces f _) _) = f +traceForest' (Failure _ (Traces f _) _) = f +traceForest' (ITE {}) = internalError"Internal Error: ITE does not contain a trace" +traceForest' (GVar {}) = internalError"Internal Error: Unexpected GVar" + +traceContext :: Expr End -> Map (Expr EAddr) Contract +traceContext (Success _ (Traces _ c) _ _) = c +traceContext (Partial _ (Traces _ c) _) = c +traceContext (Failure _ (Traces _ c) _) = c +traceContext (ITE {}) = internalError"Internal Error: ITE does not contain a trace" +traceContext (GVar {}) = internalError"Internal Error: Unexpected GVar" + +traceTopLog :: [Expr Log] -> EVM s () +traceTopLog [] = noop +traceTopLog ((LogEntry addr bytes topics) : _) = do + trace <- withTraceLocation (EventTrace addr bytes topics) + modifying #traces $ + \t -> Zipper.nextSpace (Zipper.insert (Node trace []) t) +traceTopLog ((GVar _) : _) = internalError "unexpected global variable" + +-- * Stack manipulation + +push :: W256 -> EVM s () +push = pushSym . Lit + +pushSym :: Expr EWord -> EVM s () +pushSym x = #state % #stack %= (x :) + +pushAddr :: Expr EAddr -> EVM s () +pushAddr (LitAddr x) = #state % #stack %= (Lit (into x) :) +pushAddr x@(SymAddr _) = #state % #stack %= (WAddr x :) +pushAddr (GVar _) = internalError "Unexpected GVar" + +stackOp1 + :: (?op :: Word8) + => Word64 + -> (Expr EWord -> Expr EWord) + -> EVM s () +stackOp1 cost f = + use (#state % #stack) >>= \case + x:xs -> + burn cost $ do + next + let !y = f x + #state % #stack .= y : xs + _ -> + underrun + +stackOp2 + :: (?op :: Word8) + => Word64 + -> (Expr EWord -> Expr EWord -> Expr EWord) + -> EVM s () +stackOp2 cost f = + use (#state % #stack) >>= \case + x:y:xs -> + burn cost $ do + next + #state % #stack .= f x y : xs + _ -> + underrun + +stackOp3 + :: (?op :: Word8) + => Word64 + -> (Expr EWord -> Expr EWord -> Expr EWord -> Expr EWord) + -> EVM s () +stackOp3 cost f = + use (#state % #stack) >>= \case + x:y:z:xs -> + burn cost $ do + next + (#state % #stack) .= f x y z : xs + _ -> + underrun + +-- * Bytecode data functions + +use' :: (VM s -> a) -> EVM s a +use' f = do + vm <- get + pure (f vm) + +checkJump :: Int -> [Expr EWord] -> EVM s () +checkJump x xs = noJumpIntoInitData x $ do + vm <- get + case isValidJumpDest vm x of + True -> do + #state % #stack .= xs + #state % #pc .= x + False -> vmError BadJumpDestination + +-- fails with partial if we're trying to jump into the symbolic region of an `InitCode` +noJumpIntoInitData :: Int -> EVM s () -> EVM s () +noJumpIntoInitData idx cont = do + vm <- get + case vm.state.code of + -- init code is totally concrete, so we don't return partial if we're + -- jumping beyond the range of `ops` + InitCode _ (ConcreteBuf "") -> cont + -- init code has a symbolic region, so check if we're trying to jump into + -- the symbolic region and return partial if we are + InitCode ops _ -> if idx > BS.length ops + then partial $ JumpIntoSymbolicCode vm.state.pc idx + else cont + -- we're not executing init code, so nothing to check here + _ -> cont + +isValidJumpDest :: VM s -> Int -> Bool +isValidJumpDest vm x = let + code = vm.state.code + self = vm.state.codeContract + contract = fromMaybe + (internalError "self not found in current contracts") + (Map.lookup self vm.env.contracts) + op = case code of + UnknownCode _ -> internalError "Cannot analyze jumpdests for unknown code" + InitCode ops _ -> BS.indexMaybe ops x + RuntimeCode (ConcreteRuntimeCode ops) -> BS.indexMaybe ops x + RuntimeCode (SymbolicRuntimeCode ops) -> ops V.!? x >>= maybeLitByte + in case op of + Nothing -> False + Just b -> 0x5b == b && OpJumpdest == snd (contract.codeOps V.! (contract.opIxMap SV.! x)) + +opSize :: Word8 -> Int +opSize x | x >= 0x60 && x <= 0x7f = into x - 0x60 + 2 +opSize _ = 1 + +-- i of the resulting vector contains the operation index for +-- the program counter value i. This is needed because source map +-- entries are per operation, not per byte. +mkOpIxMap :: ContractCode -> SV.Vector Int +mkOpIxMap (UnknownCode _) = internalError "Cannot build opIxMap for unknown code" +mkOpIxMap (InitCode conc _) + = SV.create $ SV.new (BS.length conc) >>= \v -> + -- Loop over the byte string accumulating a vector-mutating action. + -- This is somewhat obfuscated, but should be fast. + let (_, _, _, m) = BS.foldl' (go v) (0 :: Word8, 0, 0, pure ()) conc + in m >> pure v + where + -- concrete case + go v (0, !i, !j, !m) x | x >= 0x60 && x <= 0x7f = + {- Start of PUSH op. -} (x - 0x60 + 1, i + 1, j, m >> SV.write v i j) + go v (1, !i, !j, !m) _ = + {- End of PUSH op. -} (0, i + 1, j + 1, m >> SV.write v i j) + go v (0, !i, !j, !m) _ = + {- Other op. -} (0, i + 1, j + 1, m >> SV.write v i j) + go v (n, !i, !j, !m) _ = + {- PUSH data. -} (n - 1, i + 1, j, m >> SV.write v i j) + +mkOpIxMap (RuntimeCode (ConcreteRuntimeCode ops)) = + mkOpIxMap (InitCode ops mempty) -- a bit hacky + +mkOpIxMap (RuntimeCode (SymbolicRuntimeCode ops)) + = SV.create $ SV.new (length ops) >>= \v -> + let (_, _, _, m) = foldl (go v) (0, 0, 0, pure ()) (stripBytecodeMetadataSym $ V.toList ops) + in m >> pure v + where + go v (0, !i, !j, !m) x = case maybeLitByte x of + Just x' -> if x' >= 0x60 && x' <= 0x7f + -- start of PUSH op -- + then (x' - 0x60 + 1, i + 1, j, m >> SV.write v i j) + -- other data -- + else (0, i + 1, j + 1, m >> SV.write v i j) + _ -> internalError $ "cannot analyze symbolic code:\nx: " <> show x <> " i: " <> show i <> " j: " <> show j + + go v (1, !i, !j, !m) _ = + {- End of PUSH op. -} (0, i + 1, j + 1, m >> SV.write v i j) + go v (n, !i, !j, !m) _ = + {- PUSH data. -} (n - 1, i + 1, j, m >> SV.write v i j) + + +vmOp :: VM s -> Maybe Op +vmOp vm = + let i = vm ^. #state % #pc + code' = vm ^. #state % #code + (op, pushdata) = case code' of + UnknownCode _ -> internalError "cannot get op from unknown code" + InitCode xs' _ -> + (BS.index xs' i, fmap LitByte $ BS.unpack $ BS.drop i xs') + RuntimeCode (ConcreteRuntimeCode xs') -> + (BS.index xs' i, fmap LitByte $ BS.unpack $ BS.drop i xs') + RuntimeCode (SymbolicRuntimeCode xs') -> + ( fromMaybe (internalError "unexpected symbolic code") . maybeLitByte $ xs' V.! i , V.toList $ V.drop i xs') + in if (opslen code' < i) + then Nothing + else Just (readOp op pushdata) + +vmOpIx :: VM s -> Maybe Int +vmOpIx vm = + do self <- currentContract vm + self.opIxMap SV.!? vm.state.pc + +-- Maps operation indicies into a pair of (bytecode index, operation) +mkCodeOps :: ContractCode -> V.Vector (Int, Op) +mkCodeOps contractCode = + let l = case contractCode of + UnknownCode _ -> internalError "Cannot make codeOps for unknown code" + InitCode bytes _ -> + LitByte <$> (BS.unpack bytes) + RuntimeCode (ConcreteRuntimeCode ops) -> + LitByte <$> (BS.unpack $ stripBytecodeMetadata ops) + RuntimeCode (SymbolicRuntimeCode ops) -> + stripBytecodeMetadataSym $ V.toList ops + in V.fromList . toList $ go 0 l + where + go !i !xs = + case uncons xs of + Nothing -> + mempty + Just (x, xs') -> + let x' = fromMaybe (internalError "unexpected symbolic code argument") $ maybeLitByte x + j = opSize x' + in (i, readOp x' xs') Seq.<| go (i + j) (drop j xs) + +-- * Gas cost calculation helpers + +-- Gas cost function for CALL, transliterated from the Yellow Paper. +costOfCall + :: FeeSchedule Word64 + -> Bool -> Expr EWord -> Word64 -> Word64 -> Expr EAddr + -> EVM s (Word64, Word64) +costOfCall (FeeSchedule {..}) recipientExists (Lit xValue) availableGas xGas target = do + acc <- accessAccountForGas target + let call_base_gas = if acc then g_warm_storage_read else g_cold_account_access + c_new = if not recipientExists && xValue /= 0 + then g_newaccount + else 0 + c_xfer = if xValue /= 0 then g_callvalue else 0 + c_extra = call_base_gas + c_xfer + c_new + c_gascap = if availableGas >= c_extra + then min xGas (allButOne64th (availableGas - c_extra)) + else xGas + c_callgas = if xValue /= 0 then c_gascap + g_callstipend else c_gascap + pure (c_gascap + c_extra, c_callgas) +-- calls are free if value is symbolic :) +costOfCall _ _ _ _ _ _ = pure (0,0) + +-- Gas cost of create, including hash cost if needed +costOfCreate + :: FeeSchedule Word64 + -> Word64 -> W256 -> Bool -> (Word64, Word64) +costOfCreate (FeeSchedule {..}) availableGas size hashNeeded = (createCost, initGas) + where + byteCost = if hashNeeded then g_sha3word + g_initcodeword else g_initcodeword + createCost = g_create + codeCost + codeCost = byteCost * (ceilDiv (unsafeInto size) 32) + initGas = allButOne64th (availableGas - createCost) + +concreteModexpGasFee :: ByteString -> Word64 +concreteModexpGasFee input = + if lenb < into (maxBound :: Word32) && + (lene < into (maxBound :: Word32) || (lenb == 0 && lenm == 0)) && + lenm < into (maxBound :: Word64) + then + max 200 ((multiplicationComplexity * iterCount) `div` 3) + else + maxBound -- TODO: this is not 100% correct, return Nothing on overflow + where + (lenb, lene, lenm) = parseModexpLength input + ez = isZero (96 + lenb) lene input + e' = word $ LS.toStrict $ + lazySlice (96 + lenb) (min 32 lene) input + nwords :: Word64 + nwords = ceilDiv (unsafeInto $ max lenb lenm) 8 + multiplicationComplexity = nwords * nwords + iterCount' :: Word64 + iterCount' | lene <= 32 && ez = 0 + | lene <= 32 = unsafeInto (log2 e') + | e' == 0 = 8 * (unsafeInto lene - 32) + | otherwise = unsafeInto (log2 e') + 8 * (unsafeInto lene - 32) + iterCount = max iterCount' 1 + +-- Gas cost of precompiles +costOfPrecompile :: FeeSchedule Word64 -> Addr -> Expr Buf -> Word64 +costOfPrecompile (FeeSchedule {..}) precompileAddr input = + let errorDynamicSize = internalError "precompile input cannot have a dynamic size" + inputLen = case input of + ConcreteBuf bs -> unsafeInto $ BS.length bs + AbstractBuf _ -> errorDynamicSize + buf -> case bufLength buf of + Lit l -> unsafeInto l -- TODO: overflow + _ -> errorDynamicSize + in case precompileAddr of + -- ECRECOVER + 0x1 -> 3000 + -- SHA2-256 + 0x2 -> (((inputLen + 31) `div` 32) * 12) + 60 + -- RIPEMD-160 + 0x3 -> (((inputLen + 31) `div` 32) * 120) + 600 + -- IDENTITY + 0x4 -> (((inputLen + 31) `div` 32) * 3) + 15 + -- MODEXP + 0x5 -> case input of + ConcreteBuf i -> concreteModexpGasFee i + _ -> internalError "Unsupported symbolic modexp gas calc " + -- ECADD + 0x6 -> g_ecadd + -- ECMUL + 0x7 -> g_ecmul + -- ECPAIRING + 0x8 -> (inputLen `div` 192) * g_pairing_point + g_pairing_base + -- BLAKE2 + 0x9 -> case input of + ConcreteBuf i -> g_fround * (unsafeInto $ asInteger $ lazySlice 0 4 i) + _ -> internalError "Unsupported symbolic blake2 gas calc" + _ -> internalError $ "unimplemented precompiled contract " ++ show precompileAddr + +-- Gas cost of memory expansion +memoryCost :: FeeSchedule Word64 -> Word64 -> Word64 +memoryCost FeeSchedule{..} byteCount = + let + wordCount = ceilDiv byteCount 32 + linearCost = g_memory * wordCount + quadraticCost = div (wordCount * wordCount) 512 + in + linearCost + quadraticCost + +hashcode :: ContractCode -> Expr EWord +hashcode (UnknownCode a) = CodeHash a +hashcode (InitCode ops args) = keccak $ (ConcreteBuf ops) <> args +hashcode (RuntimeCode (ConcreteRuntimeCode ops)) = keccak (ConcreteBuf ops) +hashcode (RuntimeCode (SymbolicRuntimeCode ops)) = keccak . Expr.fromList $ ops + +-- | The length of the code ignoring any constructor args. +-- This represents the region that can contain executable opcodes +opslen :: ContractCode -> Int +opslen (UnknownCode _) = internalError "Cannot produce concrete opslen for unknown code" +opslen (InitCode ops _) = BS.length ops +opslen (RuntimeCode (ConcreteRuntimeCode ops)) = BS.length ops +opslen (RuntimeCode (SymbolicRuntimeCode ops)) = length ops + +-- | The length of the code including any constructor args. +-- This can return an abstract value +codelen :: ContractCode -> Expr EWord +codelen (UnknownCode a) = CodeSize a +codelen c@(InitCode {}) = case toBuf c of + Just b -> bufLength b + Nothing -> internalError "impossible" +-- these are never going to be negative so unsafeInto is fine here +codelen (RuntimeCode (ConcreteRuntimeCode ops)) = Lit . unsafeInto $ BS.length ops +codelen (RuntimeCode (SymbolicRuntimeCode ops)) = Lit . unsafeInto $ length ops + +toBuf :: ContractCode -> Maybe (Expr Buf) +toBuf (UnknownCode _) = Nothing +toBuf (InitCode ops args) = Just $ ConcreteBuf ops <> args +toBuf (RuntimeCode (ConcreteRuntimeCode ops)) = Just $ ConcreteBuf ops +toBuf (RuntimeCode (SymbolicRuntimeCode ops)) = Just $ Expr.fromList ops + +codeloc :: EVM s CodeLocation +codeloc = do + vm <- get + pure (vm.state.contract, vm.state.pc) + +createAddress :: Expr EAddr -> Maybe W64 -> EVM s (Expr EAddr) +createAddress (LitAddr a) (Just n) = pure $ Concrete.createAddress a n +createAddress (GVar _) _ = internalError "Unexpected GVar" +createAddress _ _ = freshSymAddr + +create2Address :: Expr EAddr -> W256 -> ByteString -> EVM s (Expr EAddr) +create2Address (LitAddr a) s b = pure $ Concrete.create2Address a s b +create2Address (SymAddr _) _ _ = freshSymAddr +create2Address (GVar _) _ _ = internalError "Unexpected GVar" + +freshSymAddr :: EVM s (Expr EAddr) +freshSymAddr = do + modifying (#env % #freshAddresses) (+ 1) + n <- use (#env % #freshAddresses) + pure $ SymAddr ("freshSymAddr" <> (pack $ show n)) + +isPrecompileAddr :: Expr EAddr -> Bool +isPrecompileAddr = \case + LitAddr a -> 0x0 < a && a <= 0x09 + SymAddr _ -> False + GVar _ -> internalError "Unexpected GVar" + +-- * Arithmetic + +ceilDiv :: (Num a, Integral a) => a -> a -> a +ceilDiv m n = div (m + n - 1) n + +allButOne64th :: (Num a, Integral a) => a -> a +allButOne64th n = n - div n 64 + +log2 :: FiniteBits b => b -> Int +log2 x = finiteBitSize x - 1 - countLeadingZeros x + +writeMemory :: MutableMemory s -> Int -> ByteString -> EVM s () +writeMemory memory offset buf = do + memory' <- expandMemory (offset + BS.length buf) + mapM_ (uncurry (VUnboxed.Mutable.write memory')) + (zip [offset..] (BS.unpack buf)) + where + expandMemory targetSize = do + let toAlloc = targetSize - VUnboxed.Mutable.length memory + if toAlloc > 0 then do + memory' <- VUnboxed.Mutable.grow memory toAlloc + assign (#state % #memory) (ConcreteMemory memory') + pure memory' + else + pure memory + +freezeMemory :: MutableMemory s -> EVM s (Expr Buf) +freezeMemory memory = + ConcreteBuf . BS.pack . VUnboxed.toList <$> VUnboxed.freeze memory diff --git a/src/EVM/ABI.hs b/src/EVM/ABI.hs --- a/src/EVM/ABI.hs +++ b/src/EVM/ABI.hs @@ -37,6 +37,7 @@ , SolError (..) , Anonymity (..) , Indexed (..) + , Sig(..) , putAbi , getAbi , getAbiSeq @@ -82,13 +83,17 @@ import Data.Vector qualified as Vector import Data.Word (Word32) import GHC.Generics (Generic) - import Test.QuickCheck hiding ((.&.), label) + import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P import Text.ParserCombinators.ReadP import Witch (unsafeInto, into) +-- | A method name, and the (ordered) types of it's arguments +data Sig = Sig Text [AbiType] + deriving (Show, Eq) + data AbiValue = AbiUInt Int Word256 | AbiInt Int Int256 @@ -410,80 +415,6 @@ <* skip ((roundTo32Bytes n) - n) where n = fromIntegral i --- QuickCheck instances - -genAbiValue :: AbiType -> Gen AbiValue -genAbiValue = \case - AbiUIntType n -> AbiUInt n <$> genUInt n - AbiIntType n -> do - x <- genUInt n - pure $ AbiInt n (signedWord (x - 2^(n-1))) - AbiAddressType -> - AbiAddress . fromIntegral <$> genUInt 20 - AbiBoolType -> - elements [AbiBool False, AbiBool True] - AbiBytesType n -> - do xs <- replicateM n arbitrary - pure (AbiBytes n (BS.pack xs)) - AbiBytesDynamicType -> - AbiBytesDynamic . BS.pack <$> listOf arbitrary - AbiStringType -> - AbiString . BS.pack <$> listOf arbitrary - AbiArrayDynamicType t -> - do xs <- listOf1 (scale (`div` 2) (genAbiValue t)) - pure (AbiArrayDynamic t (Vector.fromList xs)) - AbiArrayType n t -> - AbiArray n t . Vector.fromList <$> - replicateM n (scale (`div` 2) (genAbiValue t)) - AbiTupleType ts -> - AbiTuple <$> mapM genAbiValue ts - AbiFunctionType -> - do xs <- replicateM 24 arbitrary - pure (AbiFunction (BS.pack xs)) - where - genUInt :: Int -> Gen Word256 - genUInt n = arbitraryIntegralWithMax (2^n-1) :: Gen Word256 - -instance Arbitrary AbiType where - arbitrary = oneof - [ (AbiUIntType . (* 8)) <$> choose (1, 32) - , (AbiIntType . (* 8)) <$> choose (1, 32) - , pure AbiAddressType - , pure AbiBoolType - , AbiBytesType <$> choose (1,32) - , pure AbiBytesDynamicType - , pure AbiStringType - , AbiArrayDynamicType <$> scale (`div` 2) arbitrary - , AbiArrayType - <$> (getPositive <$> arbitrary) - <*> scale (`div` 2) arbitrary - ] - -instance Arbitrary AbiValue where - arbitrary = arbitrary >>= genAbiValue - shrink = \case - AbiArrayDynamic t v -> - Vector.toList v ++ - map (AbiArrayDynamic t . Vector.fromList) - (shrinkList shrink (Vector.toList v)) - AbiBytesDynamic b -> AbiBytesDynamic . BS.pack <$> shrinkList shrinkIntegral (BS.unpack b) - AbiString b -> AbiString . BS.pack <$> shrinkList shrinkIntegral (BS.unpack b) - AbiBytes n a | n <= 32 -> shrink $ AbiUInt (n * 8) (word256 a) - --bytesN for N > 32 don't really exist right now anyway.. - AbiBytes _ _ | otherwise -> [] - AbiArray _ t v -> - Vector.toList v ++ - map (\x -> AbiArray (length x) t (Vector.fromList x)) - (shrinkList shrink (Vector.toList v)) - AbiTuple v -> Vector.toList $ AbiTuple . Vector.fromList . shrink <$> v - AbiUInt n a -> AbiUInt n <$> (shrinkIntegral a) - AbiInt n a -> AbiInt n <$> (shrinkIntegral a) - AbiBool b -> AbiBool <$> shrink b - AbiAddress a -> [AbiAddress 0xacab, AbiAddress 0xdeadbeef, AbiAddress 0xbabeface] - <> (AbiAddress <$> shrinkIntegral a) - AbiFunction b -> shrink $ AbiBytes 24 b - - -- Bool synonym with custom read instance -- to be able to parse lower case 'false' and 'true' newtype Boolz = Boolz Bool @@ -557,7 +488,7 @@ then NoVals else let vs = decodeStaticArgs 0 (length tps) buf - allLit = Prelude.and . (fmap isLitWord) $ vs + allLit = Prelude.and (fmap isLitWord vs) asBS = mconcat $ fmap word256Bytes (mapMaybe maybeLitWord vs) in if not allLit then SAbi vs @@ -573,6 +504,78 @@ decodeStaticArgs offset numArgs b = [readWord (Lit . unsafeInto $ i) b | i <- [offset,(offset+32) .. (offset + (numArgs-1)*32)]] +-- QuickCheck instances + +genAbiValue :: AbiType -> Gen AbiValue +genAbiValue = \case + AbiUIntType n -> AbiUInt n <$> genUInt n + AbiIntType n -> do + x <- genUInt n + pure $ AbiInt n (signedWord (x - 2^(n-1))) + AbiAddressType -> + AbiAddress . fromIntegral <$> genUInt 20 + AbiBoolType -> + elements [AbiBool False, AbiBool True] + AbiBytesType n -> + do xs <- replicateM n arbitrary + pure (AbiBytes n (BS.pack xs)) + AbiBytesDynamicType -> + AbiBytesDynamic . BS.pack <$> listOf arbitrary + AbiStringType -> + AbiString . BS.pack <$> listOf arbitrary + AbiArrayDynamicType t -> + do xs <- listOf1 (scale (`div` 2) (genAbiValue t)) + pure (AbiArrayDynamic t (Vector.fromList xs)) + AbiArrayType n t -> + AbiArray n t . Vector.fromList <$> + replicateM n (scale (`div` 2) (genAbiValue t)) + AbiTupleType ts -> + AbiTuple <$> mapM genAbiValue ts + AbiFunctionType -> + do xs <- replicateM 24 arbitrary + pure (AbiFunction (BS.pack xs)) + where + genUInt :: Int -> Gen Word256 + genUInt n = arbitraryIntegralWithMax (2^n-1) :: Gen Word256 + +instance Arbitrary AbiType where + arbitrary = oneof + [ (AbiUIntType . (* 8)) <$> choose (1, 32) + , (AbiIntType . (* 8)) <$> choose (1, 32) + , pure AbiAddressType + , pure AbiBoolType + , AbiBytesType <$> choose (1,32) + , pure AbiBytesDynamicType + , pure AbiStringType + , AbiArrayDynamicType <$> scale (`div` 2) arbitrary + , AbiArrayType + <$> (getPositive <$> arbitrary) + <*> scale (`div` 2) arbitrary + ] + +instance Arbitrary AbiValue where + arbitrary = arbitrary >>= genAbiValue + shrink = \case + AbiArrayDynamic t v -> + Vector.toList v ++ + map (AbiArrayDynamic t . Vector.fromList) + (shrinkList shrink (Vector.toList v)) + AbiBytesDynamic b -> AbiBytesDynamic . BS.pack <$> shrinkList shrinkIntegral (BS.unpack b) + AbiString b -> AbiString . BS.pack <$> shrinkList shrinkIntegral (BS.unpack b) + AbiBytes n a | n <= 32 -> shrink $ AbiUInt (n * 8) (word256 a) + --bytesN for N > 32 don't really exist right now anyway.. + AbiBytes _ _ | otherwise -> [] + AbiArray _ t v -> + Vector.toList v ++ + map (\x -> AbiArray (length x) t (Vector.fromList x)) + (shrinkList shrink (Vector.toList v)) + AbiTuple v -> Vector.toList $ AbiTuple . Vector.fromList . shrink <$> v + AbiUInt n a -> AbiUInt n <$> (shrinkIntegral a) + AbiInt n a -> AbiInt n <$> (shrinkIntegral a) + AbiBool b -> AbiBool <$> shrink b + AbiAddress a -> [AbiAddress 0xacab, AbiAddress 0xdeadbeef, AbiAddress 0xbabeface] + <> (AbiAddress <$> shrinkIntegral a) + AbiFunction b -> shrink $ AbiBytes 24 b -- A modification of 'arbitrarySizedBoundedIntegral' quickcheck library -- which takes the maxbound explicitly rather than relying on a Bounded instance. diff --git a/src/EVM/Concrete.hs b/src/EVM/Concrete.hs --- a/src/EVM/Concrete.hs +++ b/src/EVM/Concrete.hs @@ -1,34 +1,23 @@ +{-# Language DataKinds #-} + module EVM.Concrete where +import Prelude hiding (Word) import EVM.RLP import EVM.Types -import Data.Bits (Bits(..), shiftR) -import Data.ByteString (ByteString, (!?)) +import Data.ByteString (ByteString) import Data.ByteString qualified as BS -import Data.Maybe (fromMaybe) -import Data.Word (Word8) -import Witch (unsafeInto) - -wordAt :: Int -> ByteString -> W256 -wordAt i bs = - word (padRight 32 (BS.drop i bs)) - -readByteOrZero :: Int -> ByteString -> Word8 -readByteOrZero i bs = fromMaybe 0 (bs !? i) +import Witch (unsafeInto, into) byteStringSliceWithDefaultZeroes :: Int -> Int -> ByteString -> ByteString byteStringSliceWithDefaultZeroes offset size bs = if size == 0 then "" - -- else if offset > BS.length bs - -- then BS.replicate size 0 - -- todo: this ^^ should work, investigate why it causes more GST fails else let bs' = BS.take size (BS.drop offset bs) in bs' <> BS.replicate (size - BS.length bs') 0 - sliceMemory :: W256 -> W256 -> ByteString -> ByteString sliceMemory o s = byteStringSliceWithDefaultZeroes (unsafeInto o) (unsafeInto s) @@ -49,24 +38,9 @@ in a <> a' <> c <> b' --- Copied from the standard library just to get specialization. --- We also use bit operations instead of modulo and multiply. --- (This operation was significantly slow.) -(^) :: W256 -> W256 -> W256 -x0 ^ y0 | y0 < 0 = errorWithoutStackTrace "Negative exponent" - | y0 == 0 = 1 - | otherwise = f x0 y0 - where - f x y | not (testBit y 0) = f (x * x) (y `shiftR` 1) - | y == 1 = x - | otherwise = g (x * x) ((y - 1) `shiftR` 1) x - g x y z | not (testBit y 0) = g (x * x) (y `shiftR` 1) z - | y == 1 = x * z - | otherwise = g (x * x) ((y - 1) `shiftR` 1) (x * z) - -createAddress :: Addr -> W256 -> Addr -createAddress a n = unsafeInto $ keccak' $ rlpList [rlpAddrFull a, rlpWord256 n] +createAddress :: Addr -> W64 -> Expr EAddr +createAddress a n = LitAddr . unsafeInto . keccak' . rlpList $ [rlpAddrFull a, rlpWord256 (into n)] -create2Address :: Addr -> W256 -> ByteString -> Addr -create2Address a s b = unsafeInto $ keccak' $ mconcat +create2Address :: Addr -> W256 -> ByteString -> Expr EAddr +create2Address a s b = LitAddr $ unsafeInto $ keccak' $ mconcat [BS.singleton 0xff, word160Bytes a, word256Bytes s, word256Bytes $ keccak' b] diff --git a/src/EVM/Dapp.hs b/src/EVM/Dapp.hs --- a/src/EVM/Dapp.hs +++ b/src/EVM/Dapp.hs @@ -1,24 +1,25 @@ +{-# Language DataKinds #-} + module EVM.Dapp where import EVM.ABI import EVM.Concrete -import EVM.Debug (srcMapCodePos) import EVM.Solidity import EVM.Types -import Control.Arrow ((>>>)) +import Control.Arrow ((>>>), second) 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.Maybe (mapMaybe) import Data.Sequence qualified as Seq -import Data.Text (Text, isPrefixOf, pack, unpack) +import Data.Text (Text, isPrefixOf, pack) import Data.Text.Encoding (encodeUtf8) import Data.Vector qualified as V +import Optics.Core import Witch (unsafeInto) data DappInfo = DappInfo @@ -27,7 +28,7 @@ , solcByHash :: Map W256 (CodeType, SolcContract) , solcByCode :: [(Code, SolcContract)] -- for contracts with `immutable` vars. , sources :: SourceCache - , unitTests :: [(Text, [(Test, [AbiType])])] + , unitTests :: [(Text, [Sig])] , abiMap :: Map FunctionSelector Method , eventMap :: Map W256 Event , errorMap :: Map W256 SolError @@ -44,14 +45,9 @@ data DappContext = DappContext { info :: DappInfo - , env :: Map Addr Contract + , env :: Map (Expr EAddr) Contract } -data Test = ConcreteTest Text | SymbolicTest Text | InvariantTest Text - -instance Show Test where - show t = unpack $ extractSig t - dappInfo :: FilePath -> BuildOutput -> DappInfo dappInfo root (BuildOutput (Contracts cs) sources) = let @@ -87,29 +83,28 @@ emptyDapp = dappInfo "" mempty -- Dapp unit tests are detected by searching within abi methods --- that begin with "test" or "prove", that are in a contract with +-- that begin with "check" or "prove", that are in a contract with -- the "IS_TEST()" abi marker, for a given regular expression. -- -- The regex is matched on the full test method name, including path -- and contract, i.e. "path/to/file.sol:TestContract.test_name()". --- --- Tests beginning with "test" are interpreted as concrete tests, whereas --- tests beginning with "prove" are interpreted as symbolic tests. unitTestMarkerAbi :: FunctionSelector unitTestMarkerAbi = abiKeccak (encodeUtf8 "IS_TEST()") -findAllUnitTests :: [SolcContract] -> [(Text, [(Test, [AbiType])])] -findAllUnitTests = findUnitTests ".*:.*\\.(test|prove|invariant).*" +findAllUnitTests :: [SolcContract] -> [(Text, [Sig])] +findAllUnitTests = findUnitTests ".*:.*\\.(check|prove).*" -mkTest :: Text -> Maybe Test -mkTest sig - | "test" `isPrefixOf` sig = Just (ConcreteTest sig) - | "prove" `isPrefixOf` sig = Just (SymbolicTest sig) - | "invariant" `isPrefixOf` sig = Just (InvariantTest sig) +mkSig :: Method -> Maybe Sig +mkSig method + | "prove" `isPrefixOf` testname = Just (Sig testname argtypes) + | "check" `isPrefixOf` testname = Just (Sig testname argtypes) | otherwise = Nothing + where + testname = method.methodSignature + argtypes = snd <$> method.inputs -findUnitTests :: Text -> ([SolcContract] -> [(Text, [(Test, [AbiType])])]) +findUnitTests :: Text -> ([SolcContract] -> [(Text, [Sig])]) findUnitTests match = concatMap $ \c -> case Map.lookup unitTestMarkerAbi c.abiMap of @@ -118,25 +113,16 @@ let testNames = unitTestMethodsFiltered (regexMatches match) c in [(c.contractName, testNames) | not (BS.null c.runtimeCode) && not (null testNames)] -unitTestMethodsFiltered :: (Text -> Bool) -> (SolcContract -> [(Test, [AbiType])]) +unitTestMethodsFiltered :: (Text -> Bool) -> (SolcContract -> [Sig]) unitTestMethodsFiltered matcher c = - let - testName method = c.contractName <> "." <> (extractSig (fst method)) - in - filter (matcher . testName) (unitTestMethods c) + let testName (Sig n _) = c.contractName <> "." <> n + in filter (matcher . testName) (unitTestMethods c) -unitTestMethods :: SolcContract -> [(Test, [AbiType])] +unitTestMethods :: SolcContract -> [Sig] unitTestMethods = (.abiMap) >>> Map.elems - >>> map (\f -> (mkTest f.methodSignature, snd <$> f.inputs)) - >>> filter (isJust . fst) - >>> fmap (first fromJust) - -extractSig :: Test -> Text -extractSig (ConcreteTest sig) = sig -extractSig (SymbolicTest sig) = sig -extractSig (InvariantTest sig) = sig + >>> mapMaybe mkSig traceSrcMap :: DappInfo -> Trace -> Maybe SrcMap traceSrcMap dapp trace = srcMap dapp trace.contract trace.opIx @@ -144,10 +130,11 @@ srcMap :: DappInfo -> Contract -> Int -> Maybe SrcMap srcMap dapp contr opIndex = do sol <- findSrc contr dapp - case contr.contractcode of - (InitCode _ _) -> - Seq.lookup opIndex sol.creationSrcmap - (RuntimeCode _) -> + case contr.code of + UnknownCode _ -> Nothing + InitCode _ _ -> + Seq.lookup opIndex sol.creationSrcmap + RuntimeCode _ -> Seq.lookup opIndex sol.runtimeSrcmap findSrc :: Contract -> DappInfo -> Maybe SolcContract @@ -155,10 +142,11 @@ hash <- maybeLitWord c.codehash case Map.lookup hash dapp.solcByHash of Just (_, v) -> Just v - Nothing -> lookupCode c.contractcode dapp + Nothing -> lookupCode c.code dapp lookupCode :: ContractCode -> DappInfo -> Maybe SolcContract +lookupCode (UnknownCode _) _ = Nothing lookupCode (InitCode c _) a = snd <$> Map.lookup (keccak' (stripBytecodeMetadata c)) a.solcByHash lookupCode (RuntimeCode (ConcreteRuntimeCode c)) a = @@ -174,7 +162,7 @@ compareCode :: ByteString -> Code -> Bool compareCode raw (Code template locs) = let holes' = sort [(start, len) | (Reference start len) <- locs] - insert at' len' bs = writeMemory (BS.replicate len' 0) (unsafeInto len') 0 (unsafeInto at') bs + insert loc len' bs = writeMemory (BS.replicate len' 0) (unsafeInto len') 0 (unsafeInto loc) bs refined = foldr (\(start, len) acc -> insert start len acc) raw holes' in BS.length raw == BS.length template && template == refined @@ -187,3 +175,15 @@ Nothing -> Left "" Just (fileName, lineIx) -> Right (pack fileName <> ":" <> pack (show lineIx)) + +srcMapCodePos :: SourceCache -> SrcMap -> Maybe (FilePath, Int) +srcMapCodePos cache sm = + fmap (second f) $ cache.files ^? ix sm.file + where + f v = BS.count 0xa (BS.take sm.offset v) + 1 + +srcMapCode :: SourceCache -> SrcMap -> Maybe ByteString +srcMapCode cache sm = + fmap f $ cache.files ^? ix sm.file + where + f (_, v) = BS.take (min 80 sm.length) (BS.drop sm.offset v) diff --git a/src/EVM/Debug.hs b/src/EVM/Debug.hs deleted file mode 100644 --- a/src/EVM/Debug.hs +++ /dev/null @@ -1,52 +0,0 @@ -module EVM.Debug where - -import EVM (bytecode) -import EVM.Expr (bufLength) -import EVM.Solidity (SrcMap(..), SourceCache(..)) -import EVM.Types (Contract(..), Addr) - -import Control.Arrow (second) -import Data.ByteString (ByteString) -import Data.ByteString qualified as ByteString -import Data.Map (Map) -import Data.Map qualified as Map -import Optics.Core -import Text.PrettyPrint.ANSI.Leijen -import Witch (unsafeInto) - -data Mode = Debug | Run | JsonTrace deriving (Eq, Show) - -object :: [(Doc, Doc)] -> Doc -object xs = - group $ lbrace - <> line - <> indent 2 (sep (punctuate (char ';') [k <+> equals <+> v | (k, v) <- xs])) - <> line - <> rbrace - -prettyContract :: Contract -> Doc -prettyContract c = - object - [ (text "codesize", text . show $ (bufLength (c ^. bytecode))) - , (text "codehash", text (show c.codehash)) - , (text "balance", int (unsafeInto c.balance)) - , (text "nonce", int (unsafeInto c.nonce)) - ] - -prettyContracts :: Map Addr Contract -> Doc -prettyContracts x = - object - (map (\(a, b) -> (text (show a), prettyContract b)) - (Map.toList x)) - -srcMapCodePos :: SourceCache -> SrcMap -> Maybe (FilePath, Int) -srcMapCodePos cache sm = - fmap (second f) $ cache.files ^? ix sm.file - where - f v = ByteString.count 0xa (ByteString.take sm.offset v) + 1 - -srcMapCode :: SourceCache -> SrcMap -> Maybe ByteString -srcMapCode cache sm = - fmap f $ cache.files ^? ix sm.file - where - f (_, v) = ByteString.take (min 80 sm.length) (ByteString.drop sm.offset v) diff --git a/src/EVM/Dev.hs b/src/EVM/Dev.hs deleted file mode 100644 --- a/src/EVM/Dev.hs +++ /dev/null @@ -1,498 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module: EVM.Dev -Description: Helpers for repl driven hevm hacking --} -module EVM.Dev where - -import Control.Monad.State.Strict hiding (state) -import Data.ByteString hiding (writeFile, zip) -import Data.Maybe (fromJust) -import Data.String.Here -import Data.Text.IO qualified as T -import Data.Text.Lazy.IO qualified as TL -import Data.Typeable (Typeable) -import System.Directory (withCurrentDirectory) -import System.Exit (exitFailure) - -import EVM -import EVM.Dapp (dappInfo) -import EVM.Expr (numBranches, simplify) -import EVM.Fetch qualified as Fetch -import EVM.FeeSchedule qualified as FeeSchedule -import EVM.Format (formatExpr) -import EVM.SMT -import EVM.Solvers -import EVM.Solidity -import EVM.SymExec -import EVM.Types -import EVM.UnitTest -import GHC.Conc -import Witch (unsafeInto) - -checkEquiv :: (Typeable a) => Expr a -> Expr a -> IO () -checkEquiv a b = withSolvers Z3 1 Nothing $ \s -> do - let smt = assertProps [a ./= b] - res <- checkSat s smt - print res - -runDappTest :: FilePath -> IO () -runDappTest root = - withCurrentDirectory root $ do - cores <- unsafeInto <$> getNumProcessors - let testFile = root <> "/out/dapp.sol.json" - Right (BuildOutput contracts _) <- readSolc DappTools root testFile - withSolvers Z3 cores Nothing $ \solvers -> do - opts <- testOpts solvers root testFile - res <- unitTest opts contracts Nothing - unless res exitFailure - -testOpts :: SolverGroup -> FilePath -> FilePath -> IO UnitTestOptions -testOpts solvers root testFile = do - srcInfo <- readSolc DappTools root testFile >>= \case - Left e -> internalError e - Right out -> - pure $ dappInfo root out - - params <- getParametersFromEnvironmentVariables Nothing - pure EVM.UnitTest.UnitTestOptions - { EVM.UnitTest.solvers = solvers - , EVM.UnitTest.rpcInfo = Nothing - , EVM.UnitTest.maxIter = Nothing - , EVM.UnitTest.askSmtIters = 1 - , EVM.UnitTest.smtTimeout = Nothing - , EVM.UnitTest.smtDebug = False - , EVM.UnitTest.solver = Nothing - , EVM.UnitTest.covMatch = Nothing - , EVM.UnitTest.verbose = Nothing - , EVM.UnitTest.match = ".*" - , EVM.UnitTest.maxDepth = Nothing - , EVM.UnitTest.fuzzRuns = 100 - , EVM.UnitTest.replay = Nothing - , EVM.UnitTest.vmModifier = id - , EVM.UnitTest.testParams = params - , EVM.UnitTest.dapp = srcInfo - , EVM.UnitTest.ffiAllowed = True - } - -doTest :: IO () -doTest = do - c <- testContract - reachable' False c - --e <- simplify <$> buildExpr c - --Prelude.putStrLn (formatExpr e) - -analyzeDai :: IO () -analyzeDai = do - d <- dai - reachable' False d - -daiExpr :: IO (Expr End) -daiExpr = do - d <- dai - withSolvers Z3 1 Nothing $ \s -> buildExpr s d - -analyzeVat :: IO () -analyzeVat = do - putStrLn "starting" - v <- vat - withSolvers Z3 1 Nothing $ \s -> do - e <- buildExpr s v - putStrLn $ "done (" <> show (numBranches e) <> " branches)" - reachable' False v - -analyzeDeposit :: IO () -analyzeDeposit = do - Just c <- solcRuntime "Deposit" - [i| - contract Deposit { - function deposit(uint256 deposit_count) external pure { - require(deposit_count < 2**32 - 1); - ++deposit_count; - bool found = false; - for (uint height = 0; height < 32; height++) { - if ((deposit_count & 1) == 1) { - found = true; - break; - } - deposit_count = deposit_count >> 1; - } - assert(found); - } - } - |] - withSolvers Z3 1 Nothing $ \s -> do - putStrLn "Exploring Contract" - e <- simplify <$> buildExpr s c - putStrLn "Writing AST" - T.writeFile "full.ast" (formatExpr e) - - -reachable' :: Bool -> ByteString -> IO () -reachable' smtdebug c = do - putStrLn "Exploring contract" - withSolvers Z3 4 Nothing $ \s -> do - full <- simplify <$> buildExpr s c - putStrLn $ "Explored contract (" <> (show $ numBranches full) <> " branches)" - --putStrLn $ formatExpr full - T.writeFile "full.ast" $ formatExpr full - putStrLn "Dumped to full.ast" - putStrLn "Checking reachability" - (qs, less) <- reachable s full - putStrLn $ "Checked reachability (" <> (show $ numBranches less) <> " reachable branches)" - T.writeFile "reachable.ast" $ formatExpr less - putStrLn "Dumped to reachable.ast" - --putStrLn $ formatExpr less - when smtdebug $ do - putStrLn "\n\nQueries\n\n" - forM_ qs $ \q -> do - putStrLn "\n\n-- Query --" - TL.putStrLn $ formatSMT2 q - - -showExpr :: ByteString -> IO () -showExpr c = do - withSolvers Z3 1 Nothing $ \s -> do - e <- buildExpr s c - T.putStrLn $ formatExpr (simplify e) - -summaryStore :: IO ByteString -summaryStore = do - let src = - [i| - contract A { - uint x; - function f(uint256 y) public { - unchecked { - x += y; - x += y; - } - } - } - |] - fmap fromJust (solcRuntime "A" src) - -safeAdd :: IO ByteString -safeAdd = do - let src = - [i| - contract SafeAdd { - function add(uint x, uint y) public pure returns (uint z) { - require((z = x + y) >= x); - } - } - |] - fmap fromJust (solcRuntime "SafeAdd" src) - - - -testContract :: IO ByteString -testContract = do - let src = - [i| - contract C { - uint x; - function set(uint v) public { - x = v + v; - } - } - |] - fmap fromJust (solcRuntime "C" src) - -vat :: IO ByteString -vat = do - let src = - [i| - /// vat.sol -- Dai CDP database - - // Copyright (C) 2018 Rain - // - // This program is free software: you can redistribute it and/or modify - // it under the terms of the GNU Affero General Public License as published by - // the Free Software Foundation, either version 3 of the License, or - // (at your option) any later version. - // - // This program is distributed in the hope that it will be useful, - // but WITHOUT ANY WARRANTY; without even the implied warranty of - // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - // GNU Affero General Public License for more details. - // - // You should have received a copy of the GNU Affero General Public License - // along with this program. If not, see . - - // FIXME: This contract was altered compared to the production version. - // It doesn't use LibNote anymore. - // New deployments of this contract will need to include custom events (TO DO). - - contract Vat { - // --- Auth --- - mapping (address => uint) public wards; - function rely(address usr) external auth { require(live == 1, "Vat/not-live"); wards[usr] = 1; } - function deny(address usr) external auth { require(live == 1, "Vat/not-live"); wards[usr] = 0; } - modifier auth { - require(wards[msg.sender] == 1, "Vat/not-authorized"); - _; - } - - mapping(address => mapping (address => uint)) public can; - function hope(address usr) external { can[msg.sender][usr] = 1; } - function nope(address usr) external { can[msg.sender][usr] = 0; } - function wish(address bit, address usr) internal view returns (bool) { - return either(bit == usr, can[bit][usr] == 1); - } - - // --- Data --- - struct Ilk { - uint256 Art; // Total Normalised Debt [wad] - uint256 rate; // Accumulated Rates [ray] - uint256 spot; // Price with Safety Margin [ray] - uint256 line; // Debt Ceiling [rad] - uint256 dust; // Urn Debt Floor [rad] - } - struct Urn { - uint256 ink; // Locked Collateral [wad] - uint256 art; // Normalised Debt [wad] - } - - mapping (bytes32 => Ilk) public ilks; - mapping (bytes32 => mapping (address => Urn )) public urns; - mapping (bytes32 => mapping (address => uint)) public gem; // [wad] - mapping (address => uint256) public dai; // [rad] - mapping (address => uint256) public sin; // [rad] - - uint256 public debt; // Total Dai Issued [rad] - uint256 public vice; // Total Unbacked Dai [rad] - uint256 public Line; // Total Debt Ceiling [rad] - uint256 public live; // Active Flag - - // --- Init --- - constructor() public { - wards[msg.sender] = 1; - live = 1; - } - - // --- Math --- - function _add(uint x, int y) internal pure returns (uint z) { - z = x + uint(y); - require(y >= 0 || z <= x); - require(y <= 0 || z >= x); - } - function _sub(uint x, int y) internal pure returns (uint z) { - z = x - uint(y); - require(y <= 0 || z <= x); - require(y >= 0 || z >= x); - } - function _mul(uint x, int y) internal pure returns (int z) { - z = int(x) * y; - require(int(x) >= 0); - require(y == 0 || z / y == int(x)); - } - function _add(uint x, uint y) internal pure returns (uint z) { - require((z = x + y) >= x); - } - function _sub(uint x, uint y) internal pure returns (uint z) { - require((z = x - y) <= x); - } - function _mul(uint x, uint y) internal pure returns (uint z) { - require(y == 0 || (z = x * y) / y == x); - } - - // --- Administration --- - function init(bytes32 ilk) external auth { - require(ilks[ilk].rate == 0, "Vat/ilk-already-init"); - ilks[ilk].rate = 10 ** 27; - } - function file(bytes32 what, uint data) external auth { - require(live == 1, "Vat/not-live"); - if (what == "Line") Line = data; - else revert("Vat/file-unrecognized-param"); - } - function file(bytes32 ilk, bytes32 what, uint data) external auth { - require(live == 1, "Vat/not-live"); - if (what == "spot") ilks[ilk].spot = data; - else if (what == "line") ilks[ilk].line = data; - else if (what == "dust") ilks[ilk].dust = data; - else revert("Vat/file-unrecognized-param"); - } - function cage() external auth { - live = 0; - } - - // --- Fungibility --- - function slip(bytes32 ilk, address usr, int256 wad) external auth { - gem[ilk][usr] = _add(gem[ilk][usr], wad); - } - function flux(bytes32 ilk, address src, address dst, uint256 wad) external { - require(wish(src, msg.sender), "Vat/not-allowed"); - gem[ilk][src] = _sub(gem[ilk][src], wad); - gem[ilk][dst] = _add(gem[ilk][dst], wad); - } - function move(address src, address dst, uint256 rad) external { - require(wish(src, msg.sender), "Vat/not-allowed"); - dai[src] = _sub(dai[src], rad); - dai[dst] = _add(dai[dst], rad); - } - - function either(bool x, bool y) internal pure returns (bool z) { - assembly{ z := or(x, y)} - } - function both(bool x, bool y) internal pure returns (bool z) { - assembly{ z := and(x, y)} - } - - // --- CDP Confiscation --- - function grab(bytes32 i, address u, address v, address w, int dink, int dart) external auth { - Urn storage urn = urns[i][u]; - Ilk storage ilk = ilks[i]; - - urn.ink = _add(urn.ink, dink); - urn.art = _add(urn.art, dart); - ilk.Art = _add(ilk.Art, dart); - - int dtab = _mul(ilk.rate, dart); - - gem[i][v] = _sub(gem[i][v], dink); - sin[w] = _sub(sin[w], dtab); - vice = _sub(vice, dtab); - } - } - |] - fmap fromJust (solcRuntime "Vat" src) - -initVm :: ByteString -> VM -initVm bs = vm - where - contractCode = RuntimeCode (ConcreteRuntimeCode bs) - c = Contract - { contractcode = contractCode - , balance = 0 - , nonce = 0 - , codehash = keccak (ConcreteBuf bs) - , opIxMap = mkOpIxMap contractCode - , codeOps = mkCodeOps contractCode - , external = False - } - vm = makeVm $ VMOpts - { contract = c - , calldata = (AbstractBuf "txdata", []) - , value = CallValue 0 - , address = Addr 0xffffffffffffffff - , caller = Lit 0 - , origin = Addr 0xffffffffffffffff - , gas = 0xffffffffffffffff - , gaslimit = 0xffffffffffffffff - , initialStorage = AbstractStore - , baseFee = 0 - , priorityFee = 0 - , coinbase = 0 - , number = 0 - , timestamp = Var "timestamp" - , blockGaslimit = 0 - , gasprice = 0 - , maxCodeSize = 0xffffffff - , prevRandao = 420 - , schedule = FeeSchedule.berlin - , chainId = 1 - , create = False - , txAccessList = mempty - , allowFFI = False - } - - --- | Builds the Expr for the given evm bytecode object -buildExpr :: SolverGroup -> ByteString -> IO (Expr End) -buildExpr solvers bs = interpret (Fetch.oracle solvers Nothing) Nothing 1 Naive (initVm bs) runExpr - -dai :: IO ByteString -dai = do - let src = - [i| - contract Dai { - // --- Auth --- - mapping (address => uint) public wards; - function rely(address guy) external auth { wards[guy] = 1; } - function deny(address guy) external auth { wards[guy] = 0; } - modifier auth { - require(wards[msg.sender] == 1, "Dai/not-authorized"); - _; - } - - // --- ERC20 Data --- - string public constant name = "Dai Stablecoin"; - string public constant symbol = "DAI"; - 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); - - // --- Math --- - function add(uint x, uint y) internal pure returns (uint z) { - require((z = x + y) >= x); - } - function sub(uint x, uint y) internal pure returns (uint z) { - require((z = x - y) <= x); - } - - // --- EIP712 niceties --- - constructor() public { - wards[msg.sender] = 1; - } - - // --- 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, "Dai/insufficient-balance"); - if (src != msg.sender && allowance[src][msg.sender] != type(uint).max) { - require(allowance[src][msg.sender] >= wad, "Dai/insufficient-allowance"); - allowance[src][msg.sender] = sub(allowance[src][msg.sender], wad); - } - balanceOf[src] = sub(balanceOf[src], wad); - balanceOf[dst] = add(balanceOf[dst], wad); - emit Transfer(src, dst, wad); - return true; - } - function mint(address usr, uint wad) external auth { - balanceOf[usr] = add(balanceOf[usr], wad); - totalSupply = add(totalSupply, wad); - emit Transfer(address(0), usr, wad); - } - function burn(address usr, uint wad) external { - require(balanceOf[usr] >= wad, "Dai/insufficient-balance"); - if (usr != msg.sender && allowance[usr][msg.sender] != type(uint).max) { - require(allowance[usr][msg.sender] >= wad, "Dai/insufficient-allowance"); - allowance[usr][msg.sender] = sub(allowance[usr][msg.sender], wad); - } - balanceOf[usr] = sub(balanceOf[usr], wad); - totalSupply = sub(totalSupply, wad); - emit Transfer(usr, address(0), wad); - } - function approve(address usr, uint wad) external returns (bool) { - allowance[msg.sender][usr] = wad; - emit Approval(msg.sender, usr, wad); - return true; - } - - // --- Alias --- - function push(address usr, uint wad) external { - transferFrom(msg.sender, usr, wad); - } - function pull(address usr, uint wad) external { - transferFrom(usr, msg.sender, wad); - } - function move(address src, address dst, uint wad) external { - transferFrom(src, dst, wad); - } - } - |] - fmap fromJust (solcRuntime "Dai" src) diff --git a/src/EVM/Exec.hs b/src/EVM/Exec.hs --- a/src/EVM/Exec.hs +++ b/src/EVM/Exec.hs @@ -1,32 +1,33 @@ module EVM.Exec where -import EVM +import EVM hiding (createAddress) import EVM.Concrete (createAddress) -import EVM.FeeSchedule qualified as FeeSchedule -import EVM.Expr (litAddr) +import EVM.FeeSchedule (feeSchedule) import EVM.Types import Control.Monad.Trans.State.Strict (get, State) import Data.ByteString (ByteString) import Data.Maybe (isNothing) import Optics.Core +import Control.Monad.ST (ST) ethrunAddress :: Addr ethrunAddress = Addr 0x00a329c0648769a73afac7f9381e08fb43dbea72 -vmForEthrunCreation :: ByteString -> VM +vmForEthrunCreation :: ByteString -> ST s (VM s) vmForEthrunCreation creationCode = (makeVm $ VMOpts { contract = initialContract (InitCode creationCode mempty) + , otherContracts = [] , calldata = mempty - , value = (Lit 0) - , initialStorage = EmptyStore + , value = Lit 0 + , baseState = EmptyBase , address = createAddress ethrunAddress 1 - , caller = litAddr ethrunAddress - , origin = ethrunAddress - , coinbase = 0 + , caller = LitAddr ethrunAddress + , origin = LitAddr ethrunAddress + , coinbase = LitAddr 0 , number = 0 - , timestamp = (Lit 0) + , timestamp = Lit 0 , blockGaslimit = 0 , gasprice = 0 , prevRandao = 42069 @@ -35,29 +36,29 @@ , baseFee = 0 , priorityFee = 0 , maxCodeSize = 0xffffffff - , schedule = FeeSchedule.berlin + , schedule = feeSchedule , chainId = 1 , create = False , txAccessList = mempty , allowFFI = False - }) & set (#env % #contracts % at ethrunAddress) + }) <&> set (#env % #contracts % at (LitAddr ethrunAddress)) (Just (initialContract (RuntimeCode (ConcreteRuntimeCode "")))) -exec :: State VM VMResult +exec :: EVM s (VMResult s) exec = do vm <- get case vm.result of Nothing -> exec1 >> exec Just r -> pure r -run :: State VM VM +run :: EVM s (VM s) run = do vm <- get case vm.result of Nothing -> exec1 >> run Just _ -> pure vm -execWhile :: (VM -> Bool) -> State VM Int +execWhile :: (VM s -> Bool) -> State (VM s) Int execWhile p = go 0 where go i = do diff --git a/src/EVM/Expr.hs b/src/EVM/Expr.hs --- a/src/EVM/Expr.hs +++ b/src/EVM/Expr.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE PatternSynonyms #-} {-| Helper functions for working with Expr instances. @@ -7,26 +8,36 @@ module EVM.Expr where import Prelude hiding (LT, GT) +import Control.Monad.ST import Data.Bits hiding (And, Xor) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.DoubleWord (Int256, Word256(Word256), Word128(Word128)) import Data.List import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, isJust, fromMaybe) import Data.Semigroup (Any, Any(..), getAny) import Data.Vector qualified as V +import Data.Vector (Vector) +import Data.Vector.Mutable qualified as MV +import Data.Vector.Mutable (MVector) import Data.Vector.Storable qualified as VS import Data.Vector.Storable.ByteString import Data.Word (Word8, Word32) import Witch (unsafeInto, into, tryFrom) +import Data.Containers.ListUtils (nubOrd) +import Control.Monad.State import Optics.Core import EVM.Traversals import EVM.Types +-- ** Constants ** +maxLit :: W256 +maxLit = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + -- ** Stack Ops ** --------------------------------------------------------------------------------- @@ -335,7 +346,7 @@ -- concrete indicies & abstract src (may produce a concrete result if we are -- copying from a concrete region of src) copySlice s@(Lit srcOffset) d@(Lit dstOffset) sz@(Lit size) src ds@(ConcreteBuf dst) - | dstOffset < maxBytes, size < maxBytes = let + | dstOffset < maxBytes, size < maxBytes, srcOffset + (size-1) > srcOffset = let hd = padRight (unsafeInto dstOffset) $ BS.take (unsafeInto dstOffset) dst sl = [readByte (Lit i) src | i <- [srcOffset .. srcOffset + (size - 1)]] tl = BS.drop (unsafeInto dstOffset + unsafeInto size) dst @@ -362,11 +373,14 @@ writeWord :: Expr EWord -> Expr EWord -> Expr Buf -> Expr Buf +writeWord o@(Lit offset) (WAddr (LitAddr val)) b@(ConcreteBuf _) + | offset < maxBytes && offset + 32 < maxBytes + = writeWord o (Lit $ into val) b writeWord (Lit offset) (Lit val) (ConcreteBuf "") - | offset + 32 < maxBytes + | offset < maxBytes && offset + 32 < maxBytes = ConcreteBuf $ BS.replicate (unsafeInto offset) 0 <> word256Bytes val writeWord o@(Lit offset) v@(Lit val) buf@(ConcreteBuf src) - | offset + 32 < maxBytes + | offset < maxBytes && offset + 32 < maxBytes = ConcreteBuf $ (padRight (unsafeInto offset) $ BS.take (unsafeInto offset) src) <> word256Bytes val <> BS.drop ((unsafeInto offset) + 32) src @@ -418,31 +432,6 @@ Nothing -> internalError "cannot compute length of open expression" go l (GVar (BufVar a)) = EVM.Expr.max l (BufLength (GVar (BufVar a))) --- | If a buffer has a concrete prefix, we return it's length here -concPrefix :: Expr Buf -> Maybe Integer -concPrefix (CopySlice (Lit srcOff) (Lit _) (Lit _) src (ConcreteBuf "")) = do - sz <- go 0 src - pure . into $ (unsafeInto sz) - srcOff - where - go :: W256 -> Expr Buf -> Maybe Integer - -- base cases - go _ (AbstractBuf _) = Nothing - go l (ConcreteBuf b) = Just . into $ Prelude.max (unsafeInto . BS.length $ b) l - - -- writes to a concrete index - go l (WriteWord (Lit idx) (Lit _) b) = go (Prelude.max l (idx + 32)) b - go l (WriteByte (Lit idx) (LitByte _) b) = go (Prelude.max l (idx + 1)) b - go l (CopySlice _ (Lit dstOffset) (Lit size) _ dst) = go (Prelude.max (dstOffset + size) l) dst - - -- writes to an abstract index are ignored - go l (WriteWord _ _ b) = go l b - go l (WriteByte _ _ b) = go l b - go _ (CopySlice _ _ _ _ _) = internalError "cannot compute a concrete prefix length for nested copySlice expressions" - go _ (GVar _) = internalError "cannot calculate a concrete prefix of an open expression" -concPrefix (ConcreteBuf b) = Just (into . BS.length $ b) -concPrefix e = internalError $ "cannot compute a concrete prefix length for: " <> show e - - -- | Return the minimum possible length of a buffer. In the case of an -- abstract buffer, it is the largest write that is made on a concrete -- location. Parameterized by an environment for buffer variables. @@ -465,6 +454,51 @@ b <- Map.lookup a bufEnv go l b +-- returns the largest prefix that is guaranteed to be concrete (if one exists) +-- partial: will hard error if we encounter an input buf with a concrete size > 500mb +-- partial: will hard error if the prefix is > 500mb +concretePrefix :: Expr Buf -> Vector Word8 +concretePrefix b = V.create $ do + v <- MV.new (fromMaybe 1024 inputLen) + (filled, v') <- go 0 v + pure $ MV.take filled v' + where + + -- if our prefix is > 500mb then we have other issues and should just bail... + maxIdx :: Num i => i + maxIdx = 500 * (10 ^ (6 :: Int)) + + -- attempts to compute a concrete length for the input buffer + inputLen :: Maybe Int + inputLen = case bufLength b of + Lit s -> if s > maxIdx + then internalError "concretePrefix: input buffer size exceeds 500mb" + -- unafeInto: s is <= 500,000,000 + else Just (unsafeInto s) + _ -> Nothing + + -- recursively reads succesive bytes from `b` until we reach a symbolic + -- byte returns the larged index read from and a reference to the mutable + -- vec (might not be the same as the input because of the call to grow) + go :: forall s . Int -> MVector s Word8 -> ST s (Int, MVector s Word8) + go i v + -- if the prefix is very large then bail + | i >= maxIdx = internalError "concretePrefix: prefix size exceeds 500mb" + -- if the input buffer has a concrete size, then don't read past the end + | Just mr <- inputLen, i >= mr = pure (i, v) + -- double the size of the vector if we've reached the end + | i >= MV.length v = do + v' <- MV.grow v (MV.length v) + go i v' + -- read the byte at `i` in `b` into `v` if it is concrete, or halt if we've reached a symbolic byte + -- unsafeInto: i will always be positive + | otherwise = case readByte (Lit . unsafeInto $ i) b of + LitByte byte -> do + MV.write v i byte + go (i+1) v + _ -> pure (i, v) + + word256At :: Expr EWord -> Lens (Expr Buf) (Expr Buf) (Expr EWord) (Expr EWord) word256At i = lens getter setter where getter = readWord i @@ -555,12 +589,17 @@ WriteByte i v prev -> WriteByte i v (stripWrites off size prev) WriteWord i v prev -> WriteWord i v (stripWrites off size prev) CopySlice srcOff dstOff size' src dst -> CopySlice srcOff dstOff size' src dst - GVar _ -> internalError "unexpected GVar in stripWrites" + GVar _ -> internalError "Unexpected GVar in stripWrites" -- ** Storage ** ----------------------------------------------------------------------------------- +readStorage' :: Expr EWord -> Expr Storage -> Expr EWord +readStorage' loc store = case readStorage loc store of + Just v -> v + Nothing -> Lit 0 + -- | Reads the word at the given slot from the given storage expression. -- -- Note that we return a Nothing instead of a 0x0 if we are reading from a @@ -568,74 +607,159 @@ -- no explicit writes to the requested slot. This makes implementing rpc -- storage lookups much easier. If the store is backed by an AbstractStore we -- always return a symbolic value. -readStorage :: Expr EWord -> Expr EWord -> Expr Storage -> Maybe (Expr EWord) -readStorage _ _ EmptyStore = Nothing -readStorage addr slot store@(ConcreteStore s) = case (addr, slot) of - (Lit a, Lit l) -> do - ctrct <- Map.lookup a s - val <- Map.lookup l ctrct - pure $ Lit val - _ -> Just $ SLoad addr slot store -readStorage addr' slot' s@AbstractStore = Just $ SLoad addr' slot' s -readStorage addr' slot' s@(SStore addr slot val prev) = - if addr == addr' - then if slot == slot' - -- if address and slot match then we return the val in this write - then Just val - else case (slot, slot') of - -- if the slots don't match and are lits, we can skip this write - (Lit _, Lit _) -> readStorage addr' slot' prev - -- if the slots don't match syntactically and are abstract then we can't skip this write - _ -> Just $ SLoad addr' slot' s - else case (addr, addr') of - -- if the the addresses don't match and are lits, we can skip this write - (Lit _, Lit _) -> readStorage addr' slot' prev - -- if the the addresses don't match syntactically and are abstract then we can't skip this write - _ -> Just $ SLoad addr' slot' s -readStorage _ _ (GVar _) = internalError "Can't read from a GVar" +readStorage :: Expr EWord -> Expr Storage -> Maybe (Expr EWord) +readStorage w st = go (simplify w) st + where + go :: Expr EWord -> Expr Storage -> Maybe (Expr EWord) + go _ (GVar _) = internalError "Can't read from a GVar" + go slot s@(AbstractStore _) = Just $ SLoad slot s + go (Lit l) (ConcreteStore s) = Lit <$> Map.lookup l s + go slot store@(ConcreteStore _) = Just $ SLoad slot store + go slot s@(SStore prevSlot val prev) = case (prevSlot, slot) of + -- if address and slot match then we return the val in this write + _ | prevSlot == slot -> Just val -readStorage' :: Expr EWord -> Expr EWord -> Expr Storage -> Expr EWord -readStorage' addr loc store = case readStorage addr loc store of - Just v -> v - Nothing -> Lit 0 + -- if the slots don't match (see previous guard) and are lits, we can skip this write + (Lit _, Lit _) -> go slot prev + -- slot is for a map + map -> skip write + (MappingSlot idA _, MappingSlot idB _) | idsDontMatch idA idB -> go slot prev + (MappingSlot _ keyA, MappingSlot _ keyB) | surelyNotEq keyA keyB -> go slot prev + -- special case of array + map -> skip write + (ArraySlotWithOffset idA _, Keccak64Bytes) | BS.length idA /= 64 -> go slot prev + (ArraySlotZero idA, Keccak64Bytes) | BS.length idA /= 64 -> go slot prev + + -- special case of array + map -> skip write + (Keccak64Bytes, ArraySlotWithOffset idA _) | BS.length idA /= 64 -> go slot prev + (Keccak64Bytes, ArraySlotZero idA) | BS.length idA /= 64 -> go slot prev + + -- Fixed SMALL value will never match Keccak (well, it might, but that's VERY low chance) + (Lit a, Keccak _) | a < 256 -> go slot prev + (Keccak _, Lit a) | a < 256 -> go slot prev + + -- the chance of adding a value <= 2^32 to any given keccack output + -- leading to an overflow is effectively zero. the chance of an overflow + -- occuring here is 2^32/2^256 = 2^-224, which is close enough to zero + -- for our purposes. This lets us completely simplify reads from write + -- chains involving writes to arrays at literal offsets. + (Lit a, Add (Lit b) (Keccak _) ) | a < 256, b < maxW32 -> go slot prev + (Add (Lit a) (Keccak _) , Lit b) | a < 256, b < maxW32 -> go slot prev + + -- Finding two Keccaks that are < 256 away from each other should be VERY hard + -- This simplification allows us to deal with maps of structs + (Add (Lit a2) (Keccak _), Add (Lit b2) (Keccak _)) | a2 /= b2, abs(a2-b2) < 256 -> go slot prev + (Add (Lit a2) (Keccak _), (Keccak _)) | a2 > 0, a2 < 256 -> go slot prev + ((Keccak _), Add (Lit b2) (Keccak _)) | b2 > 0, b2 < 256 -> go slot prev + + -- case of array + array, but different id's or different concrete offsets + -- zero offs vs zero offs + (ArraySlotZero idA, ArraySlotZero idB) | idA /= idB -> go slot prev + -- zero offs vs non-zero offs + (ArraySlotZero idA, ArraySlotWithOffset idB _) | idA /= idB -> go slot prev + (ArraySlotZero _, ArraySlotWithOffset _ (Lit offB)) | offB /= 0 -> go slot prev + -- non-zero offs vs zero offs + (ArraySlotWithOffset idA _, ArraySlotZero idB) | idA /= idB -> go slot prev + (ArraySlotWithOffset _ (Lit offA), ArraySlotZero _) | offA /= 0 -> go slot prev + -- non-zero offs vs non-zero offs + (ArraySlotWithOffset idA _, ArraySlotWithOffset idB _) | idA /= idB -> go slot prev + + (ArraySlotWithOffset _ offA, ArraySlotWithOffset _ offB) | surelyNotEq offA offB -> go slot prev + + -- we are unable to determine statically whether or not we can safely move deeper in the write chain, so return an abstract term + _ -> Just $ SLoad slot s + + surelyNotEq :: Expr a -> Expr a -> Bool + surelyNotEq (Lit a) (Lit b) = a /= b + -- never equal: x+y (y is concrete) vs x+z (z is concrete), y!=z + surelyNotEq (Add (Lit l1) v1) (Add (Lit l2) v2) = l1 /= l2 && v1 == v2 + -- never equal: x+y (y is concrete, non-zero) vs x + surelyNotEq v1 (Add (Lit l2) v2) = l2 /= 0 && v1 == v2 + surelyNotEq (Add (Lit l1) v1) v2 = l1 /= 0 && v1 == v2 + surelyNotEq _ _ = False + + maxW32 :: W256 + maxW32 = into (maxBound :: Word32) + +-- storage slots for maps are determined by (keccak (bytes32(key) ++ bytes32(id))) +pattern MappingSlot :: ByteString -> Expr EWord -> Expr EWord +pattern MappingSlot id key = Keccak (CopySlice (Lit 0) (Lit 0) (Lit 64) (WriteWord (Lit 0) key (ConcreteBuf id)) (ConcreteBuf "")) + +-- keccak of any 64 bytes value +pattern Keccak64Bytes :: Expr EWord +pattern Keccak64Bytes <- Keccak (CopySlice (Lit 0) (Lit 0) (Lit 64) _ (ConcreteBuf "")) + +-- storage slots for arrays are determined by (keccak(bytes32(id)) + offset) +pattern ArraySlotWithOffset :: ByteString -> Expr EWord -> Expr EWord +pattern ArraySlotWithOffset id offset = Add (Keccak (ConcreteBuf id)) offset + +-- special pattern to match the 0th element because the `Add` term gets simplified out +pattern ArraySlotZero :: ByteString -> Expr EWord +pattern ArraySlotZero id = Keccak (ConcreteBuf id) + +-- checks if two mapping ids match or not +idsDontMatch :: ByteString -> ByteString -> Bool +idsDontMatch a b = BS.length a >= 64 && BS.length b >= 64 && diff32to64Byte a b + where + diff32to64Byte :: ByteString -> ByteString -> Bool + diff32to64Byte x y = x32 /= y32 + where + x32 = BS.take 32 $ BS.drop 32 x + y32 = BS.take 32 $ BS.drop 32 y + +slotPos :: Word8 -> ByteString +slotPos pos = BS.pack ((replicate 31 (0::Word8))++[pos]) + +-- | Turns Literals into keccak(bytes32(id)) + offset (i.e. writes to arrays) +structureArraySlots :: Expr a -> Expr a +structureArraySlots e = mapExpr go e + where + go :: Expr a -> Expr a + go orig@(Lit key) = case litToArrayPreimage key of + Just (array, offset) -> ArraySlotWithOffset (slotPos array) (Lit offset) + _ -> orig + go a = a + +-- Takes in value, checks if it's within 256 of a pre-computed array hash value +-- if it is, it returns (array_number, offset) +litToArrayPreimage :: W256 -> Maybe (Word8, W256) +litToArrayPreimage val = go preImages + where + go :: [(W256, Word8)] -> Maybe (Word8, W256) + go ((image, preimage):ax) = if val >= image && val-image <= 255 then Just (preimage, val-image) + else go ax + go [] = Nothing + -- | Writes a value to a key in a storage expression. -- -- Concrete writes on top of a concrete or empty store will produce a new -- ConcreteStore, otherwise we add a new write to the storage expression. -writeStorage :: Expr EWord -> Expr EWord -> Expr EWord -> Expr Storage -> Expr Storage -writeStorage a@(Lit addr) k@(Lit key) v@(Lit val) store = case store of - EmptyStore -> ConcreteStore (Map.singleton addr (Map.singleton key val)) - ConcreteStore s -> let - ctrct = Map.findWithDefault Map.empty addr s - in ConcreteStore (Map.insert addr (Map.insert key val ctrct) s) - _ -> SStore a k v store -writeStorage addr key val store@(SStore addr' key' val' prev) - | addr == addr' +writeStorage :: Expr EWord -> Expr EWord -> Expr Storage -> Expr Storage +writeStorage k@(Lit key) v@(Lit val) store = case store of + ConcreteStore s -> ConcreteStore (Map.insert key val s) + _ -> SStore k v store +writeStorage key val store@(SStore key' val' prev) = if key == key' -- if we're overwriting an existing location, then drop the write - then SStore addr key val prev - else case (addr, addr', key, key') of + then SStore key val prev + else case (key, key') of -- if we can know statically that the new write doesn't overlap with the existing write, then we continue down the write chain -- we impose an ordering relation on the writes that we push down to ensure termination when this routine is called from the simplifier - (Lit a, Lit a', Lit k, Lit k') -> if a > a' || (a == a' && k > k') - then SStore addr' key' val' (writeStorage addr key val prev) - else SStore addr key val store + (Lit k, Lit k') -> if k > k' + then SStore key' val' (writeStorage key val prev) + else SStore key val store -- otherwise stack a new write on top of the the existing write chain - _ -> SStore addr key val store - | otherwise - = case (addr, addr') of - -- if we can know statically that the new write doesn't overlap with the existing write, then we continue down the write chain - -- once again we impose an ordering relation on the pushed down writes to ensure termination - (Lit a, Lit a') -> if a > a' - then SStore addr' key' val' (writeStorage addr key val prev) - else SStore addr key val store - -- otherwise stack a new write on top of the the existing write chain - _ -> SStore addr key val store -writeStorage addr key val store = SStore addr key val store + _ -> SStore key val store +writeStorage key val store = SStore key val store +getAddr :: Expr Storage -> Maybe (Expr EAddr) +getAddr (SStore _ _ p) = getAddr p +getAddr (AbstractStore a) = Just a +getAddr (ConcreteStore _) = Nothing +getAddr (GVar _) = internalError "cannot determine addr of a GVar" + + -- ** Whole Expression Simplification ** ----------------------------------------------------------- @@ -644,21 +768,27 @@ simplify :: Expr a -> Expr a simplify e = if (mapExpr go e == e) then e - else simplify (mapExpr go e) + else simplify (mapExpr go (structureArraySlots e)) where go :: Expr a -> Expr a + + go (Failure a b c) = Failure (simplifyProps a) b c + go (Partial a b c) = Partial (simplifyProps a) b c + go (Success a b c d) = Success (simplifyProps a) b c d + -- redundant CopySlice go (CopySlice (Lit 0x0) (Lit 0x0) (Lit 0x0) _ dst) = dst -- simplify storage - go (SLoad addr slot store) = readStorage' addr slot store - go (SStore addr slot val store) = writeStorage addr slot val store + go (SLoad slot store) = readStorage' slot store + go (SStore slot val store) = writeStorage slot val store -- simplify buffers go o@(ReadWord (Lit _) _) = simplifyReads o go (ReadWord idx buf) = readWord idx buf go o@(ReadByte (Lit _) _) = simplifyReads o go (ReadByte idx buf) = readByte idx buf + go (BufLength buf) = bufLength buf -- We can zero out any bytes in a base ConcreteBuf that we know will be overwritten by a later write -- TODO: make this fully general for entire write chains, not just a single write. @@ -673,6 +803,20 @@ go (WriteWord a b c) = writeWord a b c go (WriteByte a b c) = writeByte a b c + + -- truncate some concrete source buffers to the portion relevant for the CopySlice if we're copying a fully concrete region + go orig@(CopySlice srcOff@(Lit n) dstOff size@(Lit sz) + -- It doesn't matter what wOffs we write to, because only the first + -- n+sz of ConcreteBuf will be used by CopySlice + (WriteWord wOff value (ConcreteBuf buf)) dst) + -- Let's not deal with overflow + | n+sz >= n + , n+sz >= sz + , n+sz <= maxBytes + = (CopySlice srcOff dstOff size + (WriteWord wOff value (ConcreteBuf simplifiedBuf)) dst) + | otherwise = orig + where simplifiedBuf = BS.take (unsafeInto (n+sz)) buf go (CopySlice a b c d f) = copySlice a b c d f go (IndexWord a b) = indexWord a b @@ -684,26 +828,31 @@ go (EVM.Types.LT _ (Lit 0)) = Lit 0 -- normalize all comparisons in terms of LT - go (EVM.Types.GT a b) = EVM.Types.LT b a - go (EVM.Types.GEq a b) = EVM.Types.LEq b a - go (EVM.Types.LEq a b) = EVM.Types.IsZero (EVM.Types.GT a b) - + go (EVM.Types.GT a b) = lt b a + go (EVM.Types.GEq a b) = leq b a + go (EVM.Types.LEq a b) = EVM.Types.IsZero (gt a b) go (IsZero a) = iszero a -- syntactic Eq reduction go (Eq (Lit a) (Lit b)) | a == b = Lit 1 | otherwise = Lit 0 - go (Eq (Lit 0) (Sub a b)) = Eq a b - go o@(Eq a b) + go (Eq (Lit 0) (Sub a b)) = eq a b + go (Eq a b) | a == b = Lit 1 - | otherwise = o + | otherwise = eq a b -- redundant ITE go (ITE (Lit x) a b) | x == 0 = b | otherwise = a + -- address masking + go (And (Lit 0xffffffffffffffffffffffffffffffffffffffff) a@(WAddr _)) = a + + -- literal addresses + go (WAddr (LitAddr a)) = Lit $ into 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 @@ -727,28 +876,28 @@ go (Add (Sub orig (Lit x)) (Lit y)) = Add orig (Lit (y-x)) -- redundant add / sub - go o@(Sub (Add a b) c) + go (Sub (Add a b) c) | a == c = b | b == c = a - | otherwise = o + | otherwise = sub (add a b) c -- add / sub identities - go o@(Add a b) + go (Add a b) | b == (Lit 0) = a | a == (Lit 0) = b - | otherwise = o - go o@(Sub a b) + | otherwise = add a b + go (Sub a b) | a == b = Lit 0 | b == (Lit 0) = a - | otherwise = o + | otherwise = sub a b -- SHL / SHR by 0 - go o@(SHL a v) + go (SHL a v) | a == (Lit 0) = v - | otherwise = o - go o@(SHR a v) + | otherwise = shl a v + go (SHR a v) | a == (Lit 0) = v - | otherwise = o + | otherwise = shr a v -- doubled And go o@(And a (And b c)) @@ -760,8 +909,9 @@ go o@(And (Lit x) _) | x == 0 = Lit 0 | otherwise = o - go o@(And _ (Lit x)) + go o@(And v (Lit x)) | x == 0 = Lit 0 + | x == maxLit = v | otherwise = o go o@(Or (Lit x) b) | x == 0 = b @@ -790,9 +940,23 @@ go (EVM.Types.Not (EVM.Types.Not a)) = a -- Some trivial min / max eliminations - go (Max (Lit 0) a) = a - go (Min (Lit 0) _) = Lit 0 + go (Max a b) = case (a, b) of + (Lit 0, _) -> b + _ -> EVM.Expr.max a b + go (Min a b) = case (a, b) of + (Lit 0, _) -> Lit 0 + _ -> EVM.Expr.min a b + -- Some trivial mul eliminations + go (Mul a b) = case (a, b) of + (Lit 0, _) -> Lit 0 + (Lit 1, _) -> b + _ -> mul a b + -- Some trivial div eliminations + go (Div (Lit 0) _) = Lit 0 -- divide 0 by anything (including 0) is zero in EVM + go (Div _ (Lit 0)) = Lit 0 -- divide anything by 0 is zero in EVM + go (Div a (Lit 1)) = a + -- If a >= b then the value of the `Max` expression can never be < b go o@(LT (Max (Lit a) _) (Lit b)) | a >= b = Lit 0 @@ -809,6 +973,109 @@ go a = a +-- ** Prop Simplification ** ----------------------------------------------------------------------- + + +simplifyProps :: [Prop] -> [Prop] +simplifyProps ps = if canBeSat then simplified else [PBool False] + where + simplified = remRedundantProps . map simplifyProp . flattenProps $ ps + canBeSat = constFoldProp simplified + +-- | Evaluate the provided proposition down to its most concrete result +simplifyProp :: Prop -> Prop +simplifyProp prop = + let new = mapProp' go (simpInnerExpr prop) + in if (new == prop) then prop else simplifyProp new + where + go :: Prop -> Prop + + -- LT/LEq comparisions + go (PLT (Var _) (Lit 0)) = PBool False + go (PLEq (Lit 0) (Var _)) = PBool True + go (PLT (Lit val) (Var _)) | val == maxLit = PBool False + go (PLEq (Var _) (Lit val)) | val == maxLit = PBool True + go (PLT (Lit l) (Lit r)) = PBool (l < r) + go (PLEq (Lit l) (Lit r)) = PBool (l <= r) + go (PLEq a (Max b _)) | a == b = PBool True + go (PLEq a (Max _ b)) | a == b = PBool True + + -- negations + go (PNeg (PBool b)) = PBool (Prelude.not b) + go (PNeg (PNeg a)) = a + + -- solc specific stuff + + -- iszero(a) -> (a == 0) + -- iszero(iszero(a))) -> ~(a == 0) -> a > 0 + -- iszero(iszero(a)) == 0 -> ~~(a == 0) -> a == 0 + -- ~(iszero(iszero(a)) == 0) -> ~~~(a == 0) -> ~(a == 0) -> a > 0 + go (PNeg (PEq (IsZero (IsZero a)) (Lit 0))) = PGT a (Lit 0) + + -- iszero(a) -> (a == 0) + -- iszero(a) == 0 -> ~(a == 0) + -- ~(iszero(a) == 0) -> ~~(a == 0) -> a == 0 + go (PNeg (PEq (IsZero a) (Lit 0))) = PEq a (Lit 0) + + -- a < b == 0 -> ~(a < b) + -- ~(a < b == 0) -> ~~(a < b) -> a < b + go (PNeg (PEq (LT a b) (Lit 0x0))) = PLT a b + + -- And/Or + go (PAnd (PBool l) (PBool r)) = PBool (l && r) + go (PAnd (PBool False) _) = PBool False + go (PAnd _ (PBool False)) = PBool False + go (POr (PBool True) _) = PBool True + go (POr _ (PBool True)) = PBool True + go (POr (PBool l) (PBool r)) = PBool (l || r) + + -- Imply + go (PImpl _ (PBool True)) = PBool True + go (PImpl (PBool True) b) = b + go (PImpl (PBool False) _) = PBool True + + -- Eq + go (PEq (Eq a b) (Lit 0)) = PNeg (PEq a b) + go (PEq (Eq a b) (Lit 1)) = PEq a b + go (PEq (Sub a b) (Lit 0)) = PEq a b + go (PEq (Lit l) (Lit r)) = PBool (l == r) + go o@(PEq l r) + | l == r = PBool True + | otherwise = o + go p = p + + + -- Applies `simplify` to the inner part of a Prop, e.g. + -- (PEq (Add (Lit 1) (Lit 2)) (Var "a")) becomes + -- (PEq (Lit 3) (Var "a") + simpInnerExpr :: Prop -> Prop + -- rewrite everything as LEq or LT + simpInnerExpr (PGEq a b) = simpInnerExpr (PLEq b a) + simpInnerExpr (PGT a b) = simpInnerExpr (PLT b a) + -- simplifies the inner expression + simpInnerExpr (PEq a b) = PEq (simplify a) (simplify b) + simpInnerExpr (PLT a b) = PLT (simplify a) (simplify b) + simpInnerExpr (PLEq a b) = PLEq (simplify a) (simplify b) + simpInnerExpr (PNeg a) = PNeg (simpInnerExpr a) + simpInnerExpr (PAnd a b) = PAnd (simpInnerExpr a) (simpInnerExpr b) + simpInnerExpr (POr a b) = POr (simpInnerExpr a) (simpInnerExpr b) + simpInnerExpr (PImpl a b) = PImpl (simpInnerExpr a) (simpInnerExpr b) + simpInnerExpr orig@(PBool _) = orig + +-- Makes [PAnd a b] into [a,b] +flattenProps :: [Prop] -> [Prop] +flattenProps [] = [] +flattenProps (a:ax) = case a of + PAnd x1 x2 -> x1:x2:flattenProps ax + x -> x:flattenProps ax + +-- removes redundant (constant True/False) props +remRedundantProps :: [Prop] -> [Prop] +remRedundantProps p = collapseFalse . filter (\x -> x /= PBool True) . nubOrd $ p + where + collapseFalse ps = if isJust $ find (== PBool False) ps then [PBool False] else ps + + -- ** Conversions ** ------------------------------------------------------------------------------- @@ -819,6 +1086,16 @@ exprToAddr (Lit x) = Just (unsafeInto x) exprToAddr _ = Nothing +-- TODO: make this smarter, probably we will need to use the solver here? +wordToAddr :: Expr EWord -> Maybe (Expr EAddr) +wordToAddr = go . simplify + where + go :: Expr EWord -> Maybe (Expr EAddr) + go = \case + WAddr a -> Just a + Lit a -> Just $ LitAddr (truncateToAddr a) + _ -> Nothing + litCode :: BS.ByteString -> [Expr Byte] litCode bs = fmap LitByte (BS.unpack bs) @@ -837,8 +1114,24 @@ -- Is the given expr a literal word? isLitWord :: Expr EWord -> Bool isLitWord (Lit _) = True +isLitWord (WAddr (LitAddr _)) = True isLitWord _ = False +isSuccess :: Expr End -> Bool +isSuccess = \case + Success {} -> True + _ -> False + +isFailure :: Expr End -> Bool +isFailure = \case + Failure {} -> True + _ -> False + +isPartial :: Expr End -> Bool +isPartial = \case + Partial {} -> True + _ -> False + -- | Returns the byte at idx from the given word. indexWord :: Expr EWord -> Expr EWord -> Expr Byte -- Simplify masked reads: @@ -997,3 +1290,46 @@ inRange :: Int -> Expr EWord -> Prop inRange sz e = PAnd (PGEq e (Lit 0)) (PLEq e (Lit $ 2 ^ sz - 1)) + + +-- | images of keccak(bytes32(x)) where 0 <= x < 256 +preImages :: [(W256, Word8)] +preImages = [(keccak' (word256Bytes . into $ i), i) | i <- [0..255]] + +data ConstState = ConstState + { values :: Map.Map (Expr EWord) W256 + , canBeSat :: Bool + } + deriving (Show) + +-- | Folds constants +constFoldProp :: [Prop] -> Bool +constFoldProp ps = oneRun ps (ConstState mempty True) + where + oneRun ps2 startState = (execState (mapM (go . simplifyProp) ps2) startState).canBeSat + go :: Prop -> State ConstState () + go x = case x of + PEq (Lit l) a -> do + s <- get + case Map.lookup a s.values of + Just l2 -> case l==l2 of + True -> pure () + False -> put ConstState {canBeSat=False, values=mempty} + Nothing -> do + let vs' = Map.insert a l s.values + put $ s{values=vs'} + PEq a b@(Lit _) -> go (PEq b a) + PAnd a b -> do + go a + go b + POr a b -> do + s <- get + let + v1 = oneRun [a] s + v2 = oneRun [b] s + when (Prelude.not v1) $ go b + when (Prelude.not v2) $ go a + s2 <- get + put $ s{canBeSat=(s2.canBeSat && (v1 || v2))} + PBool False -> put $ ConstState {canBeSat=False, values=mempty} + _ -> pure () diff --git a/src/EVM/Facts.hs b/src/EVM/Facts.hs deleted file mode 100644 --- a/src/EVM/Facts.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - --- Converts between Ethereum contract states and simple trees of --- texts. Dumps and loads such trees as Git repositories (the state --- gets serialized as commits with folders and files). --- --- Example state file hierarchy: --- --- /0123...abc/balance says "0x500" --- /0123...abc/code says "60023429..." --- /0123...abc/nonce says "0x3" --- /0123...abc/storage/0x1 says "0x1" --- /0123...abc/storage/0x2 says "0x0" --- --- This format could easily be serialized into any nested record --- syntax, e.g. JSON. - -module EVM.Facts - ( File (..) - , Fact (..) - , Data (..) - , Path (..) - , apply - , applyCache - , cacheFacts - , contractFacts - , vmFacts - , factToFile - , fileToFact - ) where - -import EVM (bytecode) -import EVM qualified -import EVM.Expr (writeStorage, litAddr) -import EVM.Types - -import Optics.Core -import Optics.State - -import Control.Monad.State.Strict (execState, when) -import Data.ByteString (ByteString) -import Data.ByteString.Base16 qualified as BS16 -import Data.ByteString qualified as BS -import Data.ByteString.Char8 qualified as Char8 -import Data.Map (Map) -import Data.Map qualified as Map -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Ord (comparing) -import Text.Read (readMaybe) -import Witch (into) - --- We treat everything as ASCII byte strings because --- we only use hex digits (and the letter 'x'). -type ASCII = ByteString - --- When using string literals, default to infer the ASCII type. -default (ASCII) - --- We use the word "fact" to mean one piece of serializable --- information about the state. --- --- Note that Haskell allows this kind of union of records. --- It's convenient here, but typically avoided. -data Fact - = BalanceFact { addr :: Addr, what :: W256 } - | NonceFact { addr :: Addr, what :: W256 } - | StorageFact { addr :: Addr, what :: W256, which :: W256 } - | CodeFact { addr :: Addr, blob :: ByteString } - deriving (Eq, Show) - --- A fact path means something like "/0123...abc/storage/0x1", --- or alternatively "contracts['0123...abc'].storage['0x1']". -data Path = Path [ASCII] ASCII - deriving (Eq, Ord, Show) - --- A fact data is the content of a file. We encapsulate it --- with a newtype to make it easier to change the representation --- (to use bytestrings, some sum type, or whatever). -newtype Data = Data { dataASCII :: ASCII } - deriving (Eq, Ord, Show) - --- We use the word "file" to denote a serialized value at a path. -data File = File { filePath :: Path, fileData :: Data } - deriving (Eq, Ord, Show) - -class AsASCII a where - dump :: a -> ASCII - load :: ASCII -> Maybe a - -instance AsASCII Addr where - dump = Char8.pack . show - load = readMaybe . Char8.unpack - -instance AsASCII W256 where - dump = Char8.pack . show - load = readMaybe . Char8.unpack - -instance AsASCII ByteString where - dump x = BS16.encodeBase16' x <> "\n" - load x = - case BS16.decodeBase16 . mconcat . BS.split 10 $ x of - Right y -> Just y - _ -> Nothing - -contractFacts :: Addr -> Contract -> Map W256 (Map W256 W256) -> [Fact] -contractFacts a x store = case view bytecode x of - ConcreteBuf b -> - storageFacts a store ++ - [ BalanceFact a x.balance - , NonceFact a x.nonce - , CodeFact a b - ] - _ -> - -- here simply ignore storing the bytecode - storageFacts a store ++ - [ BalanceFact a x.balance - , NonceFact a x.nonce - ] - - -storageFacts :: Addr -> Map W256 (Map W256 W256) -> [Fact] -storageFacts a store = map f (Map.toList (Map.findWithDefault Map.empty (into a) store)) - where - f :: (W256, W256) -> Fact - f (k, v) = StorageFact - { addr = a - , what = v - , which = k - } - -cacheFacts :: Cache -> Set Fact -cacheFacts c = Set.fromList $ do - (k, v) <- Map.toList c.fetchedContracts - contractFacts k v c.fetchedStorage - -vmFacts :: VM -> Set Fact -vmFacts vm = Set.fromList $ do - (k, v) <- Map.toList vm.env.contracts - case vm.env.storage of - EmptyStore -> contractFacts k v Map.empty - ConcreteStore s -> contractFacts k v s - _ -> internalError "cannot serialize an abstract store" - --- Somewhat stupidly, this function demands that for each contract, --- the code fact for that contract comes before the other facts for --- that contract. This is an incidental thing because right now we --- always initialize contracts starting with the code (to calculate --- the code hash and so on). --- --- Therefore, we need to make sure to sort the fact set in such a way. -apply1 :: VM -> Fact -> VM -apply1 vm fact = - case fact of - CodeFact {..} -> flip execState vm $ do - assign (#env % #contracts % at addr) (Just (EVM.initialContract (RuntimeCode (ConcreteRuntimeCode blob)))) - when (vm.state.contract == addr) $ EVM.loadContract addr - StorageFact {..} -> - vm & over (#env % #storage) (writeStorage (litAddr addr) (Lit which) (Lit what)) - BalanceFact {..} -> - vm & set (#env % #contracts % ix addr % #balance) what - NonceFact {..} -> - vm & set (#env % #contracts % ix addr % #nonce) what - -apply2 :: VM -> Fact -> VM -apply2 vm fact = - case fact of - CodeFact {..} -> flip execState vm $ do - assign (#cache % #fetchedContracts % at addr) (Just (EVM.initialContract (RuntimeCode (ConcreteRuntimeCode blob)))) - when (vm.state.contract == addr) $ EVM.loadContract addr - StorageFact {..} -> let - store = vm.cache.fetchedStorage - ctrct = Map.findWithDefault Map.empty (into addr) store - in - vm & set (#cache % #fetchedStorage) (Map.insert (into addr) (Map.insert which what ctrct) store) - BalanceFact {..} -> - vm & set (#cache % #fetchedContracts % ix addr % #balance) what - NonceFact {..} -> - vm & set (#cache % #fetchedContracts % ix addr % #nonce) what - --- Sort facts in the right order for `apply1` to work. -instance Ord Fact where - compare = comparing f - where - f :: Fact -> (Int, Addr, W256) - f (CodeFact a _) = (0, a, 0) - f (BalanceFact a _) = (1, a, 0) - f (NonceFact a _) = (2, a, 0) - f (StorageFact a _ x) = (3, a, x) - --- Applies a set of facts to a VM. -apply :: VM -> Set Fact -> VM -apply = - -- The set's ordering is relevant; see `apply1`. - foldl apply1 --- --- Applies a set of facts to a VM. -applyCache :: VM -> Set Fact -> VM -applyCache = - -- The set's ordering is relevant; see `apply1`. - foldl apply2 - -factToFile :: Fact -> File -factToFile fact = case fact of - StorageFact {..} -> mk ["storage"] (dump which) what - BalanceFact {..} -> mk [] "balance" what - NonceFact {..} -> mk [] "nonce" what - CodeFact {..} -> mk [] "code" blob - where - mk :: AsASCII a => [ASCII] -> ASCII -> a -> File - mk prefix base a = - File (Path (dump fact.addr : prefix) base) - (Data $ dump a) - --- This lets us easier pattern match on serialized things. --- Uses language extensions: `PatternSynonyms` and `ViewPatterns`. -pattern Load :: AsASCII a => a -> ASCII -pattern Load x <- (load -> Just x) - -fileToFact :: File -> Maybe Fact -fileToFact = \case - File (Path [Load a] "code") (Data (Load x)) - -> Just (CodeFact a x) - File (Path [Load a] "balance") (Data (Load x)) - -> Just (BalanceFact a x) - File (Path [Load a] "nonce") (Data (Load x)) - -> Just (NonceFact a x) - File (Path [Load a, "storage"] (Load x)) (Data (Load y)) - -> Just (StorageFact a y x) - _ - -> Nothing diff --git a/src/EVM/Facts/Git.hs b/src/EVM/Facts/Git.hs deleted file mode 100644 --- a/src/EVM/Facts/Git.hs +++ /dev/null @@ -1,48 +0,0 @@ - --- This is a backend for the fact representation that uses a Git --- repository as the store. - -module EVM.Facts.Git - ( saveFacts - , loadFacts - , RepoAt (..) - ) where - -import EVM.Facts (Fact (..), File (..), Path (..), Data (..), fileToFact, factToFile) - -import Optics.Core -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Maybe (catMaybes) -import Restless.Git qualified as Git - -newtype RepoAt = RepoAt String - deriving (Eq, Ord, Show) - --- For modularity reasons, we have our own file data type that is --- isomorphic with the one in the `restless-git` library. We declare --- the isomorphism so we can go between them easily. -fileRepr :: Iso' File Git.File -fileRepr = iso f g - where - f :: File -> Git.File - f (File (Path ps p) (Data x)) = - Git.File (Git.Path ps p) x - - g :: Git.File -> File - g (Git.File (Git.Path ps p) x) = - File (Path ps p) (Data x) - -saveFacts :: RepoAt -> Set Fact -> IO () -saveFacts (RepoAt repo) facts = - Git.save repo "hevm execution" - (Set.map (view fileRepr . factToFile) facts) - -prune :: Ord a => Set (Maybe a) -> Set a -prune = Set.fromList . catMaybes . Set.toList - -loadFacts :: RepoAt -> IO (Set Fact) -loadFacts (RepoAt src) = - fmap - (prune . Set.map (fileToFact . review fileRepr)) - (Git.load src) diff --git a/src/EVM/FeeSchedule.hs b/src/EVM/FeeSchedule.hs --- a/src/EVM/FeeSchedule.hs +++ b/src/EVM/FeeSchedule.hs @@ -53,58 +53,36 @@ , g_access_list_storage_key :: n } deriving Show --- For the purposes of this module, we define an EIP as just a fee --- schedule modification. -type EIP n = Num n => FeeSchedule n -> FeeSchedule n - --- EIP150: Gas cost changes for IO-heavy operations --- -eip150 :: EIP n -eip150 fees = fees - { g_extcode = 700 - , g_balance = 400 - , g_sload = 200 - , g_call = 700 - , g_selfdestruct = 5000 - , g_selfdestruct_newaccount = 25000 - } - --- EIP160: EXP cost increase --- -eip160 :: EIP n -eip160 fees = fees - { g_expbyte = 50 } - -homestead :: Num n => FeeSchedule n -homestead = FeeSchedule +feeSchedule :: Num n => FeeSchedule n +feeSchedule = FeeSchedule { g_zero = 0 , g_base = 2 , g_verylow = 3 , g_low = 5 , g_mid = 8 , g_high = 10 - , g_extcode = 20 - , g_balance = 20 - , g_sload = 50 + , g_extcode = 2600 + , g_balance = 2600 + , g_sload = 100 , g_jumpdest = 1 , g_sset = 20000 - , g_sreset = 5000 + , g_sreset = 2900 , r_sclear = 15000 - , g_selfdestruct = 0 - , g_selfdestruct_newaccount = 0 + , g_selfdestruct = 5000 + , g_selfdestruct_newaccount = 25000 , r_selfdestruct = 24000 , g_create = 32000 , g_codedeposit = 200 - , g_call = 40 + , g_call = 2600 , g_callvalue = 9000 , g_callstipend = 2300 , g_newaccount = 25000 , g_exp = 10 - , g_expbyte = 10 + , g_expbyte = 50 , g_memory = 3 , g_txcreate = 32000 , g_txdatazero = 4 - , g_txdatanonzero = 68 + , g_txdatanonzero = 16 , g_transaction = 21000 , g_log = 375 , g_logdata = 8 @@ -114,12 +92,12 @@ , g_initcodeword = 2 , g_copy = 3 , g_blockhash = 20 - , g_extcodehash = 400 + , g_extcodehash = 2600 , g_quaddivisor = 20 - , g_ecadd = 500 - , g_ecmul = 40000 - , g_pairing_point = 80000 - , g_pairing_base = 100000 + , g_ecadd = 150 + , g_ecmul = 6000 + , g_pairing_point = 34000 + , g_pairing_base = 45000 , g_fround = 1 , r_block = 2000000000000000000 , g_cold_sload = 2100 @@ -128,60 +106,3 @@ , g_access_list_address = 2400 , g_access_list_storage_key = 1900 } - -metropolis :: Num n => FeeSchedule n -metropolis = eip160 . eip150 $ homestead - --- EIP1108: Reduce alt_bn128 precompile gas costs --- -eip1108 :: EIP n -eip1108 fees = fees - { g_ecadd = 150 - , g_ecmul = 6000 - , g_pairing_point = 34000 - , g_pairing_base = 45000 - } - --- EIP1884: Repricing for trie-size-dependent opcodes --- -eip1884 :: EIP n -eip1884 fees = fees - { g_sload = 800 - , g_balance = 700 - , g_extcodehash = 700 - } - --- EIP2028: Transaction data gas cost reduction --- -eip2028 :: EIP n -eip2028 fees = fees - { g_txdatanonzero = 16 - } - --- EIP2200: Structured definitions for gas metering --- -eip2200 :: EIP n -eip2200 fees = fees - { g_sload = 800 - , g_sset = 20000 -- not changed - , g_sreset = 5000 -- not changed - , r_sclear = 15000 -- not changed - } - -istanbul :: Num n => FeeSchedule n -istanbul = eip1108 . eip1884 . eip2028 . eip2200 $ metropolis - - -- EIP2929: Gas cost increases for state access opcodes - -- -eip2929 :: EIP n -eip2929 fees = fees - { g_sload = 100 - , g_sreset = 5000 - 2100 - , g_call = 2600 - , g_balance = 2600 - , g_extcode = 2600 - , g_extcodehash = 2600 - } - -berlin :: Num n => FeeSchedule n -berlin = eip2929 istanbul diff --git a/src/EVM/Fetch.hs b/src/EVM/Fetch.hs --- a/src/EVM/Fetch.hs +++ b/src/EVM/Fetch.hs @@ -2,13 +2,14 @@ module EVM.Fetch where -import EVM (initialContract) +import EVM (initialContract, unknownContract) import EVM.ABI -import EVM.FeeSchedule qualified as FeeSchedule +import EVM.FeeSchedule (feeSchedule) import EVM.Format (hexText) import EVM.SMT import EVM.Solvers import EVM.Types +import EVM (emptyContract) import Optics.Core @@ -32,7 +33,7 @@ QueryCode :: Addr -> RpcQuery BS.ByteString QueryBlock :: RpcQuery Block QueryBalance :: Addr -> RpcQuery W256 - QueryNonce :: Addr -> RpcQuery W256 + QueryNonce :: Addr -> RpcQuery W64 QuerySlot :: Addr -> W256 -> RpcQuery W256 QueryChainId :: RpcQuery W256 @@ -109,7 +110,7 @@ parseBlock :: (AsValue s, Show s) => s -> Maybe Block parseBlock j = do - coinbase <- readText <$> j ^? key "miner" % _String + coinbase <- LitAddr . readText <$> j ^? key "miner" % _String timestamp <- Lit . readText <$> j ^? key "timestamp" % _String number <- readText <$> j ^? key "number" % _String gasLimit <- readText <$> j ^? key "gasLimit" % _String @@ -127,7 +128,7 @@ (Nothing, Just _, Just d) -> d _ -> internalError "block contains both difficulty and prevRandao" -- default codesize, default gas limit, default feescedule - pure $ Block coinbase timestamp number prd gasLimit (fromMaybe 0 baseFee) 0xffffffff FeeSchedule.berlin + pure $ Block coinbase timestamp number prd gasLimit (fromMaybe 0 baseFee) 0xffffffff feeSchedule fetchWithSession :: Text -> Session -> Value -> IO (Maybe Value) fetchWithSession url sess x = do @@ -141,14 +142,14 @@ fetch :: Show a => RpcQuery a -> IO (Maybe a) fetch = fetchQuery n (fetchWithSession url sess) - theCode <- MaybeT $ fetch (QueryCode addr) - theNonce <- MaybeT $ fetch (QueryNonce addr) - theBalance <- MaybeT $ fetch (QueryBalance addr) + code <- MaybeT $ fetch (QueryCode addr) + nonce <- MaybeT $ fetch (QueryNonce addr) + balance <- MaybeT $ fetch (QueryBalance addr) pure $ - initialContract (RuntimeCode (ConcreteRuntimeCode theCode)) - & set #nonce theNonce - & set #balance theBalance + initialContract (RuntimeCode (ConcreteRuntimeCode code)) + & set #nonce (Just nonce) + & set #balance (Lit balance) & set #external True fetchSlotWithSession @@ -181,18 +182,18 @@ sess <- Session.newAPISession fetchQuery Latest (fetchWithSession url sess) QueryChainId -http :: Natural -> Maybe Natural -> BlockNumber -> Text -> Fetcher +http :: Natural -> Maybe Natural -> BlockNumber -> Text -> Fetcher s http smtjobs smttimeout n url q = withSolvers Z3 smtjobs smttimeout $ \s -> oracle s (Just (n, url)) q -zero :: Natural -> Maybe Natural -> Fetcher +zero :: Natural -> Maybe Natural -> Fetcher s zero smtjobs smttimeout q = withSolvers Z3 smtjobs smttimeout $ \s -> oracle s Nothing q -- smtsolving + (http or zero) -oracle :: SolverGroup -> RpcInfo -> Fetcher +oracle :: SolverGroup -> RpcInfo -> Fetcher s oracle solvers info q = do case q of PleaseDoFFI vals continue -> case vals of @@ -207,12 +208,14 @@ -- Is is possible to satisfy the condition? continue <$> checkBranch solvers (branchcondition ./= (Lit 0)) pathconds - -- if we are using a symbolic storage model, - -- we generate a new array to the fetched contract here - PleaseFetchContract addr continue -> do + PleaseFetchContract addr base continue -> do contract <- case info of - Nothing -> pure $ Just $ initialContract (RuntimeCode (ConcreteRuntimeCode "")) - Just (n, url) -> fetchContractFrom n url addr + Nothing -> let + c = case base of + AbstractBase -> unknownContract (LitAddr addr) + EmptyBase -> emptyContract + in pure $ Just c + Just (n, url) -> fetchContractFrom n url addr case contract of Just x -> pure $ continue x Nothing -> internalError $ "oracle error: " ++ show q @@ -226,7 +229,7 @@ Nothing -> internalError $ "oracle error: " ++ show q -type Fetcher = Query -> IO (EVM ()) +type Fetcher s = Query s -> IO (EVM s ()) -- | Checks which branches are satisfiable, checking the pathconditions for consistency -- if the third argument is true. @@ -235,20 +238,20 @@ -- will be pruned anyway. checkBranch :: SolverGroup -> Prop -> Prop -> IO BranchCondition checkBranch solvers branchcondition pathconditions = do - checkSat solvers (assertProps [(branchcondition .&& pathconditions)]) >>= \case + checkSat solvers (assertProps abstRefineDefault [(branchcondition .&& pathconditions)]) >>= \case -- the condition is unsatisfiable Unsat -> -- if pathconditions are consistent then the condition must be false pure $ Case False -- Sat means its possible for condition to hold Sat _ -> -- is its negation also possible? - checkSat solvers (assertProps [(pathconditions .&& (PNeg branchcondition))]) >>= \case + checkSat solvers (assertProps abstRefineDefault [(pathconditions .&& (PNeg branchcondition))]) >>= \case -- No. The condition must hold Unsat -> pure $ Case True -- Yes. Both branches possible Sat _ -> pure EVM.Types.Unknown -- Explore both branches in case of timeout EVM.Solvers.Unknown -> pure EVM.Types.Unknown - Error e -> error $ "Internal Error: SMT Solver pureed with an error: " <> T.unpack e + Error e -> internalError $ "SMT Solver pureed with an error: " <> T.unpack e -- If the query times out, we simply explore both paths EVM.Solvers.Unknown -> pure EVM.Types.Unknown Error e -> internalError $ "SMT Solver pureed with an error: " <> T.unpack e diff --git a/src/EVM/Format.hs b/src/EVM/Format.hs --- a/src/EVM/Format.hs +++ b/src/EVM/Format.hs @@ -30,14 +30,16 @@ , hexByteString , hexText , bsToHex + , showVal ) where +import Prelude hiding (LT, GT) + import EVM.Types -import EVM (cheatCode, traceForest, traceForest', traceContext) +import EVM (traceForest, traceForest', traceContext, cheatCode) import EVM.ABI (getAbiSeq, parseTypeName, AbiValue(..), AbiType(..), SolError(..), Indexed(..), Event(..)) import EVM.Dapp (DappContext(..), DappInfo(..), showTraceLocation) import EVM.Expr qualified as Expr -import EVM.Hexdump (prettyHex, paddedShowHex) import EVM.Solidity (SolcContract(..), Method(..), contractName, abiMap) import Control.Arrow ((>>>)) @@ -60,17 +62,18 @@ import Data.Text.Encoding qualified as T import Data.Tree.View (showTree) import Data.Vector (Vector) +import Hexdump (prettyHex) import Numeric (showHex) import Data.ByteString.Char8 qualified as Char8 import Data.ByteString.Base16 qualified as BS16 -import Witch (into, unsafeInto) +import Witch (into, unsafeInto, tryFrom) data Signedness = Signed | Unsigned deriving (Show) showDec :: Signedness -> W256 -> Text showDec signed (W256 w) - | i == into cheatCode = "" + | Right i' <- tryFrom i, LitAddr i' == cheatCode = "" | (i :: Integer) == 2 ^ (256 :: Integer) - 1 = "MAX_UINT256" | otherwise = T.pack (show (i :: Integer)) where @@ -78,7 +81,7 @@ Signed -> into (signedWord w) Unsigned -> into w -showWordExact :: W256 -> Text +showWordExact :: Integral i => i -> Text showWordExact w = humanizeInteger (toInteger w) showWordExplanation :: W256 -> DappInfo -> Text @@ -110,7 +113,7 @@ showAbiValue (AbiAddress addr) = let dappinfo = ?context.info contracts = ?context.env - name = case Map.lookup addr contracts of + name = case Map.lookup (LitAddr addr) contracts of Nothing -> "" Just contract -> let hash = maybeLitWord contract.codehash @@ -142,7 +145,7 @@ showCall :: (?context :: DappContext) => [AbiType] -> Expr Buf -> Text showCall ts (ConcreteBuf bs) = showValues ts $ ConcreteBuf (BS.drop 4 bs) -showCall _ _ = "" +showCall _ _ = "()" showError :: (?context :: DappContext) => Expr Buf -> Text showError (ConcreteBuf bs) = @@ -187,14 +190,14 @@ formatSBinary (AbstractBuf t) = "<" <> t <> " abstract buf>" formatSBinary _ = internalError "formatSBinary: implement me" -showTraceTree :: DappInfo -> VM -> Text +showTraceTree :: DappInfo -> VM s -> Text showTraceTree dapp vm = let forest = traceForest vm traces = fmap (fmap (unpack . showTrace dapp (vm.env.contracts))) forest in pack $ concatMap showTree traces showTraceTree' :: DappInfo -> Expr End -> Text -showTraceTree' _ (ITE {}) = error "Internal Error: ITE does not contain a trace" +showTraceTree' _ (ITE {}) = internalError "ITE does not contain a trace" showTraceTree' dapp leaf = let forest = traceForest' leaf traces = fmap (fmap (unpack . showTrace dapp (traceContext leaf))) forest @@ -203,7 +206,7 @@ unindexed :: [(Text, AbiType, Indexed)] -> [AbiType] unindexed ts = [t | (_, t, NotIndexed) <- ts] -showTrace :: DappInfo -> Map Addr Contract -> Trace -> Text +showTrace :: DappInfo -> Map (Expr EAddr) Contract -> Trace -> Text showTrace dapp env trace = let ?context = DappContext { info = dapp, env = env } in let @@ -299,12 +302,12 @@ FrameTrace (CreationContext addr (Lit hash) _ _ ) -> -- FIXME: irrefutable pattern "create " <> maybeContractName (preview (ix hash % _2) dapp.solcByHash) - <> "@" <> pack (show addr) + <> "@" <> formatAddr addr <> pos FrameTrace (CreationContext addr _ _ _ ) -> "create " <> "" - <> "@" <> pack (show addr) + <> "@" <> formatAddr addr <> pos FrameTrace (CallContext target context _ _ hash abi calldata _ _) -> let calltype = if target == context @@ -315,8 +318,8 @@ Nothing -> calltype <> case target of - 0x7109709ECfa91a80626fF3989D68f67F5b1DD12D -> "HEVM" - _ -> pack (show target) + LitAddr 0x7109709ECfa91a80626fF3989D68f67F5b1DD12D -> "HEVM" + _ -> formatAddr target <> pack "::" <> case Map.lookup (unsafeInto (fromMaybe 0x00 abi)) fullAbiMap of Just m -> @@ -342,6 +345,12 @@ <> "\x1b[0m" <> pos +formatAddr :: Expr EAddr -> Text +formatAddr = \case + LitAddr a -> pack (show a) + SymAddr a -> "symbolic(" <> a <> ")" + GVar _ -> internalError "Unexpected GVar" + getAbiTypes :: Text -> [Maybe AbiType] getAbiTypes abi = map (parseTypeName mempty) types where @@ -427,7 +436,8 @@ , indent 2 $ T.unlines . fmap formatSomeExpr $ args ] ] - MaxIterationsReached pc addr -> T.pack $ "Max Iterations Reached in contract: " <> show addr <> " pc: " <> show pc + MaxIterationsReached pc addr -> "Max Iterations Reached in contract: " <> formatAddr addr <> " pc: " <> pack (show pc) + JumpIntoSymbolicCode pc idx -> "Encountered a jump into a potentially symbolic code region while executing initcode. pc: " <> pack (show pc) <> " jump dst: " <> pack (show idx) formatSomeExpr :: SomeExpr -> Text formatSomeExpr (SomeExpr e) = formatExpr e @@ -436,35 +446,54 @@ formatExpr = go where go :: Expr a -> Text - go = \case - Lit w -> T.pack $ show w + go x = T.stripEnd $ case x of + Lit w -> T.pack $ show (into w :: Integer) + (Var v) -> "(Var " <> T.pack (show v) <> ")" + (GVar v) -> "(GVar " <> T.pack (show v) <> ")" LitByte w -> T.pack $ show w - ITE c t f -> rstrip . T.unlines $ - [ "(ITE (" <> formatExpr c <> ")" - , indent 2 (formatExpr t) - , indent 2 (formatExpr f) + ITE c t f -> T.unlines + [ "(ITE" + , indent 2 $ T.unlines + [ formatExpr c + , formatExpr t + , formatExpr f + ] , ")"] Success asserts _ buf store -> T.unlines - [ "(Return" + [ "(Success" , indent 2 $ T.unlines [ "Data:" , indent 2 $ formatExpr buf , "" - , "Store:" - , indent 2 $ formatExpr store + , "State:" + , indent 2 $ T.unlines (fmap (\(k,v) -> + T.unlines + [ formatExpr k <> ":" + , indent 2 $ formatExpr v + ]) (Map.toList store)) , "Assertions:" - , indent 2 $ T.pack $ show asserts + , indent 2 . T.unlines $ fmap formatProp asserts ] , ")" ] + Partial asserts _ err -> T.unlines + [ "(Partial" + , indent 2 $ T.unlines + [ "Reason:" + , indent 2 $ formatPartial err + , "Assertions:" + , indent 2 . T.unlines $ fmap formatProp asserts + ] + , ")" + ] Failure asserts _ err -> T.unlines [ "(Failure" , indent 2 $ T.unlines [ "Error:" , indent 2 $ formatError err , "Assertions:" - , indent 2 $ T.pack $ show asserts + , indent 2 . T.unlines $ fmap formatProp asserts ] , ")" ] @@ -489,35 +518,153 @@ ] , ")" ] + ReadByte idx buf -> T.unlines + [ "(ReadByte" + , indent 2 $ T.unlines + [ "idx:" + , indent 2 $ formatExpr idx + , "buf: " + , indent 2 $ formatExpr buf + ] + , ")" + ] - And a b -> T.unlines - [ "(And" + Add a b -> fmt "Add" [a, b] + Sub a b -> fmt "Sub" [a, b] + Mul a b -> fmt "Mul" [a, b] + Div a b -> fmt "Div" [a, b] + SDiv a b -> fmt "SDiv" [a, b] + Mod a b -> fmt "Mod" [a, b] + SMod a b -> fmt "SMod" [a, b] + AddMod a b c -> fmt "AddMod" [a, b, c] + MulMod a b c -> fmt "MulMod" [a, b, c] + Exp a b -> fmt "Exp" [a, b] + SEx a b -> fmt "SEx" [a, b] + Min a b -> fmt "Min" [a, b] + Max a b -> fmt "Max" [a, b] + + LT a b -> fmt "LT" [a, b] + GT a b -> fmt "GT" [a, b] + LEq a b -> fmt "LEq" [a, b] + GEq a b -> fmt "GEq" [a, b] + SLT a b -> fmt "SLT" [a, b] + SGT a b -> fmt "SGT" [a, b] + Eq a b -> fmt "Eq" [a, b] + EqByte a b -> fmt "EqByte" [a, b] + IsZero a -> fmt "IsZero" [a] + + And a b -> fmt "And" [a, b] + Or a b -> fmt "Or" [a, b] + Xor a b -> fmt "Xor" [a, b] + Not a -> fmt "Not" [a] + SHL a b -> fmt "SHL" [a, b] + SHR a b -> fmt "SHR" [a, b] + SAR a b -> fmt "SAR" [a, b] + + e@Origin -> T.pack (show e) + e@Coinbase -> T.pack (show e) + e@Timestamp -> T.pack (show e) + e@BlockNumber -> T.pack (show e) + e@PrevRandao -> T.pack (show e) + e@GasLimit -> T.pack (show e) + e@ChainId -> T.pack (show e) + e@BaseFee -> T.pack (show e) + e@TxValue -> T.pack (show e) + e@(Gas {}) -> "(" <> T.pack (show e) <> ")" + + BlockHash a -> fmt "BlockHash" [a] + Balance a -> fmt "Balance" [a] + CodeSize a -> fmt "CodeSize" [a] + CodeHash a -> fmt "CodeHash" [a] + + + JoinBytes zero one two three four five six seven eight nine + ten eleven twelve thirteen fourteen fifteen sixteen seventeen + eighteen nineteen twenty twentyone twentytwo twentythree twentyfour + twentyfive twentysix twentyseven twentyeight twentynine thirty thirtyone -> fmt "JoinBytes" + [ zero + , one + , two + , three + , four + , five + , six + , seven + , eight + , nine + , ten + , eleven + , twelve + , thirteen + , fourteen + , fifteen + , sixteen + , seventeen + , eighteen + , nineteen + , twenty + , twentyone + , twentytwo + , twentythree + , twentyfour + , twentyfive + , twentysix + , twentyseven + , twentyeight + , twentynine + , thirty + , thirtyone + ] + + LogEntry addr dat topics -> T.unlines + [ "(LogEntry" , indent 2 $ T.unlines - [ formatExpr a - , formatExpr b + [ "addr:" + , indent 2 $ formatExpr addr + , "data:" + , indent 2 $ formatExpr dat + , "topics:" + , indent 2 . T.unlines $ fmap formatExpr topics ] , ")" ] + a@(SymAddr {}) -> "(" <> T.pack (show a) <> ")" + LitAddr a -> T.pack (show a) + WAddr a -> fmt "WAddr" [a] + + BufLength b -> fmt "BufLength" [b] + + C code store bal nonce -> T.unlines + [ "(Contract" + , indent 2 $ T.unlines + [ "code:" + , indent 2 $ formatCode code + , "storage:" + , indent 2 $ formatExpr store + , "balance:" + , indent 2 $ formatExpr bal + , "nonce:" + , indent 2 $ formatNonce nonce + ] + , ")" + ] + -- Stores - SLoad addr slot store -> T.unlines + SLoad slot storage -> T.unlines [ "(SLoad" , indent 2 $ T.unlines - [ "addr:" - , indent 2 $ formatExpr addr - , "slot:" + [ "slot:" , indent 2 $ formatExpr slot - , "store:" - , indent 2 $ formatExpr store + , "storage:" + , indent 2 $ formatExpr storage ] , ")" ] - SStore addr slot val prev -> T.unlines + SStore slot val prev -> T.unlines [ "(SStore" , indent 2 $ T.unlines - [ "addr:" - , indent 2 $ formatExpr addr - , "slot:" + [ "slot:" , indent 2 $ formatExpr slot , "val:" , indent 2 $ formatExpr val @@ -525,11 +672,18 @@ , ")" , formatExpr prev ] - ConcreteStore s -> T.unlines - [ "(ConcreteStore" - , indent 2 $ T.unlines $ fmap (T.pack . show) $ Map.toList $ fmap (T.pack . show . Map.toList) s - , ")" - ] + AbstractStore a -> + "(AbstractStore " <> formatExpr a <> ")" + ConcreteStore s -> if null s + then "(ConcreteStore )" + else T.unlines + [ "(ConcreteStore" + , indent 2 $ T.unlines + [ "vals:" + , indent 2 $ T.unlines $ fmap (T.pack . show) $ Map.toList s + ] + , ")" + ] -- Buffers @@ -569,20 +723,67 @@ "" -> "(ConcreteBuf \"\")" _ -> T.unlines [ "(ConcreteBuf" - , indent 2 $ T.pack $ prettyHex 0 bs + , indent 2 $ T.pack $ prettyHex bs , ")" ] - + b@(AbstractBuf _) -> "(" <> T.pack (show b) <> ")" -- Hashes - Keccak b -> T.unlines - [ "(Keccak" - , indent 2 $ formatExpr b - , ")" - ] + Keccak b -> fmt "Keccak" [b] + SHA256 b -> fmt "SHA256" [b] + where + fmt nm args = T.unlines + [ "(" <> nm + , indent 2 $ T.unlines $ fmap formatExpr args + , ")" + ] - a -> T.pack $ show a +formatProp :: Prop -> Text +formatProp x = T.stripEnd $ case x of + PEq a b -> fmt "PEq" [a, b] + PLT a b -> fmt "PLT" [a, b] + PGT a b -> fmt "PGT" [a, b] + PGEq a b -> fmt "PGEq" [a, b] + PLEq a b -> fmt "PLEq" [a, b] + PNeg a -> fmt' "PNeg" [a] + PAnd a b -> fmt' "PAnd" [a, b] + POr a b -> fmt' "POr" [a, b] + PImpl a b -> fmt' "PImpl" [a, b] + PBool a -> T.pack (show a) + where + fmt nm args = T.unlines + [ "(" <> nm + , indent 2 $ T.unlines $ fmap formatExpr args + , ")" + ] + fmt' nm args = T.unlines + [ "(" <> nm + , indent 2 $ T.unlines $ fmap formatProp args + , ")" + ] +formatNonce :: Maybe W64 -> Text +formatNonce = \case + Just w -> T.pack $ show w + Nothing -> "symbolic" + +formatCode :: ContractCode -> Text +formatCode = \case + UnknownCode _ -> "Unknown" + InitCode c d -> T.unlines + [ "(InitCode" + , indent 2 $ T.unlines + [ "code: " <> T.pack (bsToHex c) + , "data: " <> formatExpr d + ] + , ")" + ] + RuntimeCode (ConcreteRuntimeCode c) + -> "(RuntimeCode " <> T.pack (bsToHex c) <> ")" + RuntimeCode (SymbolicRuntimeCode bs) + -> "(RuntimeCode " <> T.pack (show (fmap formatExpr bs)) <> ")" + + strip0x :: ByteString -> ByteString strip0x bs = if "0x" `Char8.isPrefixOf` bs then Char8.drop 2 bs else bs @@ -604,4 +805,7 @@ bsToHex :: ByteString -> String bsToHex bs = concatMap (paddedShowHex 2) (BS.unpack bs) - +showVal :: AbiValue -> Text +showVal (AbiBytes _ bs) = formatBytes bs +showVal (AbiAddress addr) = T.pack . show $ addr +showVal v = T.pack . show $ v diff --git a/src/EVM/Hexdump.hs b/src/EVM/Hexdump.hs deleted file mode 100644 --- a/src/EVM/Hexdump.hs +++ /dev/null @@ -1,129 +0,0 @@ --- Copyright (c) 2011, Galois Inc. All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above --- copyright notice, this list of conditions and the following --- disclaimer in the documentation and/or other materials provided --- with the distribution. --- --- * Neither the name of Trevor Elliott nor the names of other --- contributors may be used to endorse or promote products derived --- from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR --- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT --- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT --- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, --- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY --- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT --- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module EVM.Hexdump (prettyHex, simpleHex, paddedShowHex) where - -import Data.ByteString (ByteString) -import qualified Data.ByteString as B (length, unpack) -import qualified Data.ByteString.Char8 as B8 (unpack) -import Data.Char (isAscii, isControl) -import Data.List (intercalate, transpose, unfoldr) -import Numeric (showHex) - -byteWidth :: Num a => a -byteWidth = 2 -- Width of an padded 'Word8' - -numWordBytes :: Num a => a -numWordBytes = 4 -- Number of bytes to group into a 32-bit word - --- |'prettyHex' renders a 'ByteString' as a multi-line 'String' complete with --- addressing, hex digits, and ASCII representation. --- --- Sample output --- --- @Length: 100 (0x64) bytes ---0000: 4b c1 ad 8a 5b 47 d7 57 48 64 e7 cc 5e b5 2f 6e K...[G.WHd..^./n ---0010: c5 b3 a4 73 44 3b 97 53 99 2d 54 e7 1b 2f 91 12 ...sD;.S.-T../.. ---0020: c8 1a ff c4 3b 2b 72 ea 97 e2 9f e2 93 ad 23 79 ....;+r.......#y ---0030: e8 0f 08 54 02 14 fa 09 f0 2d 34 c9 08 6b e1 64 ...T.....-4..k.d ---0040: d1 c5 98 7e d6 a1 98 e2 97 da 46 68 4e 60 11 15 ...~......FhN`.. ---0050: d8 32 c6 0b 70 f5 2e 76 7f 8d f2 3b ed de 90 c6 .2..p..v...;.... ---0060: 93 12 9c e1 ....@ -prettyHex :: Int -> ByteString -> String -prettyHex hexDisplayWidth bs = unlines (header : body) - where - numLineWords = 4 -- Number of words to group onto a line - addressWidth = 4 -- Minimum width of a padded address - numLineBytes = numLineWords * numWordBytes -- Number of bytes on a line - replacementChar = '.' -- 'Char' to use for non-printable characters - - header = "Length: " ++ show (B.length bs) - ++ " (0x" ++ showHex (B.length bs) ") bytes" - - body = map (intercalate " ") - $ transpose [mkLineNumbers, mkHexDisplay bs, mkAsciiDump bs] - - mkHexDisplay - = padLast hexDisplayWidth - . map (intercalate " ") . group numLineWords - . map (intercalate " ") . group numWordBytes - . map (paddedShowHex byteWidth) - . B.unpack - - mkAsciiDump = group numLineBytes . cleanString . B8.unpack - - cleanString = map go - where - go x | isWorthPrinting x = x - | otherwise = replacementChar - - mkLineNumbers = [paddedShowHex addressWidth (x * numLineBytes) ++ ":" - | x <- [0 .. (B.length bs - 1) `div` numLineBytes] ] - - padLast w [x] = [x ++ replicate (w - length x) ' '] - padLast w (x:xs) = x : padLast w xs - padLast _ [] = [] - --- |'paddedShowHex' displays a number in hexidecimal and pads the number --- with 0 so that it has a minimum length of @w@. -paddedShowHex :: (Show a, Integral a) => Int -> a -> String -paddedShowHex w n = pad ++ str - where - str = showHex n "" - pad = replicate (w - length str) '0' - - --- |'simpleHex' converts a 'ByteString' to a 'String' showing the octets --- grouped in 32-bit words. --- --- Sample output --- --- @4b c1 ad 8a 5b 47 d7 57@ -simpleHex :: ByteString -> String -simpleHex = intercalate " " - . map (intercalate " ") . group numWordBytes - . map (paddedShowHex byteWidth) - . B.unpack - --- |'isWorthPrinting' returns 'True' for non-control ascii characters. --- These characters will all fit in a single character when rendered. -isWorthPrinting :: Char -> Bool -isWorthPrinting x = isAscii x && not (isControl x) - --- |'group' breaks up a list into sublists of size @n@. The last group --- may be smaller than @n@ elements. When @n@ less not positive the --- list is returned as one sublist. -group :: Int -> [a] -> [[a]] -group n - | n <= 0 = (:[]) - | otherwise = unfoldr go - where - go [] = Nothing - go xs = Just (splitAt n xs) diff --git a/src/EVM/Keccak.hs b/src/EVM/Keccak.hs --- a/src/EVM/Keccak.hs +++ b/src/EVM/Keccak.hs @@ -4,7 +4,7 @@ Module: EVM.Keccak Description: Expr passes to determine Keccak assumptions -} -module EVM.Keccak (keccakAssumptions) where +module EVM.Keccak (keccakAssumptions, keccakCompute) where import Control.Monad.State import Data.Set (Set) @@ -12,8 +12,9 @@ import EVM.Traversals import EVM.Types +import EVM.Expr -data BuilderState = BuilderState +newtype BuilderState = BuilderState { keccaks :: Set (Expr EWord) } deriving (Show) @@ -50,12 +51,12 @@ combine' xs (xcomb:acc) minProp :: Expr EWord -> Prop -minProp k@(Keccak _) = PGT k (Lit 50) +minProp k@(Keccak _) = PGT k (Lit 256) minProp _ = internalError "expected keccak expression" injProp :: (Expr EWord, Expr EWord) -> Prop injProp (k1@(Keccak b1), k2@(Keccak b2)) = - POr (PEq b1 b2) (PNeg (PEq k1 k2)) + POr ((b1 .== b2) .&& (bufLength b1 .== bufLength b2)) (PNeg (PEq k1 k2)) injProp _ = internalError "expected keccak expression" -- Takes a list of props, find all keccak occurences and generates two kinds of assumptions: @@ -72,3 +73,24 @@ injectivity = fmap injProp $ combine (Set.toList st.keccaks) minValue = fmap minProp (Set.toList st.keccaks) + +compute :: forall a. Expr a -> [Prop] +compute = \case + e@(Keccak buf) -> do + let b = simplify buf + case keccak b of + lit@(Lit _) -> [PEq e lit] + _ -> [] + _ -> [] + +computeKeccakExpr :: forall a. Expr a -> [Prop] +computeKeccakExpr e = foldExpr compute [] e + +computeKeccakProp :: Prop -> [Prop] +computeKeccakProp p = foldProp compute [] p + +keccakCompute :: [Prop] -> [Expr Buf] -> [Expr Storage] -> [Prop] +keccakCompute ps buf stores = + concatMap computeKeccakProp ps <> + concatMap computeKeccakExpr buf <> + concatMap computeKeccakExpr stores diff --git a/src/EVM/Patricia.hs b/src/EVM/Patricia.hs deleted file mode 100644 --- a/src/EVM/Patricia.hs +++ /dev/null @@ -1,226 +0,0 @@ -module EVM.Patricia where - -import EVM.RLP -import EVM.Types - -import Control.Monad.Free -import Control.Monad.State -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.Foldable (toList) -import Data.List (stripPrefix) -import Data.Map qualified as Map -import Data.Sequence (Seq) -import Data.Sequence qualified as Seq -import Witch (into) - -data KV k v a - = Put k v a - | Get k (v -> a) - deriving (Functor) - -newtype DB k v a = DB (Free (KV k v) a) - deriving (Functor, Applicative, Monad) - -insertDB :: k -> v -> DB k v () -insertDB k v = DB $ liftF $ Put k v () - -lookupDB :: k -> DB k v v -lookupDB k = DB $ liftF $ Get k id - --- Collapses a series of puts and gets down to the monad of your choice -runDB :: Monad m - => (k -> v -> m ()) -- ^ The 'put' function for our desired monad - -> (k -> m v) -- ^ The 'get' function for the same monad - -> DB k v a -- ^ The puts and gets to execute - -> m a -runDB putt gett (DB ops) = go ops - where - go (Pure a) = pure a - go (Free (Put k v next)) = putt k v >> go next - go (Free (Get k handler)) = gett k >>= go . handler - -type Path = [Nibble] - -data Ref = Hash ByteString | Literal Node - deriving (Eq) - -instance Show Ref where - show (Hash d) = show (ByteStringS d) - show (Literal n) = show n - -data Node = Empty - | Shortcut Path (Either Ref ByteString) - | Full (Seq Ref) ByteString - deriving (Show, Eq) - --- the function HP from Appendix C of yellow paper -encodePath :: Path -> Bool -> ByteString -encodePath p isTerminal | even (length p) - = packNibbles $ Nibble flag : Nibble 0 : p - | otherwise - = packNibbles $ Nibble (flag + 1) : p - where flag = if isTerminal then 2 else 0 - -rlpRef :: Ref -> RLP -rlpRef (Hash d) = BS d -rlpRef (Literal n) = rlpNode n - -rlpNode :: Node -> RLP -rlpNode Empty = BS mempty -rlpNode (Shortcut path (Right val)) = List [BS $ encodePath path True, BS val] -rlpNode (Shortcut path (Left ref)) = List [BS $ encodePath path False, rlpRef ref] -rlpNode (Full refs val) = List $ toList (fmap rlpRef refs) <> [BS val] - -type NodeDB = DB ByteString Node - -instance Show (NodeDB Node) where - show = show - -putNode :: Node -> NodeDB Ref -putNode node = - let bytes = rlpencode $ rlpNode node - digest = word256Bytes $ keccak' bytes - in if BS.length bytes < 32 - then pure $ Literal node - else do - insertDB digest node - pure $ Hash digest - -getNode :: Ref -> NodeDB Node -getNode (Hash d) = lookupDB d -getNode (Literal n) = pure n - -lookupPath :: Ref -> Path -> NodeDB ByteString -lookupPath root path = getNode root >>= getVal path - -getVal :: Path -> Node -> NodeDB ByteString -getVal _ Empty = pure BS.empty -getVal path (Shortcut nodePath ref) = - case (stripPrefix nodePath path, ref) of - (Just [], Right value) -> pure value - (Just remaining, Left key) -> lookupPath key remaining - _ -> pure BS.empty - -getVal [] (Full _ val) = pure val -getVal (p:ps) (Full refs _) = lookupPath (refs `Seq.index` (into p)) ps - -emptyRef :: Ref -emptyRef = Literal Empty - -emptyRefs :: Seq Ref -emptyRefs = Seq.replicate 16 emptyRef - -addPrefix :: Path -> Node -> NodeDB Node -addPrefix _ Empty = pure Empty -addPrefix [] node = pure node -addPrefix path (Shortcut p v) = pure $ Shortcut (path <> p) v -addPrefix path n = Shortcut path . Left <$> putNode n - -insertRef :: Ref -> Path -> ByteString -> NodeDB Ref -insertRef ref p val = do root <- getNode ref - newNode <- if val == BS.empty - then delete root p - else update root p val - putNode newNode - -update :: Node -> Path -> ByteString -> NodeDB Node -update Empty p new = pure $ Shortcut p (Right new) -update (Full refs _) [] new = pure (Full refs new) -update (Full refs old) (p:ps) new = do - newRef <- insertRef (refs `Seq.index` (into p)) ps new - pure $ Full (Seq.update (into p) newRef refs) old -update (Shortcut (o:os) (Right old)) [] new = do - newRef <- insertRef emptyRef os old - pure $ Full (Seq.update (into o) newRef emptyRefs) new -update (Shortcut [] (Right old)) (p:ps) new = do - newRef <- insertRef emptyRef ps new - pure $ Full (Seq.update (into p) newRef emptyRefs) old -update (Shortcut [] (Right _)) [] new = - pure $ Shortcut [] (Right new) -update (Shortcut (o:os) to) (p:ps) new | o == p - = update (Shortcut os to) ps new >>= addPrefix [o] - | otherwise = do - oldRef <- case to of - (Left ref) -> getNode ref >>= addPrefix os >>= putNode - (Right val) -> insertRef emptyRef os val - newRef <- insertRef emptyRef ps new - let refs = Seq.update (into p) newRef $ Seq.update (into o) oldRef emptyRefs - pure $ Full refs BS.empty -update (Shortcut (o:os) (Left ref)) [] new = do - newRef <- getNode ref >>= addPrefix os >>= putNode - pure $ Full (Seq.update (into o) newRef emptyRefs) new -update (Shortcut cut (Left ref)) ps new = do - newRef <- insertRef ref ps new - pure $ Shortcut cut (Left newRef) - -delete :: Node -> Path -> NodeDB Node -delete Empty _ = pure Empty -delete (Shortcut [] (Right _)) [] = pure Empty -delete n@(Shortcut [] (Right _)) _ = pure n -delete (Shortcut [] (Left ref)) p = do node <- getNode ref - delete node p -delete n@(Shortcut _ _) [] = pure n -delete n@(Shortcut (o:os) to) (p:ps) | p == o - = delete (Shortcut os to) ps >>= addPrefix [o] - | otherwise - = pure n -delete (Full refs _) [] | refs == emptyRefs - = pure Empty - | otherwise - = pure (Full refs BS.empty) -delete (Full refs val) (p:ps) = do - newRef <- insertRef (refs `Seq.index` (into p)) ps BS.empty - let newRefs = Seq.update (into p) newRef refs - nonEmpties = filter (\(_, ref) -> ref /= emptyRef) $ zip [0..15] $ toList newRefs - case (nonEmpties, BS.null val) of - ([], True) -> pure Empty - ([(n, ref)], True) -> getNode ref >>= addPrefix [Nibble n] - _ -> pure $ Full newRefs val - -insert :: Ref -> ByteString -> ByteString -> NodeDB Ref -insert ref key = insertRef ref (unpackNibbles key) - -lookupIn :: Ref -> ByteString -> NodeDB ByteString -lookupIn ref bs = lookupPath ref $ unpackNibbles bs - -type Trie = StateT Ref NodeDB - -runTrie :: DB ByteString ByteString a -> Trie a -runTrie = runDB putDB getDB - where - putDB key val = do - ref <- get - newRef <- lift $ insert ref key val - put newRef - getDB key = do - ref <- get - lift $ lookupIn ref key - -type MapDB k v a = StateT (Map.Map k v) Maybe a - -runMapDB :: Ord k => DB k v a -> MapDB k v a -runMapDB = runDB putDB getDB - where - getDB key = do - mmap <- get - lift $ Map.lookup key mmap - putDB key value = do - mmap <- get - let newMap = Map.insert key value mmap - put newMap - - -insertValues :: [(ByteString, ByteString)] -> Maybe Ref -insertValues inputs = - let trie = runTrie $ mapM_ insertPair inputs - mapDB = runMapDB $ runStateT trie (Literal Empty) - result = snd <$> evalStateT mapDB Map.empty - insertPair (key, value) = insertDB key value - in result - -calcRoot :: [(ByteString, ByteString)] -> Maybe ByteString -calcRoot vs = case insertValues vs of - Just (Hash b) -> Just b - Just (Literal n) -> Just $ word256Bytes $ keccak' $ rlpencode $ rlpNode n - Nothing -> Nothing diff --git a/src/EVM/SMT.hs b/src/EVM/SMT.hs --- a/src/EVM/SMT.hs +++ b/src/EVM/SMT.hs @@ -12,15 +12,16 @@ import Control.Monad import Data.Containers.ListUtils (nubOrd) import Data.ByteString (ByteString) -import Data.Bifunctor (second) import Data.ByteString qualified as BS import Data.List qualified as List import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty qualified as NonEmpty import Data.String.Here -import Data.Maybe (fromJust) -import Data.Map (Map) -import Data.Map qualified as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set import Data.Word (Word8) import Data.Text.Lazy (Text) import Data.Text qualified as TS @@ -30,11 +31,12 @@ import Language.SMT2.Syntax (Symbol, SpecConstant(..), GeneralRes(..), Term(..), QualIdentifier(..), Identifier(..), Sort(..), Index(..), VarBinding(..)) import Numeric (readHex, readBin) import Witch (into, unsafeInto) +import Control.Monad.State import EVM.CSE import EVM.Expr (writeByte, bufLengthEnv, containsNode, bufLength, minLength, inRange) import EVM.Expr qualified as Expr -import EVM.Keccak (keccakAssumptions) +import EVM.Keccak (keccakAssumptions, keccakCompute) import EVM.Traversals import EVM.Types @@ -42,22 +44,30 @@ -- ** Encoding ** ---------------------------------------------------------------------------------- --- variable names in SMT that we want to get values for +-- | Data that we need to construct a nice counterexample data CexVars = CexVars - { calldata :: [Text] - , buffers :: Map Text (Expr EWord) -- buffers and guesses at their maximum size - , storeReads :: [(Expr EWord, Expr EWord)] -- a list of relevant store reads + { -- | variable names that we need models for to reconstruct calldata + calldata :: [Text] + -- | symbolic address names + , addrs :: [Text] + -- | buffer names and guesses at their maximum size + , buffers :: Map Text (Expr EWord) + -- | reads from abstract storage + , storeReads :: Map (Expr EAddr) (Set (Expr EWord)) + -- | the names of any block context variables , blockContext :: [Text] + -- | the names of any tx context variables , txContext :: [Text] } deriving (Eq, Show) instance Semigroup CexVars where - (CexVars a b c d e) <> (CexVars a2 b2 c2 d2 e2) = CexVars (a <> a2) (b <> b2) (c <> c2) (d <> d2) (e <> e2) + (CexVars a b c d e f) <> (CexVars a2 b2 c2 d2 e2 f2) = CexVars (a <> a2) (b <> b2) (c <> c2) (d <> d2) (e <> e2) (f <> f2) instance Monoid CexVars where mempty = CexVars { calldata = mempty + , addrs = mempty , buffers = mempty , storeReads = mempty , blockContext = mempty @@ -83,13 +93,19 @@ -- | a final post shrinking cex, buffers here are all represented as concrete bytestrings data SMTCex = SMTCex { vars :: Map (Expr EWord) W256 + , addrs :: Map (Expr EAddr) Addr , buffers :: Map (Expr Buf) BufModel - , store :: Map W256 (Map W256 W256) + , store :: Map (Expr EAddr) (Map W256 W256) , blockContext :: Map (Expr EWord) W256 , txContext :: Map (Expr EWord) W256 } deriving (Eq, Show) + +-- | Used for abstraction-refinement of the SMT formula. Contains assertions that make our query fully precise. These will be added to the assertion stack if we get `sat` with the abstracted query. +newtype RefinementEqs = RefinementEqs [Builder] + deriving (Eq, Show, Monoid, Semigroup) + flattenBufs :: SMTCex -> Maybe SMTCex flattenBufs cex = do bs <- mapM collapse cex.buffers @@ -109,17 +125,17 @@ getVar :: SMTCex -> TS.Text -> W256 getVar cex name = fromJust $ Map.lookup (Var name) cex.vars -data SMT2 = SMT2 [Builder] CexVars +data SMT2 = SMT2 [Builder] RefinementEqs CexVars deriving (Eq, Show) instance Semigroup SMT2 where - (SMT2 a b) <> (SMT2 a2 b2) = SMT2 (a <> a2) (b <> b2) + (SMT2 a (RefinementEqs b) c) <> (SMT2 a2 (RefinementEqs b2) c2) = SMT2 (a <> a2) (RefinementEqs (b <> b2)) (c <> c2) instance Monoid SMT2 where - mempty = SMT2 mempty mempty + mempty = SMT2 mempty mempty mempty formatSMT2 :: SMT2 -> Text -formatSMT2 (SMT2 ls _) = T.unlines (fmap toLazyText ls) +formatSMT2 (SMT2 ls _ _) = T.unlines (fmap toLazyText ls) -- | Reads all intermediate variables from the builder state and produces SMT declaring them as constants declareIntermediates :: BufEnv -> StoreEnv -> SMT2 @@ -128,113 +144,175 @@ encBs = Map.mapWithKey encodeBuf bufs sorted = List.sortBy compareFst $ Map.toList $ encSs <> encBs decls = fmap snd sorted - in SMT2 ([fromText "; intermediate buffers & stores"] <> decls) mempty + smt2 = (SMT2 [fromText "; intermediate buffers & stores"] mempty mempty):decls + in foldr (<>) (SMT2[""] mempty mempty) smt2 where compareFst (l, _) (r, _) = compare l r encodeBuf n expr = - "(define-const buf" <> (fromString . show $ n) <> " Buf " <> exprToSMT expr <> ")\n" <> encodeBufLen n expr + SMT2 ["(define-const buf" <> (fromString . show $ n) <> " Buf " <> exprToSMT expr <> ")\n"] mempty mempty <> encodeBufLen n expr encodeBufLen n expr = - "(define-const buf" <> (fromString . show $ n) <>"_length" <> " (_ BitVec 256) " <> exprToSMT (bufLengthEnv bufs True expr) <> ")" + SMT2 ["(define-const buf" <> (fromString . show $ n) <>"_length" <> " (_ BitVec 256) " <> exprToSMT (bufLengthEnv bufs True expr) <> ")"] mempty mempty encodeStore n expr = - "(define-const store" <> (fromString . show $ n) <> " Storage " <> exprToSMT expr <> ")" + SMT2 ["(define-const store" <> (fromString . show $ n) <> " Storage " <> exprToSMT expr <> ")"] mempty mempty -assertProps :: [Prop] -> SMT2 -assertProps ps = - let encs = map propToSMT ps_elim +data AbstState = AbstState + { words :: Map (Expr EWord) Int + , count :: Int + } + deriving (Show) + +abstractAwayProps :: AbstRefineConfig -> [Prop] -> ([Prop], AbstState) +abstractAwayProps abstRefineConfig ps = runState (mapM abstrAway ps) (AbstState mempty 0) + where + abstrAway :: Prop -> State AbstState Prop + abstrAway prop = mapPropM go prop + go :: Expr a -> State AbstState (Expr a) + go x = case x of + e@(Mod{}) | abstRefineConfig.arith -> abstrExpr e + e@(SMod{}) | abstRefineConfig.arith -> abstrExpr e + e@(MulMod{}) | abstRefineConfig.arith -> abstrExpr e + e@(AddMod{}) | abstRefineConfig.arith -> abstrExpr e + e@(Mul{}) | abstRefineConfig.arith -> abstrExpr e + e@(Div{}) | abstRefineConfig.arith -> abstrExpr e + e@(SDiv {}) | abstRefineConfig.arith -> abstrExpr e + e@(ReadWord {}) | abstRefineConfig.mem -> abstrExpr e + e -> pure e + where + abstrExpr e = do + s <- get + case Map.lookup e s.words of + Just v -> pure (Var (TS.pack ("abst_" ++ show v))) + Nothing -> do + let + next = s.count + bs' = Map.insert e next s.words + put $ s{words=bs', count=next+1} + pure $ Var (TS.pack ("abst_" ++ show next)) + +smt2Line :: Builder -> SMT2 +smt2Line txt = SMT2 [txt] mempty mempty + +assertProps :: AbstRefineConfig -> [Prop] -> SMT2 +assertProps conf ps = assertPropsNoSimp conf (Expr.simplifyProps ps) + +-- Note: we need a version that does NOT call simplify or simplifyProps, +-- because we make use of it to verify the correctness of our simplification +-- passes through property-based testing. +assertPropsNoSimp :: AbstRefineConfig -> [Prop] -> SMT2 +assertPropsNoSimp abstRefineConfig ps = + let encs = map propToSMT psElimAbst + abstSMT = map propToSMT abstProps intermediates = declareIntermediates bufs stores in prelude - <> (declareBufs ps_elim bufs stores) - <> SMT2 [""] mempty + <> (declareAbstractStores abstractStores) + <> smt2Line "" + <> (declareAddrs addresses) + <> smt2Line "" + <> (declareBufs psElim bufs stores) + <> smt2Line "" <> (declareVars . nubOrd $ foldl (<>) [] allVars) - <> SMT2 [""] mempty + <> smt2Line "" <> (declareFrameContext . nubOrd $ foldl (<>) [] frameCtx) - <> SMT2 [""] mempty + <> smt2Line "" <> (declareBlockContext . nubOrd $ foldl (<>) [] blockCtx) - <> SMT2 [""] mempty + <> smt2Line "" <> intermediates - <> SMT2 [""] mempty + <> smt2Line "" <> keccakAssumes <> readAssumes - <> SMT2 [""] mempty - <> SMT2 (fmap (\p -> "(assert " <> p <> ")") encs) mempty - <> SMT2 [] mempty{ storeReads = storageReads } + <> smt2Line "" + <> SMT2 (fmap (\p -> "(assert " <> p <> ")") encs) mempty mempty + <> SMT2 mempty (RefinementEqs $ fmap (\p -> "(assert " <> p <> ")") abstSMT) mempty + <> SMT2 mempty mempty mempty { storeReads = storageReads } where - (ps_elim, bufs, stores) = eliminateProps ps + (psElim, bufs, stores) = eliminateProps ps + (psElimAbst, abst@(AbstState abstExprToInt _)) = if abstRefineConfig.arith || abstRefineConfig.mem + then abstractAwayProps abstRefineConfig psElim + else (psElim, AbstState mempty 0) - allVars = fmap referencedVars' ps_elim <> fmap referencedVars bufVals <> fmap referencedVars storeVals - frameCtx = fmap referencedFrameContext' ps_elim <> fmap referencedFrameContext bufVals <> fmap referencedFrameContext storeVals - blockCtx = fmap referencedBlockContext' ps_elim <> fmap referencedBlockContext bufVals <> fmap referencedBlockContext storeVals + abstProps = map toProp (Map.toList abstExprToInt) + where + toProp :: (Expr EWord, Int) -> Prop + toProp (e, num) = PEq e (Var (TS.pack ("abst_" ++ (show num)))) + allVars = fmap referencedVars psElim <> fmap referencedVars bufVals <> fmap referencedVars storeVals <> [abstrVars abst] + frameCtx = fmap referencedFrameContext psElim <> fmap referencedFrameContext bufVals <> fmap referencedFrameContext storeVals + blockCtx = fmap referencedBlockContext psElim <> fmap referencedBlockContext bufVals <> fmap referencedBlockContext storeVals + + abstrVars :: AbstState -> [Builder] + abstrVars (AbstState b _) = map ((\v->fromString ("abst_" ++ show v)) . snd) (Map.toList b) + bufVals = Map.elems bufs storeVals = Map.elems stores - - storageReads = nubOrd $ concatMap findStorageReads ps + storageReads = Map.unionsWith (<>) $ fmap findStorageReads ps + abstractStores = Set.toList $ Set.unions (fmap referencedAbstractStores ps) + addresses = Set.toList $ Set.unions (fmap referencedWAddrs ps) keccakAssumes - = SMT2 ["; keccak assumptions"] mempty - <> SMT2 (fmap (\p -> "(assert " <> propToSMT p <> ")") (keccakAssumptions ps_elim bufVals storeVals)) mempty + = smt2Line "; keccak assumptions" + <> SMT2 (fmap (\p -> "(assert " <> propToSMT p <> ")") (keccakAssumptions psElim bufVals storeVals)) mempty mempty + <> smt2Line "; keccak computations" + <> SMT2 (fmap (\p -> "(assert " <> propToSMT p <> ")") (keccakCompute psElim bufVals storeVals)) mempty mempty readAssumes - = SMT2 ["; read assumptions"] mempty - <> SMT2 (fmap (\p -> "(assert " <> propToSMT p <> ")") (assertReads ps_elim bufs stores)) 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, [Prop])] -referencedFrameContextGo = \case - CallValue a -> [(fromLazyText $ T.append "callvalue_" (T.pack . show $ a), [])] - Caller a -> [(fromLazyText $ T.append "caller_" (T.pack . show $ a), [inRange 160 (Caller a)])] - Address a -> [(fromLazyText $ T.append "address_" (T.pack . show $ a), [inRange 160 (Address a)])] - Balance {} -> internalError "TODO: BALANCE" - SelfBalance {} -> internalError "TODO: SELFBALANCE" - Gas {} -> internalError "TODO: GAS" - _ -> [] + = smt2Line "; read assumptions" + <> SMT2 (fmap (\p -> "(assert " <> propToSMT p <> ")") (assertReads psElim bufs stores)) mempty mempty -referencedFrameContext :: Expr a -> [(Builder, [Prop])] -referencedFrameContext expr = nubOrd $ foldExpr referencedFrameContextGo [] expr +referencedAbstractStores :: TraversableTerm a => a -> Set Builder +referencedAbstractStores term = foldTerm go mempty term + where + go = \case + AbstractStore s -> Set.singleton (storeName s) + _ -> mempty -referencedFrameContext' :: Prop -> [(Builder, [Prop])] -referencedFrameContext' prop = nubOrd $ foldProp referencedFrameContextGo [] prop +referencedWAddrs :: TraversableTerm a => a -> Set Builder +referencedWAddrs term = foldTerm go mempty term + where + go = \case + WAddr(a@(SymAddr _)) -> Set.singleton (formatEAddr a) + _ -> mempty +referencedBufs :: TraversableTerm a => a -> [Builder] +referencedBufs expr = nubOrd $ foldTerm go [] expr + where + go :: Expr a -> [Builder] + go = \case + AbstractBuf s -> [fromText s] + _ -> [] -referencedBlockContextGo :: Expr a -> [(Builder, [Prop])] -referencedBlockContextGo = \case - Origin -> [("origin", [inRange 160 Origin])] - Coinbase -> [("coinbase", [inRange 160 Coinbase])] - Timestamp -> [("timestamp", [])] - BlockNumber -> [("blocknumber", [])] - PrevRandao -> [("prevrandao", [])] - GasLimit -> [("gaslimit", [])] - ChainId -> [("chainid", [])] - BaseFee -> [("basefee", [])] - _ -> [] +referencedVars :: TraversableTerm a => a -> [Builder] +referencedVars expr = nubOrd $ foldTerm go [] expr + where + go :: Expr a -> [Builder] + go = \case + Var s -> [fromText s] + _ -> [] -referencedBlockContext :: Expr a -> [(Builder, [Prop])] -referencedBlockContext expr = nubOrd $ foldExpr referencedBlockContextGo [] expr +referencedFrameContext :: TraversableTerm a => a -> [(Builder, [Prop])] +referencedFrameContext expr = nubOrd $ foldTerm go [] expr + where + go :: Expr a -> [(Builder, [Prop])] + go = \case + TxValue -> [(fromString "txvalue", [])] + v@(Balance a) -> [(fromString "balance_" <> formatEAddr a, [PLT v (Lit $ 2 ^ (96 :: Int))])] + Gas {} -> internalError "TODO: GAS" + _ -> [] -referencedBlockContext' :: Prop -> [(Builder, [Prop])] -referencedBlockContext' prop = nubOrd $ foldProp referencedBlockContextGo [] prop +referencedBlockContext :: TraversableTerm a => a -> [(Builder, [Prop])] +referencedBlockContext expr = nubOrd $ foldTerm go [] expr + where + go :: Expr a -> [(Builder, [Prop])] + go = \case + Origin -> [("origin", [inRange 160 Origin])] + Coinbase -> [("coinbase", [inRange 160 Coinbase])] + Timestamp -> [("timestamp", [])] + BlockNumber -> [("blocknumber", [])] + PrevRandao -> [("prevrandao", [])] + GasLimit -> [("gaslimit", [])] + ChainId -> [("chainid", [])] + BaseFee -> [("basefee", [])] + _ -> [] -- | This function overapproximates the reads from the abstract -- storage. Potentially, it can return locations that do not read a @@ -242,18 +320,18 @@ -- 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 [] +findStorageReads :: Prop -> Map (Expr EAddr) (Set (Expr EWord)) +findStorageReads p = Map.fromListWith (<>) $ foldProp go mempty p where - go :: Expr a -> [(Expr EWord, Expr EWord)] + go :: Expr a -> [(Expr EAddr, Set (Expr EWord))] go = \case - SLoad addr slot storage -> [(addr, slot) | containsNode isAbstractStore storage] + SLoad slot store -> + [((fromMaybe (error $ "Internal Error: could not extract address from: " <> show store) (Expr.getAddr store)), Set.singleton slot) | containsNode isAbstractStore store] _ -> [] - isAbstractStore AbstractStore = True + isAbstractStore (AbstractStore _) = True isAbstractStore _ = False - findBufferAccess :: TraversableTerm a => [a] -> [(Expr EWord, Expr EWord, Expr Buf)] findBufferAccess = foldl (foldTerm go) mempty where @@ -295,7 +373,7 @@ allReads = nubOrd $ findBufferAccess props <> findBufferAccess (Map.elems benv) <> findBufferAccess (Map.elems senv) -- we can have buffers that are not read from but are still mentioned via BufLength in some branch condition -- we assign a default read hint of 4 to start with in these cases (since in most cases we will need at least 4 bytes to produce a counterexample) - allBufs = Map.fromList . fmap (, Lit 4) . fmap toLazyText . nubOrd . concat $ fmap referencedBufs' props <> fmap referencedBufs (Map.elems benv) <> fmap referencedBufs (Map.elems senv) + allBufs = Map.fromList . fmap (, Lit 4) . fmap toLazyText . nubOrd . concat $ fmap referencedBufs props <> fmap referencedBufs (Map.elems benv) <> fmap referencedBufs (Map.elems senv) bufMap = Map.unionWith Expr.max (foldl addBound mempty allReads) allBufs @@ -317,7 +395,7 @@ -- | Returns an SMT2 object with all buffers referenced from the input props declared, and with the appropriate cex extraction metadata attached declareBufs :: [Prop] -> BufEnv -> StoreEnv -> SMT2 -declareBufs props bufEnv storeEnv = SMT2 ("; buffers" : fmap declareBuf allBufs <> ("; buffer lengths" : fmap declareLength allBufs)) cexvars +declareBufs props bufEnv storeEnv = SMT2 ("; buffers" : fmap declareBuf allBufs <> ("; buffer lengths" : fmap declareLength allBufs)) mempty cexvars where cexvars = (mempty :: CexVars){ buffers = discoverMaxReads props bufEnv storeEnv } allBufs = fmap fromLazyText $ Map.keys cexvars.buffers @@ -326,30 +404,41 @@ -- Given a list of variable names, create an SMT2 object with the variables declared declareVars :: [Builder] -> SMT2 -declareVars names = SMT2 (["; variables"] <> fmap declare names) cexvars +declareVars names = SMT2 (["; variables"] <> fmap declare names) mempty cexvars where declare n = "(declare-const " <> n <> " (_ BitVec 256))" cexvars = (mempty :: CexVars){ calldata = fmap toLazyText names } +-- Given a list of variable names, create an SMT2 object with the variables declared +declareAddrs :: [Builder] -> SMT2 +declareAddrs names = SMT2 (["; symbolic addresseses"] <> fmap declare names) mempty cexvars + where + declare n = "(declare-const " <> n <> " Addr)" + cexvars = (mempty :: CexVars){ addrs = fmap toLazyText names } declareFrameContext :: [(Builder, [Prop])] -> SMT2 -declareFrameContext names = SMT2 (["; frame context"] <> concatMap declare names) cexvars +declareFrameContext names = SMT2 (["; frame context"] <> concatMap declare names) mempty cexvars where declare (n,props) = [ "(declare-const " <> n <> " (_ BitVec 256))" ] <> fmap (\p -> "(assert " <> propToSMT p <> ")") props cexvars = (mempty :: CexVars){ txContext = fmap (toLazyText . fst) names } +declareAbstractStores :: [Builder] -> SMT2 +declareAbstractStores names = SMT2 (["; abstract base stores"] <> fmap declare names) mempty mempty + where + declare n = "(declare-const " <> n <> " Storage)" declareBlockContext :: [(Builder, [Prop])] -> SMT2 -declareBlockContext names = SMT2 (["; block context"] <> concatMap declare names) cexvars +declareBlockContext names = SMT2 (["; block context"] <> concatMap declare names) mempty cexvars where declare (n, props) = [ "(declare-const " <> n <> " (_ BitVec 256))" ] <> fmap (\p -> "(assert " <> propToSMT p <> ")") props cexvars = (mempty :: CexVars){ blockContext = fmap (toLazyText . fst) names } - prelude :: SMT2 -prelude = (flip SMT2) mempty $ fmap (fromLazyText . T.drop 2) . T.lines $ [i| +prelude = SMT2 src mempty mempty + where + src = fmap (fromLazyText . T.drop 2) . T.lines $ [i| ; logic ; TODO: this creates an error when used with z3? ;(set-logic QF_AUFBV) @@ -358,15 +447,15 @@ ; types (define-sort Byte () (_ BitVec 8)) (define-sort Word () (_ BitVec 256)) + (define-sort Addr () (_ BitVec 160)) (define-sort Buf () (Array Word Byte)) - ; address -> slot -> value - (define-sort Storage () (Array Word (Array Word Word))) + ; slot -> value + (define-sort Storage () (Array Word Word)) ; hash functions (declare-fun keccak (Buf) Word) (declare-fun sha256 (Buf) Word) - (define-fun max ((a (_ BitVec 256)) (b (_ BitVec 256))) (_ BitVec 256) (ite (bvult a b) b a)) ; word indexing @@ -442,9 +531,6 @@ )))))))))))))))))))))))))))))))) ) - ; buffers - (define-const emptyBuf Buf ((as const Buf) #b00000000)) - (define-fun readWord ((idx Word) (buf Buf)) Word (concat (select buf idx) @@ -521,6 +607,7 @@ ; block context (declare-fun blockhash (Word) Word) + (declare-fun codesize (Addr) Word) ; macros (define-fun signext ( (b Word) (val Word)) Word @@ -555,23 +642,14 @@ (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))) - - (define-fun sstore ((addr Word) (key Word) (val Word) (storage Storage)) Storage (store storage addr (store (select storage addr) key val))) - - (define-fun sload ((addr Word) (key Word) (storage Storage)) Word (select (select storage addr) key)) |] - exprToSMT :: Expr a -> Builder exprToSMT = \case Lit w -> fromLazyText $ "(_ bv" <> (T.pack $ show (into w :: Integer)) <> " 256)" Var s -> fromText s - GVar (BufVar n) -> fromLazyText $ "buf" <> (T.pack . show $ n) - GVar (StoreVar n) -> fromLazyText $ "store" <> (T.pack . show $ n) + GVar (BufVar n) -> fromString $ "buf" <> (show n) + GVar (StoreVar n) -> fromString $ "store" <> (show n) JoinBytes z o two three four five six seven eight nine ten eleven twelve thirteen fourteen fifteen @@ -660,14 +738,16 @@ let enc = exprToSMT a in "(sha256 " <> enc <> ")" - 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) + TxValue -> fromString "txvalue" + Balance a -> fromString "balance_" <> formatEAddr a Origin -> "origin" BlockHash a -> let enc = exprToSMT a in "(blockhash " <> enc <> ")" + CodeSize a -> + let enc = exprToSMT a in + "(codesize " <> enc <> ")" Coinbase -> "coinbase" Timestamp -> "timestamp" BlockNumber -> "blocknumber" @@ -676,6 +756,9 @@ ChainId -> "chainid" BaseFee -> "basefee" + a@(SymAddr _) -> formatEAddr a + WAddr(a@(SymAddr _)) -> "(concat (_ bv0 96)" `sp` exprToSMT a `sp` ")" + LitByte b -> fromLazyText $ "(_ bv" <> T.pack (show (into b :: Integer)) <> " 8)" IndexWord idx w -> case idx of Lit n -> if n >= 0 && n < 32 @@ -686,7 +769,7 @@ _ -> op2 "indexWord" idx w ReadByte idx src -> op2 "select" src idx - ConcreteBuf "" -> "emptyBuf" + ConcreteBuf "" -> "((as const Buf) #b00000000)" ConcreteBuf bs -> writeBytes bs mempty AbstractBuf s -> fromText s ReadWord idx prev -> op2 "readWord" idx prev @@ -705,16 +788,14 @@ "(writeWord " <> encIdx `sp` encVal `sp` encPrev <> ")" CopySlice srcIdx dstIdx size src dst -> copySlice srcIdx dstIdx size (exprToSMT src) (exprToSMT dst) - EmptyStore -> "emptyStore" ConcreteStore s -> encodeConcreteStore s - AbstractStore -> "abstractStore" - SStore addr idx val prev -> - let encAddr = exprToSMT addr - encIdx = exprToSMT idx + AbstractStore a -> storeName a + SStore idx val prev -> + let encIdx = exprToSMT idx encVal = exprToSMT val encPrev = exprToSMT prev in - "(sstore" `sp` encAddr `sp` encIdx `sp` encVal `sp` encPrev <> ")" - SLoad addr idx store -> op3 "sload" addr idx store + "(store" `sp` encPrev `sp` encIdx `sp` encVal <> ")" + SLoad idx store -> op2 "select" store idx a -> internalError $ "TODO: implement: " <> show a where @@ -725,11 +806,6 @@ let aenc = exprToSMT a benc = exprToSMT b in "(" <> op `sp` aenc `sp` benc <> ")" - op3 op a b c = - let aenc = exprToSMT a - benc = exprToSMT b - cenc = exprToSMT c in - "(" <> op `sp` aenc `sp` benc `sp` cenc <> ")" op2CheckZero op a b = let aenc = exprToSMT a benc = exprToSMT b in @@ -825,20 +901,28 @@ idxSMT = exprToSMT . Lit . unsafeInto $ idx in (idx + 1, "(store " <> inner `sp` idxSMT `sp` byteSMT <> ")") -encodeConcreteStore :: Map W256 (Map W256 W256) -> Builder -encodeConcreteStore s = foldl encodeWrite "emptyStore" writes +encodeConcreteStore :: Map W256 W256 -> Builder +encodeConcreteStore s = foldl encodeWrite "((as const Storage) #x0000000000000000000000000000000000000000000000000000000000000000)" (Map.toList s) 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) + encodeWrite prev (key, val) = let encKey = exprToSMT (Lit key) encVal = exprToSMT (Lit val) - in "(sstore " <> encAddr `sp` encKey `sp` encVal `sp` prev <> ")" + in "(store " <> prev `sp` encKey `sp` encVal <> ")" +storeName :: Expr EAddr -> Builder +storeName a = fromString ("baseStore_") <> formatEAddr a +formatEAddr :: Expr EAddr -> Builder +formatEAddr = \case + LitAddr a -> fromString ("litaddr_" <> show a) + SymAddr a -> fromText ("symaddr_" <> a) + GVar _ -> internalError "Unexpected GVar" + + -- ** Cex parsing ** -------------------------------------------------------------------------------- +parseAddr :: SpecConstant -> Addr +parseAddr = parseSC parseW256 :: SpecConstant -> W256 parseW256 = parseSC @@ -860,6 +944,12 @@ parseVar :: TS.Text -> Expr EWord parseVar = Var +parseEAddr :: TS.Text -> Expr EAddr +parseEAddr name + | Just a <- TS.stripPrefix "litaddr_" name = LitAddr (read (TS.unpack a)) + | Just a <- TS.stripPrefix "symaddr_" name = SymAddr a + | otherwise = internalError $ "cannot parse: " <> show name + parseBlockCtx :: TS.Text -> Expr EWord parseBlockCtx "origin" = Origin parseBlockCtx "coinbase" = Coinbase @@ -871,33 +961,35 @@ parseBlockCtx "basefee" = BaseFee parseBlockCtx t = internalError $ "cannot parse " <> (TS.unpack t) <> " into an Expr" -parseFrameCtx :: TS.Text -> Expr EWord -parseFrameCtx name = case TS.unpack name of - ('c':'a':'l':'l':'v':'a':'l':'u':'e':'_':frame) -> CallValue (read frame) - ('c':'a':'l':'l':'e':'r':'_':frame) -> Caller (read frame) - ('a':'d':'d':'r':'e':'s':'s':'_':frame) -> Address (read frame) - t -> internalError $ "cannot parse " <> t <> " into an Expr" +parseTxCtx :: TS.Text -> Expr EWord +parseTxCtx name + | name == "txvalue" = TxValue + | Just a <- TS.stripPrefix "balance_" name = Balance (parseEAddr a) + | otherwise = internalError $ "cannot parse " <> (TS.unpack name) <> " into an Expr" +getAddrs :: (TS.Text -> Expr EAddr) -> (Text -> IO Text) -> [TS.Text] -> IO (Map (Expr EAddr) Addr) +getAddrs parseName getVal names = Map.mapKeys parseName <$> foldM (getOne parseAddr getVal) 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 <- getVal (T.fromStrict name) - let - parsed = case parseCommentFreeFileMsg getValueRes (T.toStrict raw) of - Right (ResSpecific (valParsed :| [])) -> valParsed - r -> parseErr r - val = case parsed of - (TermQualIdentifier ( - Unqualified (IdSymbol symbol)), - TermSpecConstant sc) - -> if symbol == name - then parseW256 sc - else internalError "solver did not return model for requested value" - r -> parseErr r - pure $ Map.insert name val acc +getVars parseName getVal names = Map.mapKeys parseName <$> foldM (getOne parseW256 getVal) mempty names +getOne :: (SpecConstant -> a) -> (Text -> IO Text) -> Map TS.Text a -> TS.Text -> IO (Map TS.Text a) +getOne parseVal getVal acc name = do + raw <- getVal (T.fromStrict name) + let + parsed = case parseCommentFreeFileMsg getValueRes (T.toStrict raw) of + Right (ResSpecific (valParsed :| [])) -> valParsed + r -> parseErr r + val = case parsed of + (TermQualIdentifier ( + Unqualified (IdSymbol symbol)), + TermSpecConstant sc) + -> if symbol == name + then parseVal sc + else internalError "solver did not return model for requested value" + r -> parseErr r + pure $ Map.insert name val acc + -- | Queries the solver for models for each of the expressions representing the -- max read index for a given buffer queryMaxReads :: (Text -> IO Text) -> Map Text (Expr EWord) -> IO (Map Text W256) @@ -973,35 +1065,35 @@ <> " in environment mapping" p -> parseErr p -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 internalError "solver did not return model for requested value" - r -> parseErr r - - -- then create a map by adding only the locations that are read by the program - foldM (\m (addr, slot) -> do - addr' <- queryValue getVal addr - slot' <- queryValue getVal slot - pure $ addElem addr' slot' m fun) Map.empty sreads - - where - - 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 +-- | Takes a Map containing all reads from a store with an abstract base, as +-- well as the conrete part of the storage prestate and returns a fully +-- concretized storage +getStore + :: (Text -> IO Text) + -> Map (Expr EAddr) (Set (Expr EWord)) + -> IO (Map (Expr EAddr) (Map W256 W256)) +getStore getVal abstractReads = + fmap Map.fromList $ forM (Map.toList abstractReads) $ \(addr, slots) -> do + let name = toLazyText (storeName addr) + raw <- getVal name + 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 == (T.toStrict name) + then interpret1DArray Map.empty term + else internalError "solver did not return model for requested value" + r -> parseErr r + -- then create a map by adding only the locations that are read by the program + store <- foldM (\m slot -> do + slot' <- queryValue getVal slot + pure $ Map.insert slot' (fun slot') m) Map.empty slots + pure (addr, store) +-- | Ask the solver to give us the concrete value of an arbitrary abstract word queryValue :: (Text -> IO Text) -> Expr EWord -> IO W256 queryValue _ (Lit w) = pure w queryValue getVal w = do @@ -1014,8 +1106,6 @@ _ -> internalError $ "cannot parse model for: " <> show w r -> parseErr r - - -- | 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) @@ -1057,7 +1147,3 @@ Just t -> interpretW256 env t Nothing -> internalError "unknown identifier, cannot parse array" interpretW256 _ t = internalError $ "cannot parse array value. Unexpected term: " <> (show t) - --- | 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,13 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE QuasiQuotes #-} module EVM.Solidity ( solidity , solcRuntime - , solidity' - , yul' , yul , yulRuntime , JumpType (..) @@ -72,11 +69,10 @@ import Data.Maybe import Data.Semigroup import Data.Sequence (Seq) -import Data.String.Here qualified as Here import Data.Text (pack, intercalate) import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Data.Text.IO (readFile, writeFile) +import Data.Text.IO (readFile) import Data.Vector (Vector) import Data.Vector qualified as Vector import Data.Word (Word8) @@ -84,8 +80,6 @@ import Prelude hiding (readFile, writeFile) import System.FilePattern.Directory import System.FilePath.Posix -import System.IO hiding (readFile, writeFile) -import System.IO.Temp import System.Process import Text.Read (readMaybe) import Witch (unsafeInto) @@ -357,38 +351,41 @@ pure (Right (BuildOutput contracts sourceCache)) yul :: Text -> Text -> IO (Maybe ByteString) -yul contract src = do - (json, path) <- yul' src - let f = (json ^?! key "contracts") ^?! key (Key.fromText path) - c = f ^?! key (Key.fromText $ if T.null contract then "object" else contract) +yul contractName src = do + json <- solc Yul src + let f = (json ^?! key "contracts") ^?! key (Key.fromText "hevm.sol") + c = f ^?! key (Key.fromText $ if T.null contractName then "object" else contractName) bytecode = c ^?! key "evm" ^?! key "bytecode" ^?! key "object" % _String - pure $ toCode <$> (Just bytecode) + pure $ (toCode contractName) <$> (Just bytecode) yulRuntime :: Text -> Text -> IO (Maybe ByteString) -yulRuntime contract src = do - (json, path) <- yul' src - let f = (json ^?! key "contracts") ^?! key (Key.fromText path) - c = f ^?! key (Key.fromText $ if T.null contract then "object" else contract) +yulRuntime contractName src = do + json <- solc Yul src + let f = (json ^?! key "contracts") ^?! key (Key.fromText "hevm.sol") + c = f ^?! key (Key.fromText $ if T.null contractName then "object" else contractName) bytecode = c ^?! key "evm" ^?! key "deployedBytecode" ^?! key "object" % _String - pure $ toCode <$> (Just bytecode) + pure $ (toCode contractName) <$> (Just bytecode) solidity :: Text -> Text -> IO (Maybe ByteString) solidity contract src = do - (json, path) <- solidity' src + json <- solc Solidity src let (Contracts sol, _, _) = fromJust $ readStdJSON json - pure $ Map.lookup (path <> ":" <> contract) sol <&> (.creationCode) + pure $ Map.lookup ("hevm.sol:" <> contract) sol <&> (.creationCode) solcRuntime :: Text -> Text -> IO (Maybe ByteString) solcRuntime contract src = do - (json, path) <- solidity' src - let (Contracts sol, _, _) = fromJust $ readStdJSON json - pure $ Map.lookup (path <> ":" <> contract) sol <&> (.runtimeCode) + json <- solc Solidity src + case readStdJSON json of + Just (Contracts sol, _, _) -> pure $ Map.lookup ("hevm.sol:" <> contract) sol <&> (.runtimeCode) + Nothing -> internalError $ "unable to parse solidity output:\n" <> (T.unpack json) functionAbi :: Text -> IO Method functionAbi f = do - (json, path) <- solidity' ("contract ABI { function " <> f <> " public {}}") - let (Contracts sol, _, _) = fromJust $ readStdJSON json - case Map.toList $ (fromJust (Map.lookup (path <> ":ABI") sol)).abiMap of + json <- solc Solidity ("contract ABI { function " <> f <> " public {}}") + let (Contracts sol, _, _) = fromMaybe + (internalError . T.unpack $ "unable to parse solc output:\n" <> json) + (readStdJSON json) + case Map.toList $ (fromJust (Map.lookup "hevm.sol:ABI" sol)).abiMap of [(_,b)] -> pure b _ -> internalError "unexpected abi format" @@ -404,12 +401,16 @@ readFoundryJSON :: Text -> Text -> Maybe (Contracts, Asts, Sources) readFoundryJSON contractName json = do runtime <- json ^? key "deployedBytecode" - runtimeCode <- toCode . strip0x'' <$> runtime ^? key "object" % _String - runtimeSrcMap <- makeSrcMaps =<< runtime ^? key "sourceMap" % _String + runtimeCode <- (toCode contractName) . strip0x'' <$> runtime ^? key "object" % _String + runtimeSrcMap <- case runtime ^? key "sourceMap" % _String of + Nothing -> makeSrcMaps "" + smap -> makeSrcMaps =<< smap creation <- json ^? key "bytecode" - creationCode <- toCode . strip0x'' <$> creation ^? key "object" % _String - creationSrcMap <- makeSrcMaps =<< creation ^? key "sourceMap" % _String + creationCode <- (toCode contractName) . strip0x'' <$> creation ^? key "object" % _String + creationSrcMap <- case creation ^? key "sourceMap" % _String of + Nothing -> makeSrcMaps "" + smap -> makeSrcMaps =<< smap ast <- json ^? key "ast" path <- ast ^? key "absolutePath" % _String @@ -430,7 +431,7 @@ , runtimeSrcmap = runtimeSrcMap , creationSrcmap = creationSrcMap , constructorInputs = mkConstructor abi - , storageLayout = mempty -- TODO: foundry doesn't expose this? + , storageLayout = mkStorageLayout $ json ^? key "storageLayout" , immutableReferences = mempty -- TODO: foundry doesn't expose this? } pure ( Contracts $ Map.singleton (path <> ":" <> contractName) contract @@ -460,10 +461,11 @@ h s (c, x) = let evmstuff = x ^?! key "evm" + sc = s <> ":" <> c runtime = evmstuff ^?! key "deployedBytecode" creation = evmstuff ^?! key "bytecode" - theRuntimeCode = toCode $ fromMaybe "" $ runtime ^? key "object" % _String - theCreationCode = toCode $ fromMaybe "" $ creation ^? key "object" % _String + theRuntimeCode = (toCode sc) $ fromMaybe "" $ runtime ^? key "object" % _String + theCreationCode = (toCode sc) $ fromMaybe "" $ creation ^? key "object" % _String srcContents :: Maybe (HMap.HashMap Text Text) srcContents = do metadata <- x ^? key "metadata" % _String srcs <- KeyMap.toHashMapText <$> metadata ^? key "sources" % _Object @@ -472,14 +474,14 @@ (HMap.filter (isJust . preview (key "content")) srcs) abis = force ("abi key not found in " <> show x) $ toList <$> x ^? key "abi" % _Array - in (s <> ":" <> c, (SolcContract { + in (sc, (SolcContract { runtimeCode = theRuntimeCode, creationCode = theCreationCode, runtimeCodehash = keccak' (stripBytecodeMetadata theRuntimeCode), creationCodehash = keccak' (stripBytecodeMetadata theCreationCode), runtimeSrcmap = force "srcmap-runtime" (makeSrcMaps (runtime ^?! key "sourceMap" % _String)), creationSrcmap = force "srcmap" (makeSrcMaps (creation ^?! key "sourceMap" % _String)), - contractName = s <> ":" <> c, + contractName = sc, constructorInputs = mkConstructor abis, abiMap = mkAbiMap abis, eventMap = mkEventMap abis, @@ -508,8 +510,8 @@ f x = Map.fromList . HMap.toList $ HMap.mapWithKey g x g s x = let - theRuntimeCode = toCode (x ^?! key "bin-runtime" % _String) - theCreationCode = toCode (x ^?! key "bin" % _String) + theRuntimeCode = (toCode s) (x ^?! key "bin-runtime" % _String) + theCreationCode = (toCode s) (x ^?! key "bin" % _String) abis = toList $ case (x ^?! key "abi") ^? _Array of Just v -> v -- solc >= 0.8 Nothing -> (x ^?! key "abi" % _String) ^?! _Array -- solc < 0.8 @@ -646,87 +648,19 @@ containsLinkerHole :: Text -> Bool containsLinkerHole = regexMatches "__\\$[a-z0-9]{34}\\$__" -toCode :: Text -> ByteString -toCode t = case BS16.decodeBase16 (encodeUtf8 t) of +toCode :: Text -> Text -> ByteString +toCode contractName t = case BS16.decodeBase16 (encodeUtf8 t) of Right d -> d Left e -> if containsLinkerHole t - then error "Error: unlinked libraries detected in bytecode" - else error $ T.unpack e - -solidity' :: Text -> IO (Text, Text) -solidity' src = withSystemTempFile "hevm.sol" $ \path handle -> do - hClose handle - writeFile path ("//SPDX-License-Identifier: UNLICENSED\n" <> "pragma solidity ^0.8.6;\n" <> src) - writeFile (path <> ".json") - [Here.i| - { - "language": "Solidity", - "sources": { - ${path}: { - "urls": [ - ${path} - ] - } - }, - "settings": { - "outputSelection": { - "*": { - "*": [ - "metadata", - "evm.bytecode", - "evm.deployedBytecode", - "abi", - "storageLayout", - "evm.bytecode.sourceMap", - "evm.bytecode.linkReferences", - "evm.bytecode.generatedSources", - "evm.deployedBytecode.sourceMap", - "evm.deployedBytecode.linkReferences", - "evm.deployedBytecode.generatedSources" - ], - "": [ - "ast" - ] - } - } - } - } - |] - x <- pack <$> - readProcess - "solc" - ["--allow-paths", path, "--standard-json", (path <> ".json")] - "" - pure (x, pack path) - -yul' :: Text -> IO (Text, Text) -yul' src = withSystemTempFile "hevm.yul" $ \path handle -> do - hClose handle - writeFile path src - writeFile (path <> ".json") - [Here.i| - { - "language": "Yul", - "sources": { ${path}: { "urls": [ ${path} ] } }, - "settings": { "outputSelection": { "*": { "*": ["*"], "": [ "*" ] } } } - } - |] - x <- pack <$> - readProcess - "solc" - ["--allow-paths", path, "--standard-json", (path <> ".json")] - "" - pure (x, pack path) + then error $ T.unpack ("Error toCode: unlinked libraries detected in bytecode, in " <> contractName) + else error $ T.unpack ("Error toCode:" <> e <> ", in " <> contractName) solc :: Language -> Text -> IO Text solc lang src = - withSystemTempFile "hevm.sol" $ \path handle -> do - hClose handle - writeFile path (stdjson lang src) - T.pack <$> readProcess - "solc" - ["--standard-json", path] - "" + T.pack <$> readProcess + "solc" + ["--standard-json"] + (T.unpack $ stdjson lang src) data Language = Solidity | Yul deriving (Show) diff --git a/src/EVM/Solvers.hs b/src/EVM/Solvers.hs --- a/src/EVM/Solvers.hs +++ b/src/EVM/Solvers.hs @@ -112,21 +112,31 @@ _ <- forkIO $ runTask task inst avail orchestrate queue avail - runTask (Task (SMT2 cmds cexvars) r) inst availableInstances = do + runTask (Task (SMT2 cmds (RefinementEqs refineEqs) cexvars) r) inst availableInstances = do -- reset solver and send all lines of provided script - out <- sendScript inst (SMT2 ("(reset)" : cmds) cexvars) + out <- sendScript inst (SMT2 ("(reset)" : cmds) mempty mempty) 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" -> Sat <$> getModel inst cexvars - "unsat" -> pure Unsat - "timeout" -> pure Unknown - "unknown" -> pure Unknown - _ -> pure . Error $ T.toStrict $ "Unable to parse solver output: " <> sat + res <- do + case sat of + "unsat" -> pure Unsat + "timeout" -> pure Unknown + "unknown" -> pure Unknown + "sat" -> if null refineEqs then Sat <$> getModel inst cexvars + else do + _ <- sendScript inst (SMT2 refineEqs mempty mempty) + sat2 <- sendLine inst "(check-sat)" + case sat2 of + "unsat" -> pure Unsat + "timeout" -> pure Unknown + "unknown" -> pure Unknown + "sat" -> Sat <$> getModel inst cexvars + _ -> pure . Error $ T.toStrict $ "Unable to parse solver output: " <> sat2 + _ -> pure . Error $ T.toStrict $ "Unable to parse solver output: " <> sat writeChan r res -- put the instance back in the list of available instances @@ -147,11 +157,12 @@ getRaw :: IO SMTCex getRaw = do vars <- getVars parseVar (getValue inst) (fmap T.toStrict cexvars.calldata) + addrs <- getAddrs parseEAddr (getValue inst) (fmap T.toStrict cexvars.addrs) buffers <- getBufs (getValue inst) (Map.keys cexvars.buffers) storage <- getStore (getValue inst) cexvars.storeReads blockctx <- getVars parseBlockCtx (getValue inst) (fmap T.toStrict cexvars.blockContext) - txctx <- getVars parseFrameCtx (getValue inst) (fmap T.toStrict cexvars.txContext) - pure $ SMTCex vars buffers storage blockctx txctx + txctx <- getVars parseTxCtx (getValue inst) (fmap T.toStrict cexvars.txContext) + pure $ SMTCex vars addrs buffers storage blockctx txctx -- sometimes the solver might give us back a model for the max read index -- that is too high to be a useful cex (e.g. in the case of reads from a @@ -182,17 +193,17 @@ shrinkBuf buf hint = do let encBound = "(_ bv" <> (T.pack $ show (into hint :: Integer)) <> " 256)" sat <- liftIO $ do - sendLine' inst "(push)" - sendLine' inst $ "(assert (bvule " <> buf <> "_length " <> encBound <> "))" + checkCommand inst "(push)" + checkCommand inst $ "(assert (bvule " <> buf <> "_length " <> encBound <> "))" sendLine inst "(check-sat)" case sat of "sat" -> do model <- liftIO getRaw put model "unsat" -> do - liftIO $ sendLine' inst "(pop)" + liftIO $ checkCommand inst "(pop)" shrinkBuf buf (if hint == 0 then hint + 1 else hint * 2) - _ -> internalError "SMT solver returned unexpected result (neither sat/unsat), which HEVM currently cannot handle" + e -> internalError $ "Unexpected solver output: " <> (T.unpack e) -- Collapses the abstract description of a models buffers down to a bytestring mkConcrete :: SMTCex -> SMTCex @@ -224,6 +235,8 @@ CVC5 -> [ "--lang=smt" , "--produce-models" + , "--print-success" + , "--interactive" , "--tlimit-per=" <> mkTimeout timeout ] Custom _ -> [] @@ -235,10 +248,12 @@ (Just stdin, Just stdout, Just stderr, process) <- createProcess cmd hSetBuffering stdin (BlockBuffering (Just 1000000)) let solverInstance = SolverInstance solver stdin stdout stderr process + case solver of CVC5 -> pure solverInstance _ -> do _ <- sendLine' solverInstance $ "(set-option :timeout " <> mkTimeout timeout <> ")" + _ <- sendLine solverInstance "(set-option :print-success true)" pure solverInstance -- | Cleanly shutdown a running solver instnace @@ -247,10 +262,24 @@ -- | 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 (splitSExpr $ fmap toLazyText cmds) - pure $ Right() +sendScript solver (SMT2 cmds _ _) = do + let sexprs = splitSExpr $ fmap toLazyText cmds + go sexprs + where + go [] = pure $ Right () + go (c:cs) = do + out <- sendCommand solver c + case out of + "success" -> go cs + e -> pure $ Left $ "Solver returned an error:\n" <> e <> "\nwhile sending the following line: " <> c +checkCommand :: SolverInstance -> Text -> IO () +checkCommand inst cmd = do + res <- sendCommand inst cmd + case res of + "success" -> pure () + _ -> internalError $ "Unexpected solver output: " <> T.unpack res + -- | 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 @@ -302,11 +331,11 @@ -- From a list of lines, take each separate SExpression and put it in -- its own list, after removing comments. -splitSExpr :: [Text] -> Text +splitSExpr :: [Text] -> [Text] splitSExpr ls = -- split lines, strip comments, and append everything to a single line let text = T.intercalate " " $ T.takeWhile (/= ';') <$> concatMap T.lines ls in - T.unlines $ filter (/= "") $ go text [] + filter (/= "") $ go text [] where go "" acc = reverse acc go text acc = diff --git a/src/EVM/Stepper.hs b/src/EVM/Stepper.hs --- a/src/EVM/Stepper.hs +++ b/src/EVM/Stepper.hs @@ -11,7 +11,6 @@ , ask , evm , evmIO - , entering , enter , interpret ) @@ -24,60 +23,58 @@ -- as the framework for monadic interpretation. import Control.Monad.Operational (Program, ProgramViewT(..), ProgramView, singleton, view) -import Control.Monad.State.Strict (StateT, execState, runState, runStateT) +import Control.Monad.State.Strict (execStateT, runStateT, get) import Data.Text (Text) import EVM qualified import EVM.Exec qualified import EVM.Fetch qualified as Fetch import EVM.Types +import Control.Monad.ST (stToIO, RealWorld) -- | The instruction type of the operational monad -data Action a where +data Action s a where -- | Keep executing until an intermediate result is reached - Exec :: Action VMResult - - -- | Keep executing until an intermediate state is reached - Run :: Action VM + Exec :: Action s (VMResult s) -- | Wait for a query to be resolved - Wait :: Query -> Action () + Wait :: Query s -> Action s () -- | Multiple things can happen - Ask :: Choose -> Action () + Ask :: Choose s -> Action s () -- | Embed a VM state transformation - EVM :: EVM a -> Action a + EVM :: EVM s a -> Action s a -- | Perform an IO action - IOAct :: StateT VM IO a -> Action a -- they should all just be this? + IOAct :: IO a -> Action s a -- | Type alias for an operational monad of @Action@ -type Stepper a = Program Action a +type Stepper s a = Program (Action s) a -- Singleton actions -exec :: Stepper VMResult +exec :: Stepper s (VMResult s) exec = singleton Exec -run :: Stepper VM -run = singleton Run +run :: Stepper s (VM s) +run = exec >> evm get -wait :: Query -> Stepper () +wait :: Query s -> Stepper s () wait = singleton . Wait -ask :: Choose -> Stepper () +ask :: Choose s -> Stepper s () ask = singleton . Ask -evm :: EVM a -> Stepper a +evm :: EVM s a -> Stepper s a evm = singleton . EVM -evmIO :: StateT VM IO a -> Stepper a +evmIO :: IO a -> Stepper s a evmIO = singleton . IOAct -- | Run the VM until final result, resolving all queries -execFully :: Stepper (Either EvmError (Expr Buf)) +execFully :: Stepper s (Either EvmError (Expr Buf)) execFully = exec >>= \case HandleEffect (Query q) -> @@ -92,7 +89,7 @@ -> internalError $ "partial execution encountered during concrete execution: " <> show x -- | Run the VM until its final state -runFully :: Stepper VM +runFully :: Stepper s (VM s) runFully = do vm <- run case vm.result of @@ -104,41 +101,33 @@ Just _ -> pure vm -entering :: Text -> Stepper a -> Stepper a -entering t stepper = do - evm (EVM.pushTrace (EntryTrace t)) - x <- stepper - evm EVM.popTrace - pure x - -enter :: Text -> Stepper () +enter :: Text -> Stepper s () enter t = evm (EVM.pushTrace (EntryTrace t)) -interpret :: Fetch.Fetcher -> VM -> Stepper a -> IO a +interpret :: Fetch.Fetcher RealWorld -> VM RealWorld -> Stepper RealWorld a -> IO a interpret fetcher vm = eval . view where - eval :: ProgramView Action a -> IO a + eval :: ProgramView (Action RealWorld) a -> IO a eval (Return x) = pure x eval (action :>>= k) = case action of - Exec -> - let (r, vm') = runState EVM.Exec.exec vm - in interpret fetcher vm' (k r) - Run -> - let vm' = execState EVM.Exec.run vm - in interpret fetcher vm' (k vm') - Wait (PleaseAskSMT (Lit c) _ continue) -> - let (r, vm') = runState (continue (Case (c > 0))) vm - in interpret fetcher vm' (k r) + Exec -> do + (r, vm') <- stToIO $ runStateT EVM.Exec.exec vm + interpret fetcher vm' (k r) + Wait (PleaseAskSMT (Lit c) _ continue) -> do + (r, vm') <- stToIO $ runStateT (continue (Case (c > 0))) vm + interpret fetcher vm' (k r) + Wait (PleaseAskSMT c _ _) -> + error $ "cannot handle symbolic branch conditions in this interpreter: " <> show c Wait q -> do m <- fetcher q - let vm' = execState m vm + vm' <- stToIO $ execStateT m vm interpret fetcher vm' (k ()) Ask _ -> internalError "cannot make choices with this interpreter" IOAct m -> do - (r, vm') <- runStateT m vm + r <- m + interpret fetcher vm (k r) + EVM m -> do + (r, vm') <- stToIO $ runStateT m vm interpret fetcher vm' (k r) - EVM m -> - let (r, vm') = runState m vm - in interpret fetcher vm' (k r) diff --git a/src/EVM/StorageLayout.hs b/src/EVM/StorageLayout.hs deleted file mode 100644 --- a/src/EVM/StorageLayout.hs +++ /dev/null @@ -1,152 +0,0 @@ -module EVM.StorageLayout where - --- Figures out the layout of storage slots for Solidity contracts. - -import EVM.Dapp (DappInfo(..)) -import EVM.Solidity (SolcContract, creationSrcmap, SlotType(..)) -import EVM.ABI (AbiType (..), parseTypeName) - -import Optics.Core -import Data.Aeson (Value (..)) -import Data.Aeson.Optics -import Data.Foldable (toList) -import Data.List.NonEmpty qualified as NonEmpty -import Data.Map qualified as Map -import Data.Maybe (fromMaybe, isJust) -import Data.Sequence qualified as Seq -import Data.Text (Text, unpack, pack, words) -import EVM.Types (internalError) - -import Prelude hiding (words) - --- A contract has all the slots of its inherited contracts. --- --- The slot order is determined by the inheritance linearization order, --- so we first have to calculate that. --- --- This information is available in the abstract syntax tree. - -findContractDefinition :: DappInfo -> SolcContract -> Maybe Value -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 solc.creationSrcmap of - firstSrcMap Seq.:< _ -> - dapp.astSrcMap firstSrcMap - _ -> - Nothing - -storageLayout :: DappInfo -> SolcContract -> [Text] -storageLayout dapp solc = - let - root :: Value - root = - fromMaybe Null - (findContractDefinition dapp solc) - in - case preview ( key "attributes" - % key "linearizedBaseContracts" - % _Array - ) root of - Nothing -> - [] - Just ((reverse . toList) -> linearizedBaseContracts) -> - flip concatMap linearizedBaseContracts - (\case - Number i -> fromMaybe (internalError "malformed AST JSON") $ - storageVariablesForContract =<< - Map.lookup (floor i) dapp.astIdMap - _ -> - internalError "malformed AST JSON") - -storageVariablesForContract :: Value -> Maybe [Text] -storageVariablesForContract node = do - name <- preview (ix "attributes" % key "name" % _String) node - vars <- - fmap - (filter isStorageVariableDeclaration . toList) - (preview (ix "children" % _Array) node) - - pure . flip map vars $ - \x -> - case preview (key "attributes" % key "name" % _String) x of - Just variableName -> - mconcat - [ variableName - , " (", name, ")" - , "\n", " Type: " - , pack $ show (slotTypeForDeclaration x) - ] - Nothing -> - internalError "malformed variable declaration" - -nodeIs :: Text -> Value -> Bool -nodeIs t x = isSourceNode && hasRightName - where - isSourceNode = - isJust (preview (key "src") x) - hasRightName = - Just t == preview (key "name" % _String) x - -isStorageVariableDeclaration :: Value -> Bool -isStorageVariableDeclaration x = - nodeIs "VariableDeclaration" x - && preview (key "attributes" % key "constant" % _Bool) x /= Just True - -slotTypeForDeclaration :: Value -> SlotType -slotTypeForDeclaration node = - case toList <$> preview (key "children" % _Array) node of - Just (x:_) -> - grokDeclarationType x - _ -> - internalError "malformed AST" - -grokDeclarationType :: Value -> SlotType -grokDeclarationType x = - case preview (key "name" % _String) x of - Just "Mapping" -> - case preview (key "children" % _Array) x of - Just (toList -> xs) -> - grokMappingType xs - _ -> - internalError "malformed AST" - Just _ -> - StorageValue (grokValueType x) - _ -> - internalError ("malformed AST " ++ show x) - -grokMappingType :: [Value] -> SlotType -grokMappingType [s, t] = - case (grokDeclarationType s, grokDeclarationType t) of - (StorageValue s', StorageMapping t' x) -> - StorageMapping (NonEmpty.cons s' t') x - (StorageValue s', StorageValue t') -> - StorageMapping (pure s') t' - (StorageMapping _ _, _) -> - internalError "unexpected mapping as mapping key" -grokMappingType _ = - internalError "unexpected AST child count for mapping" - -grokValueType :: Value -> AbiType -grokValueType x = - case ( preview (key "name" % _String) x - , preview (key "children" % _Array) x - , preview (key "attributes" % key "type" % _String) x - ) of - (Just "ElementaryTypeName", _, Just typeName) -> - fromMaybe (internalError $ "ungrokked value type: " ++ show typeName) - (parseTypeName mempty (head (words typeName))) - (Just "UserDefinedTypeName", _, _) -> - AbiAddressType - (Just "ArrayTypeName", fmap toList -> Just [t], _)-> - AbiArrayDynamicType (grokValueType t) - (Just "ArrayTypeName", fmap toList -> Just [t, n], _)-> - case ( preview (key "name" % _String) n - , preview (key "attributes" % key "value" % _String) n - ) of - (Just "Literal", Just ((read . unpack) -> i)) -> - AbiArrayType i (grokValueType t) - _ -> - internalError "malformed AST" - _ -> - internalError ("unknown value type " ++ show x) diff --git a/src/EVM/SymExec.hs b/src/EVM/SymExec.hs --- a/src/EVM/SymExec.hs +++ b/src/EVM/SymExec.hs @@ -7,6 +7,7 @@ import Control.Concurrent.Spawn (parMapIO, pool) import Control.Concurrent.STM (atomically, TVar, readTVarIO, readTVar, newTVarIO, writeTVar) import Control.Monad.Operational qualified as Operational +import Control.Monad.ST (RealWorld, stToIO, ST) import Control.Monad.State.Strict import Data.Bifunctor (second) import Data.ByteString (ByteString) @@ -15,8 +16,9 @@ import Data.DoubleWord (Word256) import Data.List (foldl', sortBy) import Data.Maybe (fromMaybe, mapMaybe) -import Data.Map (Map) -import Data.Map qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Map.Merge.Strict qualified as Map import Data.Set (Set, isSubsetOf, size) import Data.Set qualified as Set import Data.Text (Text) @@ -26,12 +28,12 @@ import Data.Text.Lazy.IO qualified as TL import Data.Tree.Zipper qualified as Zipper import Data.Tuple (swap) -import EVM (makeVm, initialContract, getCodeLocation, isValidJumpDest) +import EVM (makeVm, abstractContract, initialContract, getCodeLocation, isValidJumpDest) import EVM.Exec import EVM.Fetch qualified as Fetch import EVM.ABI import EVM.Expr qualified as Expr -import EVM.Format (formatExpr, formatPartial) +import EVM.Format (formatExpr, formatPartial, showVal, bsToHex) import EVM.SMT (SMTCex(..), SMT2(..), assertProps, formatSMT2) import EVM.SMT qualified as SMT import EVM.Solvers @@ -39,8 +41,7 @@ import EVM.Stepper qualified as Stepper import EVM.Traversals import EVM.Types -import EVM.Concrete (createAddress) -import EVM.FeeSchedule qualified as FeeSchedule +import EVM.FeeSchedule (feeSchedule) import EVM.Format (indent, formatBinary) import GHC.Conc (getNumProcessors) import GHC.Generics (Generic) @@ -48,9 +49,6 @@ import Options.Generic (ParseField, ParseFields, ParseRecord) import Witch (into, unsafeInto) --- | A method name, and the (ordered) types of it's arguments -data Sig = Sig Text [AbiType] - data LoopHeuristic = Naive | StackBased @@ -79,6 +77,7 @@ , maxIter :: Maybe Integer , askSmtIters :: Integer , loopHeuristic :: LoopHeuristic + , abstRefineConfig :: AbstRefineConfig , rpcInfo :: Fetch.RpcInfo } deriving (Eq, Show) @@ -90,6 +89,7 @@ , maxIter = Nothing , askSmtIters = 1 , loopHeuristic = StackBased + , abstRefineConfig = abstRefineDefault , rpcInfo = Nothing } @@ -99,6 +99,9 @@ debugVeriOpts :: VeriOpts debugVeriOpts = defaultVeriOpts { debug = True } +debugAbstVeriOpts :: VeriOpts +debugAbstVeriOpts = defaultVeriOpts { abstRefineConfig = AbstRefineConfig True True } + extractCex :: VerifyResult -> Maybe (Expr End, SMTCex) extractCex (Cex c) = Just c extractCex _ = Nothing @@ -119,7 +122,7 @@ then let v = Var name in St [Expr.inRange n v] v else internalError "bad type" AbiBoolType -> let v = Var name in St [bool v] v - AbiAddressType -> let v = Var name in St [Expr.inRange 160 v] v + AbiAddressType -> St [] (WAddr (SymAddr name)) AbiBytesType n -> if n > 0 && n <= 32 then let v = Var name in St [Expr.inRange (n * 8) v] v @@ -189,37 +192,35 @@ abstractVM :: (Expr Buf, [Prop]) -> ByteString - -> Maybe Precondition - -> Expr Storage - -> VM -abstractVM cd contractCode maybepre store = finalVm - where - caller' = Caller 0 - value' = CallValue 0 - code' = RuntimeCode (ConcreteRuntimeCode contractCode) - vm' = loadSymVM code' store caller' value' cd - precond = case maybepre of + -> Maybe (Precondition s) + -> Bool + -> ST s (VM s) +abstractVM cd contractCode maybepre create = do + let value = TxValue + let code = if create then InitCode contractCode (fst cd) else RuntimeCode (ConcreteRuntimeCode contractCode) + vm <- loadSymVM code value (if create then mempty else cd) create + let precond = case maybepre of Nothing -> [] - Just p -> [p vm'] - finalVm = vm' & over #constraints (<> precond) + Just p -> [p vm] + pure $ vm & over #constraints (<> precond) loadSymVM :: ContractCode - -> Expr Storage -> Expr EWord - -> Expr EWord -> (Expr Buf, [Prop]) - -> VM -loadSymVM x initStore addr callvalue' cd = + -> Bool + -> ST s (VM s) +loadSymVM x callvalue cd create = (makeVm $ VMOpts - { contract = initialContract x + { contract = if create then initialContract x else abstractContract x (SymAddr "entrypoint") + , otherContracts = [] , calldata = cd - , value = callvalue' - , initialStorage = initStore - , address = createAddress ethrunAddress 1 - , caller = addr - , origin = ethrunAddress --todo: generalize - , coinbase = 0 + , value = callvalue + , baseState = AbstractBase + , address = SymAddr "entrypoint" + , caller = SymAddr "caller" + , origin = SymAddr "origin" + , coinbase = SymAddr "coinbase" , number = 0 , timestamp = Lit 0 , blockGaslimit = 0 @@ -230,29 +231,28 @@ , baseFee = 0 , priorityFee = 0 , maxCodeSize = 0xffffffff - , schedule = FeeSchedule.berlin + , schedule = feeSchedule , chainId = 1 - , create = False + , create = create , txAccessList = mempty , allowFFI = False - }) & set (#env % #contracts % at (createAddress ethrunAddress 1)) - (Just (initialContract x)) + }) -- | Interpreter which explores all paths at branching points. Returns an -- 'Expr End' representing the possible executions. interpret - :: Fetch.Fetcher + :: Fetch.Fetcher RealWorld -> Maybe Integer -- max iterations -> Integer -- ask smt iterations -> LoopHeuristic - -> VM - -> Stepper (Expr End) + -> VM RealWorld + -> Stepper RealWorld (Expr End) -> IO (Expr End) interpret fetcher maxIter askSmtIters heuristic vm = eval . Operational.view where eval - :: Operational.ProgramView Stepper.Action (Expr End) + :: Operational.ProgramView (Stepper.Action RealWorld) (Expr End) -> IO (Expr End) eval (Operational.Return x) = pure x @@ -260,30 +260,34 @@ eval (action Operational.:>>= k) = case action of Stepper.Exec -> do - let (r, vm') = runState exec vm + (r, vm') <- stToIO $ runStateT exec vm interpret fetcher maxIter askSmtIters heuristic vm' (k r) - Stepper.Run -> do - let vm' = execState exec vm - interpret fetcher maxIter askSmtIters heuristic vm' (k vm') Stepper.IOAct q -> do - (r, vm') <- runStateT q vm - interpret fetcher maxIter askSmtIters heuristic vm' (k r) + r <- q + interpret fetcher maxIter askSmtIters heuristic vm (k r) Stepper.Ask (PleaseChoosePath cond continue) -> do (a, b) <- concurrently - (let (ra, vma) = runState (continue True) vm { result = Nothing } - in interpret fetcher maxIter askSmtIters heuristic vma (k ra)) - (let (rb, vmb) = runState (continue False) vm { result = Nothing } - in interpret fetcher maxIter askSmtIters heuristic vmb (k rb)) + (do + (ra, vma) <- stToIO $ runStateT (continue True) vm { result = Nothing } + interpret fetcher maxIter askSmtIters heuristic vma (k ra) + ) + (do + (rb, vmb) <- stToIO $ runStateT (continue False) vm { result = Nothing } + interpret fetcher maxIter askSmtIters heuristic vmb (k rb) + ) pure $ ITE cond a b Stepper.Wait q -> do let performQuery = do m <- liftIO (fetcher q) - let (r, vm') = runState m vm + (r, vm') <- stToIO $ runStateT m vm interpret fetcher maxIter askSmtIters heuristic vm' (k r) case q of - PleaseAskSMT cond _ continue -> do - case cond of + PleaseAskSMT cond preconds continue -> do + let + simpCond = Expr.simplify cond + simpProps = Expr.simplifyProps ((simpCond ./= Lit 0):preconds) + case simpCond of -- is the condition concrete? Lit c -> -- have we reached max iterations, are we inside a loop? @@ -292,9 +296,9 @@ (Just _, Just True) -> pure $ Partial vm.keccakEqs (Traces (Zipper.toForest vm.traces) vm.env.contracts) $ MaxIterationsReached vm.state.pc vm.state.contract -- No. keep executing - _ -> - let (r, vm') = runState (continue (Case (c > 0))) vm - in interpret fetcher maxIter askSmtIters heuristic vm' (k r) + _ -> do + (r, vm') <- stToIO $ runStateT (continue (Case (c > 0))) vm + interpret fetcher maxIter askSmtIters heuristic vm' (k r) -- the condition is symbolic _ -> @@ -304,25 +308,27 @@ (Just True, _, Just n) -> do -- continue execution down the opposite branch than the one that -- got us to this point and return a partial leaf for the other side - let (r, vm') = runState (continue (Case $ not n)) vm + (r, vm') <- stToIO $ runStateT (continue (Case $ not n)) vm a <- interpret fetcher maxIter askSmtIters heuristic vm' (k r) pure $ ITE cond a (Partial vm.keccakEqs (Traces (Zipper.toForest vm.traces) vm.env.contracts) (MaxIterationsReached vm.state.pc vm.state.contract)) -- we're in a loop and askSmtIters has been reached (Just True, True, _) -> -- ask the smt solver about the loop condition performQuery - -- otherwise just try both branches and don't ask the solver - _ -> - let (r, vm') = runState (continue EVM.Types.Unknown) vm - in interpret fetcher maxIter askSmtIters heuristic vm' (k r) - + _ -> do + (r, vm') <- case simpProps of + -- if we can statically determine unsatisfiability then we skip exploring the jump + [PBool False] -> stToIO $ runStateT (continue (Case False)) vm + -- otherwise we explore both branches + _ -> stToIO $ runStateT (continue EVM.Types.Unknown) vm + interpret fetcher maxIter askSmtIters heuristic vm' (k r) _ -> performQuery Stepper.EVM m -> do - let (r, vm') = runState m vm + (r, vm') <- stToIO $ runStateT m vm interpret fetcher maxIter askSmtIters heuristic vm' (k r) -maxIterationsReached :: VM -> Maybe Integer -> Maybe Bool +maxIterationsReached :: VM s -> Maybe Integer -> Maybe Bool maxIterationsReached _ Nothing = Nothing maxIterationsReached vm (Just maxIter) = let codelocation = getCodeLocation vm @@ -331,7 +337,7 @@ then Map.lookup (codelocation, iters - 1) vm.cache.path else Nothing -askSmtItersReached :: VM -> Integer -> Bool +askSmtItersReached :: VM s -> Integer -> Bool askSmtItersReached vm askSmtIters = let codelocation = getCodeLocation vm (iters, _) = view (at codelocation % non (0, [])) vm.iterations @@ -345,7 +351,7 @@ This heuristic is not perfect, and can certainly be tricked, but should generally be good enough for most compiler generated and non pathological user generated loops. -} -isLoopHead :: LoopHeuristic -> VM -> Maybe Bool +isLoopHead :: LoopHeuristic -> VM s -> Maybe Bool isLoopHead Naive _ = Just True isLoopHead StackBased vm = let loc = getCodeLocation vm @@ -356,8 +362,8 @@ Just (_, oldStack) -> Just $ filter isValid oldStack == filter isValid vm.state.stack Nothing -> Nothing -type Precondition = VM -> Prop -type Postcondition = VM -> Expr End -> Prop +type Precondition s = VM s -> Prop +type Postcondition s = VM s -> Expr End -> Prop checkAssert :: SolverGroup @@ -368,8 +374,20 @@ -> VeriOpts -> IO (Expr End, [VerifyResult]) checkAssert solvers errs c signature' concreteArgs opts = - verifyContract solvers c signature' concreteArgs opts AbstractStore Nothing (Just $ checkAssertions errs) + verifyContract solvers c signature' concreteArgs opts Nothing (Just $ checkAssertions errs) +getExpr + :: SolverGroup + -> ByteString + -> Maybe Sig + -> [String] + -> VeriOpts + -> IO (Expr End) +getExpr solvers c signature' concreteArgs opts = do + preState <- stToIO $ abstractVM (mkCalldata signature' concreteArgs) c Nothing False + exprInter <- interpret (Fetch.oracle solvers opts.rpcInfo) opts.maxIter opts.askSmtIters opts.loopHeuristic preState runExpr + if opts.simp then (pure $ Expr.simplify exprInter) else pure exprInter + {- | Checks if an assertion violation has been encountered hevm recognises the following as an assertion violation: @@ -389,7 +407,7 @@ see: https://docs.soliditylang.org/en/v0.8.6/control-structures.html?highlight=Panic#panic-via-assert-and-error-via-require -} -checkAssertions :: [Word256] -> Postcondition +checkAssertions :: [Word256] -> Postcondition s checkAssertions errs _ = \case Failure _ _ (Revert (ConcreteBuf msg)) -> PBool $ msg `notElem` (fmap panicMsg errs) Failure _ _ (Revert b) -> foldl' PAnd (PBool True) (fmap (PNeg . PEq b . ConcreteBuf . panicMsg) errs) @@ -426,25 +444,28 @@ -> Maybe Sig -> [String] -> VeriOpts - -> Expr Storage - -> Maybe Precondition - -> Maybe Postcondition + -> Maybe (Precondition RealWorld) + -> Maybe (Postcondition RealWorld) -> IO (Expr End, [VerifyResult]) -verifyContract solvers theCode signature' concreteArgs opts initStore maybepre maybepost = - let preState = abstractVM (mkCalldata signature' concreteArgs) theCode maybepre initStore - in verify solvers opts preState maybepost +verifyContract solvers theCode signature' concreteArgs opts maybepre maybepost = do + preState <- stToIO $ abstractVM (mkCalldata signature' concreteArgs) theCode maybepre False + verify solvers opts preState maybepost -- | Stepper that parses the result of Stepper.runFully into an Expr End -runExpr :: Stepper.Stepper (Expr End) +runExpr :: Stepper.Stepper RealWorld (Expr End) runExpr = do vm <- Stepper.runFully let asserts = vm.keccakEqs <> vm.constraints + traces = Traces (Zipper.toForest vm.traces) vm.env.contracts pure $ case vm.result of - Just (VMSuccess buf) -> Success asserts (Traces (Zipper.toForest vm.traces) vm.env.contracts) buf vm.env.storage - Just (VMFailure e) -> Failure asserts (Traces (Zipper.toForest vm.traces) vm.env.contracts) e - Just (Unfinished p) -> Partial asserts (Traces (Zipper.toForest vm.traces) vm.env.contracts) p + Just (VMSuccess buf) -> Success asserts traces buf (fmap toEContract vm.env.contracts) + Just (VMFailure e) -> Failure asserts traces e + Just (Unfinished p) -> Partial asserts traces p _ -> internalError "vm in intermediate state after call to runFully" +toEContract :: Contract -> Expr EContract +toEContract c = C c.code c.storage c.balance c.nonce + -- | Converts a given top level expr into a list of final states and the -- associated path conditions for each state. flattenExpr :: Expr End -> [Expr End] @@ -453,9 +474,9 @@ go :: [Prop] -> Expr End -> [Expr End] go pcs = \case ITE c t f -> go (PNeg ((PEq c (Lit 0))) : pcs) t <> go (PEq c (Lit 0) : pcs) f - Success ps trace msg store -> [Success (ps <> pcs) trace msg store] - Failure ps trace e -> [Failure (ps <> pcs) trace e] - Partial ps trace p -> [Partial (ps <> pcs) trace p] + Success ps trace msg store -> [Success (nubOrd $ ps <> pcs) trace msg store] + Failure ps trace e -> [Failure (nubOrd $ ps <> pcs) trace e] + Partial ps trace p -> [Partial (nubOrd $ ps <> pcs) trace p] GVar _ -> internalError "cannot flatten an Expr containing a GVar" -- | Strips unreachable branches from a given expr @@ -491,47 +512,13 @@ (Nothing, Nothing) -> Nothing pure (fst tres <> fst fres, subexpr) leaf -> do - let query = assertProps pcs + let query = assertProps abstRefineDefault pcs res <- checkSat solvers query case res of Sat _ -> pure ([query], Just leaf) Unsat -> pure ([query], Nothing) r -> internalError $ "Invalid solver result: " <> show r - --- | Evaluate the provided proposition down to its most concrete result -evalProp :: Prop -> Prop -evalProp = \case - o@(PBool _) -> o - o@(PNeg p) -> case p of - (PBool b) -> PBool (not b) - _ -> o - o@(PEq l r) -> if l == r - then PBool True - else o - o@(PLT (Lit l) (Lit r)) -> if l < r - then PBool True - else o - o@(PGT (Lit l) (Lit r)) -> if l > r - then PBool True - else o - o@(PGEq (Lit l) (Lit r)) -> if l >= r - then PBool True - else o - o@(PLEq (Lit l) (Lit r)) -> if l <= r - then PBool True - else o - o@(PAnd l r) -> case (evalProp l, evalProp r) of - (PBool True, PBool True) -> PBool True - (PBool _, PBool _) -> PBool False - _ -> o - o@(POr l r) -> case (evalProp l, evalProp r) of - (PBool False, PBool False) -> PBool False - (PBool _, PBool _) -> PBool True - _ -> o - o -> o - - -- | Extract contraints stored in Expr End nodes extractProps :: Expr End -> [Prop] extractProps = \case @@ -558,8 +545,8 @@ verify :: SolverGroup -> VeriOpts - -> VM - -> Maybe Postcondition + -> VM RealWorld + -> Maybe (Postcondition RealWorld) -> IO (Expr End, [VerifyResult]) verify solvers opts preState maybepost = do putStrLn "Exploring contract" @@ -568,7 +555,7 @@ when opts.debug $ T.writeFile "unsimplified.expr" (formatExpr exprInter) putStrLn "Simplifying expression" - expr <- if opts.simp then (pure $ Expr.simplify exprInter) else pure exprInter + let expr = if opts.simp then (Expr.simplify exprInter) else exprInter when opts.debug $ T.writeFile "simplified.expr" (formatExpr expr) putStrLn $ "Explored contract (" <> show (Expr.numBranches expr) <> " branches)" @@ -586,12 +573,12 @@ let -- Filter out any leaves that can be statically shown to be safe canViolate = flip filter flattened $ - \leaf -> case evalProp (post preState leaf) of + \leaf -> case Expr.simplifyProp (post preState leaf) of PBool True -> False _ -> True assumes = preState.constraints withQueries = canViolate <&> \leaf -> - (assertProps (PNeg (post preState leaf) : assumes <> extractProps leaf), leaf) + (assertProps opts.abstRefineConfig (PNeg (post preState leaf) : assumes <> extractProps leaf), leaf) putStrLn $ "Checking for reachability of " <> show (length withQueries) <> " potential property violation(s)" @@ -610,11 +597,21 @@ where toVRes :: (CheckSatResult, Expr End) -> VerifyResult toVRes (res, leaf) = case res of - Sat model -> Cex (leaf, model) + Sat model -> Cex (leaf, expandCex preState model) EVM.Solvers.Unknown -> Timeout leaf Unsat -> Qed () Error e -> internalError $ "solver responded with error: " <> show e +expandCex :: VM s -> SMTCex -> SMTCex +expandCex prestate c = c { store = Map.union c.store concretePreStore } + where + concretePreStore = Map.mapMaybe (maybeConcreteStore . (.storage)) + . Map.filter (\v -> Expr.containsNode isConcreteStore v.storage) + $ (prestate.env.contracts) + isConcreteStore = \case + ConcreteStore _ -> True + _ -> False + type UnsatCache = TVar [Set Prop] -- | Compares two contract runtimes for trace equivalence by running two VMs @@ -641,9 +638,8 @@ -- decompiles the given bytecode into a list of branches getBranches :: ByteString -> IO [Expr End] getBranches bs = do - let - bytecode = if BS.null bs then BS.pack [0] else bs - prestate = abstractVM calldata bytecode Nothing AbstractStore + let bytecode = if BS.null bs then BS.pack [0] else bs + prestate <- stToIO $ abstractVM calldata bytecode Nothing False expr <- interpret (Fetch.oracle solvers Nothing) opts.maxIter opts.askSmtIters opts.loopHeuristic prestate runExpr let simpl = if opts.simp then (Expr.simplify expr) else expr pure $ flattenExpr simpl @@ -694,10 +690,10 @@ -- used or not check :: UnsatCache -> (Set Prop) -> Int -> IO (EquivResult, Bool) check knownUnsat props idx = do - let smt = assertProps $ Set.toList props + let smt = assertProps opts.abstRefineConfig (Set.toList props) -- if debug is on, write the query to a file - when opts.debug $ TL.writeFile - ("equiv-query-" <> show idx <> ".smt2") (formatSMT2 smt <> "\n\n(check-sat)") + let filename = "equiv-query-" <> show idx <> ".smt2" + when opts.debug $ TL.writeFile filename (formatSMT2 smt <> "\n\n(check-sat)") ku <- readTVarIO knownUnsat res <- if subsetAny props ku @@ -714,7 +710,7 @@ atomically $ readTVar knownUnsat >>= writeTVar knownUnsat . (props :) pure (Qed (), False) (_, EVM.Solvers.Unknown) -> pure (Timeout (), False) - (_, Error txt) -> internalError $ "issue while running solver: `" <> T.unpack txt -- <> "` SMT file was: `" <> filename <> "`" + (_, Error txt) -> internalError $ "solver returned: " <> (T.unpack txt) <> if opts.debug then "\n SMT file was: " <> filename <> "" else "" -- 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 @@ -733,23 +729,7 @@ -- a differing result in each branch distinct :: Expr End -> Expr End -> Maybe (Set Prop) distinct aEnd bEnd = - let - differingResults = case (aEnd, bEnd) of - (Success _ _ aOut aStore, Success _ _ bOut bStore) -> - if aOut == bOut && aStore == bStore - then PBool False - else aStore ./= bStore .|| aOut ./= bOut - (Failure _ _ (Revert a), Failure _ _ (Revert b)) -> if a == b then PBool False else a ./= b - (Failure _ _ a, Failure _ _ b) -> if a == b then PBool False else PBool True - -- partial end states can't be compared to actual end states, so we always ignore them - (Partial {}, _) -> PBool False - (_, Partial {}) -> PBool False - (ITE _ _ _, _) -> internalError "Expressions must be flattened" - (_, ITE _ _ _) -> internalError "Expressions must be flattened" - (a, b) -> if a == b - then PBool False - else PBool True - in case differingResults of + case resultsDiffer aEnd bEnd of -- if the end states are the same, then they can never produce a -- different result under any circumstances PBool False -> Nothing @@ -760,15 +740,56 @@ -- 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 : extractProps aEnd <> extractProps bEnd + _ -> Just . Set.fromList $ resultsDiffer aEnd bEnd : extractProps aEnd <> extractProps bEnd + resultsDiffer :: Expr End -> Expr End -> Prop + resultsDiffer aEnd bEnd = case (aEnd, bEnd) of + (Success _ _ aOut aState, Success _ _ bOut bState) -> + case (aOut == bOut, aState == bState) of + (True, True) -> PBool False + (False, True) -> aOut ./= bOut + (True, False) -> statesDiffer aState bState + (False, False) -> statesDiffer aState bState .|| aOut ./= bOut + (Failure _ _ (Revert a), Failure _ _ (Revert b)) -> if a == b then PBool False else a ./= b + (Failure _ _ a, Failure _ _ b) -> if a == b then PBool False else PBool True + -- partial end states can't be compared to actual end states, so we always ignore them + (Partial {}, _) -> PBool False + (_, Partial {}) -> PBool False + (ITE _ _ _, _) -> internalError "Expressions must be flattened" + (_, ITE _ _ _) -> internalError "Expressions must be flattened" + (a, b) -> if a == b + then PBool False + else PBool True + + statesDiffer :: Map (Expr EAddr) (Expr EContract) -> Map (Expr EAddr) (Expr EContract) -> Prop + statesDiffer aState bState + = if Set.fromList (Map.keys aState) /= Set.fromList (Map.keys bState) + -- TODO: consider possibility of aliased symbolic addresses + then PBool True + else let + merged = (Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched (\_ x y -> (x,y))) aState bState) + in Map.foldl' (\a (ac, bc) -> a .|| contractsDiffer ac bc) (PBool False) merged + + contractsDiffer :: Expr EContract -> Expr EContract -> Prop + contractsDiffer ac bc = let + balsDiffer = case (ac.balance, bc.balance) of + (Lit ab, Lit bb) -> PBool $ ab /= bb + (ab, bb) -> if ab == bb then PBool False else ab ./= bb + -- TODO: is this sound? do we need a more sophisticated nonce representation? + noncesDiffer = PBool (ac.nonce /= bc.nonce) + storesDiffer = case (ac.storage, bc.storage) of + (ConcreteStore as, ConcreteStore bs) -> PBool $ as /= bs + (as, bs) -> if as == bs then PBool False else as ./= bs + in balsDiffer .|| storesDiffer .|| noncesDiffer + + both' :: (a -> b) -> (a, a) -> (b, b) both' f (x, y) = (f x, f y) produceModels :: SolverGroup -> Expr End -> IO [(Expr End, CheckSatResult)] produceModels solvers expr = do let flattened = flattenExpr expr - withQueries = fmap (\e -> (assertProps . extractProps $ e, e)) flattened + withQueries = fmap (\e -> ((assertProps abstRefineDefault) . extractProps $ e, e)) flattened results <- flip mapConcurrently withQueries $ \(query, leaf) -> do res <- checkSat solvers query pure (res, leaf) @@ -791,7 +812,7 @@ putStrLn "" putStrLn "Inputs:" putStrLn "" - T.putStrLn $ indent 2 $ formatCex cd cex + T.putStrLn $ indent 2 $ formatCex cd Nothing cex putStrLn "" putStrLn "End State:" putStrLn "" @@ -799,8 +820,8 @@ putStrLn "" -formatCex :: Expr Buf -> SMTCex -> Text -formatCex cd m@(SMTCex _ _ store blockContext txContext) = T.unlines $ +formatCex :: Expr Buf -> Maybe Sig -> SMTCex -> Text +formatCex cd sig m@(SMTCex _ _ _ store blockContext txContext) = T.unlines $ [ "Calldata:" , indent 2 cd' , "" @@ -816,7 +837,9 @@ -- it for branches that do not refer to calldata at all (e.g. the top level -- callvalue check inserted by solidity in contracts that don't have any -- payable functions). - cd' = prettyBuf $ Expr.simplify $ subModel m cd + cd' = case sig of + Nothing -> prettyBuf . Expr.simplify . defaultSymbolicValues $ subModel m cd + Just (Sig n ts) -> prettyCalldata m cd n ts storeCex :: [Text] storeCex @@ -824,7 +847,7 @@ | otherwise = [ "Storage:" , indent 2 $ T.unlines $ Map.foldrWithKey (\key val acc -> - ("Addr " <> (T.pack $ show (unsafeInto key :: Addr)) + ("Addr " <> (T.pack . show $ key) <> ": " <> (T.pack $ show (Map.toList val))) : acc ) mempty store , "" @@ -843,9 +866,7 @@ -- strips the frame arg from frame context vars to make them easier to read showTxCtx :: Expr EWord -> Text - showTxCtx (CallValue _) = "CallValue" - showTxCtx (Caller _) = "Caller" - showTxCtx (Address _) = "Address" + showTxCtx (TxValue) = "TxValue" showTxCtx x = T.pack $ show x -- strips all frame context that doesn't come from the top frame @@ -853,11 +874,8 @@ filterSubCtx = Map.filterWithKey go where go :: Expr EWord -> W256 -> Bool - go (CallValue x) _ = x == 0 - go (Caller x) _ = x == 0 - go (Address x) _ = x == 0 + go (TxValue) _ = True go (Balance {}) _ = internalError "TODO: BALANCE" - go (SelfBalance {}) _ = internalError "TODO: SELFBALANCE" go (Gas {}) _ = internalError "TODO: Gas" go _ _ = False @@ -875,23 +893,73 @@ prettyBuf :: Expr Buf -> Text prettyBuf (ConcreteBuf "") = "Empty" prettyBuf (ConcreteBuf bs) = formatBinary bs - prettyBuf _ = "Any" + prettyBuf b = internalError $ "Unexpected symbolic buffer:\n" <> T.unpack (formatExpr b) --- | Takes a buffer and a Cex and replaces all abstract values in the buf with +prettyCalldata :: SMTCex -> Expr Buf -> Text -> [AbiType] -> Text +prettyCalldata cex buf sig types = head (T.splitOn "(" sig) <> "(" <> body <> ")" + where + argdata = Expr.drop 4 . Expr.simplify . defaultSymbolicValues $ subModel cex buf + body = case decodeBuf types argdata of + CAbi v -> T.intercalate "," (fmap showVal v) + NoVals -> case argdata of + ConcreteBuf c -> T.pack (bsToHex c) + _ -> err + SAbi _ -> err + err = internalError $ "unable to produce a concrete model for calldata: " <> show buf + +-- | If the expression contains any symbolic values, default them to some +-- concrete value The intuition here is that if we still have symbolic values +-- in our calldata expression after substituing in our cex, then they can have +-- any value and we can safely pick a random value. This is a bit unsatisfying, +-- we should really be doing smth like: https://github.com/ethereum/hevm/issues/334 +-- but it's probably good enough for now +defaultSymbolicValues :: Expr a -> Expr a +defaultSymbolicValues e = subBufs (foldTerm symbufs mempty e) + . subVars (foldTerm symwords mempty e) + . subAddrs (foldTerm symaddrs mempty e) $ e + where + symaddrs :: Expr a -> Map (Expr EAddr) Addr + symaddrs = \case + a@(SymAddr _) -> Map.singleton a (Addr 0x1312) + _ -> mempty + symbufs :: Expr a -> Map (Expr Buf) ByteString + symbufs = \case + a@(AbstractBuf _) -> Map.singleton a "" + _ -> mempty + symwords :: Expr a -> Map (Expr EWord) W256 + symwords = \case + a@(Var _) -> Map.singleton a 0 + a@Origin -> Map.singleton a 0 + a@Coinbase -> Map.singleton a 0 + a@Timestamp -> Map.singleton a 0 + a@BlockNumber -> Map.singleton a 0 + a@PrevRandao -> Map.singleton a 0 + a@GasLimit -> Map.singleton a 0 + a@ChainId -> Map.singleton a 0 + a@BaseFee -> Map.singleton a 0 + _ -> mempty + +-- | Takes an expression and a Cex and replaces all abstract values in the buf with -- concrete ones from the Cex. subModel :: SMTCex -> Expr a -> Expr a -subModel c expr = - subBufs (fmap forceFlattened c.buffers) . subVars c.vars . subStore c.store - . subVars c.blockContext . subVars c.txContext $ expr +subModel c + = subBufs (fmap forceFlattened c.buffers) + . subStores c.store + . subVars c.vars + . subVars c.blockContext + . subVars c.txContext + . subAddrs c.addrs where forceFlattened (SMT.Flat bs) = bs forceFlattened b@(SMT.Comp _) = forceFlattened $ fromMaybe (internalError $ "cannot flatten buffer: " <> show b) (SMT.collapse b) - subVars model b = Map.foldlWithKey subVar b model +subVars :: Map (Expr EWord) W256 -> Expr a -> Expr a +subVars model b = Map.foldlWithKey subVar b model + where subVar :: Expr a -> Expr EWord -> W256 -> Expr a - subVar b var val = mapExpr go b + subVar a var val = mapExpr go a where go :: Expr a -> Expr a go = \case @@ -900,9 +968,24 @@ else v e -> e - subBufs model b = Map.foldlWithKey subBuf b model +subAddrs :: Map (Expr EAddr) Addr -> Expr a -> Expr a +subAddrs model b = Map.foldlWithKey subAddr b model + where + subAddr :: Expr a -> Expr EAddr -> Addr -> Expr a + subAddr a var val = mapExpr go a + where + go :: Expr a -> Expr a + go = \case + v@(SymAddr _) -> if v == var + then LitAddr val + else v + e -> e + +subBufs :: Map (Expr Buf) ByteString -> Expr a -> Expr a +subBufs model b = Map.foldlWithKey subBuf b model + where subBuf :: Expr a -> Expr Buf -> ByteString -> Expr a - subBuf b var val = mapExpr go b + subBuf x var val = mapExpr go x where go :: Expr a -> Expr a go = \case @@ -911,10 +994,24 @@ else a e -> e - subStore :: Map W256 (Map W256 W256) -> Expr a -> Expr a - subStore m b = mapExpr go b +subStores :: Map (Expr EAddr) (Map W256 W256) -> Expr a -> Expr a +subStores model b = Map.foldlWithKey subStore b model + where + subStore :: Expr a -> Expr EAddr -> Map W256 W256 -> Expr a + subStore x var val = mapExpr go x where go :: Expr a -> Expr a go = \case - AbstractStore -> ConcreteStore m + v@(AbstractStore a) + -> if a == var + then ConcreteStore val + else v e -> e + +getCex :: ProofResult a b c -> Maybe b +getCex (Cex c) = Just c +getCex _ = Nothing + +getTimeout :: ProofResult a b c -> Maybe c +getTimeout (Timeout c) = Just c +getTimeout _ = Nothing diff --git a/src/EVM/TTY.hs b/src/EVM/TTY.hs deleted file mode 100644 --- a/src/EVM/TTY.hs +++ /dev/null @@ -1,1047 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} - -module EVM.TTY where - -import Brick -import Brick.Widgets.Border -import Brick.Widgets.Center -import Brick.Widgets.List - -import EVM -import EVM.ABI (decodeAbiValue, emptyAbi, abiTypeSolidity, AbiType(..)) -import EVM.SymExec (maxIterationsReached, symCalldata) -import EVM.Expr (simplify) -import EVM.Dapp (DappInfo(..), emptyDapp, dappInfo, Test, extractSig, Test(..), srcMap, unitTestMethods) -import EVM.Debug -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.Solvers (SolverGroup) -import EVM.Op -import EVM.Solidity hiding (storageLayout) -import EVM.Types hiding (padRight, Max) -import EVM.UnitTest -import EVM.Stepper (Stepper) -import EVM.Stepper qualified as Stepper -import EVM.StorageLayout -import EVM.TTYCenteredList qualified as Centered - -import Optics.Core -import Optics.State -import Optics.TH - -import Control.Monad.Operational qualified as Operational -import Control.Monad.State.Strict hiding (state) -import Data.Aeson.Optics -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.Vector qualified as Vec -import Data.Vector.Storable qualified as SVec -import Data.Version (showVersion) -import Graphics.Vty qualified as V -import System.Console.Haskeline qualified as Readline -import Paths_hevm qualified as Paths -import Text.Wrap -import Witch (into) - -data Name - = AbiPane - | StackPane - | BytecodePane - | TracePane - | SolidityPane - | TestPickerPane - | BrowserPane - | Pager - deriving (Eq, Show, Ord) - -type UiWidget = Widget Name - -data UiVmState = UiVmState - { vm :: VM - , step :: Int - , snapshots :: Map Int (VM, Stepper ()) - , stepper :: Stepper () - , showMemory :: Bool - , testOpts :: UnitTestOptions - } - -data UiTestPickerState = UiTestPickerState - { tests :: List Name (Text, Text) - , dapp :: DappInfo - , opts :: UnitTestOptions - } - -data UiBrowserState = UiBrowserState - { contracts :: List Name (Addr, Contract) - , vm :: UiVmState - } - -data UiState - = ViewVm UiVmState - | ViewContracts UiBrowserState - | ViewPicker UiTestPickerState - | ViewHelp UiVmState - -makeFieldLabelsNoPrefix ''UiVmState -makeFieldLabelsNoPrefix ''UiTestPickerState -makeFieldLabelsNoPrefix ''UiBrowserState -makePrisms ''UiState - --- caching VM states lets us backstep efficiently -snapshotInterval :: Int -snapshotInterval = 50 - -type Pred a = a -> Bool - -data StepMode - = Step !Int -- ^ Run a specific number of steps - | StepUntil (Pred VM) -- ^ Finish when a VM predicate holds - --- | Each step command in the terminal should finish immediately --- with one of these outcomes. -data Continuation a - = Stopped a -- ^ Program finished - | Continue (Stepper a) -- ^ Took one step; more steps to go - - --- | This turns a @Stepper@ into a state action usable --- from within the TTY loop, yielding a @StepOutcome@ depending on the @StepMode@. -interpret - :: (?fetcher :: Fetcher - , ?maxIter :: Maybe Integer) - => StepMode - -> Stepper a - -> StateT UiVmState IO (Continuation a) -interpret mode = - - -- Like the similar interpreters in @EVM.UnitTest@ and @EVM.VMTest@, - -- this one is implemented as an "operational monad interpreter". - - eval . Operational.view - where - eval - :: Operational.ProgramView Stepper.Action a - -> StateT UiVmState IO (Continuation a) - - eval (Operational.Return x) = - pure (Stopped x) - - eval (action Operational.:>>= k) = - case action of - - Stepper.Run -> do - -- Have we reached the final result of this action? - use (#vm % #result) >>= \case - Just _ -> do - -- Yes, proceed with the next action. - vm <- use #vm - interpret mode (k vm) - Nothing -> do - -- No, keep performing the current action - keepExecuting mode (Stepper.run >>= k) - - -- Stepper wants to keep executing? - Stepper.Exec -> do - -- Have we reached the final result of this action? - use (#vm % #result) >>= \case - Just r -> - -- Yes, proceed with the next action. - interpret mode (k r) - Nothing -> do - -- No, keep performing the current action - keepExecuting mode (Stepper.exec >>= k) - - -- Stepper is waiting for user input from a query - Stepper.Ask (PleaseChoosePath _ cont) -> do - -- ensure we aren't stepping past max iterations - vm <- use #vm - case maxIterationsReached vm ?maxIter of - Nothing -> pure $ Continue (k ()) - Just n -> interpret mode (Stepper.evm (cont (not n)) >>= k) - - -- Stepper wants to make a query and wait for the results? - Stepper.Wait (PleaseAskSMT (Lit c) _ continue) -> - interpret mode (Stepper.evm (continue (Case (c > 0))) >>= k) - Stepper.Wait q -> do - do m <- liftIO (?fetcher q) - interpret mode (Stepper.evm m >>= k) - - -- Stepper wants to make a query and wait for the results? - Stepper.IOAct q -> do - Brick.zoom (toLensVL #vm) (StateT (runStateT q)) >>= interpret mode . k - - -- Stepper wants to modify the VM. - Stepper.EVM m -> do - vm <- use #vm - let (r, vm1) = runState m vm - assign #vm vm1 - interpret mode (Stepper.exec >> (k r)) - -keepExecuting :: (?fetcher :: Fetcher - , ?maxIter :: Maybe Integer) - => StepMode - -> Stepper a - -> StateT UiVmState IO (Continuation a) -keepExecuting mode restart = case mode of - Step 0 -> do - -- We come here when we've continued while stepping, - -- either from a query or from a return; - -- we should pause here and wait for the user. - pure (Continue restart) - - Step i -> do - -- Run one instruction and recurse - stepOneOpcode restart - interpret (Step (i - 1)) restart - - StepUntil p -> do - vm <- use #vm - if p vm - then - interpret (Step 0) restart - else do - -- Run one instruction and recurse - stepOneOpcode restart - interpret (StepUntil p) restart - -isUnitTestContract :: Text -> DappInfo -> Bool -isUnitTestContract name dapp = - elem name (map fst dapp.unitTests) - -mkVty :: IO V.Vty -mkVty = do - vty <- V.mkVty V.defaultConfig - V.setMode (V.outputIface vty) V.BracketedPaste True - pure vty - -runFromVM :: SolverGroup -> Fetch.RpcInfo -> Maybe Integer -> DappInfo -> VM -> IO VM -runFromVM solvers rpcInfo maxIter' dappinfo vm = do - - let - opts = UnitTestOptions - { solvers = solvers - , rpcInfo = rpcInfo - , verbose = Nothing - , maxIter = maxIter' - , askSmtIters = 1 - , smtTimeout = Nothing - , smtDebug = False - , solver = Nothing - , maxDepth = Nothing - , match = "" - , fuzzRuns = 1 - , replay = internalError "irrelevant" - , vmModifier = id - , testParams = internalError "irrelevant" - , dapp = dappinfo - , ffiAllowed = False - , covMatch = Nothing - } - ui0 = initUiVmState vm opts (void Stepper.execFully) - - v <- mkVty - ui2 <- customMain v mkVty Nothing (app opts) (ViewVm ui0) - case ui2 of - ViewVm ui -> pure ui.vm - _ -> internalError "customMain returned prematurely" - - -initUiVmState :: VM -> UnitTestOptions -> Stepper () -> UiVmState -initUiVmState vm0 opts script = - UiVmState - { vm = vm0 - , stepper = script - , step = 0 - , snapshots = singleton 0 (vm0, script) - , showMemory = False - , testOpts = opts - } - - --- filters out fuzztests, unless they have --- explicitly been given an argument by `replay` -debuggableTests :: UnitTestOptions -> (Text, [(Test, [AbiType])]) -> [(Text, Text)] -debuggableTests UnitTestOptions{..} (contractname, tests) = case replay of - Nothing -> [(contractname, extractSig $ fst x) | x <- tests, not $ isFuzzTest x] - Just (sig, _) -> [(contractname, extractSig $ fst x) | x <- tests, not (isFuzzTest x) || extractSig (fst x) == sig] - -isFuzzTest :: (Test, [AbiType]) -> Bool -isFuzzTest (SymbolicTest _, _) = False -isFuzzTest (ConcreteTest _, []) = False -isFuzzTest (ConcreteTest _, _) = True -isFuzzTest (InvariantTest _, _) = True - -main :: UnitTestOptions -> FilePath -> Maybe BuildOutput -> IO () -main opts root buildOutput = do - let - dapp = maybe emptyDapp (dappInfo root) buildOutput - ui = ViewPicker $ UiTestPickerState - { tests = - list - TestPickerPane - (Vec.fromList - (concatMap - (debuggableTests opts) - dapp.unitTests)) - 1 - , dapp = dapp - , opts = opts - } - v <- mkVty - _ <- customMain v mkVty Nothing (app opts) (ui :: UiState) - pure () - -takeStep - :: (?fetcher :: Fetcher - ,?maxIter :: Maybe Integer) - => UiVmState - -> StepMode - -> EventM n UiState () -takeStep ui mode = - liftIO nxt >>= \case - (Stopped (), _) -> - pure () - (Continue steps, ui') -> - put (ViewVm (ui' & set #stepper steps)) - where - m = interpret mode ui.stepper - nxt = runStateT m ui - -backstepUntil - :: (?fetcher :: Fetcher - ,?maxIter :: Maybe Integer) - => (UiVmState -> Pred VM) -> EventM n UiState () -backstepUntil p = get >>= \case - ViewVm s -> - case s.step of - 0 -> pure () - n -> do - s1 <- liftIO $ backstep s - let - -- find a previous vm that satisfies the predicate - snapshots' = Data.Map.filter (p s1 . fst) s1.snapshots - case lookupLT n snapshots' of - -- If no such vm exists, go to the beginning - Nothing -> - let - (step', (vm', stepper')) = fromJust $ lookupLT (n - 1) s.snapshots - s2 = s1 - & set #vm vm' - & set (#vm % #cache) s1.vm.cache - & set #step step' - & set #stepper stepper' - in takeStep s2 (Step 0) - -- step until the predicate doesn't hold - Just (step', (vm', stepper')) -> - let - s2 = s1 - & set #vm vm' - & set (#vm % #cache) s1.vm.cache - & set #step step' - & set #stepper stepper' - in takeStep s2 (StepUntil (not . p s1)) - _ -> pure () - -backstep - :: (?fetcher :: Fetcher - ,?maxIter :: Maybe Integer) - => UiVmState -> IO UiVmState -backstep s = - case s.step of - -- We're already at the first step; ignore command. - 0 -> pure s - -- To step backwards, we revert to the previous snapshot - -- and execute n - 1 `mod` snapshotInterval steps from there. - - -- We keep the current cache so we don't have to redo - -- any blocking queries, and also the memory view. - n -> - let - (step, (vm, stepper)) = fromJust $ lookupLT n s.snapshots - s1 = s - & set #vm vm - & set (#vm % #cache) s.vm.cache - & set #step step - & set #stepper stepper - stepsToTake = n - step - 1 - - in - runStateT (interpret (Step stepsToTake) stepper) s1 >>= \case - (Continue steps, ui') -> pure $ ui' & set #stepper steps - _ -> internalError "unexpected end" - -appEvent - :: (?fetcher::Fetcher, ?maxIter :: Maybe Integer) => - BrickEvent Name e -> - EventM Name UiState () - --- Contracts: Down - list down -appEvent (VtyEvent e@(V.EvKey V.KDown [])) = get >>= \case - ViewContracts _s -> do - Brick.zoom - (traverseOf $ _ViewContracts % #contracts) - (handleListEvent e) - pure () - ViewPicker _s -> do - Brick.zoom - (traverseOf $ _ViewPicker % #tests) - (handleListEvent e) - pure() - _ -> pure () - --- Contracts: Up - list up --- Page: Up - scroll -appEvent (VtyEvent e@(V.EvKey V.KUp [])) = get >>= \case - ViewContracts _s -> do - Brick.zoom - (traverseOf $ _ViewContracts % #contracts) - (handleListEvent e) - ViewPicker _s -> do - Brick.zoom - (traverseOf $ _ViewPicker % #tests) - (handleListEvent e) - pure() - _ -> pure () - --- Vm Overview: Esc - return to test picker or exit --- Any: Esc - return to Vm Overview or Exit -appEvent (VtyEvent (V.EvKey V.KEsc [])) = get >>= \case - ViewVm s -> do - let opts = s ^. #testOpts - dapp = opts.dapp - tests = concatMap (debuggableTests opts) dapp.unitTests - case tests of - [] -> halt - ts -> - put $ ViewPicker $ UiTestPickerState - { tests = list TestPickerPane (Vec.fromList ts) 1 - , dapp = dapp - , opts = opts - } - ViewHelp s -> put (ViewVm s) - ViewContracts s -> put (ViewVm $ s ^. #vm) - _ -> halt - --- Vm Overview: Enter - open contracts view --- UnitTest Picker: Enter - select from list -appEvent (VtyEvent (V.EvKey V.KEnter [])) = get >>= \case - ViewVm s -> - put . ViewContracts $ UiBrowserState - { contracts = - list - BrowserPane - (Vec.fromList (Map.toList s.vm.env.contracts)) - 2 - , vm = s - } - ViewPicker s -> - case listSelectedElement s.tests of - Nothing -> internalError "nothing selected" - Just (_, x) -> do - let initVm = initialUiVmStateForTest s.opts x - put (ViewVm initVm) - _ -> pure () - --- Vm Overview: m - toggle memory pane -appEvent (VtyEvent (V.EvKey (V.KChar 'm') [])) = get >>= \case - ViewVm s -> put (ViewVm $ over #showMemory not s) - _ -> pure () - --- Vm Overview: h - open help view -appEvent (VtyEvent (V.EvKey (V.KChar 'h') [])) = get >>= \case - ViewVm s -> put (ViewHelp s) - _ -> pure () - --- Vm Overview: spacebar - read input -appEvent (VtyEvent (V.EvKey (V.KChar ' ') [])) = - let - loop = do - Readline.getInputLine "% " >>= \case - Just hey -> Readline.outputStrLn hey - Nothing -> pure () - Readline.getInputLine "% " >>= \case - Just hey' -> Readline.outputStrLn hey' - Nothing -> pure () - in do - s <- get - suspendAndResume $ do - Readline.runInputT Readline.defaultSettings loop - pure s - --- todo refactor to zipper step forward --- Vm Overview: n - step -appEvent (VtyEvent (V.EvKey (V.KChar 'n') [])) = get >>= \case - ViewVm s -> - when (isNothing (s ^. #vm % #result)) $ - takeStep s (Step 1) - _ -> pure () - --- Vm Overview: N - step -appEvent (VtyEvent (V.EvKey (V.KChar 'N') [])) = get >>= \case - ViewVm s -> - when (isNothing (s ^. #vm % #result)) $ - takeStep s (StepUntil (isNextSourcePosition s)) - _ -> pure () - --- Vm Overview: C-n - step -appEvent (VtyEvent (V.EvKey (V.KChar 'n') [V.MCtrl])) = get >>= \case - ViewVm s -> - when (isNothing (s ^. #vm % #result)) $ - takeStep s (StepUntil (isNextSourcePositionWithoutEntering s)) - _ -> pure () - --- Vm Overview: e - step -appEvent (VtyEvent (V.EvKey (V.KChar 'e') [])) = get >>= \case - ViewVm s -> - when (isNothing (s ^. #vm % #result)) $ - takeStep s (StepUntil (isExecutionHalted s)) - _ -> pure () - --- Vm Overview: a - step -appEvent (VtyEvent (V.EvKey (V.KChar 'a') [])) = get >>= \case - ViewVm s -> - -- We keep the current cache so we don't have to redo - -- any blocking queries. - let - (vm, stepper) = fromJust (Map.lookup 0 s.snapshots) - s' = s - & set #vm vm - & set (#vm % #cache) s.vm.cache - & set #step 0 - & set #stepper stepper - - in takeStep s' (Step 0) - _ -> pure () - --- Vm Overview: p - backstep -appEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) = get >>= \case - ViewVm s -> - case s.step of - 0 -> - -- We're already at the first step; ignore command. - pure () - n -> do - -- To step backwards, we revert to the previous snapshot - -- and execute n - 1 `mod` snapshotInterval steps from there. - - -- We keep the current cache so we don't have to redo - -- any blocking queries, and also the memory view. - let - (step, (vm, stepper)) = fromJust $ lookupLT n s.snapshots - s1 = s - & set #vm vm -- set the vm to the one from the snapshot - & set (#vm % #cache) s.vm.cache -- persist the cache - & set #step step - & set #stepper stepper - stepsToTake = n - step - 1 - - takeStep s1 (Step stepsToTake) - _ -> pure () - --- Vm Overview: P - backstep to previous source -appEvent (VtyEvent (V.EvKey (V.KChar 'P') [])) = - backstepUntil isNextSourcePosition - --- Vm Overview: c-p - backstep to previous source avoiding CALL and CREATE -appEvent (VtyEvent (V.EvKey (V.KChar 'p') [V.MCtrl])) = - backstepUntil isNextSourcePositionWithoutEntering - --- Vm Overview: 0 - choose no jump -appEvent (VtyEvent (V.EvKey (V.KChar '0') [])) = get >>= \case - ViewVm s -> - case view (#vm % #result) s of - Just (HandleEffect (Choose (PleaseChoosePath _ contin))) -> - takeStep (s & set #stepper (Stepper.evm (contin True) >> s.stepper)) - (Step 1) - _ -> pure () - _ -> pure () - --- Vm Overview: 1 - choose jump -appEvent (VtyEvent (V.EvKey (V.KChar '1') [])) = get >>= \case - ViewVm s -> - case s.vm.result of - Just (HandleEffect (Choose (PleaseChoosePath _ contin))) -> - takeStep (s & set #stepper (Stepper.evm (contin False) >> s.stepper)) - (Step 1) - _ -> pure () - _ -> pure () - --- Page: C-f - Page down -appEvent (VtyEvent (V.EvKey (V.KChar 'f') [V.MCtrl])) = - vScrollPage (viewportScroll TracePane) Down - --- Page: C-b - Page up -appEvent (VtyEvent (V.EvKey (V.KChar 'b') [V.MCtrl])) = - vScrollPage (viewportScroll TracePane) Up - --- UnitTest Picker: (main) - render list -appEvent (VtyEvent e) = do - Brick.zoom (traverseOf (_ViewPicker % #tests)) - (handleListEvent e) - --- Default -appEvent _ = pure () - -app :: UnitTestOptions -> App UiState () Name -app UnitTestOptions{..} = - let ?fetcher = Fetch.oracle solvers rpcInfo - ?maxIter = maxIter - in App - { appDraw = drawUi - , appChooseCursor = neverShowCursor - , appHandleEvent = appEvent - , appStartEvent = pure () - , appAttrMap = const (attrMap V.defAttr myTheme) - } - -initialUiVmStateForTest - :: UnitTestOptions - -> (Text, Text) - -> UiVmState -initialUiVmStateForTest opts@UnitTestOptions{..} (theContractName, theTestName) = initUiVmState vm0 opts script - where - cd = case test of - SymbolicTest _ -> symCalldata theTestName types [] (AbstractBuf "txdata") - _ -> (internalError "unreachable", error $ internalError "unreachable") - (test, types) = fromJust $ find (\(test',_) -> extractSig test' == theTestName) $ unitTestMethods testContract - testContract = fromJust $ Map.lookup theContractName dapp.solcByName - vm0 = - initialUnitTestVm opts testContract - script = do - Stepper.evm . pushTrace . EntryTrace $ - "test " <> theTestName <> " (" <> theContractName <> ")" - initializeUnitTest opts testContract - case test of - ConcreteTest _ -> do - let args = case replay of - Nothing -> emptyAbi - Just (sig, callData) -> - if theTestName == sig - then decodeAbiValue (AbiTupleType (Vec.fromList types)) callData - else emptyAbi - void (runUnitTest opts theTestName args) - SymbolicTest _ -> do - void (execSymTest opts theTestName cd) - InvariantTest _ -> do - targets <- getTargetContracts opts - let randomRun = initialExplorationStepper opts theTestName [] targets (fromMaybe 20 maxDepth) - void $ case replay of - Nothing -> randomRun - Just (sig, cd') -> - if theTestName == sig - then initialExplorationStepper opts theTestName (decodeCalls cd') targets (length (decodeCalls cd')) - else randomRun - -myTheme :: [(AttrName, V.Attr)] -myTheme = - [ (selectedAttr, V.defAttr `V.withStyle` V.standout) - , (dimAttr, V.defAttr `V.withStyle` V.dim) - , (borderAttr, V.defAttr `V.withStyle` V.dim) - , (wordAttr, fg V.yellow) - , (boldAttr, V.defAttr `V.withStyle` V.bold) - , (activeAttr, V.defAttr `V.withStyle` V.standout) - ] - -drawUi :: UiState -> [UiWidget] -drawUi (ViewVm s) = drawVm s -drawUi (ViewPicker s) = drawTestPicker s -drawUi (ViewContracts s) = drawVmBrowser s -drawUi (ViewHelp _) = drawHelpView - -drawHelpView :: [UiWidget] -drawHelpView = - [ center . borderWithLabel version . - padLeftRight 4 . padTopBottom 2 . str $ - "Esc Exit the debugger\n\n" <> - "a Step to start\n" <> - "e Step to end\n" <> - "n Step fwds by one instruction\n" <> - "N Step fwds to the next source position\n" <> - "C-n Step fwds to the next source position skipping CALL & CREATE\n" <> - "p Step back by one instruction\n\n" <> - "P Step back to the previous source position\n\n" <> - "C-p Step back to the previous source position skipping CALL & CREATE\n\n" <> - "m Toggle memory pane\n" <> - "0 Choose the branch which does not jump \n" <> - "1 Choose the branch which does jump \n" <> - "Down Step to next entry in the callstack / Scroll memory pane\n" <> - "Up Step to previous entry in the callstack / Scroll memory pane\n" <> - "C-f Page memory pane fwds\n" <> - "C-b Page memory pane back\n\n" <> - "Enter Contracts browser" - ] - where - version = - txt "Hevm " <+> - str (showVersion Paths.version) <+> - txt " - Key bindings" - -drawTestPicker :: UiTestPickerState -> [UiWidget] -drawTestPicker ui = - [ center . borderWithLabel (txt "Unit tests") . - hLimit 80 $ - renderList - (\selected (x, y) -> - withHighlight selected $ - txt " Debug " <+> txt (contractNamePart x) <+> txt "::" <+> txt y) - True - ui.tests - ] - -drawVmBrowser :: UiBrowserState -> [UiWidget] -drawVmBrowser ui = - [ hBox - [ borderWithLabel (txt "Contracts") . - hLimit 60 $ - renderList - (\selected (k, c') -> - withHighlight selected . txt . mconcat $ - [ fromMaybe "" $ - Map.lookup (maybeHash c') dapp.solcByHash <&> (.contractName) . snd - , "\n" - , " ", pack (show k) - ]) - True - ui.contracts - , case snd <$> Map.lookup (maybeHash c) dapp.solcByHash of - Nothing -> - hBox - [ borderWithLabel (txt "Contract information") . padBottom Max . padRight Max $ vBox - [ txt ("Codehash: " <> pack (show c.codehash)) - , txt ("Nonce: " <> showWordExact c.nonce) - , txt ("Balance: " <> showWordExact c.balance) - --, txt ("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 sol.contractName) - , txt "File: " <+> txt (contractPathPart sol.contractName) - , txt " " - , txt "Constructor inputs:" - , vBox . flip map sol.constructorInputs $ - \(name, abiType) -> txt (" " <> name <> ": " <> abiTypeSolidity abiType) - , txt "Public methods:" - , 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)) - ] - ] - ] - where - dapp = ui.vm.testOpts.dapp - (_, (_, c)) = fromJust $ listSelectedElement ui.contracts --- currentContract = view (dappSolcByHash . ix ) dapp - maybeHash ch = fromJust (internalError "cannot find concrete codehash for partially symbolic code") (maybeLitWord ch.codehash) - -drawVm :: UiVmState -> [UiWidget] -drawVm ui = - -- EVM debugging needs a lot of space because of the 256-bit words - -- in both the bytecode and the stack . - -- - -- If on a very tall display, prefer a vertical layout. - -- - -- Actually the horizontal layout would be preferrable if the display - -- is both very tall and very wide, but this is okay for now. - [ ifTallEnough (20 * 4) - ( vBox - [ vLimit 20 $ drawBytecodePane ui - , vLimit 20 $ drawStackPane ui - , drawSolidityPane ui - , vLimit 20 $ drawTracePane ui - , vLimit 2 drawHelpBar - ] - ) - ( vBox - [ hBox - [ vLimit 20 $ drawBytecodePane ui - , vLimit 20 $ drawStackPane ui - ] - , hBox - [ drawSolidityPane ui - , drawTracePane ui - ] - , vLimit 2 drawHelpBar - ] - ) - ] - -drawHelpBar :: UiWidget -drawHelpBar = hBorder <=> hCenter help - where - help = - hBox (map (\(k, v) -> txt k <+> dim (txt (" (" <> v <> ") "))) helps) - - helps = - [ - ("n", "step") - , ("p", "step back") - , ("a", "step to start") - , ("e", "step to end") - , ("m", "toggle memory") - , ("Esc", "exit") - , ("h", "more help") - ] - -stepOneOpcode :: Stepper a -> StateT UiVmState IO () -stepOneOpcode restart = do - n <- use #step - when (n > 0 && n `mod` snapshotInterval == 0) $ do - vm <- use #vm - modifying #snapshots (insert n (vm, void restart)) - modifying #vm (execState exec1) - modifying #step (+ 1) - -isNewTraceAdded - :: UiVmState -> Pred VM -isNewTraceAdded ui vm = - let - currentTraceTree = length <$> traceForest ui.vm - newTraceTree = length <$> traceForest vm - in currentTraceTree /= newTraceTree - -isNextSourcePosition - :: UiVmState -> Pred VM -isNextSourcePosition ui vm = - let dapp = ui.testOpts.dapp - initialPosition = currentSrcMap dapp ui.vm - in currentSrcMap dapp vm /= initialPosition - -isNextSourcePositionWithoutEntering - :: UiVmState -> Pred VM -isNextSourcePositionWithoutEntering ui vm = - let - dapp = ui.testOpts.dapp - vm0 = ui.vm - initialPosition = currentSrcMap dapp vm0 - initialHeight = length vm0.frames - in - case currentSrcMap dapp vm of - Nothing -> - False - Just here -> - let - moved = Just here /= initialPosition - deeper = length vm.frames > initialHeight - boring = - case srcMapCode dapp.sources here of - Just bs -> - BS.isPrefixOf "contract " bs - Nothing -> - True - in - moved && not deeper && not boring - -isExecutionHalted :: UiVmState -> Pred VM -isExecutionHalted _ vm = isJust vm.result - -currentSrcMap :: DappInfo -> VM -> Maybe SrcMap -currentSrcMap dapp vm = do - this <- currentContract vm - i <- this.opIxMap SVec.!? vm.state.pc - srcMap dapp this i - -drawStackPane :: UiVmState -> UiWidget -drawStackPane ui = - let - gasText = showWordExact (into ui.vm.state.gas) - labelText = txt ("Gas available: " <> gasText <> "; stack:") - stackList = list StackPane (Vec.fromList $ zip [(1 :: Int)..] (simplify <$> ui.vm.state.stack)) 2 - in hBorderWithLabel labelText <=> - renderList - (\_ (i, w) -> - vBox - [ withHighlight True (str ("#" ++ show i ++ " ")) - <+> ourWrap (Text.unpack $ prettyIfConcreteWord w) - , dim (txt (" " <> case maybeLitWord w of - Nothing -> "" - Just u -> showWordExplanation u ui.testOpts.dapp)) - ]) - False - stackList - -message :: VM -> String -message vm = - case vm.result of - Just (VMSuccess (ConcreteBuf msg)) -> - "VMSuccess: " <> (show $ ByteStringS msg) - Just (VMSuccess (msg)) -> - "VMSuccess: " <> (show msg) - Just (VMFailure (Revert msg)) -> - "VMFailure: " <> (show msg) - Just (VMFailure err) -> - "VMFailure: " <> show err - Just (Unfinished p) -> - "Could not continue execution: " <> show p - Just (HandleEffect e) -> - "Handling side effect: " <> show e - Nothing -> - "Executing EVM code in " <> show vm.state.contract - - -drawBytecodePane :: UiVmState -> UiWidget -drawBytecodePane ui = - let - vm = ui.vm - move = maybe id listMoveTo $ vmOpIx vm - in - hBorderWithLabel (str $ message vm) <=> - Centered.renderList - (\active x -> if not active - then withDefAttr dimAttr (opWidget x) - else withDefAttr boldAttr (opWidget x)) - False - (move $ list BytecodePane - (maybe mempty (.codeOps) (currentContract vm)) - 1) - - -dim :: Widget n -> Widget n -dim = withDefAttr dimAttr - -withHighlight :: Bool -> Widget n -> Widget n -withHighlight False = withDefAttr dimAttr -withHighlight True = withDefAttr boldAttr - -prettyIfConcrete :: Expr Buf -> String -prettyIfConcrete (ConcreteBuf x) = prettyHex 40 x -prettyIfConcrete x = T.unpack $ formatExpr $ simplify x - -drawTracePane :: UiVmState -> UiWidget -drawTracePane s = - let vm = s.vm - dapp = s.testOpts.dapp - traceList = - list - TracePane - (Vec.fromList - . Text.lines - . showTraceTree dapp - $ vm) - 1 - - in case s.showMemory of - True -> viewport TracePane Vertical $ - hBorderWithLabel (txt "Calldata") - <=> ourWrap (prettyIfConcrete vm.state.calldata) - <=> hBorderWithLabel (txt "Returndata") - <=> ourWrap (prettyIfConcrete vm.state.returndata) - <=> hBorderWithLabel (txt "Output") - <=> ourWrap (maybe "" show vm.result) - <=> hBorderWithLabel (txt "Cache") - <=> ourWrap (show vm.cache.path) - <=> hBorderWithLabel (txt "Path Conditions") - <=> (ourWrap $ show $ vm.constraints) - <=> hBorderWithLabel (txt "Memory") - <=> (ourWrap (prettyIfConcrete vm.state.memory)) - False -> - hBorderWithLabel (txt "Trace") - <=> renderList - (\_ x -> txt x) - False - (listMoveTo (length traceList) traceList) - -ourWrap :: String -> Widget n -ourWrap = strWrapWith settings - where - settings = WrapSettings - { preserveIndentation = True - , breakLongWords = True - , fillStrategy = NoFill - , fillScope = FillAfterFirst - } - -solidityList :: VM -> DappInfo -> List Name (Int, ByteString) -solidityList vm dapp = - list SolidityPane - (case currentSrcMap dapp vm of - Nothing -> mempty - Just x -> - fromMaybe - (internalError "unable to find line for source map") - (preview ( - ix x.file - % to (Vec.imap (,))) - dapp.sources.lines)) - 1 - -drawSolidityPane :: UiVmState -> UiWidget -drawSolidityPane ui = - let dapp = ui.testOpts.dapp - dappSrcs = dapp.sources - vm = ui.vm - in case currentSrcMap dapp vm of - Nothing -> padBottom Max (hBorderWithLabel (txt "")) - Just sm -> - let - rows = dappSrcs.lines !? sm.file - subrange :: Int -> Maybe (Int, Int) - subrange i = do - rs <- rows - lineSubrange rs (sm.offset, sm.length) i - fileName :: Maybe Text - fileName = T.pack . fst <$> (dapp.sources.files !? sm.file) - lineNo :: Maybe Int - lineNo = ((\a -> Just (a - 1)) . snd) =<< srcMapCodePos dapp.sources sm - in vBox - [ hBorderWithLabel $ - txt (fromMaybe "" fileName) - <+> str (":" ++ (maybe "?" show lineNo)) - - -- Show the AST node type if present - <+> txt (" (" <> fromMaybe "?" - (dapp.astSrcMap sm - >>= preview (key "name" % _String)) <> ")") - , Centered.renderList - (\_ (i, line) -> - let s = case decodeUtf8 line of "" -> " "; y -> y - in case subrange i of - Nothing -> withHighlight False (txt s) - Just (a, b) -> - let (x, y, z) = ( Text.take a s - , Text.take b (Text.drop a s) - , Text.drop (a + b) s - ) - in hBox [ withHighlight False (txt x) - , withHighlight True (txt y) - , withHighlight False (txt z) - ]) - False - ((maybe id listMoveTo lineNo) - (solidityList vm dapp)) - ] - -ifTallEnough :: Int -> Widget n -> Widget n -> Widget n -ifTallEnough need w1 w2 = - Widget Greedy Greedy $ do - c <- getContext - if view (lensVL availHeightL) c > need - then render w1 - else render w2 - -opWidget :: (Integral a, Show a) => (a, Op) -> Widget n -opWidget = txt . pack . opString - -selectedAttr :: AttrName; selectedAttr = attrName "selected" -dimAttr :: AttrName; dimAttr = attrName "dim" -wordAttr :: AttrName; wordAttr = attrName "word" -boldAttr :: AttrName; boldAttr = attrName "bold" -activeAttr :: AttrName; activeAttr = attrName "active" diff --git a/src/EVM/TTYCenteredList.hs b/src/EVM/TTYCenteredList.hs deleted file mode 100644 --- a/src/EVM/TTYCenteredList.hs +++ /dev/null @@ -1,70 +0,0 @@ -module EVM.TTYCenteredList where - --- Hard fork of brick's List that centers the currently highlighted line. - -import Optics.Core -import Data.Maybe (fromMaybe) -import Data.Vector qualified as V - -import Brick.Types -import Brick.Widgets.Core -import Brick.Widgets.List - --- | Turn a list state value into a widget given an item drawing --- function. -renderList :: (Ord n, Show n) - => (Bool -> e -> Widget n) - -- ^ Rendering function, True for the selected element - -> Bool - -- ^ Whether the list has focus - -> List n e - -- ^ The List to be rendered - -> Widget n - -- ^ rendered widget -renderList drawElem foc l = - withDefAttr listAttr $ - drawListElements foc l drawElem - -drawListElements :: (Ord n, Show n) => Bool -> List n e -> (Bool -> e -> Widget n) -> Widget n -drawListElements foc l drawElem = - Widget Greedy Greedy $ do - c <- getContext - - let es = V.slice start num (l ^. (lensVL listElementsL)) - idx = fromMaybe 0 (l ^. (lensVL listSelectedL)) - - start = max 0 $ idx - (initialNumPerHeight `div` 2) - num = min (numPerHeight * 2) (V.length (l ^. (lensVL listElementsL)) - start) - - -- The number of items to show is the available height divided by - -- the item height... - initialNumPerHeight = (c ^. (lensVL availHeightL)) `div` (l ^. (lensVL listItemHeightL)) - -- ... but if the available height leaves a remainder of - -- an item height then we need to ensure that we render an - -- extra item to show a partial item at the top or bottom to - -- give the expected result when an item is more than one - -- row high. (Example: 5 rows available with item height - -- of 3 yields two items: one fully rendered, the other - -- rendered with only its top 2 or bottom 2 rows visible, - -- depending on how the viewport state changes.) - numPerHeight = initialNumPerHeight + - if initialNumPerHeight * (l ^. (lensVL listItemHeightL)) == c ^. (lensVL availHeightL) - then 0 - else 1 - - -- off = start * (l^.listItemHeightL) - - drawnElements = flip V.imap es $ \i e -> - let isSelected = i == (if start == 0 then idx else div initialNumPerHeight 2) - elemWidget = drawElem isSelected e - selItemAttr = if foc - then withDefAttr listSelectedFocusedAttr - else withDefAttr listSelectedAttr - makeVisible = if isSelected - then visible . selItemAttr - else id - in makeVisible elemWidget - - render $ viewport (l ^. (lensVL listNameL)) Vertical $ - -- translateBy (Location (0, off)) $ - vBox $ V.toList drawnElements diff --git a/src/EVM/Transaction.hs b/src/EVM/Transaction.hs --- a/src/EVM/Transaction.hs +++ b/src/EVM/Transaction.hs @@ -5,8 +5,8 @@ import EVM.RLP import EVM.Types import EVM.Format (hexText) -import EVM.Expr (litAddr) import EVM.Sign +import qualified EVM.Expr as Expr import Optics.Core hiding (cons) @@ -61,7 +61,7 @@ instance JSON.ToJSON Transaction where toJSON t = JSON.object [ ("input", (JSON.toJSON (ByteStringS t.txdata))) - , ("gas", (JSON.toJSON $ "0x" ++ showHex (toInteger $ t.gasLimit) "")) + , ("gas", (JSON.toJSON $ "0x" ++ showHex (into @Integer $ t.gasLimit) "")) , ("gasPrice", (JSON.toJSON $ show $ fromJust $ t.gasPrice)) , ("v", (JSON.toJSON $ show $ (t.v)-27)) , ("r", (JSON.toJSON $ show $ t.r)) @@ -225,28 +225,28 @@ parseJSON invalid = JSON.typeMismatch "Transaction" invalid -accountAt :: Addr -> Getter (Map Addr Contract) Contract +accountAt :: Expr EAddr -> Getter (Map (Expr EAddr) Contract) Contract accountAt a = (at a) % (to $ fromMaybe newAccount) -touchAccount :: Addr -> Map Addr Contract -> Map Addr Contract +touchAccount :: Expr EAddr -> Map (Expr EAddr) Contract -> Map (Expr EAddr) Contract touchAccount a = Map.insertWith (flip const) a newAccount newAccount :: Contract -newAccount = initialContract $ RuntimeCode (ConcreteRuntimeCode "") +newAccount = initialContract (RuntimeCode (ConcreteRuntimeCode "")) -- | Increments origin nonce and pays gas deposit -setupTx :: Addr -> Addr -> W256 -> Word64 -> Map Addr Contract -> Map Addr Contract +setupTx :: Expr EAddr -> Expr EAddr -> W256 -> Word64 -> Map (Expr EAddr) Contract -> Map (Expr EAddr) Contract setupTx origin coinbase gasPrice gasLimit prestate = let gasCost = gasPrice * (into gasLimit) - in (Map.adjust ((over #nonce (+ 1)) - . (over #balance (subtract gasCost))) origin) + in (Map.adjust ((over #nonce (fmap ((+) 1))) + . (over #balance (`Expr.sub` (Lit gasCost)))) origin) . touchAccount origin . touchAccount coinbase $ prestate -- | Given a valid tx loaded into the vm state, -- subtract gas payment from the origin, increment the nonce -- and pay receiving address -initTx :: VM -> VM +initTx :: VM s -> VM s initTx vm = let toAddr = vm.state.contract origin = vm.tx.origin @@ -258,23 +258,13 @@ preState = setupTx origin coinbase gasPrice gasLimit vm.env.contracts oldBalance = view (accountAt toAddr % #balance) preState creation = vm.tx.isCreate - initState = (case maybeLitWord value of - Just v -> ((Map.adjust (over #balance (subtract v))) origin) - . (Map.adjust (over #balance (+ v))) toAddr - Nothing -> id) + initState = + ((Map.adjust (over #balance (`Expr.sub` value))) origin) + . (Map.adjust (over #balance (Expr.add value))) toAddr . (if creation - then Map.insert toAddr (toContract & #balance .~ oldBalance) + then Map.insert toAddr (toContract & (set #balance oldBalance)) else touchAccount toAddr) $ preState - - resetConcreteStore s = if creation then Map.insert (into toAddr) mempty s else s - - resetStore (ConcreteStore s) = ConcreteStore (resetConcreteStore s) - resetStore (SStore a@(Lit _) k v s) = if creation && a == (litAddr toAddr) then resetStore s else (SStore a k v (resetStore s)) - resetStore (SStore {}) = internalError "cannot reset storage if it contains symbolic addresses" - resetStore s = s in vm & #env % #contracts .~ initState & #tx % #txReversion .~ preState - & #env % #storage %~ resetStore - & #env % #origStorage %~ resetConcreteStore diff --git a/src/EVM/Traversals.hs b/src/EVM/Traversals.hs --- a/src/EVM/Traversals.hs +++ b/src/EVM/Traversals.hs @@ -7,6 +7,8 @@ import Prelude hiding (LT, GT) import Control.Monad.Identity +import qualified Data.Map.Strict as Map +import Data.List (foldl') import EVM.Types @@ -26,26 +28,28 @@ POr a b -> go a <> go b PImpl a b -> go a <> go b -foldTrace :: forall b . Monoid b => (forall a . Expr a -> b) -> b -> Trace -> b -foldTrace f acc t = acc <> (go t) - where - go :: Trace -> b - go (Trace _ _ d) = case d of - EventTrace a b c -> foldExpr f mempty a <> foldExpr f mempty b <> (foldl (foldExpr f) mempty c) - FrameTrace a -> go' a - ErrorTrace _ -> mempty - EntryTrace _ -> mempty - ReturnTrace a b -> foldExpr f mempty a <> go' b - - go' :: FrameContext -> b - go' = \case - CreationContext _ b _ _ -> foldExpr f mempty b - CallContext _ _ _ _ e _ g (_, h) _ -> foldExpr f mempty e <> foldExpr f mempty g <> foldExpr f mempty h - -foldTraces :: forall b . Monoid b => (forall a . Expr a -> b) -> b -> Traces -> b -foldTraces f acc (Traces a _) = acc <> foldl (foldl (foldTrace f)) mempty a +foldEContract :: forall b . Monoid b => (forall a . Expr a -> b) -> b -> Expr EContract -> b +foldEContract f _ g@(GVar _) = f g +foldEContract f acc (C code storage balance _) + = acc + <> foldCode f code + <> foldExpr f mempty storage + <> foldExpr f mempty balance +foldContract :: forall b . Monoid b => (forall a . Expr a -> b) -> b -> Contract -> b +foldContract f acc c + = acc + <> foldCode f c.code + <> foldExpr f mempty c.storage + <> foldExpr f mempty c.origStorage + <> foldExpr f mempty c.balance +foldCode :: forall b . Monoid b => (forall a . Expr a -> b) -> ContractCode -> b +foldCode f = \case + RuntimeCode (ConcreteRuntimeCode _) -> mempty + RuntimeCode (SymbolicRuntimeCode c) -> foldl' (foldExpr f) mempty c + InitCode _ buf -> foldExpr f mempty buf + UnknownCode addr -> foldExpr f mempty addr -- | Recursively folds a given function over a given expression -- Recursion schemes do this & a lot more, but defining them over GADT's isn't worth the hassle @@ -62,6 +66,10 @@ e@(Var _) -> f e e@(GVar _) -> f e + -- contracts + + e@(C {}) -> foldEContract f acc e + -- bytes e@(IndexWord a b) -> f e <> (go a) <> (go b) @@ -86,9 +94,14 @@ -- control flow - e@(Success a b c d) -> f e <> (foldl (foldProp f) mempty a) <> foldTraces f mempty b <> (go c) <> (go d) - e@(Failure a b _) -> f e <> (foldl (foldProp f) mempty a) <> foldTraces f mempty b - e@(Partial a b _) -> f e <> (foldl (foldProp f) mempty a) <> foldTraces f mempty b + e@(Success a _ c d) -> f e + <> foldl (foldProp f) mempty a + <> go c + <> foldl' (foldExpr f) mempty (Map.keys d) + <> foldl' (foldEContract f) mempty d + e@(Failure a _ (Revert c)) -> f e <> (foldl (foldProp f) mempty a) <> go c + e@(Failure a _ _) -> f e <> (foldl (foldProp f) mempty a) + e@(Partial a _ _) -> f e <> (foldl (foldProp f) mempty a) e@(ITE a b c) -> f e <> (go a) <> (go b) <> (go c) -- integers @@ -145,89 +158,36 @@ e@(BaseFee) -> f e e@(BlockHash a) -> f e <> (go a) + -- tx context + + e@(TxValue) -> f e + -- frame context - e@(Caller _) -> f e - e@(CallValue _) -> f e - e@(Address _) -> f e - e@(SelfBalance _ _) -> f e e@(Gas _ _) -> f e e@(Balance {}) -> f e -- code e@(CodeSize a) -> f e <> (go a) - e@(ExtCodeHash a) -> f e <> (go a) + e@(CodeHash a) -> f e <> (go a) -- logs e@(LogEntry a b c) -> f e <> (go a) <> (go b) <> (foldl (<>) mempty (fmap f c)) - -- Contract Creation - - e@(Create a b c d g h) - -> f e - <> (go a) - <> (go b) - <> (go c) - <> (go d) - <> (foldl (<>) mempty (fmap go g)) - <> (go h) - e@(Create2 a b c d g h i) - -> f e - <> (go a) - <> (go b) - <> (go c) - <> (go d) - <> (go g) - <> (foldl (<>) mempty (fmap go h)) - <> (go i) - - -- Calls - - e@(Call a b c d g h i j k) - -> f e - <> (go a) - <> (maybe mempty (go) b) - <> (go c) - <> (go d) - <> (go g) - <> (go h) - <> (go i) - <> (foldl (<>) mempty (fmap go j)) - <> (go k) - - e@(CallCode a b c d g h i j k) - -> f e - <> (go a) - <> (go b) - <> (go c) - <> (go d) - <> (go g) - <> (go h) - <> (go i) - <> (foldl (<>) mempty (fmap go j)) - <> (go k) + -- storage - e@(DelegeateCall a b c d g h i j k) - -> f e - <> (go a) - <> (go b) - <> (go c) - <> (go d) - <> (go g) - <> (go h) - <> (go i) - <> (foldl (<>) mempty (fmap go j)) - <> (go k) + e@(LitAddr _) -> f e + e@(WAddr a) -> f e <> go a + e@(SymAddr _) -> f e -- storage - e@(EmptyStore) -> f e e@(ConcreteStore _) -> f e - e@(AbstractStore) -> f e - e@(SLoad a b c) -> f e <> (go a) <> (go b) <> (go c) - e@(SStore a b c d) -> f e <> (go a) <> (go b) <> (go c) <> (go d) + e@(AbstractStore _) -> f e + e@(SLoad a b) -> f e <> (go a) <> (go b) + e@(SStore a b c) -> f e <> (go a) <> (go b) <> (go c) -- buffers @@ -260,28 +220,22 @@ POr a b -> POr (mapProp f a) (mapProp f b) PImpl a b -> PImpl (mapProp f a) (mapProp f b) -mapTrace :: (forall a . Expr a -> Expr a) -> Trace -> Trace -mapTrace f (Trace x y z) = Trace x y (go z) - where - go :: TraceData -> TraceData - go = \case - EventTrace a b c -> EventTrace (f a) (f b) (fmap (mapExpr f) c) - FrameTrace a -> FrameTrace (go' a) - ErrorTrace a -> ErrorTrace a - EntryTrace a -> EntryTrace a - ReturnTrace a b -> ReturnTrace (f a) (go' b) - - go' :: FrameContext -> FrameContext - go' = \case - CreationContext a b c d -> CreationContext a (f b) c d - CallContext a b c d e g h (i,j) k -> CallContext a b c d (f e) g (f h) (i,f j) k +mapProp' :: (Prop -> Prop) -> Prop -> Prop +mapProp' f = \case + PBool b -> f $ PBool b + PEq a b -> f $ PEq a b + PLT a b -> f $ PLT a b + PGT a b -> f $ PGT a b + PLEq a b -> f $ PLEq a b + PGEq a b -> f $ PGEq a b + PNeg a -> f $ PNeg (mapProp' f a) + PAnd a b -> f $ PAnd (mapProp' f a) (mapProp' f b) + POr a b -> f $ POr (mapProp' f a) (mapProp' f b) + PImpl a b -> f $ PImpl (mapProp' f a) (mapProp' f b) --- | Recursively applies a given function to every node in a given expr instance --- Recursion schemes do this & a lot more, but defining them over GADT's isn't worth the hassle mapExpr :: (forall a . Expr a -> Expr a) -> Expr b -> Expr b mapExpr f expr = runIdentity (mapExprM (Identity . f) expr) - mapExprM :: Monad m => (forall a . Expr a -> m (Expr a)) -> Expr b -> m (Expr b) mapExprM f expr = case expr of @@ -292,6 +246,18 @@ Var a -> f (Var a) GVar s -> f (GVar s) + -- addresses + + c@(C {}) -> mapEContractM f c + + -- addresses + + LitAddr a -> f (LitAddr a) + SymAddr a -> f (SymAddr a) + WAddr a -> do + a' <- mapExprM f a + f (WAddr a') + -- bytes IndexWord a b -> do @@ -348,19 +314,21 @@ Failure a b c -> do a' <- mapM (mapPropM f) a - b' <- mapTracesM f b - f (Failure a' b' c) + f (Failure a' b c) Partial a b c -> do a' <- mapM (mapPropM f) a - b' <- mapTracesM f b - f (Partial a' b' c) + f (Partial a' b c) Success a b c d -> do a' <- mapM (mapPropM f) a - b' <- mapTracesM f b c' <- mapExprM f c - d' <- mapExprM f d - f (Success a' b' c' d') - + d' <- do + let x = Map.toList d + x' <- forM x $ \(k,v) -> do + k' <- f k + v' <- mapEContractM f v + pure (k',v') + pure $ Map.fromList x' + f (Success a' b c' d') ITE a b c -> do a' <- mapExprM f a b' <- mapExprM f b @@ -513,25 +481,25 @@ a' <- mapExprM f a f (BlockHash a') + -- tx context + + TxValue -> f TxValue + -- frame context - Caller a -> f (Caller a) - CallValue a -> f (CallValue a) - Address a -> f (Address a) - SelfBalance a b -> f (SelfBalance a b) Gas a b -> f (Gas a b) - Balance a b c -> do - c' <- mapExprM f c - f (Balance a b c') + Balance a -> do + a' <- mapExprM f a + f (Balance a') -- code CodeSize a -> do a' <- mapExprM f a f (CodeSize a') - ExtCodeHash a -> do + CodeHash a -> do a' <- mapExprM f a - f (ExtCodeHash a') + f (CodeHash a') -- logs @@ -541,78 +509,19 @@ c' <- mapM (mapExprM f) c f (LogEntry a' b' c') - -- Contract Creation - - Create a b c d e g -> do - a' <- mapExprM f a - b' <- mapExprM f b - c' <- mapExprM f c - d' <- mapExprM f d - e' <- mapM (mapExprM f) e - g' <- mapExprM f g - f (Create a' b' c' d' e' g') - Create2 a b c d e g h -> do - a' <- mapExprM f a - b' <- mapExprM f b - c' <- mapExprM f c - d' <- mapExprM f d - e' <- mapExprM f e - g' <- mapM (mapExprM f) g - h' <- mapExprM f h - f (Create2 a' b' c' d' e' g' h') - - -- Calls - - Call a b c d e g h i j -> do - a' <- mapExprM f a - b' <- mapM (mapExprM f) b - c' <- mapExprM f c - d' <- mapExprM f d - e' <- mapExprM f e - g' <- mapExprM f g - h' <- mapExprM f h - i' <- mapM (mapExprM f) i - j' <- mapExprM f j - f (Call a' b' c' d' e' g' h' i' j') - CallCode a b c d e g h i j -> do - a' <- mapExprM f a - b' <- mapExprM f b - c' <- mapExprM f c - d' <- mapExprM f d - e' <- mapExprM f e - g' <- mapExprM f g - h' <- mapExprM f h - i' <- mapM (mapExprM f) i - j' <- mapExprM f j - f (CallCode a' b' c' d' e' g' h' i' j') - DelegeateCall a b c d e g h i j -> do - a' <- mapExprM f a - b' <- mapExprM f b - c' <- mapExprM f c - d' <- mapExprM f d - e' <- mapExprM f e - g' <- mapExprM f g - h' <- mapExprM f h - i' <- mapM (mapExprM f) i - j' <- mapExprM f j - f (DelegeateCall a' b' c' d' e' g' h' i' j') - -- storage - EmptyStore -> f EmptyStore - ConcreteStore a -> f (ConcreteStore a) - AbstractStore -> f AbstractStore - SLoad a b c -> do + ConcreteStore b -> f (ConcreteStore b) + AbstractStore a -> f (AbstractStore a) + SLoad a b -> do a' <- mapExprM f a b' <- mapExprM f b - c' <- mapExprM f c - f (SLoad a' b' c') - SStore a b c d -> do + f (SLoad a' b') + SStore a b c -> do a' <- mapExprM f a b' <- mapExprM f b c' <- mapExprM f c - d' <- mapExprM f d - f (SStore a' b' c' d') + f (SStore a' b' c') -- buffers @@ -651,7 +560,6 @@ a' <- mapExprM f a f (BufLength a') - mapPropM :: Monad m => (forall a . Expr a -> m (Expr a)) -> Prop -> m Prop mapPropM f = \case PBool b -> pure $ PBool b @@ -691,48 +599,38 @@ b' <- mapPropM f b pure $ PImpl a' b' -mapTracesM :: forall m . Monad m => (forall a . Expr a -> m (Expr a)) -> Traces -> m Traces -mapTracesM f (Traces a b) = do - a' <- mapM (mapM (mapTraceM f)) a - pure $ Traces a' b -mapTraceM :: forall m . Monad m => (forall a . Expr a -> m (Expr a)) -> Trace -> m Trace -mapTraceM f (Trace x y z) = do - z' <- go z - pure $ Trace x y z' - where - go :: TraceData -> m TraceData - go = \case - EventTrace a b c -> do - a' <- mapExprM f a - b' <- mapExprM f b - c' <- mapM (mapExprM f) c - pure $ EventTrace a' b' c' - FrameTrace a -> do - a' <- go' a - pure $ FrameTrace a' - ReturnTrace a b -> do - a' <- mapExprM f a - b' <- go' b - pure $ ReturnTrace a' b' - a -> pure a +mapEContractM :: Monad m => (forall a . Expr a -> m (Expr a)) -> Expr EContract -> m (Expr EContract) +mapEContractM _ g@(GVar _) = pure g +mapEContractM f (C code storage balance nonce) = do + code' <- mapCodeM f code + storage' <- mapExprM f storage + balance' <- mapExprM f balance + pure $ C code' storage' balance' nonce - go' :: FrameContext -> m FrameContext - go' = \case - CreationContext a b c d -> do - b' <- mapExprM f b - pure $ CreationContext a b' c d - CallContext a b c d e g h (i,j) k -> do - e' <- mapExprM f e - h' <- mapExprM f h - j' <- mapExprM f j - pure $ CallContext a b c d e' g h' (i,j') k +mapContractM :: Monad m => (forall a . Expr a -> m (Expr a)) -> Contract -> m (Contract) +mapContractM f c = do + code' <- mapCodeM f c.code + storage' <- mapExprM f c.storage + origStorage' <- mapExprM f c.origStorage + balance' <- mapExprM f c.balance + pure $ c { code = code', storage = storage', origStorage = origStorage', balance = balance' } +mapCodeM :: Monad m => (forall a . Expr a -> m (Expr a)) -> ContractCode -> m (ContractCode) +mapCodeM f = \case + UnknownCode a -> fmap UnknownCode (f a) + c@(RuntimeCode (ConcreteRuntimeCode _)) -> pure c + RuntimeCode (SymbolicRuntimeCode c) -> do + c' <- mapM (mapExprM f) c + pure . RuntimeCode $ SymbolicRuntimeCode c' + InitCode bs buf -> do + buf' <- mapExprM f buf + pure $ InitCode bs buf' + -- | Generic operations over AST terms class TraversableTerm a where mapTerm :: (forall b. Expr b -> Expr b) -> a -> a foldTerm :: forall c. Monoid c => (forall b. Expr b -> c) -> c -> a -> c - instance TraversableTerm (Expr a) where mapTerm = mapExpr diff --git a/src/EVM/Types.hs b/src/EVM/Types.hs --- a/src/EVM/Types.hs +++ b/src/EVM/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} @@ -8,13 +9,15 @@ import GHC.Stack (HasCallStack, prettyCallStack, callStack) import Control.Arrow ((>>>)) -import Control.Monad.State.Strict (State, mzero) +import Control.Monad.ST (ST) +import Control.Monad.State.Strict (StateT, mzero) import Crypto.Hash (hash, Keccak_256, Digest) import Data.Aeson import Data.Aeson qualified as JSON import Data.Aeson.Types qualified as JSON import Data.Bifunctor (first) import Data.Bits (Bits, FiniteBits, shiftR, shift, shiftL, (.&.), (.|.), toIntegralSized) +import Data.Binary qualified as Binary import Data.ByteArray qualified as BA import Data.Char import Data.List (foldl') @@ -41,10 +44,10 @@ import Data.Tree.Zipper qualified as Zipper import Data.Vector qualified as V import Data.Vector.Storable qualified as SV +import Data.Vector.Unboxed.Mutable (STVector) import Numeric (readHex, showHex) import Options.Generic import Optics.TH -import EVM.Hexdump (paddedShowHex) import EVM.FeeSchedule (FeeSchedule (..)) import Text.Regex.TDFA qualified as Regex @@ -59,6 +62,14 @@ mkUnpackedDoubleWord "Word512" ''Word256 "Int512" ''Int256 ''Word256 [''Typeable, ''Data, ''Generic] + + +-- Conversions ------------------------------------------------------------------------------------- + + +-- We ignore hlint to supress the warnings about `fromIntegral` and friends here +#ifndef __HLINT__ + instance From Addr Integer where from = fromIntegral instance From Addr W256 where from = fromIntegral instance From Int256 Integer where from = fromIntegral @@ -68,7 +79,9 @@ instance From Word8 Word256 where from = fromIntegral instance From Word32 W256 where from = fromIntegral instance From Word32 Word256 where from = fromIntegral +instance From Word32 ByteString where from = toStrict . Binary.encode instance From Word64 W256 where from = fromIntegral +instance From W64 W256 where from = fromIntegral instance From Word256 Integer where from = fromIntegral instance From Word256 W256 where from = fromIntegral @@ -76,6 +89,7 @@ instance TryFrom Int Word256 where tryFrom = maybeTryFrom toIntegralSized instance TryFrom Int256 W256 where tryFrom = maybeTryFrom toIntegralSized instance TryFrom Integer W256 where tryFrom = maybeTryFrom toIntegralSized +instance TryFrom Integer Addr where tryFrom = maybeTryFrom toIntegralSized -- TODO: hevm relies on this behavior instance TryFrom W256 Addr where tryFrom = Right . fromIntegral instance TryFrom W256 FunctionSelector where tryFrom = maybeTryFrom toIntegralSized @@ -86,6 +100,7 @@ instance TryFrom W256 Word32 where tryFrom = maybeTryFrom toIntegralSized -- TODO: hevm relies on this behavior instance TryFrom W256 Word64 where tryFrom = Right . fromIntegral +instance TryFrom W256 W64 where tryFrom = Right . fromIntegral instance TryFrom Word160 Word8 where tryFrom = maybeTryFrom toIntegralSized instance TryFrom Word256 Int where tryFrom = maybeTryFrom toIntegralSized instance TryFrom Word256 Int256 where tryFrom = maybeTryFrom toIntegralSized @@ -93,19 +108,27 @@ instance TryFrom Word256 Word32 where tryFrom = maybeTryFrom toIntegralSized instance TryFrom Word512 W256 where tryFrom = maybeTryFrom toIntegralSized +truncateToAddr :: W256 -> Addr +truncateToAddr = fromIntegral + +#endif + + -- Symbolic IR ------------------------------------------------------------------------------------- + -- phantom type tags for AST construction data EType = Buf | Storage | Log | EWord + | EAddr + | EContract | Byte | End deriving (Typeable) - -- Variables refering to a global environment data GVar (a :: EType) where BufVar :: Int -> GVar Buf @@ -168,8 +191,11 @@ -- identifiers + -- | Literal words Lit :: {-# UNPACK #-} !W256 -> Expr EWord + -- | Variables Var :: Text -> Expr EWord + -- | variables introduced during the CSE pass GVar :: GVar a -> Expr a -- bytes @@ -192,7 +218,7 @@ Partial :: [Prop] -> Traces -> PartialExec -> Expr End Failure :: [Prop] -> Traces -> EvmError -> Expr End - Success :: [Prop] -> Traces -> Expr Buf -> Expr Storage -> Expr End + Success :: [Prop] -> Traces -> Expr Buf -> Map (Expr EAddr) (Expr EContract) -> Expr End ITE :: Expr EWord -> Expr End -> Expr End -> Expr End -- integers @@ -249,25 +275,13 @@ ChainId :: Expr EWord BaseFee :: Expr EWord - -- frame context - - CallValue :: Int -- frame idx - -> Expr EWord - - Caller :: Int -- frame idx - -> Expr EWord + -- tx context - Address :: Int -- frame idx - -> Expr EWord + TxValue :: Expr EWord - Balance :: Int -- frame idx - -> Int -- PC (in case we're checking the current contract) - -> Expr EWord -- address - -> Expr EWord + -- frame context - SelfBalance :: Int -- frame idx - -> Int -- PC - -> Expr EWord + Balance :: Expr EAddr -> Expr EWord Gas :: Int -- frame idx -> Int -- PC @@ -275,10 +289,10 @@ -- code - CodeSize :: Expr EWord -- address + CodeSize :: Expr EAddr -- address -> Expr EWord -- size - ExtCodeHash :: Expr EWord -- address + CodeHash :: Expr EAddr -- address -> Expr EWord -- size -- logs @@ -288,73 +302,37 @@ -> [Expr EWord] -- topics -> Expr Log - -- Contract Creation - Create :: Expr EWord -- value - -> Expr EWord -- offset - -> Expr EWord -- size - -> Expr Buf -- memory - -> [Expr Log] -- logs - -> Expr Storage -- storage - -> Expr EWord -- address - - Create2 :: Expr EWord -- value - -> Expr EWord -- offset - -> Expr EWord -- size - -> Expr EWord -- salt - -> Expr Buf -- memory - -> [Expr Log] -- logs - -> Expr Storage -- storage - -> Expr EWord -- address - - -- Calls + -- Contract - Call :: Expr EWord -- gas - -> Maybe (Expr EWord) -- target - -> Expr EWord -- value - -> Expr EWord -- args offset - -> Expr EWord -- args size - -> Expr EWord -- ret offset - -> Expr EWord -- ret size - -> [Expr Log] -- logs - -> Expr Storage -- storage - -> Expr EWord -- success + -- A restricted view of a contract that does not include extraneous metadata + -- from the full constructor defined in the VM state + C :: + { code :: ContractCode + , storage :: Expr Storage + , balance :: Expr EWord + , nonce :: Maybe W64 + } -> Expr EContract - CallCode :: Expr EWord -- gas - -> Expr EWord -- address - -> Expr EWord -- value - -> Expr EWord -- args offset - -> Expr EWord -- args size - -> Expr EWord -- ret offset - -> Expr EWord -- ret size - -> [Expr Log] -- logs - -> Expr Storage -- storage - -> Expr EWord -- success + -- addresses - DelegeateCall :: Expr EWord -- gas - -> Expr EWord -- address - -> Expr EWord -- value - -> Expr EWord -- args offset - -> Expr EWord -- args size - -> Expr EWord -- ret offset - -> Expr EWord -- ret size - -> [Expr Log] -- logs - -> Expr Storage -- storage - -> Expr EWord -- success + -- Symbolic addresses are identified with an int. It is important that + -- semantic equality is the same as syntactic equality here. Additionally all + -- SAddr's in a given expression should be constrained to differ from any LitAddr's + SymAddr :: Text -> Expr EAddr + LitAddr :: Addr -> Expr EAddr + WAddr :: Expr EAddr -> Expr EWord -- storage - EmptyStore :: Expr Storage - ConcreteStore :: Map W256 (Map W256 W256) -> Expr Storage - AbstractStore :: Expr Storage + ConcreteStore :: (Map W256 W256) -> Expr Storage + AbstractStore :: Expr EAddr -> Expr Storage - SLoad :: Expr EWord -- address - -> Expr EWord -- index + SLoad :: Expr EWord -- key -> Expr Storage -- storage -> Expr EWord -- result - SStore :: Expr EWord -- address - -> Expr EWord -- index + SStore :: Expr EWord -- key -> Expr EWord -- value -> Expr Storage -- old storage -> Expr Storage -- new storae @@ -514,12 +492,17 @@ _ <= _ = False +isPBool :: Prop -> Bool +isPBool (PBool _) = True +isPBool _ = False + + -- Errors ------------------------------------------------------------------------------------------ -- | Core EVM Error Types data EvmError - = BalanceTooLow W256 W256 + = BalanceTooLow (Expr EWord) (Expr EWord) | UnrecognizedOpcode Word8 | SelfDestruction | StackUnderrun @@ -542,35 +525,36 @@ -- | Sometimes we can only partially execute a given program data PartialExec - = UnexpectedSymbolicArg { pc :: Int, msg :: String, args :: [SomeExpr] } - | MaxIterationsReached { pc :: Int, addr :: Addr } + = UnexpectedSymbolicArg { pc :: Int, msg :: String, args :: [SomeExpr] } + | MaxIterationsReached { pc :: Int, addr :: Expr EAddr } + | JumpIntoSymbolicCode { pc :: Int, jumpDst :: Int } deriving (Show, Eq, Ord) -- | Effect types used by the vm implementation for side effects & control flow -data Effect - = Query Query - | Choose Choose -deriving instance Show Effect +data Effect s + = Query (Query s) + | Choose (Choose s) +deriving instance Show (Effect s) -- | Queries halt execution until resolved through RPC calls or SMT queries -data Query where - PleaseFetchContract :: Addr -> (Contract -> EVM ()) -> Query - PleaseFetchSlot :: Addr -> W256 -> (W256 -> EVM ()) -> Query - PleaseAskSMT :: Expr EWord -> [Prop] -> (BranchCondition -> EVM ()) -> Query - PleaseDoFFI :: [String] -> (ByteString -> EVM ()) -> Query +data Query s where + PleaseFetchContract :: Addr -> BaseState -> (Contract -> EVM s ()) -> Query s + PleaseFetchSlot :: Addr -> W256 -> (W256 -> EVM s ()) -> Query s + PleaseAskSMT :: Expr EWord -> [Prop] -> (BranchCondition -> EVM s ()) -> Query s + PleaseDoFFI :: [String] -> (ByteString -> EVM s ()) -> Query s -- | Execution could proceed down one of two branches -data Choose where - PleaseChoosePath :: Expr EWord -> (Bool -> EVM ()) -> Choose +data Choose s where + PleaseChoosePath :: Expr EWord -> (Bool -> EVM s ()) -> Choose s -- | The possible return values of a SMT query data BranchCondition = Case Bool | Unknown deriving Show -instance Show Query where +instance Show (Query s) where showsPrec _ = \case - PleaseFetchContract addr _ -> - (("") ++) + PleaseFetchContract addr base _ -> + (("") ++) PleaseFetchSlot addr slot _ -> ((" ((" ((" b = Cache - { fetchedContracts = Map.unionWith unifyCachedContract a.fetchedContracts b.fetchedContracts - , fetchedStorage = Map.unionWith unifyCachedStorage a.fetchedStorage b.fetchedStorage + { fetched = Map.unionWith unifyCachedContract a.fetched b.fetched , path = mappend a.path b.path } instance Monoid Cache where - mempty = Cache { fetchedContracts = mempty - , fetchedStorage = mempty + mempty = Cache { fetched = mempty , path = mempty } -unifyCachedStorage :: Map W256 W256 -> Map W256 W256 -> Map W256 W256 -unifyCachedStorage _ _ = undefined - -- only intended for use in Cache merges, where we expect -- everything to be Concrete unifyCachedContract :: Contract -> Contract -> Contract -unifyCachedContract _ _ = undefined - {- -unifyCachedContract a b = a & set storage merged - where merged = case (view storage a, view storage b) of +unifyCachedContract a b = a { storage = merged } + where merged = case (a.storage, b.storage) of (ConcreteStore sa, ConcreteStore sb) -> ConcreteStore (mappend sa sb) - _ -> - view storage a - -} + _ -> a.storage -- Bytecode Representations ------------------------------------------------------------------------ @@ -809,9 +799,10 @@ hopefully we do not have to deal with dynamic immutable before we get a real data section... -} data ContractCode - = InitCode ByteString (Expr Buf) -- ^ "Constructor" code, during contract creation - | RuntimeCode RuntimeCode -- ^ "Instance" code, after contract creation - deriving (Show, Ord) + = UnknownCode (Expr EAddr) -- ^ Fully abstract code, keyed on an address to give consistent results for e.g. extcodehash + | InitCode ByteString (Expr Buf) -- ^ "Constructor" code, during contract creation + | RuntimeCode RuntimeCode -- ^ "Instance" code, after contract creation + deriving (Show, Eq, Ord) -- | We have two variants here to optimize the fully concrete case. -- ConcreteRuntimeCode just wraps a ByteString @@ -821,13 +812,6 @@ | SymbolicRuntimeCode (V.Vector (Expr Byte)) deriving (Show, Eq, Ord) --- runtime err when used for symbolic code -instance Eq ContractCode where - InitCode a b == InitCode c d = a == c && b == d - RuntimeCode x == RuntimeCode y = x == y - _ == _ = False - - -- Execution Traces -------------------------------------------------------------------------------- @@ -849,7 +833,7 @@ -- | Wrapper type containing vm traces and the context needed to pretty print them properly data Traces = Traces { traces :: Forest Trace - , contracts :: Map Addr Contract + , contracts :: Map (Expr EAddr) Contract } deriving (Eq, Ord, Show, Generic) @@ -865,18 +849,19 @@ -- | A specification for an initial VM state data VMOpts = VMOpts { contract :: Contract + , otherContracts :: [(Expr EAddr, Contract)] , calldata :: (Expr Buf, [Prop]) - , initialStorage :: Expr Storage + , baseState :: BaseState , value :: Expr EWord , priorityFee :: W256 - , address :: Addr - , caller :: Expr EWord - , origin :: Addr + , address :: Expr EAddr + , caller :: Expr EAddr + , origin :: Expr EAddr , gas :: Word64 , gaslimit :: Word64 , number :: W256 , timestamp :: Expr EWord - , coinbase :: Addr + , coinbase :: Expr EAddr , prevRandao :: W256 , maxCodeSize :: W256 , blockGaslimit :: Word64 @@ -885,7 +870,7 @@ , schedule :: FeeSchedule Word64 , chainId :: W256 , create :: Bool - , txAccessList :: Map Addr [W256] + , txAccessList :: Map (Expr EAddr) [W256] , allowFFI :: Bool } deriving Show @@ -1063,7 +1048,6 @@ ( Num, Integral, Real, Ord, Generic , Bits , FiniteBits, Enum, Eq , Bounded ) -instance JSON.FromJSON W64 instance Read W64 where readsPrec _ "0x" = [(0, "")] @@ -1075,6 +1059,14 @@ instance JSON.ToJSON W64 where toJSON x = JSON.String $ T.pack $ show x +instance FromJSON W64 where + parseJSON v = do + s <- T.unpack <$> parseJSON v + case reads s of + [(x, "")] -> return x + _ -> fail $ "invalid hex word (" ++ s ++ ")" + + word64Field :: JSON.Object -> Key -> JSON.Parser Word64 word64Field x f = ((readNull 0) . T.unpack) <$> (x .: f) @@ -1168,8 +1160,18 @@ maybeLitWord :: Expr EWord -> Maybe W256 maybeLitWord (Lit w) = Just w +maybeLitWord (WAddr (LitAddr w)) = Just (into w) maybeLitWord _ = Nothing +maybeLitAddr :: Expr EAddr -> Maybe Addr +maybeLitAddr (LitAddr a) = Just a +maybeLitAddr _ = Nothing + +maybeConcreteStore :: Expr Storage -> Maybe (Map W256 W256) +maybeConcreteStore (ConcreteStore s) = Just s +maybeConcreteStore _ = Nothing + + word256 :: ByteString -> Word256 word256 xs | BS.length xs == 1 = -- optimize one byte pushes @@ -1269,8 +1271,9 @@ -- Utils ------------------------------------------------------------------------------------------- +{- HLINT ignore internalError -} internalError:: HasCallStack => [Char] -> a -internalError m = error $ "Internal error: " ++ m ++ " -- " ++ (prettyCallStack callStack) +internalError m = error $ "Internal Error: " ++ m ++ " -- " ++ (prettyCallStack callStack) concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = fmap concat (mapM f xs) @@ -1308,6 +1311,15 @@ Right s -> "\"" <> T.unpack s <> "\"" Left _ -> "❮utf8 decode failed❯: " <> (show $ ByteStringS bs) +-- |'paddedShowHex' displays a number in hexidecimal and pads the number +-- with 0 so that it has a minimum length of @w@. +paddedShowHex :: (Show a, Integral a) => Int -> a -> String +paddedShowHex w n = pad ++ str + where + str = showHex n "" + pad = replicate (w - length str) '0' + + -- Optics ------------------------------------------------------------------------------------------ @@ -1323,3 +1335,4 @@ makeFieldLabelsNoPrefix ''Contract makeFieldLabelsNoPrefix ''Env makeFieldLabelsNoPrefix ''Block +makeFieldLabelsNoPrefix ''RuntimeConfig diff --git a/src/EVM/UnitTest.hs b/src/EVM/UnitTest.hs --- a/src/EVM/UnitTest.hs +++ b/src/EVM/UnitTest.hs @@ -3,99 +3,72 @@ module EVM.UnitTest where -import Prelude hiding (Word) - import EVM 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 (readStorage') 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.FeeSchedule (feeSchedule) import EVM.Fetch qualified as Fetch import EVM.Format import EVM.Solidity -import EVM.SymExec (defaultVeriOpts, symCalldata, verify, isQed, extractCex, runExpr, subModel, VeriOpts(..)) +import EVM.SymExec (defaultVeriOpts, symCalldata, verify, isQed, extractCex, runExpr, prettyCalldata, panicMsg, VeriOpts(..), flattenExpr) import EVM.Types import EVM.Transaction (initTx) -import EVM.RLP -import EVM.Stepper (Stepper, interpret) +import EVM.Stepper (Stepper) import EVM.Stepper qualified as Stepper -import Control.Monad.Operational qualified as Operational +import Control.Monad.ST (RealWorld, ST, stToIO) import Optics.Core hiding (elements) import Optics.State import Optics.State.Operators -import Optics.Zoom -import Control.Monad.Par.Class (spawn_) -import Control.Monad.Par.Class qualified as Par -import Control.Monad.Par.IO (runParIO) 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.Either (isRight, rights, lefts) 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 Data.MultiSet qualified as MultiSet -import Data.Set (Set) -import Data.Set qualified as Set +import Data.Maybe 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 Data.Vector qualified as Vector -import Data.Word (Word32, Word64) +import Data.Word (Word64) import GHC.Natural -import System.Environment (lookupEnv) import System.IO (hFlush, stdout) -import Test.QuickCheck hiding (verbose, Success, Failure) -import qualified Test.QuickCheck as QC import Witch (unsafeInto, into) -data UnitTestOptions = UnitTestOptions +data UnitTestOptions s = UnitTestOptions { rpcInfo :: Fetch.RpcInfo , solvers :: SolverGroup , verbose :: Maybe Int , maxIter :: Maybe Integer , askSmtIters :: Integer , smtDebug :: Bool - , maxDepth :: Maybe Int , smtTimeout :: Maybe Natural , solver :: Maybe Text - , covMatch :: Maybe Text , match :: Text - , fuzzRuns :: Int - , replay :: Maybe (Text, BSLazy.ByteString) - , vmModifier :: VM -> VM , dapp :: DappInfo , testParams :: TestVMParams , ffiAllowed :: Bool } data TestVMParams = TestVMParams - { address :: Addr - , caller :: Addr - , origin :: Addr + { address :: Expr EAddr + , caller :: Expr EAddr + , origin :: Expr EAddr , gasCreate :: Word64 , gasCall :: Word64 , baseFee :: W256 , priorityFee :: W256 , balanceCreate :: W256 - , coinbase :: Addr + , coinbase :: Expr EAddr , number :: W256 , timestamp :: W256 , gaslimit :: Word64 @@ -121,7 +94,7 @@ -- | Generate VeriOpts from UnitTestOptions -makeVeriOpts :: UnitTestOptions -> VeriOpts +makeVeriOpts :: UnitTestOptions s -> VeriOpts makeVeriOpts opts = defaultVeriOpts { debug = opts.smtDebug , maxIter = opts.maxIter @@ -130,34 +103,20 @@ } -- | Top level CLI endpoint for hevm test -unitTest :: UnitTestOptions -> Contracts -> Maybe String -> IO Bool -unitTest opts (Contracts cs) cache' = do +unitTest :: UnitTestOptions RealWorld -> Contracts -> IO Bool +unitTest opts (Contracts cs) = do let unitTests = findUnitTests opts.match $ Map.elems cs results <- concatMapM (runUnitTestContract opts cs) unitTests - let (passing, vms) = unzip results - case cache' of - Nothing -> - pure () - Just path -> - -- merge all of the post-vm caches and save into the state - let - evmcache = mconcat [vm.cache | vm <- vms] - in - liftIO $ Git.saveFacts (Git.RepoAt path) (Facts.cacheFacts evmcache) - - pure $ and passing - + pure $ and results -- | Assuming a constructor is loaded, this stepper will run the constructor -- to create the test contract, give it an initial balance, and run `setUp()'. -initializeUnitTest :: UnitTestOptions -> SolcContract -> Stepper () +initializeUnitTest :: UnitTestOptions s -> SolcContract -> Stepper s () initializeUnitTest opts theContract = do let addr = opts.testParams.address Stepper.evm $ do - -- Maybe modify the initial VM, e.g. to load library code - modify opts.vmModifier -- Make a trace entry for running the constructor pushTrace (EntryTrace "constructor") @@ -166,7 +125,7 @@ Stepper.evm $ do -- Give a balance to the test target - #env % #contracts % ix addr % #balance %= (+ opts.testParams.balanceCreate) + #env % #contracts % ix addr % #balance %= (`Expr.add` (Lit opts.testParams.balanceCreate)) -- call setUp(), if it exists, to initialize the test contract let theAbi = theContract.abiMap @@ -183,244 +142,16 @@ Left e -> pushTrace (ErrorTrace e) _ -> popTrace --- | Assuming a test contract is loaded and initialized, this stepper --- will run the specified test method and return whether it succeeded. -runUnitTest :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool -runUnitTest a method args = do - x <- execTestStepper a method args - checkFailures a method x - -execTestStepper :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool -execTestStepper UnitTestOptions { .. } methodName' method = do - -- Set up the call to the test method - Stepper.evm $ do - abiCall testParams (Left (methodName', method)) - pushTrace (EntryTrace methodName') - -- Try running the test method - Stepper.execFully >>= \case - -- If we failed, put the error in the trace. - Left e -> Stepper.evm (pushTrace (ErrorTrace e) >> popTrace) >> pure True - _ -> pure False - -exploreStep :: UnitTestOptions -> ByteString -> Stepper Bool -exploreStep UnitTestOptions{..} bs = do - Stepper.evm $ do - cs <- use (#env % #contracts) - abiCall testParams (Right bs) - let Method _ inputs sig _ _ = fromMaybe (internalError "unknown abi call") $ Map.lookup (unsafeInto $ word $ BS.take 4 bs) dapp.abiMap - types = snd <$> inputs - let ?context = DappContext dapp cs - this <- fromMaybe (internalError "unknown target") <$> (use (#env % #contracts % at testParams.address)) - let name = maybe "" (contractNamePart . (.contractName)) $ lookupCode this.contractcode dapp - pushTrace (EntryTrace (name <> "." <> sig <> "(" <> intercalate "," ((pack . show) <$> types) <> ")" <> showCall types (ConcreteBuf bs))) - -- Try running the test method - Stepper.execFully >>= \case - -- If we failed, put the error in the trace. - Left e -> Stepper.evm (pushTrace (ErrorTrace e) >> popTrace) >> pure True - _ -> pure False - -checkFailures :: UnitTestOptions -> ABIMethod -> Bool -> Stepper Bool -checkFailures UnitTestOptions { .. } method bailed = do - -- Decide whether the test is supposed to fail or succeed - let shouldFail = "testFail" `isPrefixOf` method - if bailed then - pure shouldFail - else do - -- Ask whether any assertions failed - Stepper.evm $ do - popTrace - abiCall testParams $ Left ("failed()", emptyAbi) - res <- Stepper.execFully - case res of - Right (ConcreteBuf r) -> - let failed = case decodeAbiValue AbiBoolType (BSLazy.fromStrict r) of - AbiBool f -> f - _ -> internalError "fix me with better types" - in pure (shouldFail == failed) - c -> internalError $ "unexpected failure code: " <> show c - --- | Randomly generates the calldata arguments and runs the test -fuzzTest :: UnitTestOptions -> Text -> [AbiType] -> VM -> Property -fuzzTest opts@UnitTestOptions{..} sig types vm = forAllShow (genAbiValue (AbiTupleType $ Vector.fromList types)) (show . ByteStringS . encodeAbiValue) - $ \args -> ioProperty $ - EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) vm (runUnitTest opts sig args) - -tick :: Text -> IO () -tick x = Text.putStr x >> hFlush stdout - --- | This is like an unresolved source mapping. -data OpLocation = OpLocation - { srcContract :: Contract - , srcOpIx :: Int - } deriving (Show) - -instance Eq OpLocation where - (==) (OpLocation a b) (OpLocation a' b') = b == b' && a.contractcode == a'.contractcode - -instance Ord OpLocation where - compare (OpLocation a b) (OpLocation a' b') = compare (a.contractcode, b) (a'.contractcode, b') - -srcMapForOpLocation :: DappInfo -> OpLocation -> Maybe SrcMap -srcMapForOpLocation dapp (OpLocation contr opIx) = srcMap dapp contr opIx - -type CoverageState = (VM, MultiSet OpLocation) - -currentOpLocation :: VM -> OpLocation -currentOpLocation vm = - case currentContract vm of - Nothing -> - internalError "why no contract?" - Just c -> - OpLocation - c - (fromMaybe (internalError "op ix") (vmOpIx vm)) - -execWithCoverage :: StateT CoverageState IO VMResult -execWithCoverage = do _ <- runWithCoverage - fromJust <$> use (_1 % #result) - -runWithCoverage :: StateT CoverageState IO VM -runWithCoverage = do - -- This is just like `exec` except for every instruction evaluated, - -- we also increment a counter indexed by the current code location. - vm0 <- use _1 - case vm0.result of - Nothing -> do - vm1 <- zoom _1 (State.state (runState exec1) >> get) - zoom _2 (modify (MultiSet.insert (currentOpLocation vm1))) - runWithCoverage - Just _ -> pure vm0 - - -interpretWithCoverage - :: UnitTestOptions - -> Stepper a - -> StateT CoverageState IO a -interpretWithCoverage opts@UnitTestOptions{..} = - eval . Operational.view - - where - eval - :: Operational.ProgramView Stepper.Action a - -> StateT CoverageState IO a - - eval (Operational.Return x) = - pure x - - eval (action Operational.:>>= k) = - case action of - Stepper.Exec -> - execWithCoverage >>= interpretWithCoverage opts . k - Stepper.Run -> - runWithCoverage >>= interpretWithCoverage opts . k - Stepper.Wait (PleaseAskSMT (Lit c) _ continue) -> - interpretWithCoverage opts (Stepper.evm (continue (Case (c > 0))) >>= k) - Stepper.Wait q -> - do m <- liftIO ((Fetch.oracle solvers rpcInfo) q) - zoom _1 (State.state (runState m)) >> interpretWithCoverage opts (k ()) - Stepper.Ask _ -> - internalError "cannot make choice in this interpreter" - Stepper.IOAct q -> - zoom _1 (StateT (runStateT q)) >>= interpretWithCoverage opts . k - Stepper.EVM m -> - zoom _1 (State.state (runState m)) >>= interpretWithCoverage opts . k - -coverageReport - :: DappInfo - -> MultiSet SrcMap - -> Map FilePath (Vector (Int, ByteString)) -coverageReport dapp cov = - let - sources :: SourceCache - sources = dapp.sources - - allPositions :: Set (FilePath, Int) - allPositions = - ( Set.fromList - . mapMaybe (srcMapCodePos sources) - . toList - $ mconcat - ( dapp.solcByName - & Map.elems - & map (\x -> x.runtimeSrcmap <> x.creationSrcmap) - ) - ) - - srcMapCov :: MultiSet (FilePath, Int) - srcMapCov = MultiSet.mapMaybe (srcMapCodePos sources) cov - - linesByName :: Map FilePath (Vector ByteString) - linesByName = - Map.fromList $ zipWith - (\(name, _) lines' -> (name, lines')) - (Map.elems sources.files) - (Map.elems sources.lines) - - f :: FilePath -> Vector ByteString -> Vector (Int, ByteString) - f name = - Vector.imap - (\i bs -> - let - n = - if Set.member (name, i + 1) allPositions - then MultiSet.occur (name, i + 1) srcMapCov - else -1 - in (n, bs)) - in - Map.mapWithKey f linesByName - -coverageForUnitTestContract - :: UnitTestOptions - -> Map Text SolcContract - -> SourceCache - -> (Text, [(Test, [AbiType])]) - -> IO (MultiSet SrcMap) -coverageForUnitTestContract - opts@(UnitTestOptions {..}) contractMap _ (name, testNames) = do - - -- Look for the wanted contract by name from the Solidity info - case Map.lookup name contractMap of - Nothing -> - -- Fail if there's no such contract - internalError $ "Contract " ++ unpack name ++ " not found" - - Just theContract -> do - -- Construct the initial VM and begin the contract's constructor - let vm0 = initialUnitTestVm opts theContract - (vm1, cov1) <- - execStateT - (interpretWithCoverage opts - (Stepper.enter name >> initializeUnitTest opts theContract)) - (vm0, mempty) - - -- Define the thread spawner for test cases - let - runOne' (test, _) = spawn_ . liftIO $ do - (_, (_, cov)) <- - runStateT - (interpretWithCoverage opts (runUnitTest opts (extractSig test) emptyAbi)) - (vm1, mempty) - pure cov - -- Run all the test cases in parallel and gather their coverages - covs <- - runParIO (mapM runOne' testNames >>= mapM Par.get) - - -- Sum up all the coverage counts - let cov2 = MultiSet.unions (cov1 : covs) - - pure (MultiSet.mapMaybe (srcMapForOpLocation dapp) cov2) - runUnitTestContract - :: UnitTestOptions + :: UnitTestOptions RealWorld -> Map Text SolcContract - -> (Text, [(Test, [AbiType])]) - -> IO [(Bool, VM)] + -> (Text, [Sig]) + -> IO [Bool] runUnitTestContract opts@(UnitTestOptions {..}) contractMap (name, testSigs) = do -- Print a header - liftIO $ putStrLn $ "Running " ++ show (length testSigs) ++ " tests for " - ++ unpack name + putStrLn $ "Running " ++ show (length testSigs) ++ " tests for " ++ unpack name -- Look for the wanted contract by name from the Solidity info case Map.lookup name contractMap of @@ -430,8 +161,8 @@ Just theContract -> do -- Construct the initial VM and begin the contract's constructor - let vm0 = initialUnitTestVm opts theContract - vm1 <- liftIO $ EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) vm0 $ do + vm0 <- stToIO $ initialUnitTestVm opts theContract + vm1 <- Stepper.interpret (Fetch.oracle solvers rpcInfo) vm0 $ do Stepper.enter name initializeUnitTest opts theContract Stepper.evm get @@ -440,320 +171,86 @@ Just (VMFailure _) -> liftIO $ do Text.putStrLn "\x1b[31m[BAIL]\x1b[0m setUp() " tick "\n" - tick (Data.Text.pack $ show $ failOutput vm1 opts "setUp()") - pure [(False, vm1)] + tick $ failOutput vm1 opts "setUp()" + pure [False] Just (VMSuccess _) -> do let - runCache :: ([(Either Text Text, VM)], VM) -> (Test, [AbiType]) - -> IO ([(Either Text Text, VM)], VM) - runCache (results, vm) (test, types) = do - (t, r, vm') <- runTest opts vm (test, types) - liftIO $ Text.putStrLn t - let vmCached = vm { cache = vm'.cache } - pure (((r, vm'): results), vmCached) - - -- Run all the test cases and print their status updates, - -- accumulating the vm cache throughout - (details, _) <- foldM runCache ([], vm1) testSigs + -- Run all the test cases and print their status + details <- forM testSigs $ \s -> do + (result, detail) <- symRun opts vm1 s + Text.putStrLn result + pure detail - let running = [x | (Right x, _) <- details] - let bailing = [x | (Left x, _) <- details] + let running = rights details + bailing = lefts details - liftIO $ do - tick "\n" - tick (Text.unlines (filter (not . Text.null) running)) - tick (Text.unlines bailing) + tick "\n" + tick (Text.unlines (filter (not . Text.null) running)) + tick (Text.unlines bailing) - pure [(isRight r, vm) | (r, vm) <- details] + pure $ fmap isRight details _ -> internalError "setUp() did not end with a result" -runTest :: UnitTestOptions -> VM -> (Test, [AbiType]) -> IO (Text, Either Text Text, VM) -runTest opts@UnitTestOptions{} vm (ConcreteTest testName, []) = liftIO $ runOne opts vm testName emptyAbi -runTest opts@UnitTestOptions{..} vm (ConcreteTest testName, types) = liftIO $ case replay of - Nothing -> - fuzzRun opts vm testName types - Just (sig, callData) -> - if sig == testName - then runOne opts vm testName $ - decodeAbiValue (AbiTupleType (Vector.fromList types)) callData - else fuzzRun opts vm testName types -runTest opts@UnitTestOptions{..} vm (InvariantTest testName, []) = liftIO $ case replay of - Nothing -> exploreRun opts vm testName [] - Just (sig, cds) -> - if sig == testName - then exploreRun opts vm testName (decodeCalls cds) - else exploreRun opts vm testName [] -runTest _ _ (InvariantTest _, types) = internalError $ "invariant testing with arguments: " <> show types <> " is not implemented (yet!)" -runTest opts vm (SymbolicTest testName, types) = symRun opts vm testName types - -type ExploreTx = (Addr, Addr, ByteString, W256) - -decodeCalls :: BSLazy.ByteString -> [ExploreTx] -decodeCalls b = fromMaybe (internalError "could not decode replay data") $ do - List v <- rlpdecode $ BSLazy.toStrict b - pure $ unList <$> v - where - unList (List [BS caller', BS target, BS cd, BS ts]) = - (unsafeInto (word caller'), unsafeInto (word target), cd, word ts) - unList _ = internalError "fix me with better types" - --- | Runs an invariant test, calls the invariant before execution begins -initialExplorationStepper :: UnitTestOptions -> ABIMethod -> [ExploreTx] -> [Addr] -> Int -> Stepper (Bool, RLP) -initialExplorationStepper opts'' testName replayData targets i = do - let history = List [] - x <- runUnitTest opts'' testName emptyAbi - if x - then explorationStepper opts'' testName replayData targets history i - else pure (False, history) - -explorationStepper :: UnitTestOptions -> ABIMethod -> [ExploreTx] -> [Addr] -> RLP -> Int -> Stepper (Bool, RLP) -explorationStepper _ _ _ _ history 0 = pure (True, history) -explorationStepper opts@UnitTestOptions{..} testName replayData targets (List history) i = do - (caller', target, cd, timestamp') <- - case preview (ix (i - 1)) replayData of - Just v -> pure v - Nothing -> - Stepper.evmIO $ do - vm <- get - let cs = vm.env.contracts - noCode c = case c.contractcode of - RuntimeCode (ConcreteRuntimeCode "") -> True - RuntimeCode (SymbolicRuntimeCode c') -> null c' - _ -> False - mutable m = m.mutability `elem` [NonPayable, Payable] - knownAbis :: Map Addr SolcContract - knownAbis = - -- exclude contracts without code - Map.filter (not . BS.null . (.runtimeCode)) $ - -- exclude contracts without state changing functions - Map.filter (not . null . Map.filter mutable . (.abiMap)) $ - -- exclude testing abis - Map.filter (isNothing . preview (ix unitTestMarkerAbi) . (.abiMap)) $ - -- pick all contracts with known compiler artifacts - fmap fromJust (Map.filter isJust $ Map.fromList [(addr, lookupCode c.contractcode dapp) | (addr, c) <- Map.toList cs]) - selected = [(addr, - fromMaybe (internalError $ "no src found for: " <> show addr) $ - lookupCode (fromMaybe (internalError $ "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 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 - AbiAddress caller' <- - if null knownEOAs - then generate $ genAbiValue AbiAddressType - else generate $ frequency - [ (90, genAbiValue AbiAddressType) - , (10, AbiAddress <$> elements knownEOAs) - ] - -- make a call with random valid data to the function - args <- generate $ genAbiValue (AbiTupleType $ Vector.fromList types) - let cd = abiMethod (sig <> "(" <> intercalate "," ((pack . show) <$> types) <> ")") args - -- increment timestamp with random amount - timepassed <- into <$> generate (arbitrarySizedNatural :: Gen Word32) - let ts = fromMaybe (internalError "symbolic timestamp not supported here") $ maybeLitWord vm.block.timestamp - pure (caller', target, cd, into ts + timepassed) - let opts' = opts { testParams = testParams {address = target, caller = caller', timestamp = timestamp'}} - thisCallRLP = List [BS $ word160Bytes caller', BS $ word160Bytes target, BS cd, BS $ word256Bytes timestamp'] - -- set the timestamp - Stepper.evm $ assign (#block % #timestamp) (Lit timestamp') - -- perform the call - bailed <- exploreStep opts' cd - Stepper.evm popTrace - let newHistory = if bailed then List history else List (thisCallRLP:history) - opts'' = opts {testParams = testParams {timestamp = timestamp'}} - carryOn = explorationStepper opts'' testName replayData targets newHistory (i - 1) - -- if we didn't revert, run the test function - if bailed - then carryOn - else - do x <- runUnitTest opts'' testName emptyAbi - if x - then carryOn - else pure (False, List (thisCallRLP:history)) -explorationStepper _ _ _ _ _ _ = internalError "malformed rlp" - -getTargetContracts :: UnitTestOptions -> Stepper [Addr] -getTargetContracts UnitTestOptions{..} = do - vm <- Stepper.evm get - let contract' = fromJust $ currentContract vm - theAbi = (fromJust $ lookupCode contract'.contractcode dapp).abiMap - setUp = abiKeccak (encodeUtf8 "targetContracts()") - case Map.lookup setUp theAbi of - Nothing -> pure [] - Just _ -> do - Stepper.evm $ abiCall testParams (Left ("targetContracts()", emptyAbi)) - res <- Stepper.execFully - case res of - Right (ConcreteBuf r) -> - let vs = case decodeAbiValue (AbiTupleType (Vector.fromList [AbiArrayDynamicType AbiAddressType])) (BSLazy.fromStrict r) of - AbiTuple v -> v - _ -> internalError "fix me with better types" - targets = case Vector.toList vs of - [AbiArrayDynamic AbiAddressType ts] -> - let unAbiAddress (AbiAddress a) = a - unAbiAddress _ = internalError "fix me with better types" - in unAbiAddress <$> Vector.toList ts - _ -> internalError "fix me with better types" - in pure targets - _ -> internalError "internal error: unexpected failure code" - -exploreRun :: UnitTestOptions -> VM -> ABIMethod -> [ExploreTx] -> IO (Text, Either Text Text, VM) -exploreRun opts@UnitTestOptions{..} initialVm testName replayTxs = do - let oracle = Fetch.oracle solvers rpcInfo - targets <- EVM.Stepper.interpret oracle initialVm (getTargetContracts opts) - let depth = fromMaybe 20 maxDepth - ((x, counterex), vm') <- - if null replayTxs then - foldM (\a@((success, _),_) _ -> - if success then - EVM.Stepper.interpret oracle initialVm $ - (,) <$> initialExplorationStepper opts testName [] targets depth - <*> Stepper.evm get - else pure a) - ((True, (List [])), initialVm) -- no canonical "post vm" - [0..fuzzRuns] - else EVM.Stepper.interpret oracle initialVm $ - (,) <$> initialExplorationStepper opts testName replayTxs targets (length replayTxs) - <*> Stepper.evm get - if x - then pure ("\x1b[32m[PASS]\x1b[0m " <> testName <> " (runs: " <> (pack $ show fuzzRuns) <>", depth: " <> pack (show depth) <> ")", - Right (passOutput vm' opts testName), vm') -- no canonical "post vm" - else let replayText = if null replayTxs - then "\nReplay data: '(" <> pack (show testName) <> "," <> pack (show (show (ByteStringS $ rlpencode counterex))) <> ")'" - else " (replayed)" - in pure ("\x1b[31m[FAIL]\x1b[0m " <> testName <> replayText, Left (failOutput vm' opts testName), vm') - -execTest :: UnitTestOptions -> VM -> ABIMethod -> AbiValue -> IO (Bool, VM) -execTest opts@UnitTestOptions{..} vm testName args = - EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) vm $ do - (,) <$> execTestStepper opts testName args - <*> Stepper.evm get - --- | Define the thread spawner for normal test cases -runOne :: UnitTestOptions -> VM -> ABIMethod -> AbiValue -> IO (Text, Either Text Text, VM) -runOne opts@UnitTestOptions{..} vm testName args = do - let argInfo = pack (if args == emptyAbi then "" else " with arguments: " <> show args) - (bailed, vm') <- execTest opts vm testName args - (success, vm'') <- EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) vm' $ do - (,) <$> (checkFailures opts testName bailed) - <*> Stepper.evm get - if success - then - let gasSpent = testParams.gasCall - vm'.state.gas - gasText = pack $ show (into gasSpent :: Integer) - in - pure - ("\x1b[32m[PASS]\x1b[0m " - <> testName <> argInfo <> " (gas: " <> gasText <> ")" - , Right (passOutput vm'' opts testName) - , vm'' - ) - else if bailed then - pure - ("\x1b[31m[BAIL]\x1b[0m " - <> testName <> argInfo - , Left (failOutput vm'' opts testName) - , vm'' - ) - else - pure - ("\x1b[31m[FAIL]\x1b[0m " - <> testName <> argInfo - , Left (failOutput vm'' opts testName) - , vm'' - ) - --- | Define the thread spawner for property based tests -fuzzRun :: UnitTestOptions -> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM) -fuzzRun opts@UnitTestOptions{..} vm testName types = do - let args = Args{ replay = Nothing - , maxSuccess = fuzzRuns - , maxDiscardRatio = 10 - , maxSize = 100 - , chatty = isJust verbose - , maxShrinks = maxBound - } - quickCheckWithResult args (fuzzTest opts testName types vm) >>= \case - QC.Success numTests _ _ _ _ _ -> - pure ("\x1b[32m[PASS]\x1b[0m " - <> testName <> " (runs: " <> (pack $ show numTests) <> ")" - -- this isn't the post vm we actually want, as we - -- can't retrieve the correct vm from quickcheck - , Right (passOutput vm opts testName) - , vm - ) - QC.Failure _ _ _ _ _ _ _ _ _ _ failCase _ _ -> - let abiValue = decodeAbiValue (AbiTupleType (Vector.fromList types)) $ BSLazy.fromStrict $ hexText (pack $ concat failCase) - ppOutput = pack $ show abiValue - in do - -- Run the failing test again to get a proper trace - vm' <- EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) vm $ - runUnitTest opts testName abiValue >> Stepper.evm get - pure ("\x1b[31m[FAIL]\x1b[0m " - <> testName <> ". Counterexample: " <> ppOutput - <> "\nRun:\n dapp test --replay '(\"" <> testName <> "\",\"" - <> (pack (concat failCase)) <> "\")'\nto test this case again, or \n dapp debug --replay '(\"" - <> testName <> "\",\"" <> (pack (concat failCase)) <> "\")'\nto debug it." - , Left (failOutput vm' opts testName) - , vm' - ) - _ -> pure ("\x1b[31m[OOPS]\x1b[0m " - <> testName - , Left (failOutput vm opts testName) - , vm - ) - -- | Define the thread spawner for symbolic tests -symRun :: UnitTestOptions -> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM) -symRun opts@UnitTestOptions{..} vm testName types = do +symRun :: UnitTestOptions RealWorld -> VM RealWorld -> Sig -> IO (Text, Either Text Text) +symRun opts@UnitTestOptions{..} vm (Sig testName types) = do let cd = symCalldata testName types [] (AbstractBuf "txdata") shouldFail = "proveFail" `isPrefixOf` testName - testContract = vm.state.contract + testContract store = fromMaybe (internalError "test contract not found in state") (Map.lookup vm.state.contract store) -- 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() -- we need to read from slot 0 in the test contract and mask it with 0x10 to get the value of _failed -- we don't need to do this when reading the failed from the cheatcode address since we don't do any packing there - let failed store = (And (readStorage' (litAddr testContract) (Lit 0) store) (Lit 2) .== Lit 2) - .|| (readStorage' (litAddr cheatCode) (Lit 0x6661696c65640000000000000000000000000000000000000000000000000000) store .== Lit 1) + let failed store = case Map.lookup cheatCode store of + Just cheatContract -> (And (readStorage' (Lit 0) (testContract store).storage) (Lit 0x10) .== Lit 0x10) + .|| (readStorage' (Lit 0x6661696c65640000000000000000000000000000000000000000000000000000) cheatContract.storage .== Lit 1) + Nothing -> And (readStorage' (Lit 0) (testContract store).storage) (Lit 2) .== Lit 2 postcondition = curry $ case shouldFail of True -> \(_, post) -> case post of Success _ _ _ store -> failed store _ -> PBool True False -> \(_, post) -> case post of Success _ _ _ store -> PNeg (failed store) - Failure _ _ _ -> PBool False + Failure _ _ (Revert msg) -> case msg of + ConcreteBuf b -> PBool $ b /= panicMsg 0x01 + b -> b ./= ConcreteBuf (panicMsg 0x01) + Failure _ _ _ -> PBool True Partial _ _ _ -> PBool True _ -> internalError "Invalid leaf node" - vm' <- EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) vm $ + vm' <- Stepper.interpret (Fetch.oracle solvers rpcInfo) vm $ Stepper.evm $ do pushTrace (EntryTrace testName) makeTxCall testParams cd get -- check postconditions against vm - (_, results) <- verify solvers (makeVeriOpts opts) vm' (Just postcondition) + (e, results) <- verify solvers (makeVeriOpts opts) vm' (Just postcondition) + let allReverts = not . (any Expr.isSuccess) . flattenExpr $ e -- display results if all isQed results - then do - pure ("\x1b[32m[PASS]\x1b[0m " <> testName, Right "", vm) + then if allReverts && (not shouldFail) + then pure ("\x1b[31m[FAIL]\x1b[0m " <> testName, Left $ allBranchRev testName) + else pure ("\x1b[32m[PASS]\x1b[0m " <> testName, Right "") else do let x = mapMaybe extractCex results let y = symFailure opts testName (fst cd) types x - pure ("\x1b[31m[FAIL]\x1b[0m " <> testName, Left y, vm) + pure ("\x1b[31m[FAIL]\x1b[0m " <> testName, Left y) -symFailure :: UnitTestOptions -> Text -> Expr Buf -> [AbiType] -> [(Expr End, SMTCex)] -> Text +allBranchRev :: Text -> Text +allBranchRev testName = Text.unlines + [ "Failure: " <> testName + , "" + , indentLines 2 $ Text.unlines + [ "No reachable assertion violations, but all branches reverted" + , "Prefix this testname with `proveFail` if this is expected" + ] + ] +symFailure :: UnitTestOptions RealWorld -> Text -> Expr Buf -> [AbiType] -> [(Expr End, SMTCex)] -> Text symFailure UnitTestOptions {..} testName cd types failures' = mconcat [ "Failure: " @@ -764,8 +261,8 @@ where showRes = \case Success _ _ _ _ -> if "proveFail" `isPrefixOf` testName - then "Successful execution" - else "Failed: DSTest Assertion Violation" + then "Successful execution" + else "Failed: DSTest Assertion Violation" res -> let ?context = DappContext { info = dapp, env = traceContext res} in Text.pack $ prettyvmresult res @@ -783,23 +280,7 @@ _ -> "" ] -prettyCalldata :: (?context :: DappContext) => SMTCex -> Expr Buf -> Text -> [AbiType] -> Text -prettyCalldata cex buf sig types = head (Text.splitOn "(" sig) <> showCalldata cex types buf - -showCalldata :: (?context :: DappContext) => SMTCex -> [AbiType] -> Expr Buf -> Text -showCalldata cex tps buf = "(" <> intercalate "," (fmap showVal vals) <> ")" - where - argdata = Expr.drop 4 $ simplify $ subModel cex buf - vals = case decodeBuf tps argdata of - CAbi v -> v - _ -> internalError $ "unable to abi decode function arguments:\n" <> (Text.unpack $ formatExpr argdata) - -showVal :: AbiValue -> Text -showVal (AbiBytes _ bs) = formatBytes bs -showVal (AbiAddress addr) = Text.pack . show $ addr -showVal v = Text.pack . show $ v - -execSymTest :: UnitTestOptions -> ABIMethod -> (Expr Buf, [Prop]) -> Stepper (Expr End) +execSymTest :: UnitTestOptions RealWorld -> ABIMethod -> (Expr Buf, [Prop]) -> Stepper RealWorld (Expr End) execSymTest UnitTestOptions{ .. } method cd = do -- Set up the call to the test method Stepper.evm $ do @@ -808,7 +289,7 @@ -- Try running the test method runExpr -checkSymFailures :: UnitTestOptions -> Stepper VM +checkSymFailures :: UnitTestOptions RealWorld -> Stepper RealWorld (VM RealWorld) checkSymFailures UnitTestOptions { .. } = do -- Ask whether any assertions failed Stepper.evm $ do @@ -821,7 +302,7 @@ let p = Text.replicate n " " in Text.unlines (map (p <>) (Text.lines s)) -passOutput :: VM -> UnitTestOptions -> Text -> Text +passOutput :: VM s -> UnitTestOptions s -> Text -> Text passOutput vm UnitTestOptions { .. } testName = let ?context = DappContext { info = dapp, env = vm.env.contracts } in let v = fromMaybe 0 verbose @@ -836,8 +317,7 @@ ] else "" --- TODO -failOutput :: VM -> UnitTestOptions -> Text -> Text +failOutput :: VM s -> UnitTestOptions s -> Text -> Text failOutput vm UnitTestOptions { .. } testName = let ?context = DappContext { info = dapp, env = vm.env.contracts } in mconcat @@ -922,37 +402,37 @@ _ -> Nothing _ -> Just "" -abiCall :: TestVMParams -> Either (Text, AbiValue) ByteString -> EVM () +abiCall :: TestVMParams -> Either (Text, AbiValue) ByteString -> EVM s () abiCall params args = let cd = case args of Left (sig, args') -> abiMethod sig args' Right b -> b in makeTxCall params (ConcreteBuf cd, []) -makeTxCall :: TestVMParams -> (Expr Buf, [Prop]) -> EVM () +makeTxCall :: TestVMParams -> (Expr Buf, [Prop]) -> EVM s () makeTxCall params (cd, cdProps) = do resetState assign (#tx % #isCreate) False - loadContract params.address + execState (loadContract params.address) <$> get >>= put assign (#state % #calldata) cd #constraints %= (<> cdProps) - assign (#state % #caller) (litAddr params.caller) + assign (#state % #caller) params.caller assign (#state % #gas) params.gasCall - origin' <- fromMaybe (initialContract (RuntimeCode (ConcreteRuntimeCode ""))) <$> use (#env % #contracts % at params.origin) - let originBal = origin'.balance - when (originBal < params.gasprice * (into params.gasCall)) $ internalError "insufficient balance for gas cost" + origin <- fromMaybe (initialContract (RuntimeCode (ConcreteRuntimeCode ""))) <$> use (#env % #contracts % at params.origin) + let insufficientBal = maybe False (\b -> b < params.gasprice * (into params.gasCall)) (maybeLitWord origin.balance) + when insufficientBal $ internalError "insufficient balance for gas cost" vm <- get put $ initTx vm -initialUnitTestVm :: UnitTestOptions -> SolcContract -> VM -initialUnitTestVm (UnitTestOptions {..}) theContract = - let - vm = makeVm $ VMOpts +initialUnitTestVm :: UnitTestOptions s -> SolcContract -> ST s (VM s) +initialUnitTestVm (UnitTestOptions {..}) theContract = do + vm <- makeVm $ VMOpts { contract = initialContract (InitCode theContract.creationCode mempty) + , otherContracts = [] , calldata = mempty , value = Lit 0 , address = testParams.address - , caller = litAddr testParams.caller + , caller = testParams.caller , origin = testParams.origin , gas = testParams.gasCreate , gaslimit = testParams.gasCreate @@ -965,56 +445,53 @@ , priorityFee = testParams.priorityFee , maxCodeSize = testParams.maxCodeSize , prevRandao = testParams.prevrandao - , schedule = FeeSchedule.berlin + , schedule = feeSchedule , chainId = testParams.chainId , create = True - , initialStorage = EmptyStore + , baseState = EmptyBase , txAccessList = mempty -- TODO: support unit test access lists??? , allowFFI = ffiAllowed } - creator = - initialContract (RuntimeCode (ConcreteRuntimeCode "")) - & set #nonce 1 - & set #balance testParams.balanceCreate - in vm - & set (#env % #contracts % at ethrunAddress) (Just creator) - - -getParametersFromEnvironmentVariables :: Maybe Text -> IO TestVMParams -getParametersFromEnvironmentVariables rpc = do - block' <- maybe Fetch.Latest (Fetch.BlockNumber . read) <$> (lookupEnv "DAPP_TEST_NUMBER") + let creator = + initialContract (RuntimeCode (ConcreteRuntimeCode "")) + & set #nonce (Just 1) + & set #balance (Lit testParams.balanceCreate) + pure $ vm & set (#env % #contracts % at (LitAddr ethrunAddress)) (Just creator) - (miner,ts,blockNum,ran,limit,base) <- - case rpc of - Nothing -> pure (0,Lit 0,0,0,0,0) - Just url -> Fetch.fetchBlockFrom block' url >>= \case - Nothing -> internalError "Could not fetch block" - Just Block{..} -> pure ( coinbase - , timestamp - , number - , prevRandao - , gaslimit - , baseFee - ) - let - getWord s def = maybe def read <$> lookupEnv s - getAddr s def = maybe def read <$> lookupEnv s - ts' = fromMaybe (internalError "received unexpected symbolic timestamp via rpc") (maybeLitWord ts) +paramsFromRpc :: Fetch.RpcInfo -> IO TestVMParams +paramsFromRpc rpcinfo = do + (miner,ts,blockNum,ran,limit,base) <- case rpcinfo of + Nothing -> pure (SymAddr "miner", Lit 0, 0, 0, 0, 0) + Just (block, url) -> Fetch.fetchBlockFrom block url >>= \case + Nothing -> internalError "Could not fetch block" + Just Block{..} -> pure ( coinbase + , timestamp + , number + , prevRandao + , gaslimit + , baseFee + ) + let ts' = fromMaybe (internalError "received unexpected symbolic timestamp via rpc") (maybeLitWord ts) + pure $ TestVMParams + -- TODO: make this symbolic! It needs some tweaking to the way that our + -- symbolic interpreters work to allow us to symbolically exec constructor initialization + { address = LitAddr 0xacab + , caller = SymAddr "caller" + , origin = SymAddr "origin" + , gasCreate = defaultGasForCreating + , gasCall = defaultGasForInvoking + , baseFee = base + , priorityFee = 0 + , balanceCreate = defaultBalanceForTestContract + , coinbase = miner + , number = blockNum + , timestamp = ts' + , gaslimit = limit + , gasprice = 0 + , maxCodeSize = defaultMaxCodeSize + , prevrandao = ran + , chainId = 99 + } - TestVMParams - <$> getAddr "DAPP_TEST_ADDRESS" (createAddress ethrunAddress 1) - <*> getAddr "DAPP_TEST_CALLER" ethrunAddress - <*> getAddr "DAPP_TEST_ORIGIN" ethrunAddress - <*> getWord "DAPP_TEST_GAS_CREATE" defaultGasForCreating - <*> getWord "DAPP_TEST_GAS_CALL" defaultGasForInvoking - <*> getWord "DAPP_TEST_BASEFEE" base - <*> getWord "DAPP_TEST_PRIORITYFEE" 0 - <*> getWord "DAPP_TEST_BALANCE" defaultBalanceForTestContract - <*> getAddr "DAPP_TEST_COINBASE" miner - <*> getWord "DAPP_TEST_NUMBER" blockNum - <*> getWord "DAPP_TEST_TIMESTAMP" ts' - <*> getWord "DAPP_TEST_GAS_LIMIT" limit - <*> getWord "DAPP_TEST_GAS_PRICE" 0 - <*> getWord "DAPP_TEST_MAXCODESIZE" defaultMaxCodeSize - <*> getWord "DAPP_TEST_PREVRANDAO" ran - <*> getWord "DAPP_TEST_CHAINID" 99 +tick :: Text -> IO () +tick x = Text.putStr x >> hFlush stdout diff --git a/test/EVM/Test/BlockchainTests.hs b/test/EVM/Test/BlockchainTests.hs --- a/test/EVM/Test/BlockchainTests.hs +++ b/test/EVM/Test/BlockchainTests.hs @@ -2,20 +2,19 @@ import EVM (initialContract, makeVm) import EVM.Concrete qualified as EVM -import EVM.Dapp (emptyDapp) -import EVM.Expr (litAddr) -import EVM.FeeSchedule qualified +import EVM.FeeSchedule (feeSchedule) import EVM.Fetch qualified import EVM.Format (hexText) import EVM.Stepper qualified -import EVM.Solvers (withSolvers, Solver(Z3)) import EVM.Transaction -import EVM.TTY qualified as TTY import EVM.Types hiding (Block, Case) +import EVM.Test.Tracing (interpretWithTrace, VMTrace, compareTraces, EVMToolTraceOutput(..)) -import Control.Arrow ((***), (&&&)) import Optics.Core +import Control.Arrow ((***), (&&&)) import Control.Monad +import Control.Monad.ST (RealWorld, stToIO) +import Control.Monad.State.Strict import Data.Aeson ((.:), (.:?), FromJSON (..)) import Data.Aeson qualified as JSON import Data.Aeson.Types qualified as JSON @@ -30,15 +29,13 @@ import System.Environment (lookupEnv, getEnv) import System.FilePath.Find qualified as Find import System.FilePath.Posix (makeRelative, ()) +import Witch (into, unsafeInto) import Witherable (Filterable, catMaybes) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit -import Witch (into, unsafeInto) -type Storage = Map W256 W256 - data Which = Pre | Post data Block = Block @@ -54,14 +51,14 @@ data Case = Case { vmOpts :: VMOpts - , checkContracts :: Map Addr (Contract, Storage) - , testExpectation :: Map Addr (Contract, Storage) + , checkContracts :: Map Addr Contract + , testExpectation :: Map Addr Contract } deriving Show data BlockchainCase = BlockchainCase { blocks :: [Block] - , pre :: Map Addr (Contract, Storage) - , post :: Map Addr (Contract, Storage) + , pre :: Map Addr Contract + , post :: Map Addr Contract , network :: String } deriving Show @@ -89,7 +86,7 @@ parsed <- parseBCSuite <$> LazyByteString.readFile file case parsed of Left "No cases to check." -> pure [] -- error "no-cases ok" - Left _err -> pure [] -- error err + Left _err -> pure [] -- error _err Right allTests -> pure $ (\(name, x) -> testCase' name $ runVMTest True (name, x)) <$> Map.toList allTests where @@ -131,41 +128,55 @@ runVMTest :: Bool -> (String, Case) -> IO () runVMTest diffmode (_name, x) = do - let vm0 = vmForCase x + vm0 <- vmForCase x result <- EVM.Stepper.interpret (EVM.Fetch.zero 0 (Just 0)) vm0 EVM.Stepper.runFully maybeReason <- checkExpectation diffmode x result forM_ maybeReason assertFailure --- | Example usage: --- $ cabal new-repl ethereum-tests --- ghci> debugVMTest "BlockchainTests/GeneralStateTests/VMTests/vmArithmeticTest/twoOps.json" "twoOps_d0g0v0_London" -debugVMTest :: String -> String -> IO () -debugVMTest file test = do +-- | Run a vm test and output a geth style per opcode trace +traceVMTest :: String -> String -> IO [VMTrace] +traceVMTest file test = do repo <- getEnv "HEVM_ETHEREUM_TESTS_REPO" Right allTests <- parseBCSuite <$> LazyByteString.readFile (repo file) let x = case filter (\(name, _) -> name == test) $ Map.toList allTests of [(_, x')] -> x' _ -> internalError "test not found" - let vm0 = vmForCase x - result <- withSolvers Z3 0 Nothing $ \solvers -> - TTY.runFromVM solvers Nothing Nothing emptyDapp vm0 - void $ checkExpectation True x result + vm0 <- vmForCase x + (_, (_, ts)) <- runStateT (interpretWithTrace (EVM.Fetch.zero 0 (Just 0)) EVM.Stepper.runFully) (vm0, []) + pure ts +-- | Read a geth trace from disk +readTrace :: FilePath -> IO (Either String EVMToolTraceOutput) +readTrace = JSON.eitherDecodeFileStrict + +-- | given a path to a test file, a test case from within that file, and a trace from geth from running that test, compare the traces and show where we differ +-- This would need a few tweaks to geth to make this really usable (i.e. evm statetest show allow running a single test from within the test file). +traceVsGeth :: String -> String -> FilePath -> IO () +traceVsGeth file test gethTrace = do + hevm <- traceVMTest file test + EVMToolTraceOutput ts _ <- fromJust <$> (JSON.decodeFileStrict gethTrace :: IO (Maybe EVMToolTraceOutput)) + _ <- compareTraces hevm ts + pure () + splitEithers :: (Filterable f) => f (Either a b) -> (f a, f b) splitEithers = (catMaybes *** catMaybes) . (fmap fst &&& fmap snd) . (fmap (preview _Left &&& preview _Right)) -checkStateFail :: Bool -> Case -> VM -> (Bool, Bool, Bool, Bool) -> IO String +fromConcrete :: Expr Storage -> Map W256 W256 +fromConcrete (ConcreteStore s) = s +fromConcrete s = internalError $ "unexpected abstract store: " <> show s + +checkStateFail :: Bool -> Case -> VM RealWorld -> (Bool, Bool, Bool, Bool) -> IO String checkStateFail diff x vm (okMoney, okNonce, okData, okCode) = do let - printContracts :: Map Addr (Contract, Storage) -> IO () - printContracts cs = putStrLn $ Map.foldrWithKey (\k (c, s) acc -> + printContracts :: Map Addr Contract -> IO () + printContracts cs = putStrLn $ Map.foldrWithKey (\k c acc -> acc ++ show k ++ " : " - ++ (show . toInteger $ (view #nonce c)) ++ " " - ++ (show . toInteger $ (view #balance c)) ++ " " - ++ (printStorage s) + ++ (show $ fromJust $ c.nonce) ++ " " + ++ (show $ fromJust $ maybeLitWord c.balance) ++ " " + ++ (show $ fromConcrete $ c.storage) ++ "\n") "" cs reason = map fst (filter (not . snd) @@ -177,8 +188,7 @@ ]) check = x.checkContracts expected = x.testExpectation - actual = Map.map (,mempty) $ view (#env % #contracts) vm -- . to (fmap (clearZeroStorage.clearOrigStorage))) vm - printStorage = show -- TODO: fixme + actual = fmap (clearZeroStorage . clearOrigStorage) $ forceConcreteAddrs vm.env.contracts when diff $ do putStr (unwords reason) @@ -190,7 +200,7 @@ printContracts actual pure (unwords reason) -checkExpectation :: Bool -> Case -> VM -> IO (Maybe String) +checkExpectation :: Bool -> Case -> VM RealWorld -> IO (Maybe String) checkExpectation diff x vm = do let expectation = x.testExpectation (okState, b2, b3, b4, b5) = checkExpectedContracts vm expectation @@ -200,67 +210,69 @@ Just <$> checkStateFail diff x vm (b2, b3, b4, b5) -- quotient account state by nullness -(~=) :: Map Addr (Contract, Storage) -> Map Addr (Contract, Storage) -> Bool +(~=) :: Map Addr Contract -> Map Addr Contract -> Bool (~=) cs1 cs2 = let nullAccount = EVM.initialContract (RuntimeCode (ConcreteRuntimeCode "")) - padNewAccounts cs ks = Map.union cs $ Map.fromList [(k, (nullAccount, mempty)) | k <- ks] + padNewAccounts cs ks = Map.union cs $ Map.fromList [(k, nullAccount) | k <- ks] padded_cs1 = padNewAccounts cs1 (Map.keys cs2) padded_cs2 = padNewAccounts cs2 (Map.keys cs1) in and $ zipWith (===) (Map.elems padded_cs1) (Map.elems padded_cs2) -(===) :: (Contract, Storage) -> (Contract, Storage) -> Bool -(c1, s1) === (c2, s2) = +(===) :: Contract -> Contract -> Bool +c1 === c2 = codeEqual && storageEqual && (c1 ^. #balance == c2 ^. #balance) && (c1 ^. #nonce == c2 ^. #nonce) where - storageEqual = s1 == s2 - codeEqual = case (c1 ^. #contractcode, c2 ^. #contractcode) of + storageEqual = c1.storage == c2.storage + codeEqual = case (c1 ^. #code, c2 ^. #code) of (RuntimeCode a', RuntimeCode b') -> a' == b' _ -> internalError "unexpected code" -checkExpectedContracts :: VM -> Map Addr (Contract, Storage) -> (Bool, Bool, Bool, Bool, Bool) +checkExpectedContracts :: VM RealWorld -> Map Addr Contract -> (Bool, Bool, Bool, Bool, Bool) checkExpectedContracts vm expected = - let cs = zipWithStorages $ vm ^. #env % #contracts -- . to (fmap (clearZeroStorage.clearOrigStorage)) - expectedCs = clearStorage <$> expected - in ( (expectedCs ~= cs) - , (clearBalance <$> expectedCs) ~= (clearBalance <$> cs) - , (clearNonce <$> expectedCs) ~= (clearNonce <$> cs) - , (clearStorage <$> expectedCs) ~= (clearStorage <$> cs) - , (clearCode <$> expectedCs) ~= (clearCode <$> cs) + let cs = fmap (clearZeroStorage . clearOrigStorage) $ forceConcreteAddrs vm.env.contracts + in ( (expected ~= cs) + , (clearBalance <$> expected) ~= (clearBalance <$> cs) + , (clearNonce <$> expected) ~= (clearNonce <$> cs) + , (clearStorage <$> expected) ~= (clearStorage <$> cs) + , (clearCode <$> expected) ~= (clearCode <$> cs) ) - where - zipWithStorages = Map.mapWithKey (\addr c -> (c, lookupStorage addr)) - lookupStorage _ = - case vm ^. #env % #storage of - ConcreteStore _ -> mempty -- clearZeroStorage $ fromMaybe mempty $ Map.lookup (num addr) s - EmptyStore -> mempty - AbstractStore -> mempty -- error "AbstractStore, should this be handled?" - SStore {} -> mempty -- error "SStore, should this be handled?" - GVar _ -> internalError "unexpected global variable" -clearStorage :: (Contract, Storage) -> (Contract, Storage) -clearStorage (c, _) = (c, mempty) +clearOrigStorage :: Contract -> Contract +clearOrigStorage = set #origStorage (ConcreteStore mempty) -clearBalance :: (Contract, Storage) -> (Contract, Storage) -clearBalance (c, s) = (set #balance 0 c, s) +clearZeroStorage :: Contract -> Contract +clearZeroStorage c = case c.storage of + ConcreteStore m -> let store = Map.filter (/= 0) m + in set #storage (ConcreteStore store) c + _ -> internalError "Internal Error: unexpected abstract store" -clearNonce :: (Contract, Storage) -> (Contract, Storage) -clearNonce (c, s) = (set #nonce 0 c, s) +clearStorage :: Contract -> Contract +clearStorage c = c { storage = clear c.storage } + where + clear :: Expr Storage -> Expr Storage + clear (ConcreteStore _) = ConcreteStore mempty + clear _ = internalError "Internal Error: unexpected abstract store" -clearCode :: (Contract, Storage) -> (Contract, Storage) -clearCode (c, s) = (set #contractcode (RuntimeCode (ConcreteRuntimeCode "")) c, s) +clearBalance :: Contract -> Contract +clearBalance c = set #balance (Lit 0) c -newtype ContractWithStorage = ContractWithStorage (Contract, Storage) +clearNonce :: Contract -> Contract +clearNonce c = set #nonce (Just 0) c -instance FromJSON ContractWithStorage where +clearCode :: Contract -> Contract +clearCode c = set #code (RuntimeCode (ConcreteRuntimeCode "")) c + +instance FromJSON Contract where parseJSON (JSON.Object v) = do code <- (RuntimeCode . ConcreteRuntimeCode <$> (hexText <$> v .: "code")) - storage' <- v .: "storage" - balance' <- v .: "balance" - nonce' <- v .: "nonce" - let c = EVM.initialContract code - & #balance .~ balance' - & #nonce .~ nonce' - return $ ContractWithStorage (c, storage') + storage <- v .: "storage" + balance <- v .: "balance" + nonce <- v .: "nonce" + pure $ EVM.initialContract code + & #balance .~ (Lit balance) + & #nonce ?~ nonce + & #storage .~ (ConcreteStore storage) + & #origStorage .~ (ConcreteStore storage) parseJSON invalid = JSON.typeMismatch "Contract" invalid @@ -285,17 +297,15 @@ baseFee <- fmap read <$> v' .:? "baseFeePerGas" timestamp <- wordField v' "timestamp" mixHash <- wordField v' "mixHash" - return $ Block coinbase difficulty mixHash gasLimit (fromMaybe 0 baseFee) number timestamp txs + pure $ Block coinbase difficulty mixHash gasLimit (fromMaybe 0 baseFee) number timestamp txs parseJSON invalid = JSON.typeMismatch "Block" invalid -parseContracts :: Which -> JSON.Object -> JSON.Parser (Map Addr (Contract, Storage)) -parseContracts w v = - (Map.map unwrap) <$> (v .: which >>= parseJSON) +parseContracts :: Which -> JSON.Object -> JSON.Parser (Map Addr Contract) +parseContracts w v = v .: which >>= parseJSON where which = case w of Pre -> "pre" Post -> "postState" - unwrap (ContractWithStorage x) = x parseBCSuite :: Lazy.ByteString -> Either String (Map String Case) parseBCSuite x = case (JSON.eitherDecode' x) :: Either String (Map String BlockchainCase) of @@ -343,7 +353,7 @@ maxCodeSize = 24576 fromBlockchainCase' :: Block -> Transaction - -> Map Addr (Contract, Storage) -> Map Addr (Contract, Storage) + -> Map Addr Contract -> Map Addr Contract -> Either BlockchainError Case fromBlockchainCase' block tx preState postState = let isCreate = isNothing tx.toAddr in @@ -352,40 +362,40 @@ (_, Nothing) -> Left (if isCreate then FailedCreate else InvalidTx) (Just origin, Just checkState) -> Right $ Case (VMOpts - { contract = EVM.initialContract theCode - , calldata = (cd, []) - , value = Lit tx.value - , address = toAddr - , caller = litAddr origin - , initialStorage = EmptyStore - , origin = origin - , gas = tx.gasLimit - txGasCost feeSchedule tx - , baseFee = block.baseFee - , priorityFee = priorityFee tx block.baseFee - , gaslimit = tx.gasLimit - , number = block.number - , timestamp = Lit block.timestamp - , coinbase = block.coinbase - , prevRandao = block.mixHash - , maxCodeSize = maxCodeSize - , blockGaslimit = block.gasLimit - , gasprice = effectiveGasPrice - , schedule = feeSchedule - , chainId = 1 - , create = isCreate - , txAccessList = txAccessMap tx - , allowFFI = False + { contract = EVM.initialContract theCode + , otherContracts = [] + , calldata = (cd, []) + , value = Lit tx.value + , address = toAddr + , caller = LitAddr origin + , baseState = EmptyBase + , origin = LitAddr origin + , gas = tx.gasLimit - txGasCost feeSchedule tx + , baseFee = block.baseFee + , priorityFee = priorityFee tx block.baseFee + , gaslimit = tx.gasLimit + , number = block.number + , timestamp = Lit block.timestamp + , coinbase = LitAddr block.coinbase + , prevRandao = block.mixHash + , maxCodeSize = maxCodeSize + , blockGaslimit = block.gasLimit + , gasprice = effectiveGasPrice + , schedule = feeSchedule + , chainId = 1 + , create = isCreate + , txAccessList = Map.mapKeys LitAddr (txAccessMap tx) + , allowFFI = False }) checkState postState where - toAddr = fromMaybe (EVM.createAddress origin senderNonce) tx.toAddr - senderNonce = view (accountAt origin % #nonce) (Map.map fst preState) - feeSchedule = EVM.FeeSchedule.berlin - toCode = Map.lookup toAddr preState + toAddr = maybe (EVM.createAddress origin (fromJust senderNonce)) LitAddr (tx.toAddr) + senderNonce = view (accountAt (LitAddr origin) % #nonce) (Map.mapKeys LitAddr preState) + toCode = Map.lookup toAddr (Map.mapKeys LitAddr preState) theCode = if isCreate then InitCode tx.txdata mempty - else maybe (RuntimeCode (ConcreteRuntimeCode "")) (view #contractcode . fst) toCode + else maybe (RuntimeCode (ConcreteRuntimeCode "")) (view #code) toCode effectiveGasPrice = effectiveprice tx block.baseFee cd = if isCreate then mempty @@ -412,47 +422,45 @@ EIP1559Transaction -> fromJust tx.maxFeePerGas _ -> fromJust tx.gasPrice -validateTx :: Transaction -> Block -> Map Addr (Contract, Storage) -> Maybe () +validateTx :: Transaction -> Block -> Map Addr Contract -> Maybe () validateTx tx block cs = do - let cs' = Map.map fst cs origin <- sender tx - originBalance <- (view #balance) <$> view (at origin) cs' - originNonce <- (view #nonce) <$> view (at origin) cs' + (Lit originBalance) <- (view #balance) <$> view (at origin) cs + originNonce <- (view #nonce) <$> view (at origin) cs let gasDeposit = (effectiveprice tx block.baseFee) * (into tx.gasLimit) if gasDeposit + tx.value <= originBalance - && tx.nonce == originNonce && block.baseFee <= maxBaseFee tx + && (Just (unsafeInto tx.nonce) == originNonce) && block.baseFee <= maxBaseFee tx then Just () else Nothing -checkTx :: Transaction -> Block -> Map Addr (Contract, Storage) -> Maybe (Map Addr (Contract, Storage)) +checkTx :: Transaction -> Block -> Map Addr Contract -> Maybe (Map Addr Contract) checkTx tx block prestate = do origin <- sender tx validateTx tx block prestate - let isCreate = isNothing tx.toAddr - senderNonce = view (accountAt origin % #nonce) (Map.map fst prestate) - toAddr = fromMaybe (EVM.createAddress origin senderNonce) tx.toAddr - prevCode = view (accountAt toAddr % #contractcode) (Map.map fst prestate) - prevNonce = view (accountAt toAddr % #nonce) (Map.map fst prestate) + let isCreate = isNothing tx.toAddr + cs = Map.mapKeys LitAddr prestate + senderNonce = view (accountAt (LitAddr origin) % #nonce) cs + toAddr = maybe (EVM.createAddress origin (fromJust senderNonce)) LitAddr (tx.toAddr) + prevCode = view (accountAt toAddr % #code) cs + prevNonce = view (accountAt toAddr % #nonce) cs nonEmptyAccount = case prevCode of RuntimeCode (ConcreteRuntimeCode b) -> not (BS.null b) _ -> True - badNonce = prevNonce /= 0 + badNonce = prevNonce /= Just 0 initCodeSizeExceeded = BS.length tx.txdata > (unsafeInto maxCodeSize * 2) if isCreate && (badNonce || nonEmptyAccount || initCodeSizeExceeded) then mzero else - return prestate + pure prestate -vmForCase :: Case -> VM -vmForCase x = - let - a = x.checkContracts - cs = Map.map fst a - st = Map.mapKeys into $ Map.map snd a - vm = makeVm x.vmOpts - & set (#env % #contracts) cs - & set (#env % #storage) (ConcreteStore st) - & set (#env % #origStorage) st - in - initTx vm +vmForCase :: Case -> IO (VM RealWorld) +vmForCase x = do + vm <- stToIO $ makeVm x.vmOpts + <&> set (#env % #contracts) (Map.mapKeys LitAddr x.checkContracts) + pure $ initTx vm + +forceConcreteAddrs :: Map (Expr EAddr) Contract -> Map Addr Contract +forceConcreteAddrs cs = Map.mapKeys + (fromMaybe (internalError "Internal Error: unexpected symbolic address") . maybeLitAddr) + cs diff --git a/test/EVM/Test/Tracing.hs b/test/EVM/Test/Tracing.hs --- a/test/EVM/Test/Tracing.hs +++ b/test/EVM/Test/Tracing.hs @@ -13,7 +13,8 @@ import Control.Monad (when) import Control.Monad.Operational qualified as Operational -import Control.Monad.State.Strict (StateT(..), liftIO, runState) +import Control.Monad.ST (RealWorld, ST, stToIO) +import Control.Monad.State.Strict (StateT(..), liftIO) import Control.Monad.State.Strict qualified as State import Data.Aeson ((.:), (.:?)) import Data.Aeson qualified as JSON @@ -36,22 +37,21 @@ import Test.QuickCheck.Instances.Natural() import Test.QuickCheck.Instances.ByteString() import Test.Tasty (testGroup, TestTree) -import Test.Tasty.HUnit (assertEqual) +import Test.Tasty.HUnit (assertEqual, testCase) import Test.Tasty.QuickCheck hiding (Failure, Success) -import Witch (into) +import Witch (into, unsafeInto) import Optics.Core hiding (pre) import Optics.State -import Optics.Zoom import EVM (makeVm, initialContract, exec1) import EVM.Assembler (assemble) import EVM.Expr qualified as Expr +import EVM.Concrete qualified as Concrete import EVM.Exec (ethrunAddress) import EVM.Fetch qualified as Fetch import EVM.Format (bsToHex, formatBinary) -import EVM.Concrete (createAddress) -import EVM.FeeSchedule qualified as FeeSchedule +import EVM.FeeSchedule import EVM.Op (intToOpName) import EVM.Sign (deriveAddr) import EVM.Solvers @@ -65,10 +65,10 @@ VMTrace { tracePc :: Int , traceOp :: Int - , traceStack :: [W256] - , traceMemSize :: Word64 + , traceGas :: Data.Word.Word64 + , traceMemSize :: Data.Word.Word64 , traceDepth :: Int - , traceGas :: Word64 + , traceStack :: [W256] , traceError :: Maybe String } deriving (Generic, Show) @@ -96,6 +96,7 @@ , opName :: String , stack :: [W256] , error :: Maybe String + , gasCost :: Maybe W256 } deriving (Generic, Show) instance JSON.FromJSON EVMToolTrace where @@ -109,6 +110,7 @@ <*> v .: "opName" <*> v .: "stack" <*> v .:? "error" + <*> v .:? "gasCost" mkBlockHash:: Int -> Expr 'EWord mkBlockHash x = (into x :: Integer) & show & Char8.pack & EVM.Types.keccak' & Lit @@ -120,6 +122,8 @@ EVMToolOutput { output :: ByteStringS , gasUsed :: W256 + , time :: Maybe Integer + , error :: Maybe String } deriving (Generic, Show) instance JSON.FromJSON EVMToolOutput @@ -140,14 +144,14 @@ , gasLimit :: Data.Word.Word64 , baseFee :: W256 , maxCodeSize :: W256 - , schedule :: FeeSchedule.FeeSchedule Data.Word.Word64 + , schedule :: FeeSchedule Data.Word.Word64 , blockHashes :: Map.Map Int W256 } deriving (Show, Generic) instance JSON.ToJSON EVMToolEnv where toJSON b = JSON.object [ ("currentCoinBase" , (JSON.toJSON $ b.coinbase)) , ("currentDifficulty", (JSON.toJSON $ b.prevRandao)) - , ("currentGasLimit" , (JSON.toJSON ("0x" ++ showHex (toInteger $ b.gasLimit) ""))) + , ("currentGasLimit" , (JSON.toJSON ("0x" ++ showHex (into @Integer b.gasLimit) ""))) , ("currentNumber" , (JSON.toJSON $ b.number)) , ("currentTimestamp" , (JSON.toJSON tstamp)) , ("currentBaseFee" , (JSON.toJSON $ b.baseFee)) @@ -167,7 +171,7 @@ , gasLimit = 0xffffffffffffffff , baseFee = 0 , maxCodeSize= 0xffffffff - , schedule = FeeSchedule.berlin + , schedule = feeSchedule , blockHashes = mempty } @@ -263,7 +267,7 @@ } txn = EVM.Transaction.Transaction { txdata = txData - , gasLimit = fromIntegral gaslimitExec + , gasLimit = unsafeInto gaslimitExec , gasPrice = Just 1 , nonce = 172 , toAddr = Just 0x8A8eAFb1cf62BfBeb1741769DAE1a9dd47996192 @@ -281,23 +285,20 @@ , timestamp = Lit 0x3e8 , number = 0x0 , prevRandao = 0x0 - , gasLimit = fromIntegral gaslimitExec + , gasLimit = unsafeInto gaslimitExec , baseFee = 0x0 , maxCodeSize = 0xfffff - , schedule = FeeSchedule.berlin + , schedule = feeSchedule , blockHashes = blockHashesDefault } sk = 0xDC38EE117CAE37750EB1ECC5CFD3DE8E85963B481B93E732C5D0CB66EE6B0C9D - fromAddress :: Addr fromAddress = fromJust $ deriveAddr sk - toAddress :: Addr toAddress = 0x8A8eAFb1cf62BfBeb1741769DAE1a9dd47996192 getHEVMRet :: OpContract -> ByteString -> Int -> IO (Either (EvmError, [VMTrace]) (Expr 'End, [VMTrace], VMTraceResult)) getHEVMRet contr txData gaslimitExec = do let (txn, evmEnv, contrAlloc, fromAddress, toAddress, _) = evmSetup contr txData gaslimitExec - hevmRun <- runCodeWithTrace Nothing evmEnv contrAlloc txn (fromAddress, toAddress) - return hevmRun + runCodeWithTrace Nothing evmEnv contrAlloc txn (LitAddr fromAddress) (LitAddr toAddress) getEVMToolRet :: OpContract -> ByteString -> Int -> IO (Maybe EVMToolResult) getEVMToolRet contr txData gaslimitExec = do @@ -325,8 +326,7 @@ putStrLn $ "evmtool exited with code " <> show exitCode putStrLn $ "evmtool stderr output:" <> show evmtoolStderr putStrLn $ "evmtool stdout output:" <> show evmtoolStdout - evmtoolResult <- JSON.decodeFileStrict "result.json" :: IO (Maybe EVMToolResult) - return evmtoolResult + JSON.decodeFileStrict "result.json" :: IO (Maybe EVMToolResult) -- Compares traces of evmtool (from go-ethereum) and HEVM compareTraces :: [VMTrace] -> [EVMToolTrace] -> IO (Bool) @@ -341,21 +341,19 @@ bPc = b.pc aStack = a.traceStack bStack = b.stack - aGas = fromIntegral a.traceGas + aGas = into a.traceGas bGas = b.gas - if aGas /= bGas then do - putStrLn "GAS doesn't match:" - putStrLn $ "HEVM's gas : " <> (show aGas) - putStrLn $ "evmtool's gas: " <> (show bGas) - else - -- putStrLn $ "Gas match : " <> (show aGas) - return () - if aOp /= bOp || aPc /= bPc then - putStrLn $ "HEVM: " <> (intToOpName aOp) <> " (pc " <> (show aPc) <> ") --- evmtool " <> (intToOpName bOp) <> " (pc " <> (show bPc) <> ")" - else - -- putStrLn $ "trace element match. " <> (intToOpName aOp) <> " pc: " <> (show aPc) - return () + -- putStrLn $ "hevm: " <> intToOpName aOp <> " pc: " <> show aPc <> " gas: " <> show aGas <> " stack: " <> show aStack + -- putStrLn $ "geth: " <> intToOpName bOp <> " pc: " <> show bPc <> " gas: " <> show bGas <> " stack: " <> show bStack + when (aGas /= bGas) $ do + putStrLn "GAS doesn't match:" + putStrLn $ "HEVM's gas : " <> (show aGas) + putStrLn $ "evmtool's gas: " <> (show bGas) + putStrLn $ "executing opcode: " <> (intToOpName aOp) + when (aOp /= bOp || aPc /= bPc) $ do + putStrLn $ "HEVM: " <> (intToOpName aOp) <> " (pc " <> (show aPc) <> ") --- evmtool " <> (intToOpName bOp) <> " (pc " <> (show bPc) <> ")" + when (isJust b.error) $ do putStrLn $ "Error by evmtool: " <> (show b.error) putStrLn $ "Error by HEVM : " <> (show a.traceError) @@ -403,25 +401,25 @@ deleteTraceOutputFiles :: Maybe EVMToolResult -> IO () deleteTraceOutputFiles evmtoolResult = case evmtoolResult of - Nothing -> return () + Nothing -> pure () Just res -> do let traceFileName = getTraceFileName res System.Directory.removeFile traceFileName System.Directory.removeFile (traceFileName ++ ".json") -- Create symbolic VM from concrete VM -symbolify :: VM -> VM +symbolify :: VM s -> VM s symbolify vm = vm { state = vm.state { calldata = AbstractBuf "calldata" } } -- | Takes a runtime code and calls it with the provided calldata -- Uses evmtool's alloc and transaction to set up the VM correctly -runCodeWithTrace :: Fetch.RpcInfo -> EVMToolEnv -> EVMToolAlloc -> EVM.Transaction.Transaction -> (Addr, Addr) -> IO (Either (EvmError, [VMTrace]) ((Expr 'End, [VMTrace], VMTraceResult))) -runCodeWithTrace rpcinfo evmEnv alloc txn (fromAddr, toAddress) = withSolvers Z3 0 Nothing $ \solvers -> do - let origVM = vmForRuntimeCode code' calldata' evmEnv alloc txn (fromAddr, toAddress) - calldata' = ConcreteBuf txn.txdata +runCodeWithTrace :: Fetch.RpcInfo -> EVMToolEnv -> EVMToolAlloc -> EVM.Transaction.Transaction -> Expr EAddr -> Expr EAddr -> IO (Either (EvmError, [VMTrace]) ((Expr 'End, [VMTrace], VMTraceResult))) +runCodeWithTrace rpcinfo evmEnv alloc txn fromAddr toAddress = withSolvers Z3 0 Nothing $ \solvers -> do + let calldata' = ConcreteBuf txn.txdata code' = alloc.code - buildExpr :: SolverGroup -> VM -> IO (Expr End) + buildExpr :: SolverGroup -> VM RealWorld -> IO (Expr End) buildExpr s vm = interpret (Fetch.oracle s Nothing) Nothing 1 Naive vm runExpr + origVM <- stToIO $ vmForRuntimeCode code' calldata' evmEnv alloc txn fromAddr toAddress expr <- buildExpr solvers $ symbolify origVM (res, (vm, trace)) <- runStateT (interpretWithTrace (Fetch.oracle solvers rpcinfo) Stepper.execFully) (origVM, []) @@ -429,24 +427,24 @@ Left x -> pure $ Left (x, trace) Right _ -> pure $ Right (expr, trace, vmres vm) -vmForRuntimeCode :: ByteString -> Expr Buf -> EVMToolEnv -> EVMToolAlloc -> EVM.Transaction.Transaction -> (Addr, Addr) -> VM -vmForRuntimeCode runtimecode calldata' evmToolEnv alloc txn (fromAddr, toAddress) = - let contr = initialContract (RuntimeCode (ConcreteRuntimeCode runtimecode)) - contrWithBal = (contr :: Contract) { balance = alloc.balance } - in - (makeVm $ VMOpts - { contract = contrWithBal +vmForRuntimeCode :: ByteString -> Expr Buf -> EVMToolEnv -> EVMToolAlloc -> EVM.Transaction.Transaction -> Expr EAddr -> Expr EAddr -> ST s (VM s) +vmForRuntimeCode runtimecode calldata' evmToolEnv alloc txn fromAddr toAddress = + let contract = initialContract (RuntimeCode (ConcreteRuntimeCode runtimecode)) + & set #balance (Lit alloc.balance) + in (makeVm $ VMOpts + { contract = contract + , otherContracts = [] , calldata = (calldata', []) , value = Lit txn.value - , initialStorage = EmptyStore + , baseState = EmptyBase , address = toAddress - , caller = Expr.litAddr fromAddr + , caller = fromAddr , origin = fromAddr - , coinbase = evmToolEnv.coinbase + , coinbase = LitAddr evmToolEnv.coinbase , number = evmToolEnv.number , timestamp = evmToolEnv.timestamp , gasprice = fromJust txn.gasPrice - , gas = txn.gasLimit - fromIntegral (EVM.Transaction.txGasCost evmToolEnv.schedule txn) + , gas = txn.gasLimit - (EVM.Transaction.txGasCost evmToolEnv.schedule txn) , gaslimit = txn.gasLimit , blockGaslimit = evmToolEnv.gasLimit , prevRandao = evmToolEnv.prevRandao @@ -458,19 +456,26 @@ , create = False , txAccessList = mempty , allowFFI = False - }) & set (#env % #contracts % at ethrunAddress) + }) <&> set (#env % #contracts % at (LitAddr ethrunAddress)) (Just (initialContract (RuntimeCode (ConcreteRuntimeCode BS.empty)))) - & set (#state % #calldata) calldata' + <&> set (#state % #calldata) calldata' runCode :: Fetch.RpcInfo -> ByteString -> Expr Buf -> IO (Maybe (Expr Buf)) runCode rpcinfo code' calldata' = withSolvers Z3 0 Nothing $ \solvers -> do - let origVM = vmForRuntimeCode code' calldata' emptyEvmToolEnv emptyEVMToolAlloc EVM.Transaction.emptyTransaction (ethrunAddress, createAddress ethrunAddress 1) + origVM <- stToIO $ vmForRuntimeCode + code' + calldata' + emptyEvmToolEnv + emptyEVMToolAlloc + EVM.Transaction.emptyTransaction + (LitAddr ethrunAddress) + (Concrete.createAddress ethrunAddress 1) res <- Stepper.interpret (Fetch.oracle solvers rpcinfo) origVM Stepper.execFully pure $ case res of Left _ -> Nothing Right b -> Just b -vmtrace :: VM -> VMTrace +vmtrace :: VM s -> VMTrace vmtrace vm = let memsize = vm.state.memorySize @@ -485,7 +490,7 @@ , traceError = readoutError vm.result } where - readoutError :: Maybe VMResult -> Maybe String + readoutError :: Maybe (VMResult s) -> Maybe String readoutError (Just (VMFailure e)) = case e of -- NOTE: error text made to closely match go-ethereum's errors.go file OutOfGas {} -> Just "out of gas" @@ -508,7 +513,7 @@ err -> Just $ "HEVM error: " <> show err readoutError _ = Nothing -vmres :: VM -> VMTraceResult +vmres :: VM s -> VMTraceResult vmres vm = let gasUsed' = vm.tx.gaslimit - vm.state.gas @@ -523,22 +528,23 @@ , gasUsed = gasUsed' } -type TraceState = (VM, [VMTrace]) +type TraceState s = (VM s, [VMTrace]) -execWithTrace :: StateT TraceState IO VMResult +execWithTrace :: StateT (TraceState RealWorld) IO (VMResult RealWorld) execWithTrace = do _ <- runWithTrace fromJust <$> use (_1 % #result) -runWithTrace :: StateT TraceState IO VM +runWithTrace :: StateT (TraceState RealWorld) IO (VM RealWorld) runWithTrace = do -- This is just like `exec` except for every instruction evaluated, -- we also increment a counter indexed by the current code location. vm0 <- use _1 case vm0.result of Nothing -> do - State.modify (\(a, b) -> (a, b ++ [vmtrace vm0])) - zoom _1 (State.state (runState exec1)) + State.modify' (\(a, b) -> (a, b ++ [vmtrace vm0])) + vm' <- liftIO $ stToIO $ State.execStateT exec1 vm0 + assign _1 vm' runWithTrace Just (VMFailure _) -> do -- Update error text for last trace element @@ -550,16 +556,16 @@ Just _ -> pure vm0 interpretWithTrace - :: Fetch.Fetcher - -> Stepper.Stepper a - -> StateT TraceState IO a + :: Fetch.Fetcher RealWorld + -> Stepper.Stepper RealWorld a + -> StateT (TraceState RealWorld) IO a interpretWithTrace fetcher = eval . Operational.view where eval - :: Operational.ProgramView Stepper.Action a - -> StateT TraceState IO a + :: Operational.ProgramView (Stepper.Action RealWorld) a + -> StateT (TraceState RealWorld) IO a eval (Operational.Return x) = pure x @@ -568,22 +574,26 @@ case action of Stepper.Exec -> execWithTrace >>= interpretWithTrace fetcher . k - Stepper.Run -> - runWithTrace >>= interpretWithTrace fetcher . k Stepper.Wait q -> case q of PleaseAskSMT (Lit x) _ continue -> interpretWithTrace fetcher (Stepper.evm (continue (Case (x > 0))) >>= k) _ -> do m <- liftIO (fetcher q) - zoom _1 (State.state (runState m)) >> interpretWithTrace fetcher (k ()) + vm <- use _1 + vm' <- liftIO $ stToIO $ State.execStateT m vm + assign _1 vm' + interpretWithTrace fetcher (k ()) Stepper.Ask _ -> internalError "cannot make choice in this interpreter" Stepper.IOAct q -> - zoom _1 (StateT (runStateT q)) >>= interpretWithTrace fetcher . k - Stepper.EVM m -> - zoom _1 (State.state (runState m)) >>= interpretWithTrace fetcher . k + liftIO q >>= interpretWithTrace fetcher . k + Stepper.EVM m -> do + vm <- use _1 + (r, vm') <- liftIO $ stToIO $ State.runStateT m vm + assign _1 vm' + interpretWithTrace fetcher (k r) -data OpContract = OpContract [Op] +newtype OpContract = OpContract [Op] instance Show OpContract where show (OpContract a) = "OpContract " ++ (show a) @@ -646,11 +656,11 @@ OpJumpi -> do let filtDests = (filter (> pos) jumpDests) rndPos <- randItem filtDests - fixup ax (pos+34) (ret++[(OpPush (Lit (fromInteger (fromIntegral rndPos)))), (OpJumpi)]) + fixup ax (pos+34) (ret++[(OpPush (Lit (unsafeInto rndPos))), (OpJumpi)]) OpJump -> do let filtDests = (filter (> pos) jumpDests) rndPos <- randItem filtDests - fixup ax (pos+34) (ret++[(OpPush (Lit (fromInteger (fromIntegral rndPos)))), (OpJump)]) + fixup ax (pos+34) (ret++[(OpPush (Lit (unsafeInto rndPos))), (OpJump)]) myop@(OpPush _) -> fixup ax (pos+33) (ret++[myop]) myop -> fixup ax (pos+1) (ret++[myop]) fmap OpContract ops2 @@ -661,37 +671,40 @@ onePush :: Gen Op onePush = do p <- chooseInt (1, 10) - pure $ OpPush (Lit (fromIntegral p)) + pure $ OpPush (Lit (unsafeInto p)) genContract :: Int -> Gen [Op] genContract n = do y <- chooseInt (3, 6) pushes <- genPush y normalOps <- vectorOf (3*n+40) genOne + large :: Bool <- chooseAny + extra <- if large then vectorOf (100) genOne + else pure [] addReturn <- chooseInt (0, 10) - let contr = pushes ++ normalOps + let contr = pushes ++ normalOps ++ extra if addReturn < 10 then pure $ contr++[OpPush (Lit 0x40), OpPush (Lit 0x0), OpReturn] else pure contr where genOne :: Gen Op genOne = frequency [ -- math ops - (200, frequency [ - (1, pure OpAdd) - , (1, pure OpMul) + (20, frequency [ + (2, pure OpAdd) + , (2, pure OpMul) , (1, pure OpSub) - , (1, pure OpDiv) + , (2, pure OpDiv) , (1, pure OpSdiv) - , (1, pure OpMod) + , (2, pure OpMod) , (1, pure OpSmod) , (1, pure OpAddmod) - , (1, pure OpMulmod) + , (2, pure OpMulmod) , (1, pure OpExp) , (1, pure OpSignextend) - , (1, pure OpLt) - , (1, pure OpGt) - , (1, pure OpSlt) - , (1, pure OpSgt) + , (2, pure OpLt) + , (2, pure OpGt) + , (2, pure OpSlt) + , (2, pure OpSgt) , (1, pure OpSha3) ]) -- Comparison & binary ops @@ -708,8 +721,8 @@ , (1, pure OpSar) ]) -- calldata - , (800, pure OpCalldataload) - , (200, pure OpCalldatacopy) + , (200, pure OpCalldataload) + , (800, pure OpCalldatacopy) -- Get some info , (100, frequency [ (10, pure OpAddress) @@ -742,8 +755,8 @@ -- memory manip , (1200, frequency [ (50, pure OpMload) - , (50, pure OpMstore) - , (1, pure OpMstore8) + , (1, pure OpMstore) + , (300, pure OpMstore8) ]) -- storage manip , (100, frequency [ @@ -751,7 +764,7 @@ , (1, pure OpSstore) ]) -- Jumping around - , (20, frequency [ + , (50, frequency [ (1, pure OpJump) , (10, pure OpJumpi) ]) @@ -770,16 +783,16 @@ (1, pure OpPop) , (400, do -- x <- arbitrary - large <- chooseInt (0, 100) + large <- chooseInt (0, 2000) x <- if large == 0 then chooseBoundedIntegral (0::W256, (2::W256)^(256::W256)-1) else chooseBoundedIntegral (0, 10) - pure $ OpPush (Lit (fromIntegral x))) + pure $ OpPush (Lit x)) , (10, do x <- chooseInt (1, 10) - pure $ OpDup (fromIntegral x)) + pure $ OpDup (unsafeInto x)) , (10, do x <- chooseInt (1, 10) - pure $ OpSwap (fromIntegral x)) + pure $ OpSwap (unsafeInto x)) ])] -- End states -- , (1, frequency [ @@ -795,12 +808,13 @@ randItem :: [a] -> IO a randItem = generate . Test.QuickCheck.elements -getOp :: VM -> Word8 +getOp :: VM s -> Word8 getOp vm = let pcpos = vm ^. #state % #pc code' = vm ^. #state % #code xs = case code' of - InitCode _ _ -> internalError "InitCode instead of RuntimeCode" + UnknownCode _ -> internalError "UnknownCode instead of RuntimeCode" + InitCode bs _ -> BS.drop pcpos bs RuntimeCode (ConcreteRuntimeCode xs') -> BS.drop pcpos xs' RuntimeCode (SymbolicRuntimeCode _) -> internalError "RuntimeCode is symbolic" in if xs == BS.empty then 0 @@ -808,68 +822,128 @@ tests :: TestTree tests = testGroup "contract-quickcheck-run" - [ testProperty "random-contract-concrete-call" $ \(contr :: OpContract) -> ioProperty $ do - txDataRaw <- generate $ sized $ \n -> vectorOf (10*n+5) $ chooseInt (0,255) - gaslimitExec <- generate $ chooseInt (40000, 0xffff) + [ testProperty "random-contract-concrete-call" $ \(contr :: OpContract, GasLimitInt gasLimit, TxDataRaw txDataRaw) -> ioProperty $ do let txData = BS.pack $ toEnum <$> txDataRaw -- TODO: By removing external calls, we fuzz less -- It should work also when we external calls. Removing for now. contrFixed <- fixContractJumps $ removeExtcalls contr - evmtoolResult <- getEVMToolRet contrFixed txData gaslimitExec - hevmRun <- getHEVMRet contrFixed txData gaslimitExec - (Just evmtoolTraceOutput) <- getTraceOutput evmtoolResult - case hevmRun of - (Right (expr, hevmTrace, hevmTraceResult)) -> do - let - concretize :: Expr a -> Expr Buf -> Expr a - concretize a c = mapExpr go a - where - go :: Expr a -> Expr a - go = \case - AbstractBuf "calldata" -> c - y -> y - concretizedExpr = concretize expr (ConcreteBuf txData) - simplConcExpr = Expr.simplify concretizedExpr - getReturnVal :: Expr End -> Maybe ByteString - getReturnVal (Success _ _ (ConcreteBuf bs) _) = Just bs - getReturnVal _ = Nothing - simplConcrExprRetval = getReturnVal simplConcExpr - traceOK <- compareTraces hevmTrace (evmtoolTraceOutput.trace) - -- putStrLn $ "HEVM trace : " <> show hevmTrace - -- putStrLn $ "evmtool trace: " <> show (evmtoolTraceOutput.toTrace) - assertEqual "Traces and gas must match" traceOK True - let resultOK = evmtoolTraceOutput.output.output == hevmTraceResult.out - if resultOK then do - putStrLn $ "HEVM & evmtool's outputs match: '" <> (bsToHex $ bssToBs evmtoolTraceOutput.output.output) <> "'" - if isNothing simplConcrExprRetval || (fromJust simplConcrExprRetval) == (bssToBs hevmTraceResult.out) - then do - putStr "OK, symbolic interpretation -> concrete calldata -> Expr.simplify gives the same answer." - if isNothing simplConcrExprRetval then putStrLn ", but it was a Nothing, so not strong equivalence" - else putStrLn "" - else do - putStrLn $ "concretized expr : " <> (show concretizedExpr) - putStrLn $ "simplified concretized expr: " <> (show simplConcExpr) - putStrLn $ "return value computed : " <> (show simplConcrExprRetval) - putStrLn $ "evmtool's return value : " <> (show hevmTraceResult.out) - assertEqual "Simplified, concretized expression must match evmtool's output." True False - else do - putStrLn $ "Name of trace file: " <> (getTraceFileName $ fromJust evmtoolResult) - putStrLn $ "HEVM result :" <> (show hevmTraceResult) - T.putStrLn $ "HEVM result: " <> (formatBinary $ bssToBs hevmTraceResult.out) - T.putStrLn $ "evm result : " <> (formatBinary $ bssToBs evmtoolTraceOutput.output.output) - putStrLn $ "HEVM result len: " <> (show (BS.length $ bssToBs hevmTraceResult.out)) - putStrLn $ "evm result len: " <> (show (BS.length $ bssToBs evmtoolTraceOutput.output.output)) - assertEqual "Contract exec successful. HEVM & evmtool's outputs must match" resultOK True - Left (evmerr, hevmTrace) -> do - putStrLn $ "HEVM contract exec issue: " <> (show evmerr) - -- putStrLn $ "evmtool result was: " <> show (fromJust evmtoolResult) - -- putStrLn $ "output by evmtool is: '" <> bsToHex evmtoolTraceOutput.toOutput.output <> "'" - traceOK <- compareTraces hevmTrace (evmtoolTraceOutput.trace) - assertEqual "Traces and gas must match" traceOK True - System.Directory.removeFile "txs.json" - System.Directory.removeFile "alloc-out.json" - System.Directory.removeFile "alloc.json" - System.Directory.removeFile "result.json" - System.Directory.removeFile "env.json" - deleteTraceOutputFiles evmtoolResult + checkTraceAndOutputs contrFixed gasLimit txData + , testCase "calldata-wraparound" $ do + let contract = OpContract $ concat + [ [OpPush (Lit 0xff),OpPush (Lit 31),OpMstore8] -- value, offs + , [OpPush (Lit 0x3),OpPush (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff),OpPush (Lit 0x0),OpCalldatacopy] -- size, offs, destOffs + , [OpPush (Lit 0x20),OpPush (Lit 0),OpReturn] -- datasize, offs + ] + checkTraceAndOutputs contract 40000 (BS.pack [1, 2, 3, 4, 5]) + , testCase "calldata-wraparound2" $ do + let contract = OpContract $ concat + [ [OpPush (Lit 0xff),OpPush (Lit 0),OpMstore8] -- value, offs + , [OpPush (Lit 0x10),OpPush (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff),OpPush (Lit 0x0),OpCalldatacopy] -- size, offs, destOffs + , [OpPush (Lit 0x20),OpPush (Lit 0),OpReturn] -- datasize, offs + ] + checkTraceAndOutputs contract 40000 (BS.pack [1, 2, 3, 4, 5]) + , testCase "calldata-overwrite-with-0-if-oversized" $ do + -- supposed to copy 1...6 and then 0s, overwriting the 0xff with 0 + let contract = OpContract $ concat + [ [OpPush (Lit 0xff),OpPush (Lit 1),OpMstore8] -- value, offs + , [OpPush (Lit 10),OpPush (Lit 0),OpPush (Lit 0), OpCalldatacopy] -- size, offs, destOffs + , [OpPush (Lit 10),OpPush (Lit 0x0),OpReturn] -- datasize, offset + ] + checkTraceAndOutputs contract 40000 (BS.pack [1, 2, 3, 4, 5, 6]) + , testCase "calldata-overwrite-correct-size" $ do + let contract = OpContract $ concat + [ [OpPush (Lit 0xff),OpPush (Lit 8),OpMstore8] -- value, offs + , [OpPush (Lit 10),OpPush (Lit 0),OpPush (Lit 0), OpCalldatacopy] -- size, offs, destOffs + , [OpPush (Lit 10),OpPush (Lit 0x0),OpReturn] -- datasize, offset + ] + checkTraceAndOutputs contract 40000 (BS.pack [1, 2, 3, 4, 5, 6]) + , testCase "calldata-offset-copy" $ do + let contract = OpContract $ concat + [ [OpPush (Lit 0xff),OpPush (Lit 8),OpMstore8] -- value, offs + , [OpPush (Lit 0xff),OpPush (Lit 1),OpMstore8] -- value, offs + , [OpPush (Lit 10),OpPush (Lit 4),OpPush (Lit 0), OpCalldatacopy] -- size, offs, destOffs + , [OpPush (Lit 10),OpPush (Lit 0x0),OpReturn] -- datasize, offset + ] + checkTraceAndOutputs contract 40000 (BS.pack [1, 2, 3, 4, 5, 6]) ] + +checkTraceAndOutputs :: OpContract -> Int -> ByteString -> IO () +checkTraceAndOutputs contract gasLimit txData = do + evmtoolResult <- getEVMToolRet contract txData gasLimit + hevmRun <- getHEVMRet contract txData gasLimit + (Just evmtoolTraceOutput) <- getTraceOutput evmtoolResult + case hevmRun of + (Right (expr, hevmTrace, hevmTraceResult)) -> do + let + concretize :: Expr a -> Expr Buf -> Expr a + concretize a c = mapExpr go a + where + go :: Expr a -> Expr a + go = \case + AbstractBuf "calldata" -> c + y -> y + concretizedExpr = concretize expr (ConcreteBuf txData) + simplConcExpr = Expr.simplify concretizedExpr + getReturnVal :: Expr End -> Maybe ByteString + getReturnVal (Success _ _ (ConcreteBuf bs) _) = Just bs + getReturnVal _ = Nothing + simplConcrExprRetval = getReturnVal simplConcExpr + traceOK <- compareTraces hevmTrace (evmtoolTraceOutput.trace) + -- putStrLn $ "HEVM trace : " <> show hevmTrace + -- putStrLn $ "evmtool trace: " <> show (evmtoolTraceOutput.trace) + assertEqual "Traces and gas must match" traceOK True + let resultOK = evmtoolTraceOutput.output.output == hevmTraceResult.out + if resultOK then do + putStrLn $ "HEVM & evmtool's outputs match: '" <> (bsToHex $ bssToBs evmtoolTraceOutput.output.output) <> "'" + if isNothing simplConcrExprRetval || (fromJust simplConcrExprRetval) == (bssToBs hevmTraceResult.out) + then do + putStr "OK, symbolic interpretation -> concrete calldata -> Expr.simplify gives the same answer." + if isNothing simplConcrExprRetval then putStrLn ", but it was a Nothing, so not strong equivalence" + else putStrLn "" + else do + putStrLn $ "original expr : " <> (show expr) + putStrLn $ "concretized expr : " <> (show concretizedExpr) + putStrLn $ "simplified concretized expr : " <> (show simplConcExpr) + putStrLn $ "evmtoolTraceOutput.output.output : " <> (show (evmtoolTraceOutput.output.output)) + putStrLn $ "HEVM trace result output : " <> (bsToHex (bssToBs hevmTraceResult.out)) + putStrLn $ "ret value computed via symb+conc : " <> (bsToHex (fromJust simplConcrExprRetval)) + assertEqual "Simplified, concretized expression must match evmtool's output." True False + else do + putStrLn $ "Name of trace file: " <> (getTraceFileName $ fromJust evmtoolResult) + putStrLn $ "HEVM result :" <> (show hevmTraceResult) + T.putStrLn $ "HEVM result: " <> (formatBinary $ bssToBs hevmTraceResult.out) + T.putStrLn $ "evm result : " <> (formatBinary $ bssToBs evmtoolTraceOutput.output.output) + putStrLn $ "HEVM result len: " <> (show (BS.length $ bssToBs hevmTraceResult.out)) + putStrLn $ "evm result len: " <> (show (BS.length $ bssToBs evmtoolTraceOutput.output.output)) + assertEqual "Contract exec successful. HEVM & evmtool's outputs must match" resultOK True + Left (evmerr, hevmTrace) -> do + putStrLn $ "HEVM contract exec issue: " <> (show evmerr) + -- putStrLn $ "evmtool result was: " <> show (fromJust evmtoolResult) + -- putStrLn $ "output by evmtool is: '" <> bsToHex evmtoolTraceOutput.toOutput.output <> "'" + traceOK <- compareTraces hevmTrace (evmtoolTraceOutput.trace) + assertEqual "Traces and gas must match" traceOK True + System.Directory.removeFile "txs.json" + System.Directory.removeFile "alloc-out.json" + System.Directory.removeFile "alloc.json" + System.Directory.removeFile "result.json" + System.Directory.removeFile "env.json" + deleteTraceOutputFiles evmtoolResult + +-- GasLimitInt +newtype GasLimitInt = GasLimitInt (Int) + deriving (Show, Eq) + +instance Arbitrary GasLimitInt where + arbitrary = do + let mkLimit = chooseInt (50000, 0xfffff) + fmap GasLimitInt mkLimit + +-- GenTxDataRaw +newtype TxDataRaw = TxDataRaw ([Int]) + deriving (Show, Eq) + +instance Arbitrary TxDataRaw where + arbitrary = do + let + txDataRaw = sized $ \n -> vectorOf (10*n+5) $ chooseInt (0,255) + fmap TxDataRaw txDataRaw diff --git a/test/EVM/Test/Utils.hs b/test/EVM/Test/Utils.hs --- a/test/EVM/Test/Utils.hs +++ b/test/EVM/Test/Utils.hs @@ -7,6 +7,7 @@ import Data.Text qualified as T import Data.Text.IO qualified as T import GHC.IO.Handle (hClose) +import GHC.Natural import Paths_hevm qualified as Paths import System.Directory import System.IO.Temp @@ -17,37 +18,27 @@ import EVM.Fetch (RpcInfo) import EVM.Solidity import EVM.Solvers -import EVM.TTY qualified as TTY import EVM.UnitTest +import Control.Monad.ST (RealWorld) -runSolidityTestCustom :: FilePath -> Text -> Maybe Integer -> Bool -> RpcInfo -> ProjectType -> IO Bool -runSolidityTestCustom testFile match maxIter ffiAllowed rpcinfo projectType = do +runSolidityTestCustom :: FilePath -> Text -> Maybe Natural -> Maybe Integer -> Bool -> RpcInfo -> ProjectType -> IO Bool +runSolidityTestCustom testFile match timeout maxIter ffiAllowed rpcinfo projectType = do withSystemTempDirectory "dapp-test" $ \root -> do compile projectType root testFile >>= \case Left e -> error e Right bo@(BuildOutput contracts _) -> do - withSolvers Z3 1 Nothing $ \solvers -> do + withSolvers Z3 1 timeout $ \solvers -> do opts <- testOpts solvers root (Just bo) match maxIter ffiAllowed rpcinfo - unitTest opts contracts Nothing + unitTest opts contracts runSolidityTest :: FilePath -> Text -> IO Bool -runSolidityTest testFile match = runSolidityTestCustom testFile match Nothing True Nothing Foundry - -debugSolidityTest :: FilePath -> RpcInfo -> IO () -debugSolidityTest testFile rpcinfo = do - withSystemTempDirectory "dapp-test" $ \root -> do - compile DappTools root testFile >>= \case - Left e -> error e - Right bo -> do - withSolvers Z3 1 Nothing $ \solvers -> do - opts <- testOpts solvers root (Just bo) ".*" Nothing True rpcinfo - TTY.main opts root (Just bo) +runSolidityTest testFile match = runSolidityTestCustom testFile match Nothing Nothing True Nothing Foundry -testOpts :: SolverGroup -> FilePath -> Maybe BuildOutput -> Text -> Maybe Integer -> Bool -> RpcInfo -> IO UnitTestOptions +testOpts :: SolverGroup -> FilePath -> Maybe BuildOutput -> Text -> Maybe Integer -> Bool -> RpcInfo -> IO (UnitTestOptions RealWorld) testOpts solvers root buildOutput match maxIter allowFFI rpcinfo = do let srcInfo = maybe emptyDapp (dappInfo root) buildOutput - params <- getParametersFromEnvironmentVariables Nothing + params <- paramsFromRpc rpcinfo pure UnitTestOptions { solvers = solvers @@ -57,13 +48,8 @@ , smtDebug = False , smtTimeout = Nothing , solver = Nothing - , covMatch = Nothing , verbose = Just 1 , match = match - , maxDepth = Nothing - , fuzzRuns = 100 - , replay = Nothing - , vmModifier = id , testParams = params , dapp = srcInfo , ffiAllowed = allowFFI diff --git a/test/contracts/fail/cheatCodes.sol b/test/contracts/fail/cheatCodes.sol deleted file mode 100644 --- a/test/contracts/fail/cheatCodes.sol +++ /dev/null @@ -1,39 +0,0 @@ -import "ds-test/test.sol"; - -interface Hevm { - function warp(uint256) external; - function roll(uint256) external; - function load(address,bytes32) external returns (bytes32); - function store(address,bytes32,bytes32) external; - 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 Payable { - function hi() public payable {} -} - -contract TestFailCheatCodes is DSTest { - Hevm hevm = Hevm(HEVM_ADDRESS); - - function testBadFFI() public { - string[] memory inputs = new string[](2); - inputs[0] = "echo"; - inputs[1] = "acab"; - - // should revert if --ffi hasn't been passed to hevm... - hevm.ffi(inputs); - } - - function test_prank_underflow() public { - address from = address(0x1312); - uint amt = 10; - - Payable target = new Payable(); - - hevm.prank(from); - target.hi{value : amt}(); - } -} diff --git a/test/contracts/fail/dsProveFail.sol b/test/contracts/fail/dsProveFail.sol deleted file mode 100644 --- a/test/contracts/fail/dsProveFail.sol +++ /dev/null @@ -1,66 +0,0 @@ -import "ds-test/test.sol"; -import "tokens/erc20.sol"; - -contract SolidityTest is DSTest { - ERC20 token; - - function setUp() public { - token = new ERC20("TOKEN", "TKN", 18); - } - - function prove_trivial() public { - assert(false); - } - - function prove_add(uint x, uint y) public { - unchecked { - assertTrue(x + y >= x); - } - } - - //function proveFail_shouldFail(address usr) public { - //usr.call(""); - //} - - function prove_smtTimeout(uint x, uint y, uint z) public { - if ((x * y / z) * (x / y) / (x * y) == (x * x * x * y * z / x * z * y)) { - assertTrue(false); - } else { - assertTrue(true); - } - } - - function prove_multi(uint x) public { - if (x == 3) { - assertTrue(false); - } else if (x == 9) { - assertTrue(false); - } else if (x == 1023423194871904872390487213) { - assertTrue(false); - } else { - assertTrue(true); - } - } - - function prove_mul(uint136 x, uint128 y) public { - x * y; - } - - function prove_distributivity(uint120 x, uint120 y, uint120 z) public { - assertEq(x + (y * z), (x + y) * (x + z)); - } - - function prove_transfer(uint supply, address usr, uint amt) public { - token.mint(address(this), supply); - - uint prebal = token.balanceOf(usr); - token.transfer(usr, amt); - uint postbal = token.balanceOf(usr); - - uint expected = usr == address(this) - ? 0 // self transfer is a noop - : amt; // otherwise `amt` has been transfered to `usr` - assertEq(expected, postbal - prebal); - } -} - diff --git a/test/contracts/fail/invariantFail.sol b/test/contracts/fail/invariantFail.sol deleted file mode 100644 --- a/test/contracts/fail/invariantFail.sol +++ /dev/null @@ -1,50 +0,0 @@ -import "ds-test/test.sol"; - -contract Testdapp { - uint public x; - function f() public { - x++; - } - function g(uint y) public { - if (y % 2 == 0) x*=2; - } -} - - -contract TestdappTest is DSTest { - Testdapp testdapp; - - function setUp() public { - testdapp = new Testdapp(); - } - - function invariantFirst() public { - assertLt(testdapp.x(), 100); - } -} - -contract InvariantCount is DSTest { - BrokenAtStart count; - address[] targetContracts_; - - function targetContracts() public returns (address[] memory) { - return targetContracts_; - } - function setUp() public { - count = new BrokenAtStart(); - targetContracts_.push(address(count)); - } - - // this can only fail if we call the invariant method before calling any other method in the target contracts - function invariantCount() public { - assertGt(count.count(), 0); - } -} - -contract BrokenAtStart { - uint public count; - - function inc() public { - count++; - } -} diff --git a/test/contracts/fail/trivial.sol b/test/contracts/fail/trivial.sol deleted file mode 100644 --- a/test/contracts/fail/trivial.sol +++ /dev/null @@ -1,9 +0,0 @@ -import {DSTest} from "ds-test/test.sol"; - -// should run and pass -contract Trivial is DSTest { - function testFalse() public { - assertTrue(false); - } -} - diff --git a/test/contracts/lib/erc20.sol b/test/contracts/lib/erc20.sol deleted file mode 100644 --- a/test/contracts/lib/erc20.sol +++ /dev/null @@ -1,201 +0,0 @@ -// modified from solmate erc20 -// https://github.com/transmissions11/solmate/blob/c2594bf4635ad773a8f4763e20b7e79582e41535/src/tokens/ERC20.sol - -/// @notice Modern and gas efficient ERC20 + EIP-2612 implementation. -/// @author Solmate (https://github.com/transmissions11/solmate/blob/main/src/tokens/ERC20.sol) -/// @author Modified from Uniswap (https://github.com/Uniswap/uniswap-v2-core/blob/master/contracts/UniswapV2ERC20.sol) -/// @dev Do not manually set balances without updating totalSupply, as the sum of all user balances must not exceed it. -contract ERC20 { - - // --- events --- - - event Transfer(address indexed from, address indexed to, uint256 amount); - event Approval(address indexed owner, address indexed spender, uint256 amount); - - // --- metadata --- - - string public name; - string public symbol; - uint8 public immutable decimals; - - // --- erc20 data --- - - uint256 public totalSupply; - mapping(address => uint256) public balanceOf; - mapping(address => mapping(address => uint256)) public allowance; - - // --- eip2612 data --- - - uint256 internal immutable INITIAL_CHAIN_ID; - bytes32 internal immutable INITIAL_DOMAIN_SEPARATOR; - mapping(address => uint256) public nonces; - - // --- admin --- - - address public owner; - modifier auth { require(owner == msg.sender, "not-authorized"); _; } - - // --- init --- - - constructor( - string memory _name, - string memory _symbol, - uint8 _decimals - ) { - name = _name; - symbol = _symbol; - decimals = _decimals; - - INITIAL_CHAIN_ID = block.chainid; - INITIAL_DOMAIN_SEPARATOR = computeDomainSeparator(); - - owner = msg.sender; - } - - // --- erc20 logic --- - - function approve(address spender, uint256 amount) public returns (bool) { - allowance[msg.sender][spender] = amount; - - emit Approval(msg.sender, spender, amount); - - return true; - } - - function transfer(address to, uint256 amount) public returns (bool) { - balanceOf[msg.sender] -= amount; - - // Cannot overflow because the sum of all user - // balances can't exceed the max uint256 value. - unchecked { - balanceOf[to] += amount; - } - - emit Transfer(msg.sender, to, amount); - - return true; - } - - function transferFrom( - address from, - address to, - uint256 amount - ) public returns (bool) { - uint256 allowed = allowance[from][msg.sender]; // Saves gas for limited approvals. - - if (allowed != type(uint256).max) allowance[from][msg.sender] = allowed - amount; - - balanceOf[from] -= amount; - - // Cannot overflow because the sum of all user - // balances can't exceed the max uint256 value. - unchecked { - balanceOf[to] += amount; - } - - emit Transfer(from, to, amount); - - return true; - } - - // --- mint / burn logic --- - - function mint(address to, uint256 amount) public auth { - _mint(to, amount); - } - - function burn(address from, uint256 amount) public auth { - _burn(from, amount); - } - - // --- eip2612 logic --- - - function permit( - address owner, - address spender, - uint256 value, - uint256 deadline, - uint8 v, - bytes32 r, - bytes32 s - ) public { - require(deadline >= block.timestamp, "PERMIT_DEADLINE_EXPIRED"); - - // Unchecked because the only math done is incrementing - // the owner's nonce which cannot realistically overflow. - unchecked { - address recoveredAddress = ecrecover( - keccak256( - abi.encodePacked( - "\x19\x01", - DOMAIN_SEPARATOR(), - keccak256( - abi.encode( - keccak256( - "Permit(address owner,address spender,uint256 value,uint256 nonce,uint256 deadline)" - ), - owner, - spender, - value, - nonces[owner]++, - deadline - ) - ) - ) - ), - v, - r, - s - ); - - require(recoveredAddress != address(0) && recoveredAddress == owner, "INVALID_SIGNER"); - - allowance[recoveredAddress][spender] = value; - } - - emit Approval(owner, spender, value); - } - - function DOMAIN_SEPARATOR() public view returns (bytes32) { - return block.chainid == INITIAL_CHAIN_ID ? INITIAL_DOMAIN_SEPARATOR : computeDomainSeparator(); - } - - function computeDomainSeparator() internal view returns (bytes32) { - return - keccak256( - abi.encode( - keccak256("EIP712Domain(string name,string version,uint256 chainId,address verifyingContract)"), - keccak256(bytes(name)), - keccak256("1"), - block.chainid, - address(this) - ) - ); - } - - // --- internal mint / burn logic --- - - function _mint(address to, uint256 amount) internal { - totalSupply += amount; - - // Cannot overflow because the sum of all user - // balances can't exceed the max uint256 value. - unchecked { - balanceOf[to] += amount; - } - - emit Transfer(address(0), to, amount); - } - - function _burn(address from, uint256 amount) internal { - balanceOf[from] -= amount; - - // Cannot underflow because a user's balance - // will never be larger than the total supply. - unchecked { - totalSupply -= amount; - } - - emit Transfer(from, address(0), amount); - } -} diff --git a/test/contracts/lib/test.sol b/test/contracts/lib/test.sol deleted file mode 100644 --- a/test/contracts/lib/test.sol +++ /dev/null @@ -1,469 +0,0 @@ -// SPDX-License-Identifier: GPL-3.0-or-later - -// This program is free software: you can redistribute it and/or modify -// it under the terms of the GNU General Public License as published by -// the Free Software Foundation, either version 3 of the License, or -// (at your option) any later version. - -// This program is distributed in the hope that it will be useful, -// but WITHOUT ANY WARRANTY; without even the implied warranty of -// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -// GNU General Public License for more details. - -// You should have received a copy of the GNU General Public License -// along with this program. If not, see . - -pragma solidity >=0.5.0; - -contract DSTest { - event log (string); - event logs (bytes); - - event log_address (address); - event log_bytes32 (bytes32); - event log_int (int); - event log_uint (uint); - event log_bytes (bytes); - event log_string (string); - - event log_named_address (string key, address val); - event log_named_bytes32 (string key, bytes32 val); - event log_named_decimal_int (string key, int val, uint decimals); - event log_named_decimal_uint (string key, uint val, uint decimals); - event log_named_int (string key, int val); - event log_named_uint (string key, uint val); - event log_named_bytes (string key, bytes val); - event log_named_string (string key, string val); - - bool public IS_TEST = true; - bool private _failed; - - address constant HEVM_ADDRESS = - address(bytes20(uint160(uint256(keccak256('hevm cheat code'))))); - - modifier mayRevert() { _; } - modifier testopts(string memory) { _; } - - function failed() public returns (bool) { - if (_failed) { - return _failed; - } else { - bool globalFailed = false; - if (hasHEVMContext()) { - (, bytes memory retdata) = HEVM_ADDRESS.call( - abi.encodePacked( - bytes4(keccak256("load(address,bytes32)")), - abi.encode(HEVM_ADDRESS, bytes32("failed")) - ) - ); - globalFailed = abi.decode(retdata, (bool)); - } - return globalFailed; - } - } - - function fail() internal { - if (hasHEVMContext()) { - (bool status, ) = HEVM_ADDRESS.call( - abi.encodePacked( - bytes4(keccak256("store(address,bytes32,bytes32)")), - abi.encode(HEVM_ADDRESS, bytes32("failed"), bytes32(uint256(0x01))) - ) - ); - status; // Silence compiler warnings - } - _failed = true; - } - - function hasHEVMContext() internal view returns (bool) { - uint256 hevmCodeSize = 0; - assembly { - hevmCodeSize := extcodesize(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D) - } - return hevmCodeSize > 0; - } - - modifier logs_gas() { - uint startGas = gasleft(); - _; - uint endGas = gasleft(); - emit log_named_uint("gas", startGas - endGas); - } - - function assertTrue(bool condition) internal { - if (!condition) { - emit log("Error: Assertion Failed"); - fail(); - } - } - - function assertTrue(bool condition, string memory err) internal { - if (!condition) { - emit log_named_string("Error", err); - assertTrue(condition); - } - } - - function assertEq(address a, address b) internal { - if (a != b) { - emit log("Error: a == b not satisfied [address]"); - emit log_named_address(" Expected", b); - emit log_named_address(" Actual", a); - fail(); - } - } - function assertEq(address a, address b, string memory err) internal { - if (a != b) { - emit log_named_string ("Error", err); - assertEq(a, b); - } - } - - function assertEq(bytes32 a, bytes32 b) internal { - if (a != b) { - emit log("Error: a == b not satisfied [bytes32]"); - emit log_named_bytes32(" Expected", b); - emit log_named_bytes32(" Actual", a); - fail(); - } - } - function assertEq(bytes32 a, bytes32 b, string memory err) internal { - if (a != b) { - emit log_named_string ("Error", err); - assertEq(a, b); - } - } - function assertEq32(bytes32 a, bytes32 b) internal { - assertEq(a, b); - } - function assertEq32(bytes32 a, bytes32 b, string memory err) internal { - assertEq(a, b, err); - } - - function assertEq(int a, int b) internal { - if (a != b) { - emit log("Error: a == b not satisfied [int]"); - emit log_named_int(" Expected", b); - emit log_named_int(" Actual", a); - fail(); - } - } - function assertEq(int a, int b, string memory err) internal { - if (a != b) { - emit log_named_string("Error", err); - assertEq(a, b); - } - } - function assertEq(uint a, uint b) internal { - if (a != b) { - emit log("Error: a == b not satisfied [uint]"); - emit log_named_uint(" Expected", b); - emit log_named_uint(" Actual", a); - fail(); - } - } - function assertEq(uint a, uint b, string memory err) internal { - if (a != b) { - emit log_named_string("Error", err); - assertEq(a, b); - } - } - function assertEqDecimal(int a, int b, uint decimals) internal { - if (a != b) { - emit log("Error: a == b not satisfied [decimal int]"); - emit log_named_decimal_int(" Expected", b, decimals); - emit log_named_decimal_int(" Actual", a, decimals); - fail(); - } - } - function assertEqDecimal(int a, int b, uint decimals, string memory err) internal { - if (a != b) { - emit log_named_string("Error", err); - assertEqDecimal(a, b, decimals); - } - } - function assertEqDecimal(uint a, uint b, uint decimals) internal { - if (a != b) { - emit log("Error: a == b not satisfied [decimal uint]"); - emit log_named_decimal_uint(" Expected", b, decimals); - emit log_named_decimal_uint(" Actual", a, decimals); - fail(); - } - } - function assertEqDecimal(uint a, uint b, uint decimals, string memory err) internal { - if (a != b) { - emit log_named_string("Error", err); - assertEqDecimal(a, b, decimals); - } - } - - function assertGt(uint a, uint b) internal { - if (a <= b) { - emit log("Error: a > b not satisfied [uint]"); - emit log_named_uint(" Value a", a); - emit log_named_uint(" Value b", b); - fail(); - } - } - function assertGt(uint a, uint b, string memory err) internal { - if (a <= b) { - emit log_named_string("Error", err); - assertGt(a, b); - } - } - function assertGt(int a, int b) internal { - if (a <= b) { - emit log("Error: a > b not satisfied [int]"); - emit log_named_int(" Value a", a); - emit log_named_int(" Value b", b); - fail(); - } - } - function assertGt(int a, int b, string memory err) internal { - if (a <= b) { - emit log_named_string("Error", err); - assertGt(a, b); - } - } - function assertGtDecimal(int a, int b, uint decimals) internal { - if (a <= b) { - emit log("Error: a > b not satisfied [decimal int]"); - emit log_named_decimal_int(" Value a", a, decimals); - emit log_named_decimal_int(" Value b", b, decimals); - fail(); - } - } - function assertGtDecimal(int a, int b, uint decimals, string memory err) internal { - if (a <= b) { - emit log_named_string("Error", err); - assertGtDecimal(a, b, decimals); - } - } - function assertGtDecimal(uint a, uint b, uint decimals) internal { - if (a <= b) { - emit log("Error: a > b not satisfied [decimal uint]"); - emit log_named_decimal_uint(" Value a", a, decimals); - emit log_named_decimal_uint(" Value b", b, decimals); - fail(); - } - } - function assertGtDecimal(uint a, uint b, uint decimals, string memory err) internal { - if (a <= b) { - emit log_named_string("Error", err); - assertGtDecimal(a, b, decimals); - } - } - - function assertGe(uint a, uint b) internal { - if (a < b) { - emit log("Error: a >= b not satisfied [uint]"); - emit log_named_uint(" Value a", a); - emit log_named_uint(" Value b", b); - fail(); - } - } - function assertGe(uint a, uint b, string memory err) internal { - if (a < b) { - emit log_named_string("Error", err); - assertGe(a, b); - } - } - function assertGe(int a, int b) internal { - if (a < b) { - emit log("Error: a >= b not satisfied [int]"); - emit log_named_int(" Value a", a); - emit log_named_int(" Value b", b); - fail(); - } - } - function assertGe(int a, int b, string memory err) internal { - if (a < b) { - emit log_named_string("Error", err); - assertGe(a, b); - } - } - function assertGeDecimal(int a, int b, uint decimals) internal { - if (a < b) { - emit log("Error: a >= b not satisfied [decimal int]"); - emit log_named_decimal_int(" Value a", a, decimals); - emit log_named_decimal_int(" Value b", b, decimals); - fail(); - } - } - function assertGeDecimal(int a, int b, uint decimals, string memory err) internal { - if (a < b) { - emit log_named_string("Error", err); - assertGeDecimal(a, b, decimals); - } - } - function assertGeDecimal(uint a, uint b, uint decimals) internal { - if (a < b) { - emit log("Error: a >= b not satisfied [decimal uint]"); - emit log_named_decimal_uint(" Value a", a, decimals); - emit log_named_decimal_uint(" Value b", b, decimals); - fail(); - } - } - function assertGeDecimal(uint a, uint b, uint decimals, string memory err) internal { - if (a < b) { - emit log_named_string("Error", err); - assertGeDecimal(a, b, decimals); - } - } - - function assertLt(uint a, uint b) internal { - if (a >= b) { - emit log("Error: a < b not satisfied [uint]"); - emit log_named_uint(" Value a", a); - emit log_named_uint(" Value b", b); - fail(); - } - } - function assertLt(uint a, uint b, string memory err) internal { - if (a >= b) { - emit log_named_string("Error", err); - assertLt(a, b); - } - } - function assertLt(int a, int b) internal { - if (a >= b) { - emit log("Error: a < b not satisfied [int]"); - emit log_named_int(" Value a", a); - emit log_named_int(" Value b", b); - fail(); - } - } - function assertLt(int a, int b, string memory err) internal { - if (a >= b) { - emit log_named_string("Error", err); - assertLt(a, b); - } - } - function assertLtDecimal(int a, int b, uint decimals) internal { - if (a >= b) { - emit log("Error: a < b not satisfied [decimal int]"); - emit log_named_decimal_int(" Value a", a, decimals); - emit log_named_decimal_int(" Value b", b, decimals); - fail(); - } - } - function assertLtDecimal(int a, int b, uint decimals, string memory err) internal { - if (a >= b) { - emit log_named_string("Error", err); - assertLtDecimal(a, b, decimals); - } - } - function assertLtDecimal(uint a, uint b, uint decimals) internal { - if (a >= b) { - emit log("Error: a < b not satisfied [decimal uint]"); - emit log_named_decimal_uint(" Value a", a, decimals); - emit log_named_decimal_uint(" Value b", b, decimals); - fail(); - } - } - function assertLtDecimal(uint a, uint b, uint decimals, string memory err) internal { - if (a >= b) { - emit log_named_string("Error", err); - assertLtDecimal(a, b, decimals); - } - } - - function assertLe(uint a, uint b) internal { - if (a > b) { - emit log("Error: a <= b not satisfied [uint]"); - emit log_named_uint(" Value a", a); - emit log_named_uint(" Value b", b); - fail(); - } - } - function assertLe(uint a, uint b, string memory err) internal { - if (a > b) { - emit log_named_string("Error", err); - assertLe(a, b); - } - } - function assertLe(int a, int b) internal { - if (a > b) { - emit log("Error: a <= b not satisfied [int]"); - emit log_named_int(" Value a", a); - emit log_named_int(" Value b", b); - fail(); - } - } - function assertLe(int a, int b, string memory err) internal { - if (a > b) { - emit log_named_string("Error", err); - assertLe(a, b); - } - } - function assertLeDecimal(int a, int b, uint decimals) internal { - if (a > b) { - emit log("Error: a <= b not satisfied [decimal int]"); - emit log_named_decimal_int(" Value a", a, decimals); - emit log_named_decimal_int(" Value b", b, decimals); - fail(); - } - } - function assertLeDecimal(int a, int b, uint decimals, string memory err) internal { - if (a > b) { - emit log_named_string("Error", err); - assertLeDecimal(a, b, decimals); - } - } - function assertLeDecimal(uint a, uint b, uint decimals) internal { - if (a > b) { - emit log("Error: a <= b not satisfied [decimal uint]"); - emit log_named_decimal_uint(" Value a", a, decimals); - emit log_named_decimal_uint(" Value b", b, decimals); - fail(); - } - } - function assertLeDecimal(uint a, uint b, uint decimals, string memory err) internal { - if (a > b) { - emit log_named_string("Error", err); - assertGeDecimal(a, b, decimals); - } - } - - function assertEq(string memory a, string memory b) internal { - if (keccak256(abi.encodePacked(a)) != keccak256(abi.encodePacked(b))) { - emit log("Error: a == b not satisfied [string]"); - emit log_named_string(" Value a", a); - emit log_named_string(" Value b", b); - fail(); - } - } - function assertEq(string memory a, string memory b, string memory err) internal { - if (keccak256(abi.encodePacked(a)) != keccak256(abi.encodePacked(b))) { - emit log_named_string("Error", err); - assertEq(a, b); - } - } - - function checkEq0(bytes memory a, bytes memory b) internal pure returns (bool ok) { - ok = true; - if (a.length == b.length) { - for (uint i = 0; i < a.length; i++) { - if (a[i] != b[i]) { - ok = false; - } - } - } else { - ok = false; - } - } - function assertEq0(bytes memory a, bytes memory b) internal { - if (!checkEq0(a, b)) { - emit log("Error: a == b not satisfied [bytes]"); - emit log_named_bytes(" Expected", a); - emit log_named_bytes(" Actual", b); - fail(); - } - } - function assertEq0(bytes memory a, bytes memory b, string memory err) internal { - if (!checkEq0(a, b)) { - emit log_named_string("Error", err); - assertEq0(a, b); - } - } -} diff --git a/test/contracts/pass/abstract.sol b/test/contracts/pass/abstract.sol deleted file mode 100644 --- a/test/contracts/pass/abstract.sol +++ /dev/null @@ -1,15 +0,0 @@ -import {DSTest} from "ds-test/test.sol"; - -// should not be run (no code) -abstract contract MyTest is DSTest { - function testAbstract() public { - assertTrue(true); - } -} - -// should run and pass -contract TestMy is MyTest { - function testTrue() public { - assertTrue(true); - } -} diff --git a/test/contracts/pass/cheatCodes.sol b/test/contracts/pass/cheatCodes.sol deleted file mode 100644 --- a/test/contracts/pass/cheatCodes.sol +++ /dev/null @@ -1,125 +0,0 @@ -pragma experimental ABIEncoderV2; - -import "ds-test/test.sol"; - -interface Hevm { - function warp(uint256) external; - function roll(uint256) external; - function load(address,bytes32) external returns (bytes32); - function store(address,bytes32,bytes32) external; - 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 Payable { - function hi() public payable {} -} - -contract CheatCodes is DSTest { - address store = address(new HasStorage()); - Hevm hevm = Hevm(HEVM_ADDRESS); - - function test_warp_concrete(uint128 jump) public { - uint pre = block.timestamp; - hevm.warp(block.timestamp + jump); - assertEq(block.timestamp, pre + jump); - } - - function prove_warp_symbolic(uint128 jump) public { - test_warp_concrete(jump); - } - - function test_roll_concrete(uint64 jump) public { - uint pre = block.number; - hevm.roll(block.number + jump); - assertEq(block.number, pre + jump); - } - - function test_store_load_concrete(uint x) public { - uint ten = uint(hevm.load(store, bytes32(0))); - assertEq(ten, 10); - - hevm.store(store, bytes32(0), bytes32(x)); - uint val = uint(hevm.load(store, bytes32(0))); - assertEq(val, x); - } - - function prove_store_load_symbolic(uint x) public { - test_store_load_concrete(x); - } - - function test_sign_addr_digest(uint sk, bytes32 digest) public { - if (sk == 0) return; // invalid key - - (uint8 v, bytes32 r, bytes32 s) = hevm.sign(sk, digest); - address expected = hevm.addr(sk); - address actual = ecrecover(digest, v, r, s); - - assertEq(actual, expected); - } - - function test_sign_addr_message(uint sk, bytes memory message) public { - test_sign_addr_digest(sk, keccak256(message)); - } - - function testFail_sign_addr(uint sk, bytes32 digest) public { - uint badKey = sk + 1; - - (uint8 v, bytes32 r, bytes32 s) = hevm.sign(badKey, digest); - address expected = hevm.addr(sk); - address actual = ecrecover(digest, v, r, s); - - assertEq(actual, expected); - } - - function testFail_addr_zero_sk() public { - hevm.addr(0); - } - - function testFFI() public { - string[] memory inputs = new string[](3); - inputs[0] = "echo"; - inputs[1] = "-n"; - inputs[2] = "0x000000000000000000000000000000000000000000000000000000000000002000000000000000000000000000000000000000000000000000000000000000046163616200000000000000000000000000000000000000000000000000000000"; - - (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)); - } - - function test_prank_val() public { - address from = address(0x1312); - uint amt = 10; - - Payable target = new Payable(); - from.call{value: amt}(""); - - uint preBal = from.balance; - - hevm.prank(from); - target.hi{value : amt}(); - - uint postBal = from.balance; - - assertEq(preBal - postBal, amt); - } -} diff --git a/test/contracts/pass/constantinople.sol b/test/contracts/pass/constantinople.sol deleted file mode 100644 --- a/test/contracts/pass/constantinople.sol +++ /dev/null @@ -1,331 +0,0 @@ -import "ds-test/test.sol"; - -contract DeadCode{ - function dummy() external returns (uint256) {} -} - -contract ConstantinopleTests is DSTest { - DeadCode notmuch; - function setUp() public { - notmuch = new DeadCode(); - } - - // this 5 byte-long initcode simply returns nothing - // PUSH1 00 PUSH1 00 RETURN - // 60 00 60 00 f3 - bytes32 zerocode = 0x60006000f3000000000000000000000000000000000000000000000000000000; - // this 13 byte-long initcode simply returns 0xdeadbeef: - // PUSH4 de ad be ef PUSH1 00 MSTORE PUSH1 32 PUSH1 00 RETURN - // 63 de ad be ef 60 00 52 60 20 60 00 f3 - bytes32 deadcode = 0x63deadbeef60005260206000f300000000000000000000000000000000000000; - // this 25 byte-long initcode returns deadcode (but without the padding) - // PUSH1 0d PUSH1 0c PUSH1 00 CODECO PUSH1 0d PUSH1 00 RETURN deadcode - // 60 0d 60 0c 60 00 39 60 0d 60 00 f3 - bytes32 deploysdeadcode = 0x600d600c600039600d6000f363deadbeef60005260206000f300000000000000; - - // EXTCODEHASH of non-existent account is 0 - function test_extcodehash_1() public { - uint256 h; - assembly { - h := extcodehash(0x10) - } - assertEq(h, 0); - } - // EXTCODEHASH of account with no code is keccak256("") - function test_extcodehash_2() public { - address a; - uint256 h; - assembly { - let top := mload(0x40) - mstore(top, sload(zerocode.slot)) - a := create(0, top, 5) - h := extcodehash(a) - } - assertEq(h, 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470); - } - // EXTCODEHASH of account with code 0xdeadbeef is keccak256(0xdeadbeef) - function test_extcodehash_3() public { - address a; - uint256 h; - - assembly { - let top := mload(0x40) - mstore(top, sload(deadcode.slot)) - a := create(0, top, 13) - h := extcodehash(a) - } - - uint256 expected_h; - assembly { - let top := mload(0x40) - mstore(top, 0xdeadbeef) - expected_h := keccak256(top, 32) - } - assertEq(h, expected_h); - } - // EXTCODEHASH of the notmuch contract should be same as - // doing EXTCODECOPY and then keccak256 - function test_extcodehash_4() public { - address a = address(notmuch); - uint256 h; - - assembly { - h := extcodehash(a) - } - - uint256 expected_h; - assembly { - let top := mload(0x40) - let size := extcodesize(a) - extcodecopy(a, top, 0, size) - expected_h := keccak256(top, size) - } - assertEq(h, expected_h); - } - - // address of account created by CREATE2 is - // keccak256(0xff + address + salt + keccak256(init_code))[12:] - function test_create2_1() public { - address a; - uint256 salt = 0xfacefeed; - assembly { - let top := mload(0x40) - mstore(top, sload(deadcode.slot)) - a := create2(0, top, 13, salt) - } - - address expected_a; - - assembly { - let top := mload(0x40) - mstore(top, sload(deadcode.slot)) - let inithash := keccak256(top, 13) - mstore(sub(top, 11), address()) - mstore8(top, 0xff) - mstore(add(top, 21), salt) - mstore(add(top, 53), inithash) - expected_a := and(keccak256(top, 85), 0x000000000000000000000000ffffffffffffffffffffffffffffffffffffffff) - } - - assertEq(a, expected_a); - } - // calling a CREATE2 contract works as expected - function test_create2_2() public { - address a; - uint256 salt = 0xfacefeed; - assembly { - let top := mload(0x40) - mstore(top, sload(deploysdeadcode.slot)) - a := create2(0, top, 25, salt) - } - - assertEq(DeadCode(a).dummy(), 0xdeadbeef); - } - // TODO: test some SELFDESTRUCT properties of CREATE2 - // TODO: test EXTCODEHASH on self-destructed contract - // TODO: test EXTCODEHASH on precompiled contracts - - // SHL, SHR and SAR tests taken from - // https://github.com/ethereum/EIPs/blob/fde32dfd6b24bac7bfabf6c1ebe3f5a603d5ff4c/EIPS/eip-145.md - function test_shl() public { - uint z; - - assembly { - z := shl(0x00, 0x0000000000000000000000000000000000000000000000000000000000000001) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000001); - - assembly { - z := shl(0x01, 0x0000000000000000000000000000000000000000000000000000000000000001) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000002); - - assembly { - z := shl(0xff, 0x0000000000000000000000000000000000000000000000000000000000000001) - } - assertEq(z, 0x8000000000000000000000000000000000000000000000000000000000000000); - - assembly { - z := shl(0x0100, 0x0000000000000000000000000000000000000000000000000000000000000001) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); - - assembly { - z := shl(0x0101, 0x0000000000000000000000000000000000000000000000000000000000000001) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); - - assembly { - z := shl(0x00, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(z, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff); - - assembly { - z := shl(0x01, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(z, 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe); - - assembly { - z := shl(0xff, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(z, 0x8000000000000000000000000000000000000000000000000000000000000000); - - assembly { - z := shl(0x0100, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); - - assembly { - z := shl(0x01, 0x0000000000000000000000000000000000000000000000000000000000000000) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); - - assembly { - z := shl(0x01, 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(z, 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe); - } - - function test_shr() public { - uint z; - - assembly { - z := shr(0x00, 0x0000000000000000000000000000000000000000000000000000000000000001) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000001); - - assembly { - z := shr(0x01, 0x0000000000000000000000000000000000000000000000000000000000000001) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); - - assembly { - z := shr(0x01, 0x8000000000000000000000000000000000000000000000000000000000000000) - } - assertEq(z, 0x4000000000000000000000000000000000000000000000000000000000000000); - - assembly { - z := shr(0xff, 0x8000000000000000000000000000000000000000000000000000000000000000) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000001); - - assembly { - z := shr(0x0100, 0x8000000000000000000000000000000000000000000000000000000000000000) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); - - assembly { - z := shr(0x0101, 0x8000000000000000000000000000000000000000000000000000000000000000) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); - - assembly { - z := shr(0x00, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(z, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff); - - assembly { - z := shr(0x01, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(z, 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff); - - assembly { - z := shr(0xff, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000001); - - assembly { - z := shr(0x0100, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); - - assembly { - z := shr(0x01, 0x0000000000000000000000000000000000000000000000000000000000000000) - } - assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); - } - - function test_sar() public { - uint z; - - assembly { - z := sar(0x00, 0x0000000000000000000000000000000000000000000000000000000000000001) - } - assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000001)); - - assembly { - z := sar(0x01, 0x0000000000000000000000000000000000000000000000000000000000000001) - } - assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000000)); - - assembly { - z := sar(0x01, 0x8000000000000000000000000000000000000000000000000000000000000000) - } - assertEq(bytes32(z), bytes32(0xc000000000000000000000000000000000000000000000000000000000000000)); - - assembly { - z := sar(0xff, 0x8000000000000000000000000000000000000000000000000000000000000000) - } - assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); - - assembly { - z := sar(0x0100, 0x8000000000000000000000000000000000000000000000000000000000000000) - } - assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); - - assembly { - z := sar(0x0101, 0x8000000000000000000000000000000000000000000000000000000000000000) - } - assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); - - assembly { - z := sar(0x00, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); - - assembly { - z := sar(0x01, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); - - assembly { - z := sar(0xff, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); - - assembly { - z := sar(0x0100, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); - - assembly { - z := sar(0x01, 0x0000000000000000000000000000000000000000000000000000000000000000) - } - assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000000)); - - assembly { - z := sar(0xfe, 0x4000000000000000000000000000000000000000000000000000000000000000) - } - assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000001)); - - assembly { - z := sar(0xf8, 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(bytes32(z), bytes32(0x000000000000000000000000000000000000000000000000000000000000007f)); - - assembly { - z := sar(0xfe, 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000001)); - - assembly { - z := sar(0xff, 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000000)); - - assembly { - z := sar(0x0100, 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) - } - assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000000)); - } -} diff --git a/test/contracts/pass/dsProvePass.sol b/test/contracts/pass/dsProvePass.sol deleted file mode 100644 --- a/test/contracts/pass/dsProvePass.sol +++ /dev/null @@ -1,83 +0,0 @@ -import "ds-test/test.sol"; -import "tokens/erc20.sol"; - -contract ConstructorArg { - address immutable public a; - constructor(address _a) public { - a = _a; - } -} - -contract SolidityTest is DSTest { - ERC20 token; - - function setUp() public { - token = new ERC20("Token", "TKN", 18); - } - - function prove_trivial() public { - assertTrue(true); - } - - function prove_easy(uint v) public { - if (v != 100) return; - assertEq(v, 100); - } - - function prove_add(uint x, uint y) public { - unchecked { - if (x + y < x) return; // no overflow - assertTrue(x + y >= x); - } - } - - function prove_balance(address usr, uint amt) public { - assertEq(0, token.balanceOf(usr)); - token.mint(usr, amt); - assertEq(amt, token.balanceOf(usr)); - } - - function prove_supply(uint supply) public { - token.mint(address(this), supply); - uint actual = token.totalSupply(); - assertEq(supply, actual); - } - - function prove_constructorArgs(address b) public { - ConstructorArg c = new ConstructorArg(b); - assertEq(b, c.a()); - } - - function proveFail_revertSmoke() public { - require(false); - } - - function proveFail_assertSmoke() public { - assertTrue(false); - } - - // Takes too long, disabling here, moving to benchmarks - // function prove_transfer(uint supply, address usr, uint amt) public { - // if (amt > supply) return; // no underflow - // - // token.mint(address(this), supply); - // - // uint prebal = token.balanceOf(usr); - // token.transfer(usr, amt); - // uint postbal = token.balanceOf(usr); - // - // uint expected = usr == address(this) - // ? 0 // self transfer is a noop - // : amt; // otherwise `amt` has been transfered to `usr` - // assertEq(expected, postbal - prebal); - // } - - function prove_burn(uint supply, uint amt) public { - if (amt > supply) return; // no undeflow - - token.mint(address(this), supply); - token.burn(address(this), amt); - - assertEq(supply - amt, token.totalSupply()); - } -} diff --git a/test/contracts/pass/invariants.sol b/test/contracts/pass/invariants.sol deleted file mode 100644 --- a/test/contracts/pass/invariants.sol +++ /dev/null @@ -1,41 +0,0 @@ -import "ds-test/test.sol"; -import "tokens/erc20.sol"; - -contract InvariantTest is DSTest { - ERC20 token; - User user; - address[] targetContracts_; - - function targetContracts() public returns (address[] memory) { - return targetContracts_; - } - - function setUp() public { - token = new ERC20("TOKEN", "TKN", 18); - user = new User(token); - token.mint(address(user), type(uint).max); - targetContracts_.push(address(user)); - } - - function invariantTestThisBal() public { - assertLe(token.balanceOf(address(user)), type(uint).max); - } - function invariantTotSupply() public { - assertEq(token.totalSupply(), type(uint).max); - } -} - -contract User { - ERC20 token; - constructor(ERC20 token_) public { - token = token_; - } - - function doTransfer(address to, uint amount) public { - token.transfer(to, amount); - } - - function doSelfTransfer(uint amount) public { - token.transfer(address(this), amount); - } -} diff --git a/test/contracts/pass/libraries.sol b/test/contracts/pass/libraries.sol deleted file mode 100644 --- a/test/contracts/pass/libraries.sol +++ /dev/null @@ -1,18 +0,0 @@ -import "ds-test/test.sol"; - -library A { - function f(uint128 x) public returns (uint256) { - return uint(x) * 2; - } -} - -contract B is DSTest { - using A for uint128; - function test_f(uint128 x) public { - assertEq(uint(x) * 2, x.f()); - } - - function testFail_f() public { - assertEq(1, uint128(1).f()); - } -} diff --git a/test/contracts/pass/loops.sol b/test/contracts/pass/loops.sol deleted file mode 100644 --- a/test/contracts/pass/loops.sol +++ /dev/null @@ -1,12 +0,0 @@ -import "ds-test/test.sol"; - -contract Loops is DSTest { - - function prove_loop(uint n) public { - uint counter = 0; - for (uint i = 0; i < n; i++) { - counter++; - } - assertTrue(counter < 100); - } -} diff --git a/test/contracts/pass/rpc.sol b/test/contracts/pass/rpc.sol deleted file mode 100644 --- a/test/contracts/pass/rpc.sol +++ /dev/null @@ -1,16 +0,0 @@ -import {DSTest} from "ds-test/test.sol"; -import {ERC20} from "tokens/erc20.sol"; - -contract C is DSTest { - // BAL: https://etherscan.io/address/0xba100000625a3754423978a60c9317c58a424e3D#code - ERC20 bal = ERC20(0xba100000625a3754423978a60c9317c58a424e3D); - - function test_trivial() public { - uint ub = bal.balanceOf(0xBA12222222228d8Ba445958a75a0704d566BF2C8); - assertEq(ub, 27099516537379438397130892); - } - - function prove_trivial() public { - test_trivial(); - } -} diff --git a/test/contracts/pass/trivial.sol b/test/contracts/pass/trivial.sol deleted file mode 100644 --- a/test/contracts/pass/trivial.sol +++ /dev/null @@ -1,9 +0,0 @@ -import {DSTest} from "ds-test/test.sol"; - -// should run and pass -contract Trivial is DSTest { - function testTrue() public { - assertTrue(true); - } -} - diff --git a/test/rpc.hs b/test/rpc.hs --- a/test/rpc.hs +++ b/test/rpc.hs @@ -10,6 +10,7 @@ import Data.Text (Text) import Data.Vector qualified as V +import Optics.Core import EVM (makeVm) import EVM.ABI import EVM.Fetch @@ -20,6 +21,7 @@ import EVM.Test.Utils import EVM.Solidity (ProjectType(..)) import EVM.Types hiding (BlockNumber) +import Control.Monad.ST (stToIO, RealWorld) main :: IO () main = defaultMain tests @@ -37,7 +39,7 @@ , prevRandao ) - assertEqual "coinbase" (Addr 0xea674fdde714fd979de3edf0f56aa9716b898ec8) cb + assertEqual "coinbase" (LitAddr 0xea674fdde714fd979de3edf0f56aa9716b898ec8) cb assertEqual "number" (BlockNumber numb) block assertEqual "basefee" 38572377838 basefee assertEqual "prevRan" 11049842297455506 prevRan @@ -51,7 +53,7 @@ , prevRandao ) - assertEqual "coinbase" (Addr 0x690b9a9e9aa1c9db991c7721a92d351db4fac990) cb + assertEqual "coinbase" (LitAddr 0x690b9a9e9aa1c9db991c7721a92d351db4fac990) cb assertEqual "number" (BlockNumber numb) block assertEqual "basefee" 22163046690 basefee assertEqual "prevRan" 0x2267531ab030ed32fd5f2ef51f81427332d0becbd74fe7f4cd5684ddf4b287e0 prevRan @@ -60,7 +62,7 @@ -- execute against remote state from a ds-test harness [ testCase "dapp-test" $ do let testFile = "test/contracts/pass/rpc.sol" - runSolidityTestCustom testFile ".*" Nothing False testRpcInfo Foundry >>= assertEqual "test result" True + runSolidityTestCustom testFile ".*" Nothing Nothing False testRpcInfo Foundry >>= assertEqual "test result" True -- concretely exec "transfer" on WETH9 using remote rpc -- https://etherscan.io/token/0xc02aaa39b223fe8d0a0e5c4f27ead9083c756cc2#code @@ -73,11 +75,11 @@ postVm <- withSolvers Z3 1 Nothing $ \solvers -> Stepper.interpret (oracle solvers (Just (BlockNumber blockNum, testRpc))) vm Stepper.runFully let - postStore = case postVm.env.storage of + wethStore = (fromJust $ Map.lookup (LitAddr 0xC02aaA39b223FE8D0A0e5C4F27eAD9083C756Cc2) postVm.env.contracts).storage + wethStore' = case wethStore of ConcreteStore s -> s - _ -> internalError "ConcreteStore expected" - wethStore = fromJust $ Map.lookup 0xC02aaA39b223FE8D0A0e5C4F27eAD9083C756Cc2 postStore - receiverBal = fromJust $ Map.lookup (keccak' (word256Bytes 0xdead <> word256Bytes 0x3)) wethStore + _ -> internalError "Expecting concrete store" + receiverBal = fromJust $ Map.lookup (keccak' (word256Bytes 0xdead <> word256Bytes 0x3)) wethStore' msg = case postVm.result of Just (VMSuccess m) -> m _ -> internalError "VMSuccess expected" @@ -100,49 +102,50 @@ ] -- call into WETH9 from 0xf04a... (a large holder) -weth9VM :: W256 -> (Expr Buf, [Prop]) -> IO VM +weth9VM :: W256 -> (Expr Buf, [Prop]) -> IO (VM RealWorld) weth9VM blockNum calldata' = do let - caller' = Lit 0xf04a5cc80b1e94c69b48f5ee68a08cd2f09a7c3e + caller' = LitAddr 0xf04a5cc80b1e94c69b48f5ee68a08cd2f09a7c3e weth9 = Addr 0xC02aaA39b223FE8D0A0e5C4F27eAD9083C756Cc2 callvalue' = Lit 0 vmFromRpc blockNum calldata' callvalue' caller' weth9 -vmFromRpc :: W256 -> (Expr Buf, [Prop]) -> Expr EWord -> Expr EWord -> Addr -> IO VM -vmFromRpc blockNum calldata' callvalue' caller' address' = do - ctrct <- fetchContractFrom (BlockNumber blockNum) testRpc address' >>= \case - Nothing -> internalError $ "contract not found: " <> show address' +vmFromRpc :: W256 -> (Expr Buf, [Prop]) -> Expr EWord -> Expr EAddr -> Addr -> IO (VM RealWorld) +vmFromRpc blockNum calldata callvalue caller address = do + ctrct <- fetchContractFrom (BlockNumber blockNum) testRpc address >>= \case + Nothing -> internalError $ "contract not found: " <> show address Just contract' -> return contract' blk <- fetchBlockFrom (BlockNumber blockNum) testRpc >>= \case Nothing -> internalError "could not fetch block" Just b -> pure b - pure $ makeVm $ VMOpts - { contract = ctrct - , calldata = calldata' - , value = callvalue' - , address = address' - , caller = caller' - , origin = 0xacab - , gas = 0xffffffffffffffff - , gaslimit = 0xffffffffffffffff - , baseFee = blk.baseFee - , priorityFee = 0 - , coinbase = blk.coinbase - , number = blk.number - , timestamp = blk.timestamp - , blockGaslimit = blk.gaslimit - , gasprice = 0 - , maxCodeSize = blk.maxCodeSize - , prevRandao = blk.prevRandao - , schedule = blk.schedule - , chainId = 1 - , create = False - , initialStorage = EmptyStore - , txAccessList = mempty - , allowFFI = False - } + stToIO $ (makeVm $ VMOpts + { contract = ctrct + , otherContracts = [] + , calldata = calldata + , value = callvalue + , address = LitAddr address + , caller = caller + , origin = LitAddr 0xacab + , gas = 0xffffffffffffffff + , gaslimit = 0xffffffffffffffff + , baseFee = blk.baseFee + , priorityFee = 0 + , coinbase = blk.coinbase + , number = blk.number + , timestamp = blk.timestamp + , blockGaslimit = blk.gaslimit + , gasprice = 0 + , maxCodeSize = blk.maxCodeSize + , prevRandao = blk.prevRandao + , schedule = blk.schedule + , chainId = 1 + , create = False + , baseState = EmptyBase + , txAccessList = mempty + , allowFFI = False + }) <&> set (#cache % #fetched % at address) (Just ctrct) testRpc :: Text testRpc = "https://eth-mainnet.alchemyapi.io/v2/vpeKFsEF6PHifHzdtcwXSDbhV3ym5Ro4" diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -7,2766 +7,3816 @@ import GHC.TypeLits import Data.Proxy -import Control.Monad.State.Strict -import Data.Bits hiding (And, Xor) -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Base16 qualified as BS16 -import Data.Binary.Put (runPut) -import Data.Binary.Get (runGetOrFail) -import Data.DoubleWord -import Data.List qualified as List -import Data.Map.Strict qualified as Map -import Data.Maybe -import Data.String.Here -import Data.Text (Text) -import Data.Text qualified as T -import Data.Time (diffUTCTime, getCurrentTime) -import Data.Typeable -import Data.Vector qualified as Vector -import GHC.Conc (getNumProcessors) -import System.Directory -import System.Environment -import Test.Tasty -import Test.Tasty.QuickCheck hiding (Failure, Success) -import Test.QuickCheck.Instances.Text() -import Test.QuickCheck.Instances.Natural() -import Test.QuickCheck.Instances.ByteString() -import Test.Tasty.HUnit -import Test.Tasty.Runners hiding (Failure, Success) -import Test.Tasty.ExpectedFailure -import Text.RE.TDFA.String -import Text.RE.Replace -import Witch (into, unsafeInto) - -import Optics.Core hiding (pre, re) -import Optics.State -import Optics.Operators.Unsafe - -import EVM hiding (choose) -import EVM.ABI -import EVM.Concrete (createAddress) -import EVM.Exec -import EVM.Expr qualified as Expr -import EVM.Fetch qualified as Fetch -import EVM.Format (hexText) -import EVM.Patricia qualified as Patricia -import EVM.Precompiled -import EVM.RLP -import EVM.SMT hiding (one) -import EVM.Solidity -import EVM.Solvers -import EVM.Stepper qualified as Stepper -import EVM.SymExec -import EVM.Test.Tracing qualified as Tracing -import EVM.Test.Utils -import EVM.Traversals -import EVM.Types - -main :: IO () -main = defaultMain tests - --- | run a subset of tests in the repl. p is a tasty pattern: --- https://github.com/UnkindPartition/tasty/tree/ee6fe7136fbcc6312da51d7f1b396e1a2d16b98a#patterns -runSubSet :: String -> IO () -runSubSet p = defaultMain . applyPattern p $ tests - -tests :: TestTree -tests = testGroup "hevm" - [ Tracing.tests - , testGroup "StorageTests" - [ testCase "read-from-sstore" $ assertEqual "" - (Lit 0xab) - (Expr.readStorage' (Lit 0x0) (Lit 0x0) (SStore (Lit 0x0) (Lit 0x0) (Lit 0xab) AbstractStore)) - , testCase "read-from-concrete" $ assertEqual "" - (Lit 0xab) - (Expr.readStorage' (Lit 0x0) (Lit 0x0) (ConcreteStore $ Map.fromList [(0x0, Map.fromList [(0x0, 0xab)])])) - , testCase "read-past-abstract-writes-to-different-address" $ assertEqual "" - (Lit 0xab) - (Expr.readStorage' (Lit 0x0) (Lit 0x0) (SStore (Lit 0x1) (Var "a") (Var "b") (ConcreteStore $ Map.fromList [(0x0, Map.fromList [(0x0, 0xab)])]))) - , testCase "abstract-slots-block-reads-for-same-address" $ assertEqual "" - (SLoad (Lit 0x0) (Lit 0x0) (SStore (Lit 0x0) (Var "b") (Var "c") (ConcreteStore $ Map.fromList [(0x0, Map.fromList [(0x0, 0xab)])]))) - (Expr.readStorage' (Lit 0x0) (Lit 0x0) - (SStore (Lit 0x1) (Var "1312") (Var "acab") (SStore (Lit 0x0) (Var "b") (Var "c") (ConcreteStore $ Map.fromList [(0x0, Map.fromList [(0x0, 0xab)])])))) - , testCase "abstract-addrs-block-reads" $ assertEqual "" - (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 (HandleEffect (Query (PleaseFetchContract _addr continue))) -> - execState (continue dummyContract) vm1 - _ -> internalError "unexpected result" - -- then it should fetch the slow - vm3 = case vm2.result of - Just (HandleEffect (Query (PleaseFetchSlot _addr _slot continue))) -> - execState (continue 1337) vm2 - _ -> internalError "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) - ] - , testGroup "SimplifierUnitTests" - -- common overflow cases that the simplifier was getting wrong - [ testCase "writeWord-overflow" $ do - let e = ReadByte (Lit 0x0) (WriteWord (Lit 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffd) (Lit 0x0) (ConcreteBuf "\255\255\255\255")) - b <- checkEquiv e (Expr.simplify e) - assertBool "Simplifier failed" b - , testCase "CopySlice-overflow" $ do - let e = ReadWord (Lit 0x0) (CopySlice (Lit 0x0) (Lit 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc) (Lit 0x6) (ConcreteBuf "\255\255\255\255\255\255") (ConcreteBuf "")) - b <- checkEquiv e (Expr.simplify e) - assertBool "Simplifier failed" b - , testCase "stripWrites-overflow" $ do - -- below eventually boils down to - -- unsafeInto (0xf0000000000000000000000000000000000000000000000000000000000000+1) :: Int - -- which failed before - let - a = ReadByte (Lit 0xf0000000000000000000000000000000000000000000000000000000000000) (WriteByte (And (SHA256 (ConcreteBuf "")) (Lit 0x1)) (LitByte 0) (ConcreteBuf "")) - b = Expr.simplify a - ret <- checkEquiv a b - assertBool "must be equivalent" ret - ] - -- These tests fuzz the simplifier by generating a random expression, - -- applying some simplification rules, and then using the smt encoding to - -- check that the simplified version is semantically equivalent to the - -- unsimplified one - , adjustOption (\(Test.Tasty.QuickCheck.QuickCheckTests n) -> Test.Tasty.QuickCheck.QuickCheckTests (min n 50)) $ testGroup "SimplifierTests" - [ testProperty "buffer-simplification" $ \(expr :: Expr Buf) -> ioProperty $ do - let simplified = Expr.simplify expr - checkEquiv expr simplified - , testProperty "store-simplification" $ \(expr :: Expr Storage) -> ioProperty $ do - let simplified = Expr.simplify expr - checkEquiv expr simplified - , testProperty "byte-simplification" $ \(expr :: Expr Byte) -> ioProperty $ do - let simplified = Expr.simplify expr - checkEquiv expr simplified - -- https://github.com/ethereum/hevm/issues/311 - , ignoreTest $ testProperty "word-simplification" $ \(ZeroDepthWord expr) -> ioProperty $ do - let simplified = Expr.simplify expr - checkEquiv expr simplified - , testProperty "readStorage-equivalance" $ \(store, addr, slot) -> ioProperty $ do - let simplified = Expr.readStorage' addr slot store - full = SLoad addr slot store - checkEquiv simplified full - , testProperty "writeStorage-equivalance" $ \(val, GenWriteStorageExpr (addr, slot, store)) -> ioProperty $ do - let simplified = Expr.writeStorage addr slot val store - full = SStore addr slot val store - checkEquiv simplified full - , testProperty "readWord-equivalance" $ \(buf, idx) -> ioProperty $ do - let simplified = Expr.readWord idx buf - full = ReadWord idx buf - checkEquiv simplified full - , testProperty "writeWord-equivalance" $ \(idx, val, WriteWordBuf buf) -> ioProperty $ do - 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 - checkEquiv simplified full - -- we currently only simplify concrete writes over concrete buffers so that's what we test here - , testProperty "writeByte-equivalance" $ \(LitOnly val, LitOnly buf, GenWriteByteIdx idx) -> ioProperty $ do - let simplified = Expr.writeByte idx val buf - full = WriteByte idx val buf - checkEquiv simplified full - , testProperty "copySlice-equivalance" $ \(srcOff, GenCopySliceBuf src, GenCopySliceBuf dst, LitWord @300 size) -> ioProperty $ do - -- we bias buffers to be concrete more often than not - dstOff <- generate (maybeBoundedLit 100_000) - let simplified = Expr.copySlice srcOff dstOff size src dst - full = CopySlice srcOff dstOff size src dst - checkEquiv simplified full - , testProperty "indexWord-equivalence" $ \(src, LitWord @50 idx) -> ioProperty $ do - let simplified = Expr.indexWord idx src - full = IndexWord idx src - checkEquiv simplified full - , testProperty "indexWord-mask-equivalence" $ \(src :: Expr EWord, LitWord @35 idx) -> ioProperty $ do - mask <- generate $ do - pow <- arbitrary :: Gen Int - frequency - [ (1, pure $ Lit $ (shiftL 1 (pow `mod` 256)) - 1) -- potentially non byte aligned - , (1, pure $ Lit $ (shiftL 1 ((pow * 8) `mod` 256)) - 1) -- byte aligned - ] - let - input = And mask src - simplified = Expr.indexWord idx input - full = IndexWord idx input - checkEquiv simplified full - , testProperty "toList-equivalance" $ \buf -> ioProperty $ do - let - -- transforms the input buffer to give it a known length - fixLength :: Expr Buf -> Gen (Expr Buf) - fixLength = mapExprM go - where - go :: Expr a -> Gen (Expr a) - go = \case - WriteWord _ val b -> liftM3 WriteWord idx (pure val) (pure b) - WriteByte _ val b -> liftM3 WriteByte idx (pure val) (pure b) - CopySlice so _ sz src dst -> liftM5 CopySlice (pure so) idx (pure sz) (pure src) (pure dst) - AbstractBuf _ -> cbuf - e -> pure e - cbuf = do - bs <- arbitrary - pure $ ConcreteBuf bs - idx = do - w <- arbitrary - -- we use 100_000 as an upper bound for indices to keep tests reasonably fast here - pure $ Lit (w `mod` 100_000) - - input <- generate $ fixLength buf - case Expr.toList input of - Nothing -> do - putStrLn "skip" - pure True -- ignore cases where the buf cannot be represented as a list - Just asList -> do - let asBuf = Expr.fromList asList - checkEquiv asBuf input - ] - , testGroup "MemoryTests" - [ testCase "read-write-same-byte" $ assertEqual "" - (LitByte 0x12) - (Expr.readByte (Lit 0x20) (WriteByte (Lit 0x20) (LitByte 0x12) mempty)) - , testCase "read-write-same-word" $ assertEqual "" - (Lit 0x12) - (Expr.readWord (Lit 0x20) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) - , testCase "read-byte-write-word" $ assertEqual "" - -- reading at byte 31 a word that's been written should return LSB - (LitByte 0x12) - (Expr.readByte (Lit 0x1f) (WriteWord (Lit 0x0) (Lit 0x12) mempty)) - , testCase "read-byte-write-word2" $ assertEqual "" - -- Same as above, but offset not 0 - (LitByte 0x12) - (Expr.readByte (Lit 0x20) (WriteWord (Lit 0x1) (Lit 0x12) mempty)) - ,testCase "read-write-with-offset" $ assertEqual "" - -- 0x3F = 63 decimal, 0x20 = 32. 0x12 = 18 - -- We write 128bits (32 Bytes), representing 18 at offset 32. - -- Hence, when reading out the 63rd byte, we should read out the LSB 8 bits - -- which is 0x12 - (LitByte 0x12) - (Expr.readByte (Lit 0x3F) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) - ,testCase "read-write-with-offset2" $ assertEqual "" - -- 0x20 = 32, 0x3D = 61 - -- we write 128 bits (32 Bytes) representing 0x10012, at offset 32. - -- we then read out a byte at offset 61. - -- So, at 63 we'd read 0x12, at 62 we'd read 0x00, at 61 we should read 0x1 - (LitByte 0x1) - (Expr.readByte (Lit 0x3D) (WriteWord (Lit 0x20) (Lit 0x10012) mempty)) - , testCase "read-write-with-extension-to-zero" $ assertEqual "" - -- write word and read it at the same place (i.e. 0 offset) - (Lit 0x12) - (Expr.readWord (Lit 0x0) (WriteWord (Lit 0x0) (Lit 0x12) mempty)) - , testCase "read-write-with-extension-to-zero-with-offset" $ assertEqual "" - -- write word and read it at the same offset of 4 - (Lit 0x12) - (Expr.readWord (Lit 0x4) (WriteWord (Lit 0x4) (Lit 0x12) mempty)) - , testCase "read-write-with-extension-to-zero-with-offset2" $ assertEqual "" - -- write word and read it at the same offset of 16 - (Lit 0x12) - (Expr.readWord (Lit 0x20) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) - , testCase "read-word-copySlice-overlap" $ assertEqual "" - -- we should not recurse into a copySlice if the read index + 32 overlaps the sliced region - (ReadWord (Lit 40) (CopySlice (Lit 0) (Lit 30) (Lit 12) (WriteWord (Lit 10) (Lit 0x64) (AbstractBuf "hi")) (AbstractBuf "hi"))) - (Expr.readWord (Lit 40) (CopySlice (Lit 0) (Lit 30) (Lit 12) (WriteWord (Lit 10) (Lit 0x64) (AbstractBuf "hi")) (AbstractBuf "hi"))) - , testCase "indexword-MSB" $ assertEqual "" - -- 31st is the LSB byte (of 32) - (LitByte 0x78) - (Expr.indexWord (Lit 31) (Lit 0x12345678)) - , testCase "indexword-LSB" $ assertEqual "" - -- 0th is the MSB byte (of 32), Lit 0xff22bb... is exactly 32 Bytes. - (LitByte 0xff) - (Expr.indexWord (Lit 0) (Lit 0xff22bb4455667788990011223344556677889900112233445566778899001122)) - , testCase "indexword-LSB2" $ assertEqual "" - -- same as above, but with offset 2 - (LitByte 0xbb) - (Expr.indexWord (Lit 2) (Lit 0xff22bb4455667788990011223344556677889900112233445566778899001122)) - , testCase "encodeConcreteStore-overwrite" $ - let - w :: Int -> W256 - w x = W256 $ EVM.Types.word256 $ BS.pack [fromIntegral x] - in - assertEqual "" - (EVM.SMT.encodeConcreteStore $ - Map.fromList [(w 1, (Map.fromList [(w 2, w 99), (w 2, w 100)]))]) - "(sstore (_ bv1 256) (_ bv2 256) (_ bv100 256) emptyStore)" - , testCase "indexword-oob-sym" $ assertEqual "" - -- indexWord should return 0 for oob access - (LitByte 0x0) - (Expr.indexWord (Lit 100) (JoinBytes - (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) - (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) - (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) - (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0))) - , testCase "stripbytes-concrete-bug" $ assertEqual "" - (Expr.simplifyReads (ReadByte (Lit 0) (ConcreteBuf "5"))) - (LitByte 53) - ] - , testGroup "ABI" - [ testProperty "Put/get inverse" $ \x -> - case runGetOrFail (getAbi (abiValueType x)) (runPut (putAbi x)) of - Right ("", _, x') -> x' == x - _ -> False - ] - , testGroup "Solidity-Expressions" - [ testCase "Trivial" $ - SolidityCall "x = 3;" [] - ===> AbiUInt 256 3 - - , testCase "Arithmetic" $ do - SolidityCall "x = a + 1;" - [AbiUInt 256 1] ===> AbiUInt 256 2 - SolidityCall "unchecked { x = a - 1; }" - [AbiUInt 8 0] ===> AbiUInt 8 255 - - , testCase "keccak256()" $ - SolidityCall "x = uint(keccak256(abi.encodePacked(a)));" - [AbiString ""] ===> AbiUInt 256 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470 - - , testProperty "abi encoding vs. solidity" $ withMaxSuccess 20 $ forAll (arbitrary >>= genAbiValue) $ - \y -> ioProperty $ do - Just encoded <- runStatements [i| x = abi.encode(a);|] - [y] AbiBytesDynamicType - let solidityEncoded = case decodeAbiValue (AbiTupleType $ Vector.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of - AbiTuple (Vector.toList -> [e]) -> e - _ -> internalError "AbiTuple expected" - let hevmEncoded = encodeAbiValue (AbiTuple $ Vector.fromList [y]) - assertEqual "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) - - , testProperty "abi encoding vs. solidity (2 args)" $ withMaxSuccess 20 $ forAll (arbitrary >>= bothM genAbiValue) $ - \(x', y') -> ioProperty $ do - Just encoded <- runStatements [i| x = abi.encode(a, b);|] - [x', y'] AbiBytesDynamicType - let solidityEncoded = case decodeAbiValue (AbiTupleType $ Vector.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of - AbiTuple (Vector.toList -> [e]) -> e - _ -> internalError "AbiTuple expected" - let hevmEncoded = encodeAbiValue (AbiTuple $ Vector.fromList [x',y']) - assertEqual "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) - - -- we need a separate test for this because the type of a function is "function() external" in solidity but just "function" in the abi: - , testProperty "abi encoding vs. solidity (function pointer)" $ withMaxSuccess 20 $ forAll (genAbiValue AbiFunctionType) $ - \y -> ioProperty $ do - Just encoded <- runFunction [i| - function foo(function() external a) public pure returns (bytes memory x) { - x = abi.encode(a); - } - |] (abiMethod "foo(function)" (AbiTuple (Vector.singleton y))) - let solidityEncoded = case decodeAbiValue (AbiTupleType $ Vector.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of - AbiTuple (Vector.toList -> [e]) -> e - _ -> internalError "AbiTuple expected" - let hevmEncoded = encodeAbiValue (AbiTuple $ Vector.fromList [y]) - assertEqual "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) - ] - - , testGroup "Precompiled contracts" - [ testGroup "Example (reverse)" - [ testCase "success" $ - assertEqual "example contract reverses" - (execute 0xdeadbeef "foobar" 6) (Just "raboof") - , testCase "failure" $ - assertEqual "example contract fails on length mismatch" - (execute 0xdeadbeef "foobar" 5) Nothing - ] - - , testGroup "ECRECOVER" - [ testCase "success" $ do - let - r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4732" - s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" - v = hex "000000000000000000000000000000000000000000000000000000000000001c" - h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31" - a = hex "0000000000000000000000002d5e56d45c63150d937f2182538a0f18510cb11f" - assertEqual "successful recovery" - (Just a) - (execute 1 (h <> v <> r <> s) 32) - , testCase "fail on made up values" $ do - let - r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4731" - s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" - v = hex "000000000000000000000000000000000000000000000000000000000000001c" - h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31" - assertEqual "fail because bit flip" - Nothing - (execute 1 (h <> v <> r <> s) 32) - ] - ] - , testGroup "Byte/word manipulations" - [ testProperty "padLeft length" $ \n (Bytes bs) -> - BS.length (padLeft n bs) == max n (BS.length bs) - , testProperty "padLeft identity" $ \(Bytes bs) -> - padLeft (BS.length bs) bs == bs - , testProperty "padRight length" $ \n (Bytes bs) -> - BS.length (padLeft n bs) == max n (BS.length bs) - , testProperty "padRight identity" $ \(Bytes bs) -> - padLeft (BS.length bs) bs == bs - , testProperty "padLeft zeroing" $ \(NonNegative n) (Bytes bs) -> - let x = BS.take n (padLeft (BS.length bs + n) bs) - y = BS.replicate n 0 - in x == y - ] - - , testGroup "Unresolved link detection" - [ testCase "holes detected" $ do - let code' = "608060405234801561001057600080fd5b5060405161040f38038061040f83398181016040528101906100329190610172565b73__$f3cbc3eb14e5bd0705af404abcf6f741ec$__63ab5c1ffe826040518263ffffffff1660e01b81526004016100699190610217565b60206040518083038186803b15801561008157600080fd5b505af4158015610095573d6000803e3d6000fd5b505050506040513d601f19601f820116820180604052508101906100b99190610145565b50506103c2565b60006100d36100ce84610271565b61024c565b9050828152602081018484840111156100ef576100ee610362565b5b6100fa8482856102ca565b509392505050565b600081519050610111816103ab565b92915050565b600082601f83011261012c5761012b61035d565b5b815161013c8482602086016100c0565b91505092915050565b60006020828403121561015b5761015a61036c565b5b600061016984828501610102565b91505092915050565b6000602082840312156101885761018761036c565b5b600082015167ffffffffffffffff8111156101a6576101a5610367565b5b6101b284828501610117565b91505092915050565b60006101c6826102a2565b6101d081856102ad565b93506101e08185602086016102ca565b6101e981610371565b840191505092915050565b60006102016003836102ad565b915061020c82610382565b602082019050919050565b6000604082019050818103600083015261023181846101bb565b90508181036020830152610244816101f4565b905092915050565b6000610256610267565b905061026282826102fd565b919050565b6000604051905090565b600067ffffffffffffffff82111561028c5761028b61032e565b5b61029582610371565b9050602081019050919050565b600081519050919050565b600082825260208201905092915050565b60008115159050919050565b60005b838110156102e85780820151818401526020810190506102cd565b838111156102f7576000848401525b50505050565b61030682610371565b810181811067ffffffffffffffff821117156103255761032461032e565b5b80604052505050565b7f4e487b7100000000000000000000000000000000000000000000000000000000600052604160045260246000fd5b600080fd5b600080fd5b600080fd5b600080fd5b6000601f19601f8301169050919050565b7f6261720000000000000000000000000000000000000000000000000000000000600082015250565b6103b4816102be565b81146103bf57600080fd5b50565b603f806103d06000396000f3fe6080604052600080fdfea26469706673582212207d03b26e43dc3d116b0021ddc9817bde3762a3b14315351f11fc4be384fd14a664736f6c63430008060033" - assertBool "linker hole not detected" (containsLinkerHole code'), - testCase "no false positives" $ do - let code' = "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fea265627a7a723158205d775f914dcb471365a430b5f5b2cfe819e615cbbb5b2f1ccc7da1fd802e43c364736f6c634300050b0032" - assertBool "false positive" (not . containsLinkerHole $ code') - ] - - , testGroup "metadata stripper" - [ testCase "it strips the metadata for solc => 0.6" $ do - let code' = hexText "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fea265627a7a723158205d775f914dcb471365a430b5f5b2cfe819e615cbbb5b2f1ccc7da1fd802e43c364736f6c634300050b0032" - stripped = stripBytecodeMetadata code' - assertEqual "failed to strip metadata" (show (ByteStringS stripped)) "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fe" - , - testCase "it strips the metadata and constructor args" $ do - let srccode = - [i| - contract A { - uint y; - constructor(uint x) public { - y = x; - } - } - |] - - (json, path') <- solidity' srccode - let (Contracts solc', _, _) = fromJust $ readStdJSON json - initCode = (solc' ^?! ix (path' <> ":A")).creationCode - -- add constructor arguments - assertEqual "constructor args screwed up metadata stripping" (stripBytecodeMetadata (initCode <> encodeAbiValue (AbiUInt 256 1))) (stripBytecodeMetadata initCode) - ] - - , testGroup "RLP encodings" - [ testProperty "rlp decode is a retraction (bytes)" $ \(Bytes bs) -> --- withMaxSuccess 100000 $ - rlpdecode (rlpencode (BS bs)) == Just (BS bs) - , testProperty "rlp encode is a partial inverse (bytes)" $ \(Bytes bs) -> --- withMaxSuccess 100000 $ - case rlpdecode bs of - Just r -> rlpencode r == bs - Nothing -> True - , testProperty "rlp decode is a retraction (RLP)" $ \(RLPData r) -> --- withMaxSuccess 100000 $ - rlpdecode (rlpencode r) == Just r - ] - , testGroup "Merkle Patricia Trie" - [ testProperty "update followed by delete is id" $ \(Bytes r, Bytes s, Bytes t) -> - whenFail - (putStrLn ("r:" <> (show (ByteStringS r))) >> - putStrLn ("s:" <> (show (ByteStringS s))) >> - putStrLn ("t:" <> (show (ByteStringS t)))) $ --- withMaxSuccess 100000 $ - Patricia.insertValues [(r, BS.pack[1]), (s, BS.pack[2]), (t, BS.pack[3]), - (r, mempty), (s, mempty), (t, mempty)] - === (Just $ Patricia.Literal Patricia.Empty) - ] - , testGroup "Remote State Tests" - [ - ] - , testGroup "Panic code tests via symbolic execution" - [ - testCase "assert-fail" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a) external pure { - assert(a != 0); - } - } - |] - (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x01] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - assertEqual "Must be 0" 0 $ getVar ctr "arg1" - putStrLn $ "expected counterexample found, and it's correct: " <> (show $ getVar ctr "arg1") - , - testCase "safeAdd-fail" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a, uint256 b) external pure returns (uint256 c) { - c = a+b; - } - } - |] - (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x11] c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - let x = getVar ctr "arg1" - let y = getVar ctr "arg2" - - let maxUint = 2 ^ (256 :: Integer) :: Integer - assertBool "Overflow must occur" (toInteger x + toInteger y >= maxUint) - putStrLn "expected counterexample found" - , - testCase "div-by-zero-fail" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a, uint256 b) external pure returns (uint256 c) { - c = a/b; - } - } - |] - (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x12] c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - assertEqual "Division by 0 needs b=0" (getVar ctr "arg2") 0 - putStrLn "expected counterexample found" - , - testCase "unused-args-fail" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun(uint256 a) public pure { - assert(false); - } - } - |] - (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x1] c Nothing [] defaultVeriOpts - putStrLn "expected counterexample found" - , - testCase "enum-conversion-fail" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - enum MyEnum { ONE, TWO } - function fun(uint256 a) external pure returns (MyEnum b) { - b = MyEnum(a); - } - } - |] - (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x21] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - assertBool "Enum is only defined for 0 and 1" $ (getVar ctr "arg1") > 1 - putStrLn "expected counterexample found" - , - -- TODO 0x22 is missing: "0x22: If you access a storage byte array that is incorrectly encoded." - -- TODO below should NOT fail - -- TODO this has a loop that depends on a symbolic value and currently causes interpret to loop - ignoreTest $ testCase "pop-empty-array" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - uint[] private arr; - function fun(uint8 a) external { - arr.push(1); - arr.push(2); - for (uint i = 0; i < a; i++) { - arr.pop(); - } - } - } - |] - a <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x31] c (Just (Sig "fun(uint8)" [AbiUIntType 8])) [] defaultVeriOpts - print $ length a - print $ show a - putStrLn "expected counterexample found" - , - testCase "access-out-of-bounds-array" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - uint[] private arr; - function fun(uint8 a) external returns (uint x){ - arr.push(1); - arr.push(2); - x = arr[a]; - } - } - |] - (_, [Cex (_, _)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x32] c (Just (Sig "fun(uint8)" [AbiUIntType 8])) [] defaultVeriOpts - -- assertBool "Access must be beyond element 2" $ (getVar ctr "arg1") > 1 - putStrLn "expected counterexample found" - , - -- Note: we catch the assertion here, even though we are only able to explore partially - testCase "alloc-too-much" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a) external { - uint[] memory arr = new uint[](a); - } - } - |] - (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> - checkAssert s [0x41] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn "expected counterexample found" - , - -- TODO the system currently does not allow for symbolic JUMP - expectFail $ testCase "call-zero-inited-var-thats-a-function" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function (uint256) internal returns (uint) funvar; - function fun2(uint256 a) internal returns (uint){ - return a; - } - function fun(uint256 a) external returns (uint) { - if (a != 44) { - funvar = fun2; - } - return funvar(a); - } - } - |] - (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x51] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn "expected counterexample found" - ] - - , testGroup "Dapp-Tests" - [ testCase "Trivial-Pass" $ do - let testFile = "test/contracts/pass/trivial.sol" - runSolidityTest testFile ".*" >>= assertEqual "test result" True - , testCase "DappTools" $ do - -- quick smokecheck to make sure that we can parse dapptools style build outputs - let cases = - [ ("test/contracts/pass/trivial.sol", ".*", True) - , ("test/contracts/pass/invariants.sol", "invariantTestThisBal", True) - , ("test/contracts/pass/dsProvePass.sol", "proveEasy", True) - , ("test/contracts/fail/trivial.sol", ".*", False) - , ("test/contracts/fail/invariantFail.sol", "invariantCount", False) - , ("test/contracts/fail/dsProveFail.sol", "prove_add", False) - ] - results <- forM cases $ \(testFile, match, expected) -> do - actual <- runSolidityTestCustom testFile match Nothing False Nothing DappTools - pure (actual == expected) - assertBool "test result" (and results) - , testCase "Trivial-Fail" $ do - let testFile = "test/contracts/fail/trivial.sol" - runSolidityTest testFile "testFalse" >>= assertEqual "test result" False - , testCase "Abstract" $ do - let testFile = "test/contracts/pass/abstract.sol" - runSolidityTest testFile ".*" >>= assertEqual "test result" True - , testCase "Constantinople" $ do - let testFile = "test/contracts/pass/constantinople.sol" - runSolidityTest testFile ".*" >>= assertEqual "test result" True - , testCase "Prove-Tests-Pass" $ do - let testFile = "test/contracts/pass/dsProvePass.sol" - runSolidityTest testFile ".*" >>= assertEqual "test result" True - , testCase "Prove-Tests-Fail" $ do - let testFile = "test/contracts/fail/dsProveFail.sol" - runSolidityTest testFile "prove_trivial" >>= assertEqual "test result" False - runSolidityTest testFile "prove_add" >>= assertEqual "test result" False - --runSolidityTest testFile "prove_smtTimeout" >>= assertEqual "test result" False - runSolidityTest testFile "prove_multi" >>= assertEqual "test result" False - -- TODO: implement overflow checking optimizations and enable, currently this runs forever - --runSolidityTest testFile "prove_distributivity" >>= assertEqual "test result" False - , testCase "Loop-Tests" $ do - let testFile = "test/contracts/pass/loops.sol" - runSolidityTestCustom testFile "prove_loop" (Just 10) False Nothing Foundry >>= assertEqual "test result" True - runSolidityTestCustom testFile "prove_loop" (Just 100) False Nothing Foundry >>= assertEqual "test result" False - , testCase "Invariant-Tests-Pass" $ do - let testFile = "test/contracts/pass/invariants.sol" - runSolidityTest testFile ".*" >>= assertEqual "test result" True - , testCase "Invariant-Tests-Fail" $ do - let testFile = "test/contracts/fail/invariantFail.sol" - runSolidityTest testFile "invariantFirst" >>= assertEqual "test result" False - runSolidityTest testFile "invariantCount" >>= assertEqual "test result" False - , testCase "Cheat-Codes-Pass" $ do - let testFile = "test/contracts/pass/cheatCodes.sol" - runSolidityTest testFile ".*" >>= assertEqual "test result" True - , testCase "Cheat-Codes-Fail" $ do - let testFile = "test/contracts/fail/cheatCodes.sol" - runSolidityTestCustom testFile "testBadFFI" Nothing False Nothing Foundry >>= assertEqual "test result" False - runSolidityTestCustom testFile "test_prank_underflow" Nothing False Nothing Foundry >>= assertEqual "test result" False - , testCase "Unwind" $ do - let testFile = "test/contracts/pass/unwind.sol" - runSolidityTest testFile ".*" >>= assertEqual "test result" True - ] - , testGroup "max-iterations" - [ testCase "concrete-loops-reached" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun() external payable returns (uint) { - uint count = 0; - for (uint i = 0; i < 5; i++) count++; - return count; - } - } - |] - let sig = Just $ Sig "fun()" [] - opts = defaultVeriOpts{ maxIter = Just 3 } - (e, [Qed _]) <- withSolvers Z3 1 Nothing $ - \s -> checkAssert s defaultPanicCodes c sig [] opts - assertBool "The expression is not partial" $ isPartial e - , testCase "concrete-loops-not-reached" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun() external payable returns (uint) { - uint count = 0; - for (uint i = 0; i < 5; i++) count++; - return count; - } - } - |] - - let sig = Just $ Sig "fun()" [] - opts = defaultVeriOpts{ maxIter = Just 6 } - (e, [Qed _]) <- withSolvers Z3 1 Nothing $ - \s -> checkAssert s defaultPanicCodes c sig [] opts - assertBool "The expression is partial" $ not $ isPartial e - , testCase "symbolic-loops-reached" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun(uint j) external payable returns (uint) { - uint count = 0; - for (uint i = 0; i < j; i++) count++; - return count; - } - } - |] - (e, [Qed _]) <- withSolvers Z3 1 Nothing $ - \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] (defaultVeriOpts{ maxIter = Just 5 }) - assertBool "The expression is not partial" $ Expr.containsNode isPartial e - , testCase "inconsistent-paths" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun(uint j) external payable returns (uint) { - require(j <= 3); - uint count = 0; - for (uint i = 0; i < j; i++) count++; - return count; - } - } - |] - let sig = Just $ Sig "fun(uint256)" [AbiUIntType 256] - -- we dont' ask the solver about the loop condition until we're - -- already in an inconsistent path (i == 5, j <= 3, i < j), so we - -- will continue looping here until we hit max iterations - opts = defaultVeriOpts{ maxIter = Just 10, askSmtIters = 5 } - (e, [Qed _]) <- withSolvers Z3 1 Nothing $ - \s -> checkAssert s defaultPanicCodes c sig [] opts - assertBool "The expression is not partial" $ Expr.containsNode isPartial e - , testCase "symbolic-loops-not-reached" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun(uint j) external payable returns (uint) { - require(j <= 3); - uint count = 0; - for (uint i = 0; i < j; i++) count++; - return count; - } - } - |] - let sig = Just $ Sig "fun(uint256)" [AbiUIntType 256] - -- askSmtIters is low enough here to avoid the inconsistent path - -- conditions, so we never hit maxIters - opts = defaultVeriOpts{ maxIter = Just 5, askSmtIters = 1 } - (e, [Qed _]) <- withSolvers Z3 1 Nothing $ - \s -> checkAssert s defaultPanicCodes c sig [] opts - assertBool "The expression is partial" $ not (Expr.containsNode isPartial e) - ] - , testGroup "Symbolic execution" - [ - testCase "require-test" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(int256 a) external pure { - require(a <= 0); - assert (a <= 0); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256)" [AbiIntType 256])) [] defaultVeriOpts - putStrLn "Require works as expected" - , - testCase "ITE-with-bitwise-AND" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function f(uint256 x) public pure { - require(x > 0); - uint256 a = (x & 8); - bool w; - // assembly is needed here, because solidity doesn't allow uint->bool conversion - assembly { - w:=a - } - if (!w) assert(false); //we should get a CEX: when x has a 0 at bit 3 - } - } - |] - -- should find a counterexample - (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn "expected counterexample found" - , - testCase "ITE-with-bitwise-OR" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function f(uint256 x) public pure { - uint256 a = (x | 8); - bool w; - // assembly is needed here, because solidity doesn't allow uint->bool conversion - assembly { - w:=a - } - assert(w); // due to bitwise OR with positive value, this must always be true - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn "this should always be true, due to bitwise OR with positive value" - , - -- CopySlice check - -- uses identity precompiled contract (0x4) to copy memory - -- checks 9af114613075a2cd350633940475f8b6699064de (readByte + CopySlice had src/dest mixed up) - -- without 9af114613 it dies with: `Exception: UnexpectedSymbolicArg 296 "MSTORE index"` - -- TODO: check 9e734b9da90e3e0765128b1f20ce1371f3a66085 (bufLength + copySlice was off by 1) - testCase "copyslice-check" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function checkval(uint8 a) public { - bytes memory data = new bytes(5); - for(uint i = 0; i < 5; i++) data[i] = bytes1(a); - bytes memory ret = new bytes(data.length); - assembly { - let len := mload(data) - if iszero(call(0xff, 0x04, 0, add(data, 0x20), len, add(ret,0x20), len)) { - invalid() - } - } - for(uint i = 0; i < 5; i++) assert(ret[i] == data[i]); - } - } - |] - let sig = Just (Sig "checkval(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> - checkAssert s defaultPanicCodes c sig [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - -- TODO look at tests here for SAR: https://github.com/dapphub/dapptools/blob/01ef8ea418c3fe49089a44d56013d8fcc34a1ec2/src/dapp-tests/pass/constantinople.sol#L250 - testCase "opcode-sar-neg" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(int256 shift_by, int256 val) external pure returns (int256 out) { - require(shift_by >= 0); - require(val <= 0); - assembly { - out := sar(shift_by,val) - } - assert (out <= 0); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts - putStrLn "SAR works as expected" - , - testCase "opcode-sar-pos" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(int256 shift_by, int256 val) external pure returns (int256 out) { - require(shift_by >= 0); - require(val >= 0); - assembly { - out := sar(shift_by,val) - } - assert (out >= 0); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts - putStrLn "SAR works as expected" - , - testCase "opcode-sar-fixedval-pos" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(int256 shift_by, int256 val) external pure returns (int256 out) { - require(shift_by == 1); - require(val == 64); - assembly { - out := sar(shift_by,val) - } - assert (out == 32); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts - putStrLn "SAR works as expected" - , - testCase "opcode-sar-fixedval-neg" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(int256 shift_by, int256 val) external pure returns (int256 out) { - require(shift_by == 1); - require(val == -64); - assembly { - out := sar(shift_by,val) - } - assert (out == -32); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts - putStrLn "SAR works as expected" - , - testCase "opcode-div-zero-1" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val) external pure { - uint out; - assembly { - out := div(val, 0) - } - assert(out == 0); - - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn "sdiv works as expected" - , - testCase "opcode-sdiv-zero-1" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val) external pure { - uint out; - assembly { - out := sdiv(val, 0) - } - assert(out == 0); - - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn "sdiv works as expected" - , - testCase "opcode-sdiv-zero-2" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val) external pure { - uint out; - assembly { - out := sdiv(0, val) - } - assert(out == 0); - - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn "sdiv works as expected" - , - testCase "signed-overflow-checks" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function fun(uint160 a) external { - int256 j = int256(uint256(a)) + 1; - assert(false); - } - } - |] - (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint160)" [AbiUIntType 160])) [] defaultVeriOpts - putStrLn "expected cex discovered" - , - testCase "opcode-signextend-neg" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val, uint8 b) external pure { - require(b <= 31); - require(b >= 0); - require(val < (1 <<(b*8))); - require(val & (1 <<(b*8-1)) != 0); // MSbit set, i.e. negative - uint256 out; - assembly { - out := signextend(b, val) - } - if (b == 31) assert(out == val); - else assert(out > val); - assert(out & (1<<254) != 0); // MSbit set, i.e. negative - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn "signextend works as expected" - , - testCase "opcode-signextend-pos-nochop" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val, uint8 b) external pure { - require(val < (1 <<(b*8))); - require(val & (1 <<(b*8-1)) == 0); // MSbit not set, i.e. positive - uint256 out; - assembly { - out := signextend(b, val) - } - assert (out == val); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts - putStrLn "signextend works as expected" - , - testCase "opcode-signextend-pos-chopped" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val, uint8 b) external pure { - require(b == 0); // 1-byte - require(val == 514); // but we set higher bits - uint256 out; - assembly { - out := signextend(b, val) - } - assert (out == 2); // chopped - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts - putStrLn "signextend works as expected" - , - -- when b is too large, value is unchanged - testCase "opcode-signextend-pos-b-toolarge" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 val, uint8 b) external pure { - require(b >= 31); - uint256 out; - assembly { - out := signextend(b, val) - } - assert (out == val); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts - putStrLn "signextend works as expected" - , - testCase "opcode-shl" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 shift_by, uint256 val) external pure { - require(val < (1<<16)); - require(shift_by < 16); - uint256 out; - assembly { - out := shl(shift_by,val) - } - assert (out >= val); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLn "SAR works as expected" - , - testCase "opcode-xor-cancel" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a, uint256 b) external pure { - require(a == b); - uint256 c; - assembly { - c := xor(a,b) - } - assert (c == 0); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLn "XOR works as expected" - , - testCase "opcode-xor-reimplement" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint256 a, uint256 b) external pure { - uint256 c; - assembly { - c := xor(a,b) - } - assert (c == (~(a & b)) & (a | b)); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLn "XOR works as expected" - , - testCase "opcode-div-res-zero-on-div-by-zero" $ do - Just c <- solcRuntime "MyContract" - [i| - contract MyContract { - function fun(uint16 a) external pure { - uint16 b = 0; - uint16 res; - assembly { - res := div(a,b) - } - assert (res == 0); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint16)" [AbiUIntType 16])) [] defaultVeriOpts - putStrLn "DIV by zero is zero" - , - -- Somewhat tautological since we are asserting the precondition - -- on the same form as the actual "requires" clause. - testCase "SafeAdd success case" $ do - Just safeAdd <- solcRuntime "SafeAdd" - [i| - contract SafeAdd { - function add(uint x, uint y) public pure returns (uint z) { - require((z = x + y) >= x); - } - } - |] - let pre preVM = let (x, y) = case getStaticAbiArgs 2 preVM of - [x', y'] -> (x', y') - _ -> internalError "expected 2 args" - in (x .<= Expr.add x y) - -- TODO check if it's needed - .&& preVM.state.callvalue .== Lit 0 - post prestate leaf = - let (x, y) = case getStaticAbiArgs 2 prestate of - [x', y'] -> (x', y') - _ -> internalError "expected 2 args" - in case leaf of - Success _ _ b _ -> (ReadWord (Lit 0) b) .== (Add x y) - _ -> PBool True - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s safeAdd (Just (Sig "add(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts AbstractStore (Just pre) (Just post) - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - - testCase "x == y => x + y == 2 * y" $ do - Just safeAdd <- solcRuntime "SafeAdd" - [i| - contract SafeAdd { - function add(uint x, uint y) public pure returns (uint z) { - require((z = x + y) >= x); - } - } - |] - let pre preVM = let (x, y) = case getStaticAbiArgs 2 preVM of - [x', y'] -> (x', y') - _ -> internalError "expected 2 args" - in (x .<= Expr.add x y) - .&& (x .== y) - .&& preVM.state.callvalue .== Lit 0 - post prestate leaf = - let (_, y) = case getStaticAbiArgs 2 prestate of - [x', y'] -> (x', y') - _ -> internalError "expected 2 args" - in case leaf of - Success _ _ b _ -> (ReadWord (Lit 0) b) .== (Mul (Lit 2) y) - _ -> PBool True - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> - verifyContract s safeAdd (Just (Sig "add(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts AbstractStore (Just pre) (Just post) - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - testCase "summary storage writes" $ do - Just c <- solcRuntime "A" - [i| - contract A { - uint x; - function f(uint256 y) public { - unchecked { - x += y; - x += y; - } - } - } - |] - let pre vm = Lit 0 .== vm.state.callvalue - post prestate leaf = - let y = case getStaticAbiArgs 1 prestate of - [y'] -> y' - _ -> internalError "expected 1 arg" - this = Expr.litAddr $ prestate.state.codeContract - prex = Expr.readStorage' this (Lit 0) prestate.env.storage - in case leaf of - Success _ _ _ postStore -> Expr.add prex (Expr.mul (Lit 2) y) .== (Expr.readStorage' this (Lit 0) postStore) - _ -> PBool True - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts AbstractStore (Just pre) (Just post) - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - -- tests how whiffValue handles Neg via application of the triple IsZero simplification rule - -- regression test for: https://github.com/dapphub/dapptools/pull/698 - testCase "Neg" $ do - let src = - [i| - object "Neg" { - code { - // Deploy the contract - datacopy(0, dataoffset("runtime"), datasize("runtime")) - return(0, datasize("runtime")) - } - object "runtime" { - code { - let v := calldataload(4) - if iszero(iszero(and(v, not(0xffffffffffffffffffffffffffffffffffffffff)))) { - invalid() - } - } - } - } - |] - Just c <- yulRuntime "Neg" src - (res, [Qed _]) <- withSolvers Z3 4 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "hello(address)" [AbiAddressType])) [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - testCase "catch-storage-collisions-noproblem" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y) public { - if (x != y) { - assembly { - let newx := sub(sload(x), 1) - let newy := add(sload(y), 1) - sstore(x,newx) - sstore(y,newy) - } - } - } - } - |] - let pre vm = (Lit 0) .== vm.state.callvalue - post prestate poststate = - let (x,y) = case getStaticAbiArgs 2 prestate of - [x',y'] -> (x',y') - _ -> internalError "expected 2 args" - this = Expr.litAddr $ prestate.state.codeContract - prestore = prestate.env.storage - prex = Expr.readStorage' this x prestore - prey = Expr.readStorage' this y prestore - in case poststate of - Success _ _ _ poststore -> let - postx = Expr.readStorage' this x poststore - posty = Expr.readStorage' this y poststore - in Expr.add prex prey .== Expr.add postx posty - _ -> PBool True - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts AbstractStore (Just pre) (Just post) - putStrLn "Correct, this can never fail" - , - -- Inspired by these `msg.sender == to` token bugs - -- which break linearity of totalSupply. - testCase "catch-storage-collisions-good" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y) public { - assembly { - let newx := sub(sload(x), 1) - let newy := add(sload(y), 1) - sstore(x,newx) - sstore(y,newy) - } - } - } - |] - let pre vm = (Lit 0) .== vm.state.callvalue - post prestate poststate = - let (x,y) = case getStaticAbiArgs 2 prestate of - [x',y'] -> (x',y') - _ -> internalError "expected 2 args" - this = Expr.litAddr $ prestate.state.codeContract - prestore = prestate.env.storage - prex = Expr.readStorage' this x prestore - prey = Expr.readStorage' this y prestore - in case poststate of - Success _ _ _ poststore -> let - postx = Expr.readStorage' this x poststore - posty = Expr.readStorage' this y poststore - in Expr.add prex prey .== Expr.add postx posty - _ -> PBool True - (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts AbstractStore (Just pre) (Just post) - let x = getVar ctr "arg1" - let y = getVar ctr "arg2" - putStrLn $ "y:" <> show y - putStrLn $ "x:" <> show x - assertEqual "Catch storage collisions" x y - putStrLn "expected counterexample found" - , - testCase "simple-assert" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo() external pure { - assert(false); - } - } - |] - (_, [Cex (Failure _ _ (Revert msg), _)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo()" [])) [] defaultVeriOpts - assertEqual "incorrect revert msg" msg (ConcreteBuf $ panicMsg 0x01) - , - testCase "simple-assert-2" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - assert(x != 10); - } - } - |] - (_, [(Cex (_, ctr))]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - assertEqual "Must be 10" 10 $ getVar ctr "arg1" - putStrLn "Got 10 Cex, as expected" - , - testCase "assert-fail-equal" $ do - Just c <- solcRuntime "AssertFailEqual" - [i| - contract AssertFailEqual { - function fun(uint256 deposit_count) external pure { - assert(deposit_count == 0); - assert(deposit_count == 11); - } - } - |] - (_, [Cex (_, a), Cex (_, b)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - let ints = map (flip getVar "arg1") [a,b] - assertBool "0 must be one of the Cex-es" $ isJust $ List.elemIndex 0 ints - putStrLn "expected 2 counterexamples found, one Cex is the 0 value" - , - testCase "assert-fail-notequal" $ do - Just c <- solcRuntime "AssertFailNotEqual" - [i| - contract AssertFailNotEqual { - function fun(uint256 deposit_count) external pure { - assert(deposit_count != 0); - assert(deposit_count != 11); - } - } - |] - (_, [Cex (_, a), Cex (_, b)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - let x = getVar a "arg1" - let y = getVar b "arg1" - assertBool "At least one has to be 0, to go through the first assert" (x == 0 || y == 0) - putStrLn "expected 2 counterexamples found." - , - testCase "assert-fail-twoargs" $ do - Just c <- solcRuntime "AssertFailTwoParams" - [i| - contract AssertFailTwoParams { - function fun(uint256 deposit_count1, uint256 deposit_count2) external pure { - assert(deposit_count1 != 0); - assert(deposit_count2 != 11); - } - } - |] - (_, [Cex _, Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLn "expected 2 counterexamples found" - , - testCase "assert-2nd-arg" $ do - Just c <- solcRuntime "AssertFailTwoParams" - [i| - contract AssertFailTwoParams { - function fun(uint256 deposit_count1, uint256 deposit_count2) external pure { - assert(deposit_count2 != 666); - } - } - |] - (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - assertEqual "Must be 666" 666 $ getVar ctr "arg2" - putStrLn "Found arg2 Ctx to be 666" - , - -- LSB is zeroed out, byte(31,x) takes LSB, so y==0 always holds - testCase "check-lsb-msb1" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - x &= 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff00; - uint8 y; - assembly { y := byte(31,x) } - assert(y == 0); - } - } - |] - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - -- We zero out everything but the LSB byte. However, byte(31,x) takes the LSB byte - -- so there is a counterexamle, where LSB of x is not zero - testCase "check-lsb-msb2" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - x &= 0x00000000000000000000000000000000000000000000000000000000000000ff; - uint8 y; - assembly { y := byte(31,x) } - assert(y == 0); - } - } - |] - (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - assertBool "last byte must be non-zero" $ ((Data.Bits..&.) (getVar ctr "arg1") 0xff) > 0 - putStrLn "Expected counterexample found" - , - -- We zero out everything but the 2nd LSB byte. However, byte(31,x) takes the 2nd LSB byte - -- so there is a counterexamle, where 2nd LSB of x is not zero - testCase "check-lsb-msb3 -- 2nd byte" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - x &= 0x000000000000000000000000000000000000000000000000000000000000ff00; - uint8 y; - assembly { y := byte(30,x) } - assert(y == 0); - } - } - |] - (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - assertBool "second to last byte must be non-zero" $ ((Data.Bits..&.) (getVar ctr "arg1") 0xff00) > 0 - putStrLn "Expected counterexample found" - , - -- Reverse of thest above - testCase "check-lsb-msb4 2nd byte rev" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - x &= 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff00ff; - uint8 y; - assembly { - y := byte(30,x) - } - assert(y == 0); - } - } - |] - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - -- Bitwise OR operation test - testCase "opcode-bitwise-or-full-1s" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - uint256 y; - uint256 z = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff; - assembly { y := or(x, z) } - assert(y == 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn "When OR-ing with full 1's we should get back full 1's" - , - -- Bitwise OR operation test - testCase "opcode-bitwise-or-byte-of-1s" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x) external pure { - uint256 y; - uint256 z = 0x000000000000000000000000000000000000000000000000000000000000ff00; - assembly { y := or(x, z) } - assert((y & 0x000000000000000000000000000000000000000000000000000000000000ff00) == - 0x000000000000000000000000000000000000000000000000000000000000ff00); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn "When OR-ing with a byte of 1's, we should get 1's back there" - , - testCase "Deposit contract loop (z3)" $ do - Just c <- solcRuntime "Deposit" - [i| - contract Deposit { - function deposit(uint256 deposit_count) external pure { - require(deposit_count < 2**32 - 1); - ++deposit_count; - bool found = false; - for (uint height = 0; height < 32; height++) { - if ((deposit_count & 1) == 1) { - found = true; - break; - } - deposit_count = deposit_count >> 1; - } - assert(found); - } - } - |] - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "deposit(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - testCase "Deposit-contract-loop-error-version" $ do - Just c <- solcRuntime "Deposit" - [i| - contract Deposit { - function deposit(uint8 deposit_count) external pure { - require(deposit_count < 2**32 - 1); - ++deposit_count; - bool found = false; - for (uint height = 0; height < 32; height++) { - if ((deposit_count & 1) == 1) { - found = true; - break; - } - deposit_count = deposit_count >> 1; - } - assert(found); - } - } - |] - (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s allPanicCodes c (Just (Sig "deposit(uint8)" [AbiUIntType 8])) [] defaultVeriOpts - assertEqual "Must be 255" 255 $ getVar ctr "arg1" - putStrLn $ "expected counterexample found, and it's correct: " <> (show $ getVar ctr "arg1") - , - testCase "explore function dispatch" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x) public pure returns (uint) { - return x; - } - } - |] - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - testCase "check-asm-byte-in-bounds" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 idx, uint256 val) external pure { - uint256 actual; - uint256 expected; - require(idx < 32); - assembly { - actual := byte(idx,val) - expected := shr(248, shl(mul(idx, 8), val)) - } - assert(actual == expected); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts - putStrLn "in bounds byte reads return the expected value" - , - testCase "check-div-mod-sdiv-smod-by-zero-constant-prop" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 e) external pure { - uint x = 0; - uint y = 55; - uint z; - assembly { z := div(y,x) } - assert(z == 0); - assembly { z := div(x,y) } - assert(z == 0); - assembly { z := sdiv(y,x) } - assert(z == 0); - assembly { z := sdiv(x,y) } - assert(z == 0); - assembly { z := mod(y,x) } - assert(z == 0); - assembly { z := mod(x,y) } - assert(z == 0); - assembly { z := smod(y,x) } - assert(z == 0); - assembly { z := smod(x,y) } - assert(z == 0); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn "div/mod/sdiv/smod by zero works as expected during constant propagation" - , - testCase "check-asm-byte-oob" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function foo(uint256 x, uint256 y) external pure { - uint256 z; - require(x >= 32); - assembly { z := byte(x,y) } - assert(z == 0); - } - } - |] - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts - putStrLn "oob byte reads always return 0" - , - testCase "injectivity of keccak (32 bytes)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y) public pure { - if (keccak256(abi.encodePacked(x)) == keccak256(abi.encodePacked(y))) assert(x == y); - } - } - |] - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - testCase "injectivity of keccak contrapositive (32 bytes)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y) public pure { - require (x != y); - assert (keccak256(abi.encodePacked(x)) != keccak256(abi.encodePacked(y))); - } - } - |] - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - testCase "injectivity of keccak (64 bytes)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y, uint w, uint z) public pure { - assert (keccak256(abi.encodePacked(x,y)) != keccak256(abi.encodePacked(w,z))); - } - } - |] - (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256,uint256,uint256,uint256)" (replicate 4 (AbiUIntType 256)))) [] defaultVeriOpts - let x = getVar ctr "arg1" - let y = getVar ctr "arg2" - let w = getVar ctr "arg3" - let z = getVar ctr "arg4" - assertEqual "x==y for hash collision" x y - assertEqual "w==z for hash collision" w z - putStrLn "expected counterexample found" - , - testCase "calldata beyond calldatasize is 0 (symbolic calldata)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f() public pure { - uint y; - assembly { - let x := calldatasize() - y := calldataload(x) - } - assert(y == 0); - } - } - |] - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - testCase "calldata beyond calldatasize is 0 (concrete dalldata prefix)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint256 z) public pure { - uint y; - assembly { - let x := calldatasize() - y := calldataload(x) - } - assert(y == 0); - } - } - |] - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - testCase "calldata symbolic access" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint256 z) public pure { - uint x; uint y; - assembly { - y := calldatasize() - } - require(z >= y); - assembly { - x := calldataload(z) - } - assert(x == 0); - } - } - |] - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - testCase "multiple-contracts" $ do - let code' = - [i| - contract C { - uint x; - A constant a = A(0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B); - - function call_A() public view { - // should fail since a.x() can be anything - assert(a.x() == x); - } - } - contract A { - uint public x; - } - |] - aAddr = Addr 0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B - Just c <- solcRuntime "C" code' - Just a <- solcRuntime "A" code' - (_, [Cex (_, cex)]) <- withSolvers Z3 1 Nothing $ \s -> do - let vm0 = abstractVM (mkCalldata (Just (Sig "call_A()" [])) []) c Nothing AbstractStore - let vm = vm0 - & set (#state % #callvalue) (Lit 0) - & over (#env % #contracts) - (Map.insert aAddr (initialContract (RuntimeCode (ConcreteRuntimeCode a)))) - verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) - - let storeCex = cex.store - addrC = into $ 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" - [i| - contract C { - uint x; - A a; - - function call_A() public { - a = new A(); - // should fail since x can be anything - assert(a.x() == x); - } - } - contract A { - uint public x; - } - |] - (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "call_A()" [])) [] defaultVeriOpts - putStrLn "expected counterexample found" - , - testCase "keccak concrete and sym agree" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function kecc(uint x) public pure { - if (x == 0) { - assert(keccak256(abi.encode(x)) == keccak256(abi.encode(0))); - } - } - } - |] - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "kecc(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - testCase "keccak concrete and sym injectivity" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x) public pure { - if (x !=3) assert(keccak256(abi.encode(x)) != keccak256(abi.encode(3))); - } - } - |] - (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" - , - ignoreTest $ testCase "safemath distributivity (yul)" $ do - let yulsafeDistributivity = hex "6355a79a6260003560e01c14156016576015601f565b5b60006000fd60a1565b603d602d604435600435607c565b6039602435600435607c565b605d565b6052604b604435602435605d565b600435607c565b141515605a57fe5b5b565b6000828201821115151560705760006000fd5b82820190505b92915050565b6000818384048302146000841417151560955760006000fd5b82820290505b92915050565b" - let vm = abstractVM (mkCalldata (Just (Sig "distributivity(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) []) yulsafeDistributivity Nothing AbstractStore - (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) - putStrLn "Proven" - , - testCase "safemath distributivity (sol)" $ do - Just c <- solcRuntime "C" - [i| - contract C { - function distributivity(uint x, uint y, uint z) public { - assert(mul(x, add(y, z)) == add(mul(x, y), mul(x, z))); - } - - function add(uint x, uint y) internal pure returns (uint z) { - unchecked { - require((z = x + y) >= x, "ds-math-add-overflow"); - } - } - - function mul(uint x, uint y) internal pure returns (uint z) { - unchecked { - require(y == 0 || (z = x * y) / y == x, "ds-math-mul-overflow"); - } - } - } - |] - - (_, [Qed _]) <- withSolvers Z3 1 (Just 99999999) $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "distributivity(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts - putStrLn "Proven" - , - testCase "storage-cex-1" $ do - 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 (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - let addr = into $ 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 (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts - let addr = into $ 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 (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts EmptyStore Nothing (Just $ checkAssertions [0x01]) - let testCex = Map.null cex.store - assertBool "Did not find expected storage cex" testCex - putStrLn "Expected counterexample found" - ] - , testGroup "Equivalence checking" - [ - testCase "eq-yul-simple-cex" $ do - Just aPrgm <- yul "" - [i| - { - calldatacopy(0, 0, 32) - switch mload(0) - case 0 { } - case 1 { } - default { invalid() } - } - |] - Just bPrgm <- yul "" - [i| - { - calldatacopy(0, 0, 32) - switch mload(0) - case 0 { } - case 2 { } - default { invalid() } - } - |] - withSolvers Z3 3 Nothing $ \s -> do - a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) - assertBool "Must have a difference" (any isCex a) - , - testCase "eq-sol-exp-qed" $ do - Just aPrgm <- solcRuntime "C" - [i| - contract C { - function a(uint8 x) public returns (uint8 b) { - unchecked { - b = x*2; - } - } - } - |] - Just bPrgm <- solcRuntime "C" - [i| - contract C { - function a(uint8 x) public returns (uint8 b) { - unchecked { - b = x<<1; - } - } - } - |] - withSolvers Z3 3 Nothing $ \s -> do - a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) - assertEqual "Must have no difference" [Qed ()] a - return () - , - testCase "eq-sol-exp-cex" $ do - -- These yul programs are not equivalent: (try --calldata $(seth --to-uint256 2) for example) - Just aPrgm <- solcRuntime "C" - [i| - contract C { - function a(uint8 x) public returns (uint8 b) { - unchecked { - b = x*2+1; - } - } - } - |] - Just bPrgm <- solcRuntime "C" - [i| - contract C { - function a(uint8 x) public returns (uint8 b) { - unchecked { - b = x<<1; - } - } - } - |] - withSolvers Z3 3 Nothing $ \s -> do - a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) - assertEqual "Must be different" (any isCex a) True - return () - , testCase "eq-all-yul-optimization-tests" $ do - let opts = defaultVeriOpts{ maxIter = Just 5, askSmtIters = 20, loopHeuristic = Naive } - ignoredTests = - -- unbounded loop -- - [ "commonSubexpressionEliminator/branches_for.yul" - , "conditionalSimplifier/no_opt_if_break_is_not_last.yul" - , "conditionalUnsimplifier/no_opt_if_break_is_not_last.yul" - , "expressionSimplifier/inside_for.yul" - , "forLoopConditionIntoBody/cond_types.yul" - , "forLoopConditionIntoBody/simple.yul" - , "fullSimplify/inside_for.yul" - , "fullSuite/no_move_loop_orig.yul" - , "loopInvariantCodeMotion/multi.yul" - , "redundantAssignEliminator/for_deep_simple.yul" - , "unusedAssignEliminator/for_deep_noremove.yul" - , "unusedAssignEliminator/for_deep_simple.yul" - , "ssaTransform/for_def_in_init.yul" - , "loopInvariantCodeMotion/simple_state.yul" - , "loopInvariantCodeMotion/simple.yul" - , "loopInvariantCodeMotion/recursive.yul" - , "loopInvariantCodeMotion/no_move_staticall_returndatasize.yul" - , "loopInvariantCodeMotion/no_move_state_loop.yul" - , "loopInvariantCodeMotion/no_move_state.yul" -- not infinite, but rollaround on a large int - , "loopInvariantCodeMotion/no_move_loop.yul" - - -- unexpected symbolic arg -- - - -- OpCreate2 - , "expressionSimplifier/create2_and_mask.yul" - - -- OpCreate - , "expressionSimplifier/create_and_mask.yul" - , "expressionSimplifier/large_byte_access.yul" - - -- OpMload - , "yulOptimizerTests/expressionSplitter/inside_function.yul" - , "fullInliner/double_inline.yul" - , "fullInliner/inside_condition.yul" - , "fullInliner/large_function_multi_use.yul" - , "fullInliner/large_function_single_use.yul" - , "fullInliner/no_inline_into_big_global_context.yul" - , "fullSimplify/invariant.yul" - , "fullSuite/abi_example1.yul" - , "ssaAndBack/for_loop.yul" - , "ssaAndBack/multi_assign_multi_var_if.yul" - , "ssaAndBack/multi_assign_multi_var_switch.yul" - , "ssaAndBack/two_vars.yul" - , "ssaTransform/multi_assign.yul" - , "ssaTransform/multi_decl.yul" - , "expressionSplitter/inside_function.yul" - , "fullSuite/ssaReverseComplex.yul" - - -- OpMstore - , "commonSubexpressionEliminator/function_scopes.yul" - , "commonSubexpressionEliminator/variable_for_variable.yul" - , "expressionSplitter/trivial.yul" - , "fullInliner/multi_return.yul" - , "fullSimplify/constant_propagation.yul" - , "fullSimplify/identity_rules_complex.yul" - , "fullSuite/medium.yul" - , "loadResolver/memory_with_msize.yul" - , "loadResolver/merge_known_write.yul" - , "loadResolver/merge_known_write_with_distance.yul" - , "loadResolver/merge_unknown_write.yul" - , "loadResolver/reassign_value_expression.yul" - , "loadResolver/second_mstore_with_delta.yul" - , "loadResolver/second_store_with_delta.yul" - , "loadResolver/simple.yul" - , "loadResolver/simple_memory.yul" - , "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" - - -- OpRevert - , "ssaAndBack/ssaReverse.yul" - , "redundantAssignEliminator/for_continue_3.yul" - , "controlFlowSimplifier/terminating_for_revert.yul" - - -- invalid test -- - -- https://github.com/ethereum/solidity/issues/9500 - , "commonSubexpressionEliminator/object_access.yul" - , "expressionSplitter/object_access.yul" - , "fullSuite/stack_compressor_msize.yul" - - -- stack too deep -- - , "fullSuite/abi2.yul" - , "fullSuite/aztec.yul" - , "stackCompressor/inlineInBlock.yul" - , "stackCompressor/inlineInFunction.yul" - , "stackCompressor/unusedPrunerWithMSize.yul" - , "wordSizeTransform/function_call.yul" - , "fullInliner/no_inline_into_big_function.yul" - , "controlFlowSimplifier/switch_only_default.yul" - , "stackLimitEvader" -- all that are in this subdirectory - - -- wrong number of args -- - , "wordSizeTransform/functional_instruction.yul" - , "wordSizeTransform/if.yul" - , "wordSizeTransform/or_bool_renamed.yul" - , "wordSizeTransform/switch_1.yul" - , "wordSizeTransform/switch_2.yul" - , "wordSizeTransform/switch_3.yul" - , "wordSizeTransform/switch_4.yul" - , "wordSizeTransform/switch_5.yul" - , "unusedFunctionParameterPruner/too_many_arguments.yul" - - -- typed yul -- - , "conditionalSimplifier/add_correct_type_wasm.yul" - , "conditionalSimplifier/add_correct_type.yul" - , "disambiguator/for_statement.yul" - , "disambiguator/funtion_call.yul" - , "disambiguator/if_statement.yul" - , "disambiguator/long_names.yul" - , "disambiguator/switch_statement.yul" - , "disambiguator/variables_clash.yul" - , "disambiguator/variables_inside_functions.yul" - , "disambiguator/variables.yul" - , "expressionInliner/simple.yul" - , "expressionInliner/with_args.yul" - , "expressionSplitter/typed.yul" - , "fullInliner/multi_return_typed.yul" - , "functionGrouper/empty_block.yul" - , "functionGrouper/multi_fun_mixed.yul" - , "functionGrouper/nested_fun.yul" - , "functionGrouper/single_fun.yul" - , "functionHoister/empty_block.yul" - , "functionHoister/multi_mixed.yul" - , "functionHoister/nested.yul" - , "functionHoister/single.yul" - , "mainFunction/empty_block.yul" - , "mainFunction/multi_fun_mixed.yul" - , "mainFunction/nested_fun.yul" - , "mainFunction/single_fun.yul" - , "ssaTransform/typed_for.yul" - , "ssaTransform/typed_switch.yul" - , "ssaTransform/typed.yul" - , "varDeclInitializer/typed.yul" - - -- New: symbolic index on MSTORE/MLOAD/CopySlice/CallDataCopy/ExtCodeCopy/Revert, - -- or exponent is symbolic (requires symbolic gas) - -- or SHA3 offset symbolic - , "blockFlattener/basic.yul" - , "commonSubexpressionEliminator/case2.yul" - , "equalStoreEliminator/indirect_inferrence.yul" - , "expressionJoiner/reassignment.yul" - , "expressionSimplifier/exp_simplifications.yul" - , "expressionSimplifier/zero_length_read.yul" - , "expressionSimplifier/side_effects_in_for_condition.yul" - , "fullSuite/create_and_mask.yul" - , "fullSuite/unusedFunctionParameterPruner_return.yul" - , "fullSuite/unusedFunctionParameterPruner_simple.yul" - , "fullSuite/unusedFunctionParameterPruner.yul" - , "loadResolver/double_mload_with_other_reassignment.yul" - , "loadResolver/double_mload_with_reassignment.yul" - , "loadResolver/double_mload.yul" - , "loadResolver/keccak_reuse_basic.yul" - , "loadResolver/keccak_reuse_expr_mstore.yul" - , "loadResolver/keccak_reuse_msize.yul" - , "loadResolver/keccak_reuse_mstore.yul" - , "loadResolver/keccak_reuse_reassigned_branch.yul" - , "loadResolver/keccak_reuse_reassigned_value.yul" - , "loadResolver/keccak_symbolic_memory.yul" - , "loadResolver/merge_mload_with_known_distance.yul" - , "loadResolver/mload_self.yul" - , "loadResolver/keccak_reuse_in_expression.yul" - , "loopInvariantCodeMotion/complex_move.yul" - , "loopInvariantCodeMotion/move_memory_function.yul" - , "loopInvariantCodeMotion/move_state_function.yul" - , "loopInvariantCodeMotion/no_move_memory.yul" - , "loopInvariantCodeMotion/no_move_storage.yul" - , "loopInvariantCodeMotion/not_first.yul" - , "ssaAndBack/single_assign_if.yul" - , "ssaAndBack/single_assign_switch.yul" - , "structuralSimplifier/switch_inline_no_match.yul" - , "unusedFunctionParameterPruner/simple.yul" - , "unusedStoreEliminator/covering_calldatacopy.yul" - , "unusedStoreEliminator/remove_before_revert.yul" - , "unusedStoreEliminator/unknown_length2.yul" - , "unusedStoreEliminator/unrelated_relative.yul" - , "fullSuite/extcodelength.yul" - , "unusedStoreEliminator/create_inside_function.yul"-- "trying to reset symbolic storage with writes in create" - - -- Takes too long, would timeout on most test setups. - -- We could probably fix these by "bunching together" queries - , "reasoningBasedSimplifier/mulmod.yul" - , "loadResolver/multi_sload_loop.yul" - , "reasoningBasedSimplifier/mulcheck.yul" - , "reasoningBasedSimplifier/smod.yul" - - -- TODO check what's wrong with these! - , "loadResolver/keccak_short.yul" -- ACTUAL bug -- keccak - , "reasoningBasedSimplifier/signed_division.yul" -- ACTUAL bug, SDIV - ] - - solcRepo <- fromMaybe (internalError "cannot find solidity repo") <$> (lookupEnv "HEVM_SOLIDITY_REPO") - let testDir = solcRepo <> "/test/libyul/yulOptimizerTests" - dircontents <- System.Directory.listDirectory testDir - let - fullpaths = map ((testDir ++ "/") ++) dircontents - recursiveList :: [FilePath] -> [FilePath] -> IO [FilePath] - recursiveList (a:ax) b = do - isdir <- doesDirectoryExist a - case isdir of - True -> do - fs <- System.Directory.listDirectory a - let fs2 = map ((a ++ "/") ++) fs - recursiveList (ax++fs2) b - False -> recursiveList ax (a:b) - recursiveList [] b = pure b - files <- recursiveList fullpaths [] - let filesFiltered = filter (\file -> not $ any (`List.isSubsequenceOf` file) ignoredTests) files - - -- Takes one file which follows the Solidity Yul optimizer unit tests format, - -- extracts both the nonoptimized and the optimized versions, and checks equivalence. - forM_ filesFiltered (\f-> do - origcont <- readFile f - let - onlyAfter pattern (a:ax) = if a =~ pattern then (a:ax) else onlyAfter pattern ax - onlyAfter _ [] = [] - replaceOnce pat repl inp = go inp [] where - go (a:ax) b = if a =~ pat then let a2 = replaceAll repl $ a *=~ pat in b ++ a2:ax - else go ax (b ++ [a]) - go [] b = b - - -- takes a yul program and ensures memory is symbolic by prepending - -- `calldatacopy(0,0,1024)`. (calldata is symbolic, but memory starts empty). - -- This forces the exploration of more branches, and makes the test vectors a - -- little more thorough. - symbolicMem (a:ax) = if a =~ [re|"^ *object"|] then - let a2 = replaceAll "a calldatacopy(0,0,1024)" $ a *=~ [re|code {|] - in (a2:ax) - else replaceOnce [re|^ *{|] "{\ncalldatacopy(0,0,1024)" $ onlyAfter [re|^ *{|] (a:ax) - symbolicMem _ = internalError "Program too short" - - unfiltered = lines origcont - filteredASym = symbolicMem [ x | x <- unfiltered, (not $ x =~ [re|^//|]) && (not $ x =~ [re|^$|]) ] - filteredBSym = symbolicMem [ replaceAll "" $ x *=~[re|^//|] | x <- onlyAfter [re|^// step:|] unfiltered, not $ x =~ [re|^$|] ] - start <- getCurrentTime - putStrLn $ "Checking file: " <> f - when opts.debug $ do - putStrLn "-------------Original Below-----------------" - mapM_ putStrLn unfiltered - putStrLn "------------- Filtered A + Symb below-----------------" - mapM_ putStrLn filteredASym - putStrLn "------------- Filtered B + Symb below-----------------" - mapM_ putStrLn filteredBSym - putStrLn "------------- END -----------------" - Just aPrgm <- yul "" $ T.pack $ unlines filteredASym - Just bPrgm <- yul "" $ T.pack $ unlines filteredBSym - procs <- getNumProcessors - withSolvers CVC5 (unsafeInto procs) (Just 100) $ \s -> do - res <- equivalenceCheck s aPrgm bPrgm opts (mkCalldata Nothing []) - end <- getCurrentTime - case any isCex res of - False -> do - print $ "OK. Took " <> (show $ diffUTCTime end start) <> " seconds" - let timeouts = filter isTimeout res - unless (null timeouts) $ do - putStrLn $ "But " <> (show $ length timeouts) <> " timeout(s) occurred" - internalError "Encountered timeouts" - True -> do - putStrLn $ "Not OK: " <> show f <> " Got: " <> show res - internalError "Was NOT equivalent" - ) - ] - ] - where - (===>) = assertSolidityComputation - - -checkEquiv :: (Typeable a) => Expr a -> Expr a -> IO Bool -checkEquiv l r = withSolvers Z3 1 (Just 10) $ \solvers -> do - if l == r - then do - putStrLn "skip" - pure True - else do - let smt = assertProps [l ./= r] - res <- checkSat solvers smt - print res - pure $ case res of - Unsat -> True - EVM.Solvers.Unknown -> True - Sat _ -> False - Error _ -> False - --- | Takes a runtime code and calls it with the provided calldata - --- | Takes a creation code and some calldata, runs the creation code, and calls the resulting contract with the provided calldata -runSimpleVM :: ByteString -> ByteString -> IO (Maybe ByteString) -runSimpleVM x ins = do - loadVM x >>= \case - Nothing -> pure Nothing - Just vm -> do - let calldata = (ConcreteBuf ins) - vm' = set (#state % #calldata) calldata vm - res <- Stepper.interpret (Fetch.zero 0 Nothing) vm' Stepper.execFully - case res of - (Right (ConcreteBuf bs)) -> pure $ Just bs - s -> internalError $ show s - --- | Takes a creation code and returns a vm with the result of executing the creation code -loadVM :: ByteString -> IO (Maybe VM) -loadVM x = do - vm1 <- Stepper.interpret (Fetch.zero 0 Nothing) (vmForEthrunCreation x) Stepper.runFully - case vm1.result of - Just (VMSuccess (ConcreteBuf targetCode)) -> do - let target = vm1.state.contract - vm2 <- Stepper.interpret (Fetch.zero 0 Nothing) vm1 (prepVm target targetCode >> Stepper.run) - pure $ Just vm2 - _ -> pure Nothing - where - prepVm target targetCode = Stepper.evm $ do - replaceCodeOfSelf (RuntimeCode $ ConcreteRuntimeCode targetCode) - resetState - assign (#state % #gas) 0xffffffffffffffff -- kludge - loadContract target - -hex :: ByteString -> ByteString -hex s = - case BS16.decodeBase16 s of - Right x -> x - Left e -> internalError $ T.unpack e - -singleContract :: Text -> Text -> IO (Maybe ByteString) -singleContract x s = - solidity x [i| - pragma experimental ABIEncoderV2; - contract ${x} { ${s} } - |] - -defaultDataLocation :: AbiType -> Text -defaultDataLocation t = - if (case t of - AbiBytesDynamicType -> True - AbiStringType -> True - AbiArrayDynamicType _ -> True - AbiArrayType _ _ -> True - _ -> False) - then "memory" - else "" - -runFunction :: Text -> ByteString -> IO (Maybe ByteString) -runFunction c input = do - Just x <- singleContract "X" c - runSimpleVM x input - -runStatements - :: Text -> [AbiValue] -> AbiType - -> IO (Maybe ByteString) -runStatements stmts args t = do - let params = - T.intercalate ", " - (map (\(x, c) -> abiTypeSolidity (abiValueType x) - <> " " <> defaultDataLocation (abiValueType x) - <> " " <> T.pack [c]) - (zip args "abcdefg")) - s = - "foo(" <> T.intercalate "," - (map (abiTypeSolidity . abiValueType) args) <> ")" - - runFunction [i| - function foo(${params}) public pure returns (${abiTypeSolidity t} ${defaultDataLocation t} x) { - ${stmts} - } - |] (abiMethod s (AbiTuple $ Vector.fromList args)) - -getStaticAbiArgs :: Int -> VM -> [Expr EWord] -getStaticAbiArgs n vm = - let cd = vm.state.calldata - in decodeStaticArgs 4 n cd - --- includes shaving off 4 byte function sig -decodeAbiValues :: [AbiType] -> ByteString -> [AbiValue] -decodeAbiValues types bs = - let xy = case decodeAbiValue (AbiTupleType $ Vector.fromList types) (BS.fromStrict (BS.drop 4 bs)) of - AbiTuple xy' -> xy' - _ -> internalError "AbiTuple expected" - in Vector.toList xy - -newtype Bytes = Bytes ByteString - deriving Eq - -instance Show Bytes where - showsPrec _ (Bytes x) _ = show (BS.unpack x) - -instance Arbitrary Bytes where - arbitrary = fmap (Bytes . BS.pack) arbitrary - -newtype RLPData = RLPData RLP - deriving (Eq, Show) - --- bias towards bytestring to try to avoid infinite recursion -instance Arbitrary RLPData where - arbitrary = frequency - [(5, do - Bytes bytes <- arbitrary - return $ RLPData $ BS bytes) - , (1, do - k <- choose (0,10) - ls <- vectorOf k arbitrary - return $ RLPData $ List [r | RLPData r <- ls]) - ] - -instance Arbitrary Word128 where - arbitrary = liftM2 fromHiAndLo arbitrary arbitrary - -instance Arbitrary Word256 where - arbitrary = liftM2 fromHiAndLo arbitrary arbitrary - -instance Arbitrary W256 where - arbitrary = fmap W256 arbitrary - -instance Arbitrary (Expr Storage) where - arbitrary = sized genStorage - -instance Arbitrary (Expr EWord) where - arbitrary = sized defaultWord - -instance Arbitrary (Expr Byte) where - arbitrary = sized genByte - -instance Arbitrary (Expr Buf) where - arbitrary = sized defaultBuf - -instance Arbitrary (Expr End) where - arbitrary = sized genEnd - --- LitOnly -newtype LitOnly a = LitOnly a - deriving (Show, Eq) - -newtype LitWord (sz :: Nat) = LitWord (Expr EWord) - deriving (Show) - -instance (KnownNat sz) => Arbitrary (LitWord sz) where - arbitrary = LitWord <$> genLit (fromInteger v) - where - v = natVal (Proxy @sz) - -instance Arbitrary (LitOnly (Expr Byte)) where - arbitrary = LitOnly . LitByte <$> arbitrary - -instance Arbitrary (LitOnly (Expr EWord)) where - arbitrary = LitOnly . Lit <$> arbitrary - -instance Arbitrary (LitOnly (Expr Buf)) where - arbitrary = LitOnly . ConcreteBuf <$> arbitrary - --- ZeroDepthWord -newtype ZeroDepthWord = ZeroDepthWord (Expr EWord) - deriving (Show, Eq) - -instance Arbitrary ZeroDepthWord where - arbitrary = do - fmap ZeroDepthWord . sized $ genWord 0 - --- WriteWordBuf -newtype WriteWordBuf = WriteWordBuf (Expr Buf) - deriving (Show, Eq) - -instance Arbitrary WriteWordBuf where - arbitrary = do - let mkBuf = oneof - [ pure $ ConcreteBuf "" -- empty - , fmap ConcreteBuf arbitrary -- concrete - , sized (genBuf 100) -- overlapping writes - , arbitrary -- sparse writes - ] - fmap WriteWordBuf mkBuf - --- GenCopySliceBuf -newtype GenCopySliceBuf = GenCopySliceBuf (Expr Buf) - deriving (Show, Eq) - -instance Arbitrary GenCopySliceBuf where - arbitrary = do - let mkBuf = oneof - [ pure $ ConcreteBuf "" - , fmap ConcreteBuf arbitrary - , arbitrary - ] - fmap GenCopySliceBuf mkBuf - --- GenWriteStorageExpr -newtype GenWriteStorageExpr = GenWriteStorageExpr (Expr EWord, Expr EWord, Expr Storage) - deriving (Show, Eq) - -instance Arbitrary GenWriteStorageExpr where - arbitrary = do - addr <- arbitrary - slot <- arbitrary - let mkStore = oneof - [ pure EmptyStore - , fmap ConcreteStore arbitrary - , do - -- generate some write chains where we know that at least one - -- write matches either the input addr, or both the input - -- addr and slot - let matchAddr = liftM2 (SStore addr) arbitrary arbitrary - matchBoth = fmap (SStore addr slot) arbitrary - addWrites :: Expr Storage -> Int -> Gen (Expr Storage) - addWrites b 0 = pure b - addWrites b n = liftM4 SStore arbitrary arbitrary arbitrary (addWrites b (n - 1)) - s <- arbitrary - addMatch <- oneof [ matchAddr, matchBoth ] - let withMatch = addMatch s - newWrites <- oneof [ pure 0, pure 1, fmap (`mod` 5) arbitrary ] - addWrites withMatch newWrites - , arbitrary - ] - store <- mkStore - pure $ GenWriteStorageExpr (addr, slot, store) - --- GenWriteByteIdx -newtype GenWriteByteIdx = GenWriteByteIdx (Expr EWord) - deriving (Show, Eq) - -instance Arbitrary GenWriteByteIdx where - arbitrary = do - -- 1st: can never overflow an Int - -- 2nd: can overflow an Int - let mkIdx = frequency [ (10, genLit (fromIntegral (1_000_000 :: Int))) , (1, fmap Lit arbitrary) ] - fmap GenWriteByteIdx mkIdx - -genByte :: Int -> Gen (Expr Byte) -genByte 0 = fmap LitByte arbitrary -genByte sz = oneof - [ liftM2 IndexWord subWord subWord - , liftM2 ReadByte subWord subBuf - ] - where - subWord = defaultWord (sz `div` 10) - subBuf = defaultBuf (sz `div` 10) - -genLit :: W256 -> Gen (Expr EWord) -genLit bound = do - w <- arbitrary - pure $ Lit (w `mod` bound) - -genNat :: Gen Int -genNat = fmap fromIntegral (arbitrary :: Gen Natural) - -genName :: Gen Text --- In order not to generate SMT reserved words, we prepend with "esc_" -genName = fmap (T.pack . ("esc_" <> )) $ listOf1 (oneof . (fmap pure) $ ['a'..'z'] <> ['A'..'Z']) - -genEnd :: Int -> Gen (Expr End) -genEnd 0 = oneof - [ fmap (Failure mempty mempty . UnrecognizedOpcode) arbitrary - , pure $ Failure mempty mempty IllegalOverflow - , pure $ Failure mempty mempty SelfDestruction - ] -genEnd sz = oneof - [ fmap (Failure mempty mempty . Revert) subBuf - , liftM4 Success (return mempty) (return mempty) subBuf subStore - , liftM3 ITE subWord subEnd subEnd - ] - where - subBuf = defaultBuf (sz `div` 2) - subStore = genStorage (sz `div` 2) - subWord = defaultWord (sz `div` 2) - subEnd = genEnd (sz `div` 2) - -genWord :: Int -> Int -> Gen (Expr EWord) -genWord litFreq 0 = frequency - [ (litFreq, do - val <- frequency - [ (10, fmap (`mod` 100) arbitrary) - , (1, arbitrary) - ] - pure $ Lit val - ) - , (1, oneof - [ pure Origin - , pure Coinbase - , pure Timestamp - , pure BlockNumber - , pure PrevRandao - , pure GasLimit - , pure ChainId - , pure BaseFee - , fmap CallValue genNat - , fmap Caller genNat - , fmap Address genNat - --, liftM2 SelfBalance arbitrary arbitrary - --, liftM2 Gas arbitrary arbitrary - , fmap Lit arbitrary - , fmap Var genName - ] - ) - ] -genWord litFreq sz = frequency - [ (litFreq, do - val <- frequency - [ (10, fmap (`mod` 100) arbitrary) - , (1, arbitrary) - ] - pure $ Lit val - ) - , (1, oneof - [ liftM2 Add subWord subWord - , liftM2 Sub subWord subWord - , liftM2 Mul subWord subWord - , liftM2 Div subWord subWord - , liftM2 SDiv subWord subWord - , liftM2 Mod subWord subWord - , liftM2 SMod subWord subWord - --, liftM3 AddMod subWord subWord subWord - --, liftM3 MulMod subWord subWord subWord -- it works, but it's VERY SLOW - --, liftM2 Exp subWord litWord - , liftM2 SEx subWord subWord - , liftM2 Min subWord subWord - , liftM2 LT subWord subWord - , liftM2 GT subWord subWord - , liftM2 LEq subWord subWord - , liftM2 GEq subWord subWord - , liftM2 SLT subWord subWord - --, liftM2 SGT subWord subWord - , liftM2 Eq subWord subWord - , fmap IsZero subWord - , liftM2 And subWord subWord - , liftM2 Or subWord subWord - , liftM2 Xor subWord subWord - , fmap Not subWord - , liftM2 SHL subWord subWord - , liftM2 SHR subWord subWord - , liftM2 SAR subWord subWord - , fmap BlockHash subWord - --, liftM3 Balance arbitrary arbitrary subWord - --, fmap CodeSize subWord - --, fmap ExtCodeHash subWord - , fmap Keccak subBuf - , fmap SHA256 subBuf - , liftM3 SLoad subWord subWord subStore - , liftM2 ReadWord subWord subBuf - , fmap BufLength subBuf - , do - one <- subByte - two <- subByte - three <- subByte - four <- subByte - five <- subByte - six <- subByte - seven <- subByte - eight <- subByte - nine <- subByte - ten <- subByte - eleven <- subByte - twelve <- subByte - thirteen <- subByte - fourteen <- subByte - fifteen <- subByte - sixteen <- subByte - seventeen <- subByte - eighteen <- subByte - nineteen <- subByte - twenty <- subByte - twentyone <- subByte - twentytwo <- subByte - twentythree <- subByte - twentyfour <- subByte - twentyfive <- subByte - twentysix <- subByte - twentyseven <- subByte - twentyeight <- subByte - twentynine <- subByte - thirty <- subByte - thirtyone <- subByte - thirtytwo <- subByte - pure $ JoinBytes - one two three four five six seven eight nine ten - eleven twelve thirteen fourteen fifteen sixteen - seventeen eighteen nineteen twenty twentyone - twentytwo twentythree twentyfour twentyfive - twentysix twentyseven twentyeight twentynine - thirty thirtyone thirtytwo - ]) - ] - where - subWord = genWord litFreq (sz `div` 5) - subBuf = defaultBuf (sz `div` 10) - subStore = genStorage (sz `div` 10) - subByte = genByte (sz `div` 10) - -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) - -defaultWord :: Int -> Gen (Expr EWord) -defaultWord = genWord 10 - -maybeBoundedLit :: W256 -> Gen (Expr EWord) -maybeBoundedLit bound = do - o <- (arbitrary :: Gen (Expr EWord)) - pure $ case o of - Lit w -> Lit $ w `mod` bound - _ -> o - -genBuf :: W256 -> Int -> Gen (Expr Buf) -genBuf _ 0 = oneof - [ fmap AbstractBuf genName - , fmap ConcreteBuf arbitrary - ] -genBuf bound sz = oneof - [ liftM3 WriteWord (maybeBoundedLit bound) subWord subBuf - , liftM3 WriteByte (maybeBoundedLit bound) subByte subBuf - -- we don't generate copyslice instances where: - -- - size is abstract - -- - size > 100 (due to unrolling in SMT.hs) - -- - literal dstOffsets are > 4,000,000 (due to unrolling in SMT.hs) - -- n.b. that 4,000,000 is the theoretical maximum memory size given a 30,000,000 block gas limit - , liftM5 CopySlice subWord (maybeBoundedLit bound) smolLitWord subBuf subBuf - ] - where - -- copySlice gets unrolled in the generated SMT so we can't go too crazy here - smolLitWord = do - w <- arbitrary - pure $ Lit (w `mod` 100) - subWord = defaultWord (sz `div` 5) - subByte = genByte (sz `div` 10) - subBuf = genBuf bound (sz `div` 10) - -genStorage :: Int -> Gen (Expr Storage) -genStorage 0 = oneof - [ pure AbstractStore - , pure EmptyStore - --, fmap ConcreteStore arbitrary - ] -genStorage sz = liftM4 SStore subWord subWord subWord subStore - where - subStore = genStorage (sz `div` 10) - subWord = defaultWord (sz `div` 5) - -data Invocation - = SolidityCall Text [AbiValue] - deriving Show - -assertSolidityComputation :: Invocation -> AbiValue -> IO () -assertSolidityComputation (SolidityCall s args) x = - do y <- runStatements s args (abiValueType x) - assertEqual (T.unpack s) - (fmap Bytes (Just (encodeAbiValue x))) - (fmap Bytes y) - -bothM :: (Monad m) => (a -> m b) -> (a, a) -> m (b, b) -bothM f (a, a') = do - b <- f a - b' <- f a' - return (b, b') - -applyPattern :: String -> TestTree -> TestTree -applyPattern p = localOption (TestPattern (parseExpr p)) +import Control.Monad.ST (RealWorld, stToIO) +import Control.Monad.State.Strict +import Data.Bits hiding (And, Xor) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as BS16 +import Data.Binary.Put (runPut) +import Data.Binary.Get (runGetOrFail) +import Data.DoubleWord +import Data.Either +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Maybe +import Data.String.Here +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Time (diffUTCTime, getCurrentTime) +import Data.Typeable +import Data.Vector qualified as V +import Data.Word (Word8) +import GHC.Conc (getNumProcessors) +import System.Directory +import System.Environment +import Test.Tasty +import Test.Tasty.QuickCheck hiding (Failure, Success) +import Test.QuickCheck.Instances.Text() +import Test.QuickCheck.Instances.Natural() +import Test.QuickCheck.Instances.ByteString() +import Test.Tasty.HUnit +import Test.Tasty.Runners hiding (Failure, Success) +import Test.Tasty.ExpectedFailure +import Text.RE.TDFA.String +import Text.RE.Replace +import Witch (unsafeInto, into) + +import Optics.Core hiding (pre, re, elements) +import Optics.State + +import EVM hiding (choose) +import EVM.ABI +import EVM.Assembler +import EVM.Exec +import EVM.Expr qualified as Expr +import EVM.Fetch qualified as Fetch +import EVM.Format (hexText, formatExpr) +import EVM.Precompiled +import EVM.RLP +import EVM.SMT hiding (one) +import EVM.Solidity +import EVM.Solvers +import EVM.Stepper qualified as Stepper +import EVM.SymExec +import EVM.Test.Tracing qualified as Tracing +import EVM.Test.Utils +import EVM.Traversals +import EVM.Types + +main :: IO () +main = defaultMain tests + +-- | run a subset of tests in the repl. p is a tasty pattern: +-- https://github.com/UnkindPartition/tasty/tree/ee6fe7136fbcc6312da51d7f1b396e1a2d16b98a#patterns +runSubSet :: String -> IO () +runSubSet p = defaultMain . applyPattern p $ tests + +tests :: TestTree +tests = testGroup "hevm" + [ Tracing.tests + , testGroup "simplify-storage" + [ testCase "simplify-storage-array-only-static" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] a; + function transfer(uint acct, uint val1, uint val2) public { + unchecked { + a[0] = val1 + 1; + a[1] = val2 + 2; + assert(a[0]+a[1] == val1 + val2 + 3); + } + } + } + |] + expr <- withSolvers Z3 1 Nothing $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] debugVeriOpts + assertEqual "Expression is not clean." (badStoresInExpr expr) False + -- This case is somewhat artificial. We can't simplify this using only + -- static rewrite rules, because acct is totally abstract and acct + 1 + -- could overflow back to zero. we may be able to do better if we have some + -- smt assisted simplification that can take branch conditions into account. + , expectFail $ testCase "simplify-storage-array-symbolic-index" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint b; + uint[] a; + function transfer(uint acct, uint val1) public { + unchecked { + a[acct] = val1; + assert(a[acct] == val1); + } + } + } + |] + expr <- withSolvers Z3 1 Nothing $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] debugVeriOpts + -- T.writeFile "symbolic-index.expr" $ formatExpr expr + assertEqual "Expression is not clean." (badStoresInExpr expr) False + , expectFail $ testCase "simplify-storage-array-of-struct-symbolic-index" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + struct MyStruct { + uint a; + uint b; + } + MyStruct[] arr; + function transfer(uint acct, uint val1, uint val2) public { + unchecked { + arr[acct].a = val1+1; + arr[acct].b = val1+2; + assert(arr[acct].a + arr[acct].b == val1+val2+3); + } + } + } + |] + expr <- withSolvers Z3 1 Nothing $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] debugVeriOpts + assertEqual "Expression is not clean." (badStoresInExpr expr) False + , testCase "simplify-storage-array-loop-nonstruct" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] a; + function transfer(uint v) public { + for (uint i = 0; i < a.length; i++) { + a[i] = v; + assert(a[i] == v); + } + } + } + |] + expr <- withSolvers Z3 1 Nothing $ \s -> getExpr s c (Just (Sig "transfer(uint256)" [AbiUIntType 256])) [] (debugVeriOpts { maxIter = Just 5 }) + assertEqual "Expression is not clean." (badStoresInExpr expr) False + , testCase "simplify-storage-array-loop-struct" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + struct MyStruct { + uint a; + uint b; + } + MyStruct[] arr; + function transfer(uint v1, uint v2) public { + for (uint i = 0; i < arr.length; i++) { + arr[i].a = v1+1; + arr[i].b = v2+2; + assert(arr[i].a + arr[i].b == v1 + v2 + 3); + } + } + } + |] + expr <- withSolvers Z3 1 Nothing $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] (debugVeriOpts { maxIter = Just 5 }) + assertEqual "Expression is not clean." (badStoresInExpr expr) False + , testCase "simplify-storage-map-only-static" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping(uint => uint) items1; + function transfer(uint acct, uint val1, uint val2) public { + unchecked { + items1[0] = val1+1; + items1[1] = val2+2; + assert(items1[0]+items1[1] == val1 + val2 + 3); + } + } + } + |] + expr <- withSolvers Z3 1 Nothing $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] debugVeriOpts + assertEqual "Expression is not clean." (badStoresInExpr expr) False + , testCase "simplify-storage-map-only-2" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + mapping(uint => uint) items1; + function transfer(uint acct, uint val1, uint val2) public { + unchecked { + items1[acct] = val1+1; + items1[acct+1] = val2+2; + assert(items1[acct]+items1[acct+1] == val1 + val2 + 3); + } + } + } + |] + expr <- withSolvers Z3 1 Nothing $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] debugVeriOpts + -- putStrLn $ T.unpack $ formatExpr expr + assertEqual "Expression is not clean." (badStoresInExpr expr) False + , testCase "simplify-storage-map-with-struct" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + struct MyStruct { + uint a; + uint b; + } + mapping(uint => MyStruct) items1; + function transfer(uint acct, uint val1, uint val2) public { + unchecked { + items1[acct].a = val1+1; + items1[acct].b = val2+2; + assert(items1[acct].a+items1[acct].b == val1 + val2 + 3); + } + } + } + |] + expr <- withSolvers Z3 1 Nothing $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] debugVeriOpts + assertEqual "Expression is not clean." (badStoresInExpr expr) False + , testCase "simplify-storage-map-and-array" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] a; + mapping(uint => uint) items1; + mapping(uint => uint) items2; + function transfer(uint acct, uint val1, uint val2) public { + uint beforeVal1 = items1[acct]; + uint beforeVal2 = items2[acct]; + unchecked { + items1[acct] = val1+1; + items2[acct] = val2+2; + a[0] = val1 + val2 + 1; + a[1] = val1 + val2 + 2; + assert(items1[acct]+items2[acct]+a[0]+a[1] > beforeVal1 + beforeVal2); + } + } + } + |] + expr <- withSolvers Z3 1 Nothing $ \s -> getExpr s c (Just (Sig "transfer(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] debugVeriOpts + -- putStrLn $ T.unpack $ formatExpr expr + assertEqual "Expression is not clean." (badStoresInExpr expr) False + ] + , testGroup "StorageTests" + [ testCase "read-from-sstore" $ assertEqual "" + (Lit 0xab) + (Expr.readStorage' (Lit 0x0) (SStore (Lit 0x0) (Lit 0xab) (AbstractStore (LitAddr 0x0)))) + , testCase "read-from-concrete" $ assertEqual "" + (Lit 0xab) + (Expr.readStorage' (Lit 0x0) (ConcreteStore $ Map.fromList [(0x0, 0xab)])) + , testCase "read-past-write" $ assertEqual "" + (Lit 0xab) + (Expr.readStorage' (Lit 0x0) (SStore (Lit 0x1) (Var "b") (ConcreteStore $ Map.fromList [(0x0, 0xab)]))) + , testCase "accessStorage uses fetchedStorage" $ do + let dummyContract = + (initialContract (RuntimeCode (ConcreteRuntimeCode mempty))) + { external = True } + vm <- stToIO $ vmForEthrunCreation "" + -- perform the initial access + vm1 <- stToIO $ execStateT (EVM.accessStorage (LitAddr 0) (Lit 0) (pure . pure ())) vm + -- it should fetch the contract first + vm2 <- case vm1.result of + Just (HandleEffect (Query (PleaseFetchContract _addr _ continue))) -> + stToIO $ execStateT (continue dummyContract) vm1 + _ -> internalError "unexpected result" + -- then it should fetch the slow + vm3 <- case vm2.result of + Just (HandleEffect (Query (PleaseFetchSlot _addr _slot continue))) -> + stToIO $ execStateT (continue 1337) vm2 + _ -> internalError "unexpected result" + -- perform the same access as for vm1 + vm4 <- stToIO $ execStateT (EVM.accessStorage (LitAddr 0) (Lit 0) (pure . pure ())) vm3 + + -- there won't be query now as accessStorage uses fetch cache + assertBool (show vm4.result) (isNothing vm4.result) + ] + , testGroup "SimplifierUnitTests" + -- common overflow cases that the simplifier was getting wrong + [ testCase "bufLength-simp" $ do + let + a = BufLength (ConcreteBuf "ab") + simp = Expr.simplify a + assertEqual "Must be simplified down to a Lit" simp (Lit 2) + , testCase "writeWord-overflow" $ do + let e = ReadByte (Lit 0x0) (WriteWord (Lit 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffd) (Lit 0x0) (ConcreteBuf "\255\255\255\255")) + b <- checkEquiv e (Expr.simplify e) + assertBool "Simplifier failed" b + , testCase "CopySlice-overflow" $ do + let e = ReadWord (Lit 0x0) (CopySlice (Lit 0x0) (Lit 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc) (Lit 0x6) (ConcreteBuf "\255\255\255\255\255\255") (ConcreteBuf "")) + b <- checkEquiv e (Expr.simplify e) + assertBool "Simplifier failed" b + , testCase "stripWrites-overflow" $ do + -- below eventually boils down to + -- unsafeInto (0xf0000000000000000000000000000000000000000000000000000000000000+1) :: Int + -- which failed before + let + a = ReadByte (Lit 0xf0000000000000000000000000000000000000000000000000000000000000) (WriteByte (And (SHA256 (ConcreteBuf "")) (Lit 0x1)) (LitByte 0) (ConcreteBuf "")) + b = Expr.simplify a + ret <- checkEquiv a b + assertBool "must be equivalent" ret + ] + -- These tests fuzz the simplifier by generating a random expression, + -- applying some simplification rules, and then using the smt encoding to + -- check that the simplified version is semantically equivalent to the + -- unsimplified one + , adjustOption (\(Test.Tasty.QuickCheck.QuickCheckTests n) -> Test.Tasty.QuickCheck.QuickCheckTests (min n 50)) $ testGroup "SimplifierTests" + [ testProperty "buffer-simplification" $ \(expr :: Expr Buf) -> ioProperty $ do + let simplified = Expr.simplify expr + checkEquiv expr simplified + , testProperty "store-simplification" $ \(expr :: Expr Storage) -> ioProperty $ do + let simplified = Expr.simplify expr + checkEquiv expr simplified + , testProperty "byte-simplification" $ \(expr :: Expr Byte) -> ioProperty $ do + let simplified = Expr.simplify expr + checkEquiv expr simplified + , testProperty "word-simplification" $ \(ZeroDepthWord expr) -> ioProperty $ do + let simplified = Expr.simplify expr + checkEquiv expr simplified + , testProperty "readStorage-equivalance" $ \(store, slot) -> ioProperty $ do + let simplified = Expr.readStorage' slot store + full = SLoad slot store + checkEquiv simplified full + , testProperty "writeStorage-equivalance" $ \(val, GenWriteStorageExpr (slot, store)) -> ioProperty $ do + let simplified = Expr.writeStorage slot val store + full = SStore slot val store + checkEquiv simplified full + , testProperty "readWord-equivalance" $ \(buf, idx) -> ioProperty $ do + let simplified = Expr.readWord idx buf + full = ReadWord idx buf + checkEquiv simplified full + , testProperty "writeWord-equivalance" $ \(idx, val, WriteWordBuf buf) -> ioProperty $ do + 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 + checkEquiv simplified full + -- we currently only simplify concrete writes over concrete buffers so that's what we test here + , testProperty "writeByte-equivalance" $ \(LitOnly val, LitOnly buf, GenWriteByteIdx idx) -> ioProperty $ do + let simplified = Expr.writeByte idx val buf + full = WriteByte idx val buf + checkEquiv simplified full + , testProperty "copySlice-equivalance" $ \(srcOff, GenCopySliceBuf src, GenCopySliceBuf dst, LitWord @300 size) -> ioProperty $ do + -- we bias buffers to be concrete more often than not + dstOff <- generate (maybeBoundedLit 100_000) + let simplified = Expr.copySlice srcOff dstOff size src dst + full = CopySlice srcOff dstOff size src dst + checkEquiv simplified full + , testProperty "indexWord-equivalence" $ \(src, LitWord @50 idx) -> ioProperty $ do + let simplified = Expr.indexWord idx src + full = IndexWord idx src + checkEquiv simplified full + , testProperty "indexWord-mask-equivalence" $ \(src :: Expr EWord, LitWord @35 idx) -> ioProperty $ do + mask <- generate $ do + pow <- arbitrary :: Gen Int + frequency + [ (1, pure $ Lit $ (shiftL 1 (pow `mod` 256)) - 1) -- potentially non byte aligned + , (1, pure $ Lit $ (shiftL 1 ((pow * 8) `mod` 256)) - 1) -- byte aligned + ] + let + input = And mask src + simplified = Expr.indexWord idx input + full = IndexWord idx input + checkEquiv simplified full + , testProperty "toList-equivalance" $ \buf -> ioProperty $ do + let + -- transforms the input buffer to give it a known length + fixLength :: Expr Buf -> Gen (Expr Buf) + fixLength = mapExprM go + where + go :: Expr a -> Gen (Expr a) + go = \case + WriteWord _ val b -> liftM3 WriteWord idx (pure val) (pure b) + WriteByte _ val b -> liftM3 WriteByte idx (pure val) (pure b) + CopySlice so _ sz src dst -> liftM5 CopySlice (pure so) idx (pure sz) (pure src) (pure dst) + AbstractBuf _ -> cbuf + e -> pure e + cbuf = do + bs <- arbitrary + pure $ ConcreteBuf bs + idx = do + w <- arbitrary + -- we use 100_000 as an upper bound for indices to keep tests reasonably fast here + pure $ Lit (w `mod` 100_000) + + input <- generate $ fixLength buf + case Expr.toList input of + Nothing -> do + putStrLn "skip" + pure True -- ignore cases where the buf cannot be represented as a list + Just asList -> do + let asBuf = Expr.fromList asList + checkEquiv asBuf input + , testProperty "simplifyProp-equivalence-lit" $ \(LitProp p) -> ioProperty $ do + let simplified = Expr.simplifyProps [p] + case simplified of + [] -> checkEquivProp (PBool True) p + [val@(PBool _)] -> checkEquivProp val p + _ -> assertFailure "must evaluate down to a literal bool" + , testProperty "simplifyProp-equivalence-sym" $ \(p) -> ioProperty $ do + let simplified = Expr.simplifyProp p + checkEquivProp simplified p + , testProperty "simpProp-equivalence-sym" $ \(ps :: [Prop]) -> ioProperty $ do + let simplified = pand (Expr.simplifyProps ps) + checkEquivProp simplified (pand ps) + , testProperty "simpProp-equivalence-sym" $ \(LitProp p) -> ioProperty $ do + let simplified = pand (Expr.simplifyProps [p]) + checkEquivProp simplified p + -- This would need to be a fuzz test I think. The SMT encoding of Keccak is not precise + -- enough for this to succeed + , ignoreTest $ testProperty "storage-slot-simp-property" $ \(StorageExp s) -> ioProperty $ do + T.writeFile "unsimplified.expr" $ formatExpr s + let simplified = Expr.simplify s + T.writeFile "simplified.expr" $ formatExpr simplified + checkEquiv simplified s + ] + , testGroup "simpProp-concrete-tests" [ + testCase "simpProp-concrete-trues" $ do + let + t = [PBool True, PBool True] + simplified = Expr.simplifyProps t + assertEqual "Must be equal" [] simplified + , testCase "simpProp-concrete-false1" $ do + let + t = [PBool True, PBool False] + simplified = Expr.simplifyProps t + assertEqual "Must be equal" [PBool False] simplified + , testCase "simpProp-concrete-false2" $ do + let + t = [PBool False, PBool False] + simplified = Expr.simplifyProps t + assertEqual "Must be equal" [PBool False] simplified + , testCase "simpProp-concrete-or-1" $ do + let + -- a = 5 && (a=4 || a=3) -> False + t = [PEq (Lit 5) (Var "a"), POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 3))] + simplified = Expr.simplifyProps t + assertEqual "Must be equal" [PBool False] simplified + , ignoreTest $ testCase "simpProp-concrete-or-2" $ do + let + -- Currently does not work, because we don't do simplification inside + -- POr/PAnd using canBeSat + -- a = 5 && (a=4 || a=5) -> a=5 + t = [PEq (Lit 5) (Var "a"), POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 5))] + simplified = Expr.simplifyProps t + assertEqual "Must be equal" [] simplified + , testCase "simpProp-concrete-and-1" $ do + let + -- a = 5 && (a=4 && a=3) -> False + t = [PEq (Lit 5) (Var "a"), PAnd (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 3))] + simplified = Expr.simplifyProps t + assertEqual "Must be equal" [PBool False] simplified + , testCase "simpProp-concrete-or-of-or" $ do + let + -- a = 5 && ((a=4 || a=6) || a=3) -> False + t = [PEq (Lit 5) (Var "a"), POr (POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 6))) (PEq (Var "a") (Lit 3))] + simplified = Expr.simplifyProps t + assertEqual "Must be equal" [PBool False] simplified + , testCase "simpProp-concrete-or-eq-rem" $ do + let + -- a = 5 && ((a=4 || a=6) || a=3) -> False + t = [PEq (Lit 5) (Var "a"), POr (POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 6))) (PEq (Var "a") (Lit 3))] + simplified = Expr.simplifyProps t + assertEqual "Must be equal" [PBool False] simplified + , testCase "simpProp-inner-expr-simp" $ do + let + -- 5+1 = 6 + t = [PEq (Add (Lit 5) (Lit 1)) (Var "a")] + simplified = Expr.simplifyProps t + assertEqual "Must be equal" [PEq (Lit 6) (Var "a")] simplified + , testCase "simpProp-inner-expr-simp-with-canBeSat" $ do + let + -- 5+1 = 6, 6 != 7 + t = [PAnd (PEq (Add (Lit 5) (Lit 1)) (Var "a")) (PEq (Var "a") (Lit 7))] + simplified = Expr.simplifyProps t + assertEqual "Must be equal" [PBool False] simplified + ] + , testGroup "MemoryTests" + [ testCase "read-write-same-byte" $ assertEqual "" + (LitByte 0x12) + (Expr.readByte (Lit 0x20) (WriteByte (Lit 0x20) (LitByte 0x12) mempty)) + , testCase "read-write-same-word" $ assertEqual "" + (Lit 0x12) + (Expr.readWord (Lit 0x20) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) + , testCase "read-byte-write-word" $ assertEqual "" + -- reading at byte 31 a word that's been written should return LSB + (LitByte 0x12) + (Expr.readByte (Lit 0x1f) (WriteWord (Lit 0x0) (Lit 0x12) mempty)) + , testCase "read-byte-write-word2" $ assertEqual "" + -- Same as above, but offset not 0 + (LitByte 0x12) + (Expr.readByte (Lit 0x20) (WriteWord (Lit 0x1) (Lit 0x12) mempty)) + ,testCase "read-write-with-offset" $ assertEqual "" + -- 0x3F = 63 decimal, 0x20 = 32. 0x12 = 18 + -- We write 128bits (32 Bytes), representing 18 at offset 32. + -- Hence, when reading out the 63rd byte, we should read out the LSB 8 bits + -- which is 0x12 + (LitByte 0x12) + (Expr.readByte (Lit 0x3F) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) + ,testCase "read-write-with-offset2" $ assertEqual "" + -- 0x20 = 32, 0x3D = 61 + -- we write 128 bits (32 Bytes) representing 0x10012, at offset 32. + -- we then read out a byte at offset 61. + -- So, at 63 we'd read 0x12, at 62 we'd read 0x00, at 61 we should read 0x1 + (LitByte 0x1) + (Expr.readByte (Lit 0x3D) (WriteWord (Lit 0x20) (Lit 0x10012) mempty)) + , testCase "read-write-with-extension-to-zero" $ assertEqual "" + -- write word and read it at the same place (i.e. 0 offset) + (Lit 0x12) + (Expr.readWord (Lit 0x0) (WriteWord (Lit 0x0) (Lit 0x12) mempty)) + , testCase "read-write-with-extension-to-zero-with-offset" $ assertEqual "" + -- write word and read it at the same offset of 4 + (Lit 0x12) + (Expr.readWord (Lit 0x4) (WriteWord (Lit 0x4) (Lit 0x12) mempty)) + , testCase "read-write-with-extension-to-zero-with-offset2" $ assertEqual "" + -- write word and read it at the same offset of 16 + (Lit 0x12) + (Expr.readWord (Lit 0x20) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) + , testCase "read-word-copySlice-overlap" $ assertEqual "" + -- we should not recurse into a copySlice if the read index + 32 overlaps the sliced region + (ReadWord (Lit 40) (CopySlice (Lit 0) (Lit 30) (Lit 12) (WriteWord (Lit 10) (Lit 0x64) (AbstractBuf "hi")) (AbstractBuf "hi"))) + (Expr.readWord (Lit 40) (CopySlice (Lit 0) (Lit 30) (Lit 12) (WriteWord (Lit 10) (Lit 0x64) (AbstractBuf "hi")) (AbstractBuf "hi"))) + , testCase "indexword-MSB" $ assertEqual "" + -- 31st is the LSB byte (of 32) + (LitByte 0x78) + (Expr.indexWord (Lit 31) (Lit 0x12345678)) + , testCase "indexword-LSB" $ assertEqual "" + -- 0th is the MSB byte (of 32), Lit 0xff22bb... is exactly 32 Bytes. + (LitByte 0xff) + (Expr.indexWord (Lit 0) (Lit 0xff22bb4455667788990011223344556677889900112233445566778899001122)) + , testCase "indexword-LSB2" $ assertEqual "" + -- same as above, but with offset 2 + (LitByte 0xbb) + (Expr.indexWord (Lit 2) (Lit 0xff22bb4455667788990011223344556677889900112233445566778899001122)) + , testCase "encodeConcreteStore-overwrite" $ + assertEqual "" + "(store (store ((as const Storage) #x0000000000000000000000000000000000000000000000000000000000000000) (_ bv1 256) (_ bv2 256)) (_ bv3 256) (_ bv4 256))" + (EVM.SMT.encodeConcreteStore $ + Map.fromList [(W256 1, W256 2), (W256 3, W256 4)]) + , testCase "indexword-oob-sym" $ assertEqual "" + -- indexWord should return 0 for oob access + (LitByte 0x0) + (Expr.indexWord (Lit 100) (JoinBytes + (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) + (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) + (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) + (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0))) + , testCase "stripbytes-concrete-bug" $ assertEqual "" + (Expr.simplifyReads (ReadByte (Lit 0) (ConcreteBuf "5"))) + (LitByte 53) + ] + , testGroup "ABI" + [ testProperty "Put/get inverse" $ \x -> + case runGetOrFail (getAbi (abiValueType x)) (runPut (putAbi x)) of + Right ("", _, x') -> x' == x + _ -> False + ] + , testGroup "Solidity-Expressions" + [ testCase "Trivial" $ + SolidityCall "x = 3;" [] + ===> AbiUInt 256 3 + + , testCase "Arithmetic" $ do + SolidityCall "x = a + 1;" + [AbiUInt 256 1] ===> AbiUInt 256 2 + SolidityCall "unchecked { x = a - 1; }" + [AbiUInt 8 0] ===> AbiUInt 8 255 + + , testCase "keccak256()" $ + SolidityCall "x = uint(keccak256(abi.encodePacked(a)));" + [AbiString ""] ===> AbiUInt 256 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470 + + , testProperty "abi encoding vs. solidity" $ withMaxSuccess 20 $ forAll (arbitrary >>= genAbiValue) $ + \y -> ioProperty $ do + Just encoded <- runStatements [i| x = abi.encode(a);|] + [y] AbiBytesDynamicType + let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of + AbiTuple (V.toList -> [e]) -> e + _ -> internalError "AbiTuple expected" + let hevmEncoded = encodeAbiValue (AbiTuple $ V.fromList [y]) + assertEqual "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) + + , testProperty "abi encoding vs. solidity (2 args)" $ withMaxSuccess 20 $ forAll (arbitrary >>= bothM genAbiValue) $ + \(x', y') -> ioProperty $ do + Just encoded <- runStatements [i| x = abi.encode(a, b);|] + [x', y'] AbiBytesDynamicType + let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of + AbiTuple (V.toList -> [e]) -> e + _ -> internalError "AbiTuple expected" + let hevmEncoded = encodeAbiValue (AbiTuple $ V.fromList [x',y']) + assertEqual "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) + + -- we need a separate test for this because the type of a function is "function() external" in solidity but just "function" in the abi: + , testProperty "abi encoding vs. solidity (function pointer)" $ withMaxSuccess 20 $ forAll (genAbiValue AbiFunctionType) $ + \y -> ioProperty $ do + Just encoded <- runFunction [i| + function foo(function() external a) public pure returns (bytes memory x) { + x = abi.encode(a); + } + |] (abiMethod "foo(function)" (AbiTuple (V.singleton y))) + let solidityEncoded = case decodeAbiValue (AbiTupleType $ V.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) of + AbiTuple (V.toList -> [e]) -> e + _ -> internalError "AbiTuple expected" + let hevmEncoded = encodeAbiValue (AbiTuple $ V.fromList [y]) + assertEqual "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) + ] + + , testGroup "Precompiled contracts" + [ testGroup "Example (reverse)" + [ testCase "success" $ + assertEqual "example contract reverses" + (execute 0xdeadbeef "foobar" 6) (Just "raboof") + , testCase "failure" $ + assertEqual "example contract fails on length mismatch" + (execute 0xdeadbeef "foobar" 5) Nothing + ] + + , testGroup "ECRECOVER" + [ testCase "success" $ do + let + r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4732" + s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" + v = hex "000000000000000000000000000000000000000000000000000000000000001c" + h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31" + a = hex "0000000000000000000000002d5e56d45c63150d937f2182538a0f18510cb11f" + assertEqual "successful recovery" + (Just a) + (execute 1 (h <> v <> r <> s) 32) + , testCase "fail on made up values" $ do + let + r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4731" + s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" + v = hex "000000000000000000000000000000000000000000000000000000000000001c" + h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31" + assertEqual "fail because bit flip" + Nothing + (execute 1 (h <> v <> r <> s) 32) + ] + ] + , testGroup "Byte/word manipulations" + [ testProperty "padLeft length" $ \n (Bytes bs) -> + BS.length (padLeft n bs) == max n (BS.length bs) + , testProperty "padLeft identity" $ \(Bytes bs) -> + padLeft (BS.length bs) bs == bs + , testProperty "padRight length" $ \n (Bytes bs) -> + BS.length (padLeft n bs) == max n (BS.length bs) + , testProperty "padRight identity" $ \(Bytes bs) -> + padLeft (BS.length bs) bs == bs + , testProperty "padLeft zeroing" $ \(NonNegative n) (Bytes bs) -> + let x = BS.take n (padLeft (BS.length bs + n) bs) + y = BS.replicate n 0 + in x == y + ] + + , testGroup "Unresolved link detection" + [ testCase "holes detected" $ do + let code' = "608060405234801561001057600080fd5b5060405161040f38038061040f83398181016040528101906100329190610172565b73__$f3cbc3eb14e5bd0705af404abcf6f741ec$__63ab5c1ffe826040518263ffffffff1660e01b81526004016100699190610217565b60206040518083038186803b15801561008157600080fd5b505af4158015610095573d6000803e3d6000fd5b505050506040513d601f19601f820116820180604052508101906100b99190610145565b50506103c2565b60006100d36100ce84610271565b61024c565b9050828152602081018484840111156100ef576100ee610362565b5b6100fa8482856102ca565b509392505050565b600081519050610111816103ab565b92915050565b600082601f83011261012c5761012b61035d565b5b815161013c8482602086016100c0565b91505092915050565b60006020828403121561015b5761015a61036c565b5b600061016984828501610102565b91505092915050565b6000602082840312156101885761018761036c565b5b600082015167ffffffffffffffff8111156101a6576101a5610367565b5b6101b284828501610117565b91505092915050565b60006101c6826102a2565b6101d081856102ad565b93506101e08185602086016102ca565b6101e981610371565b840191505092915050565b60006102016003836102ad565b915061020c82610382565b602082019050919050565b6000604082019050818103600083015261023181846101bb565b90508181036020830152610244816101f4565b905092915050565b6000610256610267565b905061026282826102fd565b919050565b6000604051905090565b600067ffffffffffffffff82111561028c5761028b61032e565b5b61029582610371565b9050602081019050919050565b600081519050919050565b600082825260208201905092915050565b60008115159050919050565b60005b838110156102e85780820151818401526020810190506102cd565b838111156102f7576000848401525b50505050565b61030682610371565b810181811067ffffffffffffffff821117156103255761032461032e565b5b80604052505050565b7f4e487b7100000000000000000000000000000000000000000000000000000000600052604160045260246000fd5b600080fd5b600080fd5b600080fd5b600080fd5b6000601f19601f8301169050919050565b7f6261720000000000000000000000000000000000000000000000000000000000600082015250565b6103b4816102be565b81146103bf57600080fd5b50565b603f806103d06000396000f3fe6080604052600080fdfea26469706673582212207d03b26e43dc3d116b0021ddc9817bde3762a3b14315351f11fc4be384fd14a664736f6c63430008060033" + assertBool "linker hole not detected" (containsLinkerHole code'), + testCase "no false positives" $ do + let code' = "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fea265627a7a723158205d775f914dcb471365a430b5f5b2cfe819e615cbbb5b2f1ccc7da1fd802e43c364736f6c634300050b0032" + assertBool "false positive" (not . containsLinkerHole $ code') + ] + + , testGroup "metadata stripper" + [ testCase "it strips the metadata for solc => 0.6" $ do + let code' = hexText "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fea265627a7a723158205d775f914dcb471365a430b5f5b2cfe819e615cbbb5b2f1ccc7da1fd802e43c364736f6c634300050b0032" + stripped = stripBytecodeMetadata code' + assertEqual "failed to strip metadata" (show (ByteStringS stripped)) "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fe" + , + testCase "it strips the metadata and constructor args" $ do + let srccode = + [i| + contract A { + uint y; + constructor(uint x) public { + y = x; + } + } + |] + + Just initCode <- solidity "A" srccode + assertEqual "constructor args screwed up metadata stripping" (stripBytecodeMetadata (initCode <> encodeAbiValue (AbiUInt 256 1))) (stripBytecodeMetadata initCode) + ] + + , testGroup "RLP encodings" + [ testProperty "rlp decode is a retraction (bytes)" $ \(Bytes bs) -> + rlpdecode (rlpencode (BS bs)) == Just (BS bs) + , testProperty "rlp encode is a partial inverse (bytes)" $ \(Bytes bs) -> + case rlpdecode bs of + Just r -> rlpencode r == bs + Nothing -> True + , testProperty "rlp decode is a retraction (RLP)" $ \(RLPData r) -> + rlpdecode (rlpencode r) == Just r + ] + , testGroup "Panic code tests via symbolic execution" + [ + testCase "assert-fail" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a) external pure { + assert(a != 0); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x01] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + assertEqual "Must be 0" 0 $ getVar ctr "arg1" + putStrLn $ "expected counterexample found, and it's correct: " <> (show $ getVar ctr "arg1") + , + testCase "safeAdd-fail" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure returns (uint256 c) { + c = a+b; + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x11] c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + let x = getVar ctr "arg1" + let y = getVar ctr "arg2" + + let maxUint = 2 ^ (256 :: Integer) :: Integer + assertBool "Overflow must occur" (toInteger x + toInteger y >= maxUint) + putStrLn "expected counterexample found" + , + testCase "div-by-zero-fail" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure returns (uint256 c) { + c = a/b; + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x12] c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + assertEqual "Division by 0 needs b=0" (getVar ctr "arg2") 0 + putStrLn "expected counterexample found" + , + testCase "unused-args-fail" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun(uint256 a) public pure { + assert(false); + } + } + |] + (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x1] c Nothing [] defaultVeriOpts + putStrLn "expected counterexample found" + , + testCase "enum-conversion-fail" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + enum MyEnum { ONE, TWO } + function fun(uint256 a) external pure returns (MyEnum b) { + b = MyEnum(a); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x21] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + assertBool "Enum is only defined for 0 and 1" $ (getVar ctr "arg1") > 1 + putStrLn "expected counterexample found" + , + -- TODO 0x22 is missing: "0x22: If you access a storage byte array that is incorrectly encoded." + -- TODO below should NOT fail + -- TODO this has a loop that depends on a symbolic value and currently causes interpret to loop + ignoreTest $ testCase "pop-empty-array" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] private arr; + function fun(uint8 a) external { + arr.push(1); + arr.push(2); + for (uint i = 0; i < a; i++) { + arr.pop(); + } + } + } + |] + a <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x31] c (Just (Sig "fun(uint8)" [AbiUIntType 8])) [] defaultVeriOpts + print $ length a + print $ show a + putStrLn "expected counterexample found" + , + testCase "access-out-of-bounds-array" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] private arr; + function fun(uint8 a) external returns (uint x){ + arr.push(1); + arr.push(2); + x = arr[a]; + } + } + |] + (_, [Cex (_, _)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x32] c (Just (Sig "fun(uint8)" [AbiUIntType 8])) [] defaultVeriOpts + -- assertBool "Access must be beyond element 2" $ (getVar ctr "arg1") > 1 + putStrLn "expected counterexample found" + , + -- Note: we catch the assertion here, even though we are only able to explore partially + testCase "alloc-too-much" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a) external { + uint[] memory arr = new uint[](a); + } + } + |] + (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> + checkAssert s [0x41] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "expected counterexample found" + , + testCase "vm.deal unknown address" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function deal(address,uint256) external; + } + contract C { + // this is not supported yet due to restrictions around symbolic address aliasing... + function f(address e, uint val) external { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + vm.deal(e, val); + assert(e.balance == val); + } + } + |] + Right e <- reachableUserAsserts c (Just $ Sig "f(address,uint256)" [AbiAddressType, AbiUIntType 256]) + assertBool "The expression is not partial" $ Expr.containsNode isPartial e + , + testCase "vm.prank underflow" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function prank(address) external; + } + contract Payable { + function hi() public payable {} + } + contract C { + function f() external { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + + uint amt = 10; + address from = address(0xacab); + require(from.balance < amt); + + Payable target = new Payable(); + vm.prank(from); + target.hi{value : amt}(); + } + } + |] + r <- allBranchesFail c Nothing + assertBool "all branches must fail" (isRight r) + , + testCase "call ffi when disabled" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function ffi(string[] calldata) external; + } + contract C { + function f() external { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + + string[] memory inputs = new string[](2); + inputs[0] = "echo"; + inputs[1] = "acab"; + + // should fail to explore this branch + vm.ffi(inputs); + } + } + |] + Right e <- reachableUserAsserts c Nothing + T.putStrLn $ formatExpr e + assertBool "The expression is not partial" $ Expr.containsNode isPartial e + , + -- TODO: we can't deal with symbolic jump conditions + expectFail $ testCase "call-zero-inited-var-thats-a-function" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function (uint256) internal returns (uint) funvar; + function fun2(uint256 a) internal returns (uint){ + return a; + } + function fun(uint256 a) external returns (uint) { + if (a != 44) { + funvar = fun2; + } + return funvar(a); + } + } + |] + (_, [Cex (_, cex)]) <- withSolvers Z3 1 Nothing $ + \s -> checkAssert s [0x51] c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + let a = fromJust $ Map.lookup (Var "arg1") cex.vars + assertEqual "unexpected cex value" a 44 + putStrLn "expected counterexample found" + ] + , testGroup "Symbolic-Constructor-Args" + -- this produced some hard to debug failures. keeping it around since it seemed to exercise the contract creation code in interesting ways... + [ testCase "multiple-symbolic-constructor-calls" $ do + Just initCode <- solidity "C" + [i| + contract A { + uint public x; + constructor (uint z) {} + } + + contract B { + constructor (uint i) {} + + } + + contract C { + constructor(uint u) { + new A(u); + new B(u); + } + } + |] + withSolvers Z3 1 Nothing $ \s -> do + let calldata = (WriteWord (Lit 0x0) (Var "u") (ConcreteBuf ""), []) + initVM <- stToIO $ abstractVM calldata initCode Nothing True + expr <- Expr.simplify <$> interpret (Fetch.oracle s Nothing) Nothing 1 StackBased initVM runExpr + assertBool "unexptected partial execution" (not $ Expr.containsNode isPartial expr) + , testCase "mixed-concrete-symbolic-args" $ do + Just c <- solcRuntime "C" + [i| + contract B { + uint public x; + uint public y; + constructor (uint i, uint j) { + x = i; + y = j; + } + + } + + contract C { + function foo(uint i) public { + B b = new B(10, i); + assert(b.x() == 10); + assert(b.y() == i); + } + } + |] + Right expr <- reachableUserAsserts c (Just $ Sig "foo(uint256)" [AbiUIntType 256]) + assertBool "unexptected partial execution" (not $ Expr.containsNode isPartial expr) + , testCase "jump-into-symbolic-region" $ do + let + -- our initCode just jumps directly to the end + code = BS.pack . mapMaybe maybeLitByte $ V.toList $ assemble + [ OpPush (Lit 0x85) + , OpJump + , OpPush (Lit 1) + , OpPush (Lit 1) + , OpPush (Lit 1) + , OpJumpdest + ] + -- we write a symbolic word to the middle, so the jump above should + -- fail since the target is not in the concrete region + initCode = (WriteWord (Lit 0x43) (Var "HI") (ConcreteBuf code), []) + + -- we pass in the above initCode buffer as calldata, and then copy + -- it into memory before calling Create + runtimecode = RuntimeCode (SymbolicRuntimeCode $ assemble + [ OpPush (Lit 0x85) + , OpPush (Lit 0x0) + , OpPush (Lit 0x0) + , OpCalldatacopy + , OpPush (Lit 0x85) + , OpPush (Lit 0x0) + , OpPush (Lit 0x0) + , OpCreate + ]) + withSolvers Z3 1 Nothing $ \s -> do + vm <- stToIO $ loadSymVM runtimecode (Lit 0) initCode False + expr <- Expr.simplify <$> interpret (Fetch.oracle s Nothing) Nothing 1 StackBased vm runExpr + case expr of + Partial _ _ (JumpIntoSymbolicCode _ _) -> assertBool "" True + _ -> assertBool "did not encounter expected partial node" False + ] + , testGroup "Dapp-Tests" + [ testCase "Trivial-Pass" $ do + let testFile = "test/contracts/pass/trivial.sol" + runSolidityTest testFile ".*" >>= assertEqual "test result" True + , testCase "DappTools" $ do + -- quick smokecheck to make sure that we can parse dapptools style build outputs + let cases = + [ ("test/contracts/pass/trivial.sol", ".*", True) + , ("test/contracts/pass/dsProvePass.sol", "proveEasy", True) + , ("test/contracts/fail/trivial.sol", ".*", False) + , ("test/contracts/fail/dsProveFail.sol", "prove_add", False) + ] + results <- forM cases $ \(testFile, match, expected) -> do + actual <- runSolidityTestCustom testFile match Nothing Nothing False Nothing DappTools + pure (actual == expected) + assertBool "test result" (and results) + , testCase "Trivial-Fail" $ do + let testFile = "test/contracts/fail/trivial.sol" + runSolidityTest testFile "prove_false" >>= assertEqual "test result" False + , testCase "Abstract" $ do + let testFile = "test/contracts/pass/abstract.sol" + runSolidityTest testFile ".*" >>= assertEqual "test result" True + , testCase "Constantinople" $ do + let testFile = "test/contracts/pass/constantinople.sol" + runSolidityTest testFile ".*" >>= assertEqual "test result" True + , testCase "Prove-Tests-Pass" $ do + let testFile = "test/contracts/pass/dsProvePass.sol" + runSolidityTest testFile ".*" >>= assertEqual "test result" True + , testCase "prefix-check-for-dapp" $ do + let testFile = "test/contracts/fail/check-prefix.sol" + runSolidityTest testFile "check_trivial" >>= assertEqual "test result" False + , testCase "Prove-Tests-Fail" $ do + let testFile = "test/contracts/fail/dsProveFail.sol" + runSolidityTest testFile "prove_trivial" >>= assertEqual "test result" False + runSolidityTest testFile "prove_trivial_dstest" >>= assertEqual "test result" False + runSolidityTest testFile "prove_add" >>= assertEqual "test result" False + runSolidityTestCustom testFile "prove_smtTimeout" (Just 1) Nothing False Nothing Foundry >>= assertEqual "test result" False + runSolidityTest testFile "prove_multi" >>= assertEqual "test result" False + -- TODO: implement overflow checking optimizations and enable, currently this runs forever + --runSolidityTest testFile "prove_distributivity" >>= assertEqual "test result" False + , testCase "Loop-Tests" $ do + let testFile = "test/contracts/pass/loops.sol" + runSolidityTestCustom testFile "prove_loop" Nothing (Just 10) False Nothing Foundry >>= assertEqual "test result" True + runSolidityTestCustom testFile "prove_loop" Nothing (Just 100) False Nothing Foundry >>= assertEqual "test result" False + , testCase "Cheat-Codes-Pass" $ do + let testFile = "test/contracts/pass/cheatCodes.sol" + runSolidityTest testFile ".*" >>= assertEqual "test result" True + , testCase "Unwind" $ do + let testFile = "test/contracts/pass/unwind.sol" + runSolidityTest testFile ".*" >>= assertEqual "test result" True + ] + , testGroup "max-iterations" + [ testCase "concrete-loops-reached" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun() external payable returns (uint) { + uint count = 0; + for (uint i = 0; i < 5; i++) count++; + return count; + } + } + |] + let sig = Just $ Sig "fun()" [] + opts = defaultVeriOpts{ maxIter = Just 3 } + (e, [Qed _]) <- withSolvers Z3 1 Nothing $ + \s -> checkAssert s defaultPanicCodes c sig [] opts + assertBool "The expression is not partial" $ isPartial e + , testCase "concrete-loops-not-reached" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun() external payable returns (uint) { + uint count = 0; + for (uint i = 0; i < 5; i++) count++; + return count; + } + } + |] + + let sig = Just $ Sig "fun()" [] + opts = defaultVeriOpts{ maxIter = Just 6 } + (e, [Qed _]) <- withSolvers Z3 1 Nothing $ + \s -> checkAssert s defaultPanicCodes c sig [] opts + assertBool "The expression is partial" $ not $ isPartial e + , testCase "symbolic-loops-reached" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun(uint j) external payable returns (uint) { + uint count = 0; + for (uint i = 0; i < j; i++) count++; + return count; + } + } + |] + (e, [Qed _]) <- withSolvers Z3 1 Nothing $ + \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] (defaultVeriOpts{ maxIter = Just 5 }) + assertBool "The expression is not partial" $ Expr.containsNode isPartial e + , testCase "inconsistent-paths" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun(uint j) external payable returns (uint) { + require(j <= 3); + uint count = 0; + for (uint i = 0; i < j; i++) count++; + return count; + } + } + |] + let sig = Just $ Sig "fun(uint256)" [AbiUIntType 256] + -- we dont' ask the solver about the loop condition until we're + -- already in an inconsistent path (i == 5, j <= 3, i < j), so we + -- will continue looping here until we hit max iterations + opts = defaultVeriOpts{ maxIter = Just 10, askSmtIters = 5 } + (e, [Qed _]) <- withSolvers Z3 1 Nothing $ + \s -> checkAssert s defaultPanicCodes c sig [] opts + assertBool "The expression is not partial" $ Expr.containsNode isPartial e + , testCase "symbolic-loops-not-reached" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun(uint j) external payable returns (uint) { + require(j <= 3); + uint count = 0; + for (uint i = 0; i < j; i++) count++; + return count; + } + } + |] + let sig = Just $ Sig "fun(uint256)" [AbiUIntType 256] + -- askSmtIters is low enough here to avoid the inconsistent path + -- conditions, so we never hit maxIters + opts = defaultVeriOpts{ maxIter = Just 5, askSmtIters = 1 } + (e, [Qed _]) <- withSolvers Z3 1 Nothing $ + \s -> checkAssert s defaultPanicCodes c sig [] opts + assertBool "The expression is partial" $ not (Expr.containsNode isPartial e) + ] + , testGroup "Symbolic Addresses" + [ testCase "symbolic-address-create" $ do + let src = [i| + contract A { + constructor() payable {} + } + contract C { + function fun(uint256 a) external{ + require(address(this).balance > a); + new A{value:a}(); + } + } + |] + Just a <- solcRuntime "A" src + Just c <- solcRuntime "C" src + let sig = Sig "fun(uint256)" [AbiUIntType 256] + (expr, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> + verifyContract s c (Just sig) [] defaultVeriOpts Nothing Nothing + let isSuc (Success {}) = True + isSuc _ = False + case filter isSuc (flattenExpr expr) of + [Success _ _ _ store] -> do + let ca = fromJust (Map.lookup (SymAddr "freshSymAddr1") store) + let code = case ca.code of + RuntimeCode (ConcreteRuntimeCode c') -> c' + _ -> internalError "expected concrete code" + assertEqual "balance mismatch" (Var "arg1") ca.balance + assertEqual "code mismatch" (stripBytecodeMetadata a) (stripBytecodeMetadata code) + assertEqual "nonce mismatch" (Just 1) ca.nonce + _ -> assertBool "too many success nodes!" False + , testCase "symbolic-balance-call" $ do + let src = [i| + contract A { + function f() public payable returns (uint) { + return msg.value; + } + } + contract C { + function fun(uint256 x) external { + require(address(this).balance > x); + A a = new A(); + uint res = a.f{value:x}(); + assert(res == x); + } + } + |] + Just c <- solcRuntime "C" src + res <- reachableUserAsserts c Nothing + assertBool "unexpected cex" (isRight res) + -- TODO: implement missing aliasing rules + , expectFail $ testCase "deployed-contract-addresses-cannot-alias" $ do + Just c <- solcRuntime "C" + [i| + contract A {} + contract C { + function f() external { + A a = new A(); + if (address(a) == address(this)) assert(false); + } + } + |] + res <- reachableUserAsserts c Nothing + assertBool "should not be able to alias" (isRight res) + , testCase "addresses-in-args-can-alias-anything" $ do + let addrs :: [Text] + addrs = ["address(this)", "tx.origin", "block.coinbase", "msg.sender"] + sig = Just $ Sig "f(address)" [AbiAddressType] + checkVs vs = [i| + contract C { + function f(address a) external { + if (${vs} == a) assert(false); + } + } + |] + + [self, origin, coinbase, caller] <- forM addrs $ \addr -> do + Just c <- solcRuntime "C" (checkVs addr) + Left [cex] <- reachableUserAsserts c sig + pure cex.addrs + + let check as a = (Map.lookup (SymAddr "arg1") as) @?= (Map.lookup a as) + check self (SymAddr "entrypoint") + check origin (SymAddr "origin") + check coinbase (SymAddr "coinbase") + check caller (SymAddr "caller") + , testCase "addresses-in-args-can-alias-themselves" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function f(address a, address b) external { + if (a == b) assert(false); + } + } + |] + let sig = Just $ Sig "f(address,address)" [AbiAddressType,AbiAddressType] + Left [cex] <- reachableUserAsserts c sig + let arg1 = fromJust $ Map.lookup (SymAddr "arg1") cex.addrs + arg2 = fromJust $ Map.lookup (SymAddr "arg1") cex.addrs + assertEqual "should match" arg1 arg2 + -- TODO: fails due to missing aliasing rules + , expectFail $ testCase "tx.origin cannot alias deployed contracts" $ do + Just c <- solcRuntime "C" + [i| + contract A {} + contract C { + function f() external { + address a = address(new A()); + if (tx.origin == a) assert(false); + } + } + |] + cexs <- reachableUserAsserts c Nothing + assertBool "unexpected cex" (isRight cexs) + , testCase "tx.origin can alias everything else" $ do + let addrs = ["address(this)", "block.coinbase", "msg.sender", "arg"] :: [Text] + sig = Just $ Sig "f(address)" [AbiAddressType] + checkVs vs = [i| + contract C { + function f(address arg) external { + if (${vs} == tx.origin) assert(false); + } + } + |] + + [self, coinbase, caller, arg] <- forM addrs $ \addr -> do + Just c <- solcRuntime "C" (checkVs addr) + Left [cex] <- reachableUserAsserts c sig + pure cex.addrs + + let check as a = (Map.lookup (SymAddr "origin") as) @?= (Map.lookup a as) + check self (SymAddr "entrypoint") + check coinbase (SymAddr "coinbase") + check caller (SymAddr "caller") + check arg (SymAddr "arg1") + , testCase "coinbase can alias anything" $ do + let addrs = ["address(this)", "tx.origin", "msg.sender", "a", "arg"] :: [Text] + sig = Just $ Sig "f(address)" [AbiAddressType] + checkVs vs = [i| + contract A {} + contract C { + function f(address arg) external { + address a = address(new A()); + if (${vs} == block.coinbase) assert(false); + } + } + |] + + [self, origin, caller, a, arg] <- forM addrs $ \addr -> do + Just c <- solcRuntime "C" (checkVs addr) + Left [cex] <- reachableUserAsserts c sig + pure cex.addrs + + let check as a' = (Map.lookup (SymAddr "coinbase") as) @?= (Map.lookup a' as) + check self (SymAddr "entrypoint") + check origin (SymAddr "origin") + check caller (SymAddr "caller") + check a (SymAddr "freshSymAddr1") + check arg (SymAddr "arg1") + , testCase "caller can alias anything" $ do + let addrs = ["address(this)", "tx.origin", "block.coinbase", "a", "arg"] :: [Text] + sig = Just $ Sig "f(address)" [AbiAddressType] + checkVs vs = [i| + contract A {} + contract C { + function f(address arg) external { + address a = address(new A()); + if (${vs} == msg.sender) assert(false); + } + } + |] + + [self, origin, coinbase, a, arg] <- forM addrs $ \addr -> do + Just c <- solcRuntime "C" (checkVs addr) + Left [cex] <- reachableUserAsserts c sig + pure cex.addrs + + let check as a' = (Map.lookup (SymAddr "caller") as) @?= (Map.lookup a' as) + check self (SymAddr "entrypoint") + check origin (SymAddr "origin") + check coinbase (SymAddr "coinbase") + check a (SymAddr "freshSymAddr1") + check arg (SymAddr "arg1") + , testCase "vm.load fails for a potentially aliased address" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function load(address,bytes32) external; + } + contract C { + function f() external { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + vm.load(msg.sender, 0x0); + } + } + |] + (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> + verifyContract s c Nothing [] defaultVeriOpts Nothing (Just $ checkBadCheatCode "load(address,bytes32)") + pure () + , testCase "vm.store fails for a potentially aliased address" $ do + Just c <- solcRuntime "C" + [i| + interface Vm { + function store(address,bytes32,bytes32) external; + } + contract C { + function f() external { + Vm vm = Vm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D); + vm.store(msg.sender, 0x0, 0x0); + } + } + |] + (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> + verifyContract s c Nothing [] defaultVeriOpts Nothing (Just $ checkBadCheatCode "store(address,bytes32,bytes32)") + pure () + -- TODO: make this work properly + , testCase "transfering-eth-does-not-dealias" $ do + Just c <- solcRuntime "C" + [i| + // we can't do calls to unknown code yet so we use selfdestruct + contract Send { + constructor(address payable dst) payable { + selfdestruct(dst); + } + } + contract C { + function f() external { + uint preSender = msg.sender.balance; + uint preOrigin = tx.origin.balance; + + new Send{value:10}(payable(msg.sender)); + new Send{value:5}(payable(tx.origin)); + + if (msg.sender == tx.origin) { + assert(preSender == preOrigin + && msg.sender.balance == preOrigin + 15 + && tx.origin.balance == preSender + 15); + } else { + assert(msg.sender.balance == preSender + 10 + && tx.origin.balance == preOrigin + 5); + } + } + } + |] + Right e <- reachableUserAsserts c Nothing + -- TODO: this should work one day + assertBool "should be partial" (Expr.containsNode isPartial e) + , testCase "addresses-in-context-are-symbolic" $ do + Just a <- solcRuntime "A" + [i| + contract A { + function f() external { + assert(msg.sender != address(0x0)); + } + } + |] + Just b <- solcRuntime "B" + [i| + contract B { + function f() external { + assert(block.coinbase != address(0x1)); + } + } + |] + Just c <- solcRuntime "C" + [i| + contract C { + function f() external { + assert(tx.origin != address(0x2)); + } + } + |] + Just d <- solcRuntime "D" + [i| + contract D { + function f() external { + assert(address(this) != address(0x3)); + } + } + |] + [acex,bcex,ccex,dcex] <- forM [a,b,c,d] $ \con -> do + Left [cex] <- reachableUserAsserts con Nothing + assertEqual "wrong number of addresses" 1 (length (Map.keys cex.addrs)) + pure cex + + assertEqual "wrong model for a" (Addr 0) (fromJust $ Map.lookup (SymAddr "caller") acex.addrs) + assertEqual "wrong model for b" (Addr 1) (fromJust $ Map.lookup (SymAddr "coinbase") bcex.addrs) + assertEqual "wrong model for c" (Addr 2) (fromJust $ Map.lookup (SymAddr "origin") ccex.addrs) + assertEqual "wrong model for d" (Addr 3) (fromJust $ Map.lookup (SymAddr "entrypoint") dcex.addrs) + ] + , testGroup "Symbolic execution" + [ + testCase "require-test" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 a) external pure { + require(a <= 0); + assert (a <= 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256)" [AbiIntType 256])) [] defaultVeriOpts + putStrLn "Require works as expected" + , + testCase "ITE-with-bitwise-AND" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function f(uint256 x) public pure { + require(x > 0); + uint256 a = (x & 8); + bool w; + // assembly is needed here, because solidity doesn't allow uint->bool conversion + assembly { + w:=a + } + if (!w) assert(false); //we should get a CEX: when x has a 0 at bit 3 + } + } + |] + -- should find a counterexample + (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "expected counterexample found" + , + testCase "ITE-with-bitwise-OR" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function f(uint256 x) public pure { + uint256 a = (x | 8); + bool w; + // assembly is needed here, because solidity doesn't allow uint->bool conversion + assembly { + w:=a + } + assert(w); // due to bitwise OR with positive value, this must always be true + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "this should always be true, due to bitwise OR with positive value" + , + -- CopySlice check + -- uses identity precompiled contract (0x4) to copy memory + -- checks 9af114613075a2cd350633940475f8b6699064de (readByte + CopySlice had src/dest mixed up) + -- without 9af114613 it dies with: `Exception: UnexpectedSymbolicArg 296 "MSTORE index"` + -- TODO: check 9e734b9da90e3e0765128b1f20ce1371f3a66085 (bufLength + copySlice was off by 1) + testCase "copyslice-check" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(uint8 a) public { + bytes memory data = new bytes(5); + for(uint i = 0; i < 5; i++) data[i] = bytes1(a); + bytes memory ret = new bytes(data.length); + assembly { + let len := mload(data) + if iszero(call(0xff, 0x04, 0, add(data, 0x20), len, add(ret,0x20), len)) { + invalid() + } + } + for(uint i = 0; i < 5; i++) assert(ret[i] == data[i]); + } + } + |] + let sig = Just (Sig "checkval(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> + checkAssert s defaultPanicCodes c sig [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + -- TODO look at tests here for SAR: https://github.com/dapphub/dapptools/blob/01ef8ea418c3fe49089a44d56013d8fcc34a1ec2/src/dapp-tests/pass/constantinople.sol#L250 + testCase "opcode-sar-neg" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 shift_by, int256 val) external pure returns (int256 out) { + require(shift_by >= 0); + require(val <= 0); + assembly { + out := sar(shift_by,val) + } + assert (out <= 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLn "SAR works as expected" + , + testCase "opcode-sar-pos" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 shift_by, int256 val) external pure returns (int256 out) { + require(shift_by >= 0); + require(val >= 0); + assembly { + out := sar(shift_by,val) + } + assert (out >= 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLn "SAR works as expected" + , + testCase "opcode-sar-fixedval-pos" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 shift_by, int256 val) external pure returns (int256 out) { + require(shift_by == 1); + require(val == 64); + assembly { + out := sar(shift_by,val) + } + assert (out == 32); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLn "SAR works as expected" + , + testCase "opcode-sar-fixedval-neg" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 shift_by, int256 val) external pure returns (int256 out) { + require(shift_by == 1); + require(val == -64); + assembly { + out := sar(shift_by,val) + } + assert (out == -32); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(int256,int256)" [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLn "SAR works as expected" + , + testCase "opcode-div-zero-1" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val) external pure { + uint out; + assembly { + out := div(val, 0) + } + assert(out == 0); + + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "sdiv works as expected" + , + testCase "opcode-sdiv-zero-1" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val) external pure { + uint out; + assembly { + out := sdiv(val, 0) + } + assert(out == 0); + + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "sdiv works as expected" + , + testCase "opcode-sdiv-zero-2" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val) external pure { + uint out; + assembly { + out := sdiv(0, val) + } + assert(out == 0); + + } + } + |] + (_, [Qed _]) <- withSolvers CVC5 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "sdiv works as expected" + , + testCase "signed-overflow-checks" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function fun(int256 a) external returns (int256) { + return a + a; + } + } + |] + (_, [Cex (_, _)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x11] c (Just (Sig "fun(int256)" [AbiIntType 256])) [] defaultVeriOpts + putStrLn "expected cex discovered" + , + testCase "opcode-signextend-neg" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val, uint8 b) external pure { + require(b <= 31); + require(b >= 0); + require(val < (1 <<(b*8))); + require(val & (1 <<(b*8-1)) != 0); // MSbit set, i.e. negative + uint256 out; + assembly { + out := signextend(b, val) + } + if (b == 31) assert(out == val); + else assert(out > val); + assert(out & (1<<254) != 0); // MSbit set, i.e. negative + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "signextend works as expected" + , + testCase "opcode-signextend-pos-nochop" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val, uint8 b) external pure { + require(val < (1 <<(b*8))); + require(val & (1 <<(b*8-1)) == 0); // MSbit not set, i.e. positive + uint256 out; + assembly { + out := signextend(b, val) + } + assert (out == val); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts + putStrLn "signextend works as expected" + , + testCase "opcode-signextend-pos-chopped" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val, uint8 b) external pure { + require(b == 0); // 1-byte + require(val == 514); // but we set higher bits + uint256 out; + assembly { + out := signextend(b, val) + } + assert (out == 2); // chopped + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts + putStrLn "signextend works as expected" + , + -- when b is too large, value is unchanged + testCase "opcode-signextend-pos-b-toolarge" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val, uint8 b) external pure { + require(b >= 31); + uint256 out; + assembly { + out := signextend(b, val) + } + assert (out == val); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint8)" [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts + putStrLn "signextend works as expected" + , + testCase "opcode-shl" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 shift_by, uint256 val) external pure { + require(val < (1<<16)); + require(shift_by < 16); + uint256 out; + assembly { + out := shl(shift_by,val) + } + assert (out >= val); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn "SAR works as expected" + , + testCase "opcode-xor-cancel" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure { + require(a == b); + uint256 c; + assembly { + c := xor(a,b) + } + assert (c == 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn "XOR works as expected" + , + testCase "opcode-xor-reimplement" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure { + uint256 c; + assembly { + c := xor(a,b) + } + assert (c == (~(a & b)) & (a | b)); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn "XOR works as expected" + , + testCase "opcode-add-commutative" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure { + uint256 res1; + uint256 res2; + assembly { + res1 := add(a,b) + res2 := add(b,a) + } + assert (res1 == res2); + } + } + |] + a <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + case a of + (_, [Cex (_, ctr)]) -> do + let x = getVar ctr "arg1" + let y = getVar ctr "arg2" + putStrLn $ "y:" <> show y + putStrLn $ "x:" <> show x + assertEqual "Addition is not commutative... that's wrong" False True + (_, [Qed _]) -> do + putStrLn "adding is commutative" + _ -> internalError "Unexpected" + , + testCase "opcode-div-res-zero-on-div-by-zero" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint16 a) external pure { + uint16 b = 0; + uint16 res; + assembly { + res := div(a,b) + } + assert (res == 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint16)" [AbiUIntType 16])) [] defaultVeriOpts + putStrLn "DIV by zero is zero" + , + -- Somewhat tautological since we are asserting the precondition + -- on the same form as the actual "requires" clause. + testCase "SafeAdd success case" $ do + Just safeAdd <- solcRuntime "SafeAdd" + [i| + contract SafeAdd { + function add(uint x, uint y) public pure returns (uint z) { + require((z = x + y) >= x); + } + } + |] + let pre preVM = let (x, y) = case getStaticAbiArgs 2 preVM of + [x', y'] -> (x', y') + _ -> internalError "expected 2 args" + in (x .<= Expr.add x y) + -- TODO check if it's needed + .&& preVM.state.callvalue .== Lit 0 + post prestate leaf = + let (x, y) = case getStaticAbiArgs 2 prestate of + [x', y'] -> (x', y') + _ -> internalError "expected 2 args" + in case leaf of + Success _ _ b _ -> (ReadWord (Lit 0) b) .== (Add x y) + _ -> PBool True + sig = Just (Sig "add(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> + verifyContract s safeAdd sig [] defaultVeriOpts (Just pre) (Just post) + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + + testCase "x == y => x + y == 2 * y" $ do + Just safeAdd <- solcRuntime "SafeAdd" + [i| + contract SafeAdd { + function add(uint x, uint y) public pure returns (uint z) { + require((z = x + y) >= x); + } + } + |] + let pre preVM = let (x, y) = case getStaticAbiArgs 2 preVM of + [x', y'] -> (x', y') + _ -> internalError "expected 2 args" + in (x .<= Expr.add x y) + .&& (x .== y) + .&& preVM.state.callvalue .== Lit 0 + post prestate leaf = + let (_, y) = case getStaticAbiArgs 2 prestate of + [x', y'] -> (x', y') + _ -> internalError "expected 2 args" + in case leaf of + Success _ _ b _ -> (ReadWord (Lit 0) b) .== (Mul (Lit 2) y) + _ -> PBool True + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> + verifyContract s safeAdd (Just (Sig "add(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts (Just pre) (Just post) + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "summary storage writes" $ do + Just c <- solcRuntime "A" + [i| + contract A { + uint x; + function f(uint256 y) public { + unchecked { + x += y; + x += y; + } + } + } + |] + let pre vm = Lit 0 .== vm.state.callvalue + post prestate leaf = + let y = case getStaticAbiArgs 1 prestate of + [y'] -> y' + _ -> error "expected 1 arg" + this = prestate.state.codeContract + prestore = (fromJust (Map.lookup this prestate.env.contracts)).storage + prex = Expr.readStorage' (Lit 0) prestore + in case leaf of + Success _ _ _ postState -> let + poststore = (fromJust (Map.lookup this postState)).storage + in Expr.add prex (Expr.mul (Lit 2) y) .== (Expr.readStorage' (Lit 0) poststore) + _ -> PBool True + sig = Just (Sig "f(uint256)" [AbiUIntType 256]) + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> + verifyContract s c sig [] defaultVeriOpts (Just pre) (Just post) + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + -- tests how whiffValue handles Neg via application of the triple IsZero simplification rule + -- regression test for: https://github.com/dapphub/dapptools/pull/698 + testCase "Neg" $ do + let src = + [i| + object "Neg" { + code { + // Deploy the contract + datacopy(0, dataoffset("runtime"), datasize("runtime")) + return(0, datasize("runtime")) + } + object "runtime" { + code { + let v := calldataload(4) + if iszero(iszero(and(v, not(0xffffffffffffffffffffffffffffffffffffffff)))) { + invalid() + } + } + } + } + |] + Just c <- yulRuntime "Neg" src + (res, [Qed _]) <- withSolvers Z3 4 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "hello(address)" [AbiAddressType])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "catch-storage-collisions-noproblem" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y) public { + if (x != y) { + assembly { + let newx := sub(sload(x), 1) + let newy := add(sload(y), 1) + sstore(x,newx) + sstore(y,newy) + } + } + } + } + |] + let pre vm = (Lit 0) .== vm.state.callvalue + post prestate poststate = + let (x,y) = case getStaticAbiArgs 2 prestate of + [x',y'] -> (x',y') + _ -> error "expected 2 args" + this = prestate.state.codeContract + prestore = (fromJust (Map.lookup this prestate.env.contracts)).storage + prex = Expr.readStorage' x prestore + prey = Expr.readStorage' y prestore + in case poststate of + Success _ _ _ postcs -> let + poststore = (fromJust (Map.lookup this postcs)).storage + postx = Expr.readStorage' x poststore + posty = Expr.readStorage' y poststore + in Expr.add prex prey .== Expr.add postx posty + _ -> PBool True + sig = Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> + verifyContract s c sig [] defaultVeriOpts (Just pre) (Just post) + putStrLn "Correct, this can never fail" + , + -- Inspired by these `msg.sender == to` token bugs + -- which break linearity of totalSupply. + testCase "catch-storage-collisions-good" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y) public { + assembly { + let newx := sub(sload(x), 1) + let newy := add(sload(y), 1) + sstore(x,newx) + sstore(y,newy) + } + } + } + |] + let pre vm = (Lit 0) .== vm.state.callvalue + post prestate leaf = + let (x,y) = case getStaticAbiArgs 2 prestate of + [x',y'] -> (x',y') + _ -> error "expected 2 args" + this = prestate.state.codeContract + prestore = (fromJust (Map.lookup this prestate.env.contracts)).storage + prex = Expr.readStorage' x prestore + prey = Expr.readStorage' y prestore + in case leaf of + Success _ _ _ poststate -> let + poststore = (fromJust (Map.lookup this poststate)).storage + postx = Expr.readStorage' x poststore + posty = Expr.readStorage' y poststore + in Expr.add prex prey .== Expr.add postx posty + _ -> PBool True + sig = Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256]) + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> + verifyContract s c sig [] defaultVeriOpts (Just pre) (Just post) + let x = getVar ctr "arg1" + let y = getVar ctr "arg2" + putStrLn $ "y:" <> show y + putStrLn $ "x:" <> show x + assertEqual "Catch storage collisions" x y + putStrLn "expected counterexample found" + , + testCase "simple-assert" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo() external pure { + assert(false); + } + } + |] + (_, [Cex (Failure _ _ (Revert msg), _)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo()" [])) [] defaultVeriOpts + assertEqual "incorrect revert msg" msg (ConcreteBuf $ panicMsg 0x01) + , + testCase "simple-assert-2" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + assert(x != 10); + } + } + |] + (_, [(Cex (_, ctr))]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + assertEqual "Must be 10" 10 $ getVar ctr "arg1" + putStrLn "Got 10 Cex, as expected" + , + testCase "assert-fail-equal" $ do + Just c <- solcRuntime "AssertFailEqual" + [i| + contract AssertFailEqual { + function fun(uint256 deposit_count) external pure { + assert(deposit_count == 0); + assert(deposit_count == 11); + } + } + |] + (_, [Cex (_, a), Cex (_, b)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + let ints = map (flip getVar "arg1") [a,b] + assertBool "0 must be one of the Cex-es" $ isJust $ List.elemIndex 0 ints + putStrLn "expected 2 counterexamples found, one Cex is the 0 value" + , + testCase "assert-fail-notequal" $ do + Just c <- solcRuntime "AssertFailNotEqual" + [i| + contract AssertFailNotEqual { + function fun(uint256 deposit_count) external pure { + assert(deposit_count != 0); + assert(deposit_count != 11); + } + } + |] + (_, [Cex (_, a), Cex (_, b)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + let x = getVar a "arg1" + let y = getVar b "arg1" + assertBool "At least one has to be 0, to go through the first assert" (x == 0 || y == 0) + putStrLn "expected 2 counterexamples found." + , + testCase "assert-fail-twoargs" $ do + Just c <- solcRuntime "AssertFailTwoParams" + [i| + contract AssertFailTwoParams { + function fun(uint256 deposit_count1, uint256 deposit_count2) external pure { + assert(deposit_count1 != 0); + assert(deposit_count2 != 11); + } + } + |] + (_, [Cex _, Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn "expected 2 counterexamples found" + , + testCase "assert-2nd-arg" $ do + Just c <- solcRuntime "AssertFailTwoParams" + [i| + contract AssertFailTwoParams { + function fun(uint256 deposit_count1, uint256 deposit_count2) external pure { + assert(deposit_count2 != 666); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "fun(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + assertEqual "Must be 666" 666 $ getVar ctr "arg2" + putStrLn "Found arg2 Ctx to be 666" + , + -- LSB is zeroed out, byte(31,x) takes LSB, so y==0 always holds + testCase "check-lsb-msb1" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + x &= 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff00; + uint8 y; + assembly { y := byte(31,x) } + assert(y == 0); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + -- We zero out everything but the LSB byte. However, byte(31,x) takes the LSB byte + -- so there is a counterexamle, where LSB of x is not zero + testCase "check-lsb-msb2" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + x &= 0x00000000000000000000000000000000000000000000000000000000000000ff; + uint8 y; + assembly { y := byte(31,x) } + assert(y == 0); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + assertBool "last byte must be non-zero" $ ((Data.Bits..&.) (getVar ctr "arg1") 0xff) > 0 + putStrLn "Expected counterexample found" + , + -- We zero out everything but the 2nd LSB byte. However, byte(31,x) takes the 2nd LSB byte + -- so there is a counterexamle, where 2nd LSB of x is not zero + testCase "check-lsb-msb3 -- 2nd byte" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + x &= 0x000000000000000000000000000000000000000000000000000000000000ff00; + uint8 y; + assembly { y := byte(30,x) } + assert(y == 0); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + assertBool "second to last byte must be non-zero" $ ((Data.Bits..&.) (getVar ctr "arg1") 0xff00) > 0 + putStrLn "Expected counterexample found" + , + -- Reverse of thest above + testCase "check-lsb-msb4 2nd byte rev" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + x &= 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff00ff; + uint8 y; + assembly { + y := byte(30,x) + } + assert(y == 0); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + -- Bitwise OR operation test + testCase "opcode-bitwise-or-full-1s" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + uint256 y; + uint256 z = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff; + assembly { y := or(x, z) } + assert(y == 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "When OR-ing with full 1's we should get back full 1's" + , + -- Bitwise OR operation test + testCase "opcode-bitwise-or-byte-of-1s" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + uint256 y; + uint256 z = 0x000000000000000000000000000000000000000000000000000000000000ff00; + assembly { y := or(x, z) } + assert((y & 0x000000000000000000000000000000000000000000000000000000000000ff00) == + 0x000000000000000000000000000000000000000000000000000000000000ff00); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "When OR-ing with a byte of 1's, we should get 1's back there" + , + testCase "Deposit contract loop (z3)" $ do + Just c <- solcRuntime "Deposit" + [i| + contract Deposit { + function deposit(uint256 deposit_count) external pure { + require(deposit_count < 2**32 - 1); + ++deposit_count; + bool found = false; + for (uint height = 0; height < 32; height++) { + if ((deposit_count & 1) == 1) { + found = true; + break; + } + deposit_count = deposit_count >> 1; + } + assert(found); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "deposit(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "Deposit-contract-loop-error-version" $ do + Just c <- solcRuntime "Deposit" + [i| + contract Deposit { + function deposit(uint8 deposit_count) external pure { + require(deposit_count < 2**32 - 1); + ++deposit_count; + bool found = false; + for (uint height = 0; height < 32; height++) { + if ((deposit_count & 1) == 1) { + found = true; + break; + } + deposit_count = deposit_count >> 1; + } + assert(found); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s allPanicCodes c (Just (Sig "deposit(uint8)" [AbiUIntType 8])) [] defaultVeriOpts + assertEqual "Must be 255" 255 $ getVar ctr "arg1" + putStrLn $ "expected counterexample found, and it's correct: " <> (show $ getVar ctr "arg1") + , + testCase "explore function dispatch" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x) public pure returns (uint) { + return x; + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "check-asm-byte-in-bounds" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 idx, uint256 val) external pure { + uint256 actual; + uint256 expected; + require(idx < 32); + assembly { + actual := byte(idx,val) + expected := shr(248, shl(mul(idx, 8), val)) + } + assert(actual == expected); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLn "in bounds byte reads return the expected value" + , + testCase "check-div-mod-sdiv-smod-by-zero-constant-prop" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 e) external pure { + uint x = 0; + uint y = 55; + uint z; + assembly { z := div(y,x) } + assert(z == 0); + assembly { z := div(x,y) } + assert(z == 0); + assembly { z := sdiv(y,x) } + assert(z == 0); + assembly { z := sdiv(x,y) } + assert(z == 0); + assembly { z := mod(y,x) } + assert(z == 0); + assembly { z := mod(x,y) } + assert(z == 0); + assembly { z := smod(y,x) } + assert(z == 0); + assembly { z := smod(x,y) } + assert(z == 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "foo(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "div/mod/sdiv/smod by zero works as expected during constant propagation" + , + testCase "check-asm-byte-oob" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x, uint256 y) external pure { + uint256 z; + require(x >= 32); + assembly { z := byte(x,y) } + assert(z == 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLn "oob byte reads always return 0" + , + testCase "injectivity of keccak (diff sizes)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint128 x, uint256 y) external pure { + assert( + keccak256(abi.encodePacked(x)) != + keccak256(abi.encodePacked(y)) + ); + } + } + |] + Right _ <- reachableUserAsserts c (Just $ Sig "f(uint128,uint256)" [AbiUIntType 128, AbiUIntType 256]) + pure () + , + testCase "injectivity of keccak (32 bytes)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y) public pure { + if (keccak256(abi.encodePacked(x)) == keccak256(abi.encodePacked(y))) assert(x == y); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "injectivity of keccak contrapositive (32 bytes)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y) public pure { + require (x != y); + assert (keccak256(abi.encodePacked(x)) != keccak256(abi.encodePacked(y))); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256,uint256)" [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "injectivity of keccak (64 bytes)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y, uint w, uint z) public pure { + assert (keccak256(abi.encodePacked(x,y)) != keccak256(abi.encodePacked(w,z))); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256,uint256,uint256,uint256)" (replicate 4 (AbiUIntType 256)))) [] defaultVeriOpts + let x = getVar ctr "arg1" + let y = getVar ctr "arg2" + let w = getVar ctr "arg3" + let z = getVar ctr "arg4" + assertEqual "x==y for hash collision" x y + assertEqual "w==z for hash collision" w z + putStrLn "expected counterexample found" + , + testCase "calldata beyond calldatasize is 0 (symbolic calldata)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f() public pure { + uint y; + assembly { + let x := calldatasize() + y := calldataload(x) + } + assert(y == 0); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "calldata beyond calldatasize is 0 (concrete dalldata prefix)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint256 z) public pure { + uint y; + assembly { + let x := calldatasize() + y := calldataload(x) + } + assert(y == 0); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "calldata symbolic access" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint256 z) public pure { + uint x; uint y; + assembly { + y := calldatasize() + } + require(z >= y); + assembly { + x := calldataload(z) + } + assert(x == 0); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "multiple-contracts" $ do + let code = + [i| + contract C { + uint x; + A constant a = A(0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B); + + function call_A() public view { + // should fail since x can be anything + assert(a.x() == x); + } + } + contract A { + uint public x; + } + |] + aAddr = LitAddr (Addr 0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B) + cAddr = SymAddr "entrypoint" + Just c <- solcRuntime "C" code + Just a <- solcRuntime "A" code + (_, [Cex (_, cex)]) <- withSolvers Z3 1 Nothing $ \s -> do + vm <- stToIO $ abstractVM (mkCalldata (Just (Sig "call_A()" [])) []) c Nothing False + <&> set (#state % #callvalue) (Lit 0) + <&> over (#env % #contracts) + (Map.insert aAddr (initialContract (RuntimeCode (ConcreteRuntimeCode a)))) + verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) + + let storeCex = cex.store + testCex = case (Map.lookup cAddr storeCex, Map.lookup aAddr storeCex) of + (Just sC, Just sA) -> case (Map.lookup 0 sC, Map.lookup 0 sA) of + (Just x, Just y) -> x /= y + (Just x, Nothing) -> x /= 0 + _ -> False + _ -> False + 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" + [i| + contract C { + uint x; + A a; + + function call_A() public { + a = new A(); + // should fail since x can be anything + assert(a.x() == x); + } + } + contract A { + uint public x; + } + |] + (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "call_A()" [])) [] defaultVeriOpts + putStrLn "expected counterexample found" + , + testCase "keccak concrete and sym agree" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function kecc(uint x) public pure { + if (x == 0) { + assert(keccak256(abi.encode(x)) == keccak256(abi.encode(0))); + } + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "kecc(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "keccak concrete and sym injectivity" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x) public pure { + if (x !=3) assert(keccak256(abi.encode(x)) != keccak256(abi.encode(3))); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "f(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "safemath-distributivity-yul" $ do + let yulsafeDistributivity = hex "6355a79a6260003560e01c14156016576015601f565b5b60006000fd60a1565b603d602d604435600435607c565b6039602435600435607c565b605d565b6052604b604435602435605d565b600435607c565b141515605a57fe5b5b565b6000828201821115151560705760006000fd5b82820190505b92915050565b6000818384048302146000841417151560955760006000fd5b82820290505b92915050565b" + vm <- stToIO $ abstractVM (mkCalldata (Just (Sig "distributivity(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) []) yulsafeDistributivity Nothing False + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) + putStrLn "Proven" + , + testCase "safemath-distributivity-sol" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function distributivity(uint x, uint y, uint z) public { + assert(mul(x, add(y, z)) == add(mul(x, y), mul(x, z))); + } + + function add(uint x, uint y) internal pure returns (uint z) { + unchecked { + require((z = x + y) >= x, "ds-math-add-overflow"); + } + } + + function mul(uint x, uint y) internal pure returns (uint z) { + unchecked { + require(y == 0 || (z = x * y) / y == x, "ds-math-mul-overflow"); + } + } + } + |] + + (_, [Qed _]) <- withSolvers CVC5 1 (Just 99999999) $ \s -> checkAssert s defaultPanicCodes c (Just (Sig "distributivity(uint256,uint256,uint256)" [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn "Proven" + , + testCase "storage-cex-1" $ do + 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 (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + let addr = SymAddr "entrypoint" + testCex = Map.size cex.store == 1 && + case Map.lookup addr cex.store of + Just s -> Map.size s == 2 && + case (Map.lookup 0 s, Map.lookup 1 s) of + (Just x, Just y) -> x /= y + _ -> False + _ -> False + 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 (Sig "fun(uint256)" [AbiUIntType 256])) [] defaultVeriOpts + let addr = SymAddr "entrypoint" + a = getVar cex "arg1" + testCex = Map.size cex.store == 1 && + case Map.lookup addr cex.store of + Just s -> 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); + } + } + |] + let sig = Just (Sig "fun(uint256)" [AbiUIntType 256]) + (_, [Cex (_, cex)]) <- withSolvers Z3 1 Nothing $ + \s -> verifyContract s c sig [] defaultVeriOpts Nothing (Just $ checkAssertions [0x01]) + let addr = SymAddr "entrypoint" + testCex = Map.size cex.store == 1 && + case Map.lookup addr cex.store of + Just s -> Map.size s == 2 && + case (Map.lookup 0 s, Map.lookup 1 s) of + (Just x, Just y) -> x == y + _ -> False + _ -> False + assertBool "Did not find expected storage cex" testCex + putStrLn "Expected counterexample found" + ] + , testGroup "simplification-working" + [ + testCase "prop-simp-bool1" $ do + let + a = successGen [PAnd (PBool True) (PBool False)] + b = Expr.simplify a + assertEqual "Must simplify down" (successGen [PBool False]) b + , testCase "prop-simp-bool2" $ do + let + a = successGen [POr (PBool True) (PBool False)] + b = Expr.simplify a + assertEqual "Must simplify down" (successGen []) b + , testCase "prop-simp-LT" $ do + let + a = successGen [PLT (Lit 1) (Lit 2)] + b = Expr.simplify a + assertEqual "Must simplify down" (successGen []) b + , testCase "prop-simp-GEq" $ do + let + a = successGen [PGEq (Lit 1) (Lit 2)] + b = Expr.simplify a + assertEqual "Must simplify down" (successGen [PBool False]) b + , testCase "prop-simp-multiple" $ do + let + a = successGen [PBool False, PBool True] + b = Expr.simplify a + assertEqual "Must simplify down" (successGen [PBool False]) b + , testCase "prop-simp-expr" $ do + let + a = successGen [PEq (Add (Lit 1) (Lit 2)) (Sub (Lit 4) (Lit 1))] + b = Expr.simplify a + assertEqual "Must simplify down" (successGen []) b + , testCase "prop-simp-impl" $ do + let + a = successGen [PImpl (PBool False) (PEq (Var "abc") (Var "bcd"))] + b = Expr.simplify a + assertEqual "Must simplify down" (successGen []) b + ] + , testGroup "equivalence-checking" + [ + testCase "eq-yul-simple-cex" $ do + Just aPrgm <- yul "" + [i| + { + calldatacopy(0, 0, 32) + switch mload(0) + case 0 { } + case 1 { } + default { invalid() } + } + |] + Just bPrgm <- yul "" + [i| + { + calldatacopy(0, 0, 32) + switch mload(0) + case 0 { } + case 2 { } + default { invalid() } + } + |] + withSolvers Z3 3 Nothing $ \s -> do + a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) + assertBool "Must have a difference" (any isCex a) + , + testCase "eq-sol-exp-qed" $ do + Just aPrgm <- solcRuntime "C" + [i| + contract C { + function a(uint8 x) public returns (uint8 b) { + unchecked { + b = x*2; + } + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract C { + function a(uint8 x) public returns (uint8 b) { + unchecked { + b = x<<1; + } + } + } + |] + withSolvers Z3 3 Nothing $ \s -> do + a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) + assertEqual "Must have no difference" [Qed ()] a + , + testCase "eq-balance-differs" $ do + Just aPrgm <- solcRuntime "C" + [i| + contract Send { + constructor(address payable dst) payable { + selfdestruct(dst); + } + } + contract C { + function f() public { + new Send{value:2}(payable(address(0x0))); + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract Send { + constructor(address payable dst) payable { + selfdestruct(dst); + } + } + contract C { + function f() public { + new Send{value:1}(payable(address(0x0))); + } + } + |] + withSolvers Z3 3 Nothing $ \s -> do + a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) + assertBool "Must differ" (all isCex a) + , + -- TODO: this fails because we don't check equivalence of deployed contracts + expectFail $ testCase "eq-handles-contract-deployment" $ do + Just aPrgm <- solcRuntime "B" + [i| + contract Send { + constructor(address payable dst) payable { + selfdestruct(dst); + } + } + + contract A { + address parent; + constructor(address p) { + parent = p; + } + function evil() public { + parent.call(abi.encode(B.drain.selector)); + } + } + + contract B { + address child; + function a() public { + child = address(new A(address(this))); + } + function drain() public { + require(msg.sender == child); + new Send{value: address(this).balance}(payable(address(0x0))); + } + } + |] + Just bPrgm <- solcRuntime "D" + [i| + contract Send { + constructor(address payable dst) payable { + selfdestruct(dst); + } + } + + contract C { + address parent; + constructor(address p) { + parent = p; + } + } + + contract D { + address child; + function a() public { + child = address(new C(address(this))); + } + function drain() public { + require(msg.sender == child); + new Send{value: address(this).balance}(payable(address(0x0))); + } + } + |] + withSolvers Z3 3 Nothing $ \s -> do + a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) + assertBool "Must differ" (all isCex a) + , + testCase "eq-unknown-addr" $ do + Just aPrgm <- solcRuntime "C" + [i| + contract C { + address addr; + function a(address a, address b) public { + addr = a; + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract C { + address addr; + function a(address a, address b) public { + addr = b; + } + } + |] + withSolvers Z3 3 Nothing $ \s -> do + let cd = mkCalldata (Just (Sig "a(address,address)" [AbiAddressType, AbiAddressType])) [] + a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts cd + assertEqual "Must be different" (any isCex a) True + , + testCase "eq-sol-exp-cex" $ do + Just aPrgm <- solcRuntime "C" + [i| + contract C { + function a(uint8 x) public returns (uint8 b) { + unchecked { + b = x*2+1; + } + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract C { + function a(uint8 x) public returns (uint8 b) { + unchecked { + b = x<<1; + } + } + } + |] + withSolvers Z3 3 Nothing $ \s -> do + a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts (mkCalldata Nothing []) + assertEqual "Must be different" (any isCex a) True + , testCase "eq-all-yul-optimization-tests" $ do + let opts = defaultVeriOpts{ maxIter = Just 5, askSmtIters = 20, loopHeuristic = Naive } + ignoredTests = + -- unbounded loop -- + [ "commonSubexpressionEliminator/branches_for.yul" + , "conditionalSimplifier/no_opt_if_break_is_not_last.yul" + , "conditionalUnsimplifier/no_opt_if_break_is_not_last.yul" + , "expressionSimplifier/inside_for.yul" + , "forLoopConditionIntoBody/cond_types.yul" + , "forLoopConditionIntoBody/simple.yul" + , "fullSimplify/inside_for.yul" + , "fullSuite/no_move_loop_orig.yul" + , "loopInvariantCodeMotion/multi.yul" + , "redundantAssignEliminator/for_deep_simple.yul" + , "unusedAssignEliminator/for_deep_noremove.yul" + , "unusedAssignEliminator/for_deep_simple.yul" + , "ssaTransform/for_def_in_init.yul" + , "loopInvariantCodeMotion/simple_state.yul" + , "loopInvariantCodeMotion/simple.yul" + , "loopInvariantCodeMotion/recursive.yul" + , "loopInvariantCodeMotion/no_move_staticall_returndatasize.yul" + , "loopInvariantCodeMotion/no_move_state_loop.yul" + , "loopInvariantCodeMotion/no_move_state.yul" -- not infinite, but rollaround on a large int + , "loopInvariantCodeMotion/no_move_loop.yul" + + -- unexpected symbolic arg -- + + -- OpCreate2 + , "expressionSimplifier/create2_and_mask.yul" + + -- OpCreate + , "expressionSimplifier/create_and_mask.yul" + , "expressionSimplifier/large_byte_access.yul" + + -- OpMload + , "yulOptimizerTests/expressionSplitter/inside_function.yul" + , "fullInliner/double_inline.yul" + , "fullInliner/inside_condition.yul" + , "fullInliner/large_function_multi_use.yul" + , "fullInliner/large_function_single_use.yul" + , "fullInliner/no_inline_into_big_global_context.yul" + , "fullSimplify/invariant.yul" + , "fullSuite/abi_example1.yul" + , "ssaAndBack/for_loop.yul" + , "ssaAndBack/multi_assign_multi_var_if.yul" + , "ssaAndBack/multi_assign_multi_var_switch.yul" + , "ssaAndBack/two_vars.yul" + , "ssaTransform/multi_assign.yul" + , "ssaTransform/multi_decl.yul" + , "expressionSplitter/inside_function.yul" + , "fullSuite/ssaReverseComplex.yul" + + -- OpMstore + , "commonSubexpressionEliminator/function_scopes.yul" + , "commonSubexpressionEliminator/variable_for_variable.yul" + , "expressionSplitter/trivial.yul" + , "fullInliner/multi_return.yul" + , "fullSimplify/constant_propagation.yul" + , "fullSimplify/identity_rules_complex.yul" + , "fullSuite/medium.yul" + , "loadResolver/memory_with_msize.yul" + , "loadResolver/merge_known_write.yul" + , "loadResolver/merge_known_write_with_distance.yul" + , "loadResolver/merge_unknown_write.yul" + , "loadResolver/reassign_value_expression.yul" + , "loadResolver/second_mstore_with_delta.yul" + , "loadResolver/second_store_with_delta.yul" + , "loadResolver/simple.yul" + , "loadResolver/simple_memory.yul" + , "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" + + -- OpRevert + , "ssaAndBack/ssaReverse.yul" + , "redundantAssignEliminator/for_continue_3.yul" + , "controlFlowSimplifier/terminating_for_revert.yul" + + -- invalid test -- + -- https://github.com/ethereum/solidity/issues/9500 + , "commonSubexpressionEliminator/object_access.yul" + , "expressionSplitter/object_access.yul" + , "fullSuite/stack_compressor_msize.yul" + + -- stack too deep -- + , "fullSuite/abi2.yul" + , "fullSuite/aztec.yul" + , "stackCompressor/inlineInBlock.yul" + , "stackCompressor/inlineInFunction.yul" + , "stackCompressor/unusedPrunerWithMSize.yul" + , "wordSizeTransform/function_call.yul" + , "fullInliner/no_inline_into_big_function.yul" + , "controlFlowSimplifier/switch_only_default.yul" + , "stackLimitEvader" -- all that are in this subdirectory + + -- wrong number of args -- + , "wordSizeTransform/functional_instruction.yul" + , "wordSizeTransform/if.yul" + , "wordSizeTransform/or_bool_renamed.yul" + , "wordSizeTransform/switch_1.yul" + , "wordSizeTransform/switch_2.yul" + , "wordSizeTransform/switch_3.yul" + , "wordSizeTransform/switch_4.yul" + , "wordSizeTransform/switch_5.yul" + , "unusedFunctionParameterPruner/too_many_arguments.yul" + + -- typed yul -- + , "conditionalSimplifier/add_correct_type_wasm.yul" + , "conditionalSimplifier/add_correct_type.yul" + , "disambiguator/for_statement.yul" + , "disambiguator/funtion_call.yul" + , "disambiguator/if_statement.yul" + , "disambiguator/long_names.yul" + , "disambiguator/switch_statement.yul" + , "disambiguator/variables_clash.yul" + , "disambiguator/variables_inside_functions.yul" + , "disambiguator/variables.yul" + , "expressionInliner/simple.yul" + , "expressionInliner/with_args.yul" + , "expressionSplitter/typed.yul" + , "fullInliner/multi_return_typed.yul" + , "functionGrouper/empty_block.yul" + , "functionGrouper/multi_fun_mixed.yul" + , "functionGrouper/nested_fun.yul" + , "functionGrouper/single_fun.yul" + , "functionHoister/empty_block.yul" + , "functionHoister/multi_mixed.yul" + , "functionHoister/nested.yul" + , "functionHoister/single.yul" + , "mainFunction/empty_block.yul" + , "mainFunction/multi_fun_mixed.yul" + , "mainFunction/nested_fun.yul" + , "mainFunction/single_fun.yul" + , "ssaTransform/typed_for.yul" + , "ssaTransform/typed_switch.yul" + , "ssaTransform/typed.yul" + , "varDeclInitializer/typed.yul" + + -- New: symbolic index on MSTORE/MLOAD/CopySlice/CallDataCopy/ExtCodeCopy/Revert, + -- or exponent is symbolic (requires symbolic gas) + -- or SHA3 offset symbolic + , "blockFlattener/basic.yul" + , "commonSubexpressionEliminator/case2.yul" + , "equalStoreEliminator/indirect_inferrence.yul" + , "expressionJoiner/reassignment.yul" + , "expressionSimplifier/exp_simplifications.yul" + , "expressionSimplifier/zero_length_read.yul" + , "expressionSimplifier/side_effects_in_for_condition.yul" + , "fullSuite/create_and_mask.yul" + , "fullSuite/unusedFunctionParameterPruner_return.yul" + , "fullSuite/unusedFunctionParameterPruner_simple.yul" + , "fullSuite/unusedFunctionParameterPruner.yul" + , "loadResolver/double_mload_with_other_reassignment.yul" + , "loadResolver/double_mload_with_reassignment.yul" + , "loadResolver/double_mload.yul" + , "loadResolver/keccak_reuse_basic.yul" + , "loadResolver/keccak_reuse_expr_mstore.yul" + , "loadResolver/keccak_reuse_msize.yul" + , "loadResolver/keccak_reuse_mstore.yul" + , "loadResolver/keccak_reuse_reassigned_branch.yul" + , "loadResolver/keccak_reuse_reassigned_value.yul" + , "loadResolver/keccak_symbolic_memory.yul" + , "loadResolver/merge_mload_with_known_distance.yul" + , "loadResolver/mload_self.yul" + , "loadResolver/keccak_reuse_in_expression.yul" + , "loopInvariantCodeMotion/complex_move.yul" + , "loopInvariantCodeMotion/move_memory_function.yul" + , "loopInvariantCodeMotion/move_state_function.yul" + , "loopInvariantCodeMotion/no_move_memory.yul" + , "loopInvariantCodeMotion/no_move_storage.yul" + , "loopInvariantCodeMotion/not_first.yul" + , "ssaAndBack/single_assign_if.yul" + , "ssaAndBack/single_assign_switch.yul" + , "structuralSimplifier/switch_inline_no_match.yul" + , "unusedFunctionParameterPruner/simple.yul" + , "unusedStoreEliminator/covering_calldatacopy.yul" + , "unusedStoreEliminator/remove_before_revert.yul" + , "unusedStoreEliminator/unknown_length2.yul" + , "unusedStoreEliminator/unrelated_relative.yul" + , "fullSuite/extcodelength.yul" + , "unusedStoreEliminator/create_inside_function.yul"-- "trying to reset symbolic storage with writes in create" + + -- Takes too long, would timeout on most test setups. + -- We could probably fix these by "bunching together" queries + , "reasoningBasedSimplifier/mulmod.yul" + , "loadResolver/multi_sload_loop.yul" + , "reasoningBasedSimplifier/mulcheck.yul" + , "reasoningBasedSimplifier/smod.yul" + + -- TODO check what's wrong with these! + , "loadResolver/keccak_short.yul" -- ACTUAL bug -- keccak + , "reasoningBasedSimplifier/signed_division.yul" -- ACTUAL bug, SDIV + ] + + solcRepo <- fromMaybe (internalError "cannot find solidity repo") <$> (lookupEnv "HEVM_SOLIDITY_REPO") + let testDir = solcRepo <> "/test/libyul/yulOptimizerTests" + dircontents <- System.Directory.listDirectory testDir + let + fullpaths = map ((testDir ++ "/") ++) dircontents + recursiveList :: [FilePath] -> [FilePath] -> IO [FilePath] + recursiveList (a:ax) b = do + isdir <- doesDirectoryExist a + case isdir of + True -> do + fs <- System.Directory.listDirectory a + let fs2 = map ((a ++ "/") ++) fs + recursiveList (ax++fs2) b + False -> recursiveList ax (a:b) + recursiveList [] b = pure b + files <- recursiveList fullpaths [] + let filesFiltered = filter (\file -> not $ any (`List.isSubsequenceOf` file) ignoredTests) files + + -- Takes one file which follows the Solidity Yul optimizer unit tests format, + -- extracts both the nonoptimized and the optimized versions, and checks equivalence. + forM_ filesFiltered (\f-> do + origcont <- readFile f + let + onlyAfter pattern (a:ax) = if a =~ pattern then (a:ax) else onlyAfter pattern ax + onlyAfter _ [] = [] + replaceOnce pat repl inp = go inp [] where + go (a:ax) b = if a =~ pat then let a2 = replaceAll repl $ a *=~ pat in b ++ a2:ax + else go ax (b ++ [a]) + go [] b = b + + -- takes a yul program and ensures memory is symbolic by prepending + -- `calldatacopy(0,0,1024)`. (calldata is symbolic, but memory starts empty). + -- This forces the exploration of more branches, and makes the test vectors a + -- little more thorough. + symbolicMem (a:ax) = if a =~ [re|"^ *object"|] then + let a2 = replaceAll "a calldatacopy(0,0,1024)" $ a *=~ [re|code {|] + in (a2:ax) + else replaceOnce [re|^ *{|] "{\ncalldatacopy(0,0,1024)" $ onlyAfter [re|^ *{|] (a:ax) + symbolicMem _ = internalError "Program too short" + + unfiltered = lines origcont + filteredASym = symbolicMem [ x | x <- unfiltered, (not $ x =~ [re|^//|]) && (not $ x =~ [re|^$|]) ] + filteredBSym = symbolicMem [ replaceAll "" $ x *=~[re|^//|] | x <- onlyAfter [re|^// step:|] unfiltered, not $ x =~ [re|^$|] ] + start <- getCurrentTime + putStrLn $ "Checking file: " <> f + when opts.debug $ do + putStrLn "-------------Original Below-----------------" + mapM_ putStrLn unfiltered + putStrLn "------------- Filtered A + Symb below-----------------" + mapM_ putStrLn filteredASym + putStrLn "------------- Filtered B + Symb below-----------------" + mapM_ putStrLn filteredBSym + putStrLn "------------- END -----------------" + Just aPrgm <- yul "" $ T.pack $ unlines filteredASym + Just bPrgm <- yul "" $ T.pack $ unlines filteredBSym + procs <- getNumProcessors + withSolvers CVC5 (unsafeInto procs) (Just 100) $ \s -> do + res <- equivalenceCheck s aPrgm bPrgm opts (mkCalldata Nothing []) + end <- getCurrentTime + case any isCex res of + False -> do + print $ "OK. Took " <> (show $ diffUTCTime end start) <> " seconds" + let timeouts = filter isTimeout res + unless (null timeouts) $ do + putStrLn $ "But " <> (show $ length timeouts) <> " timeout(s) occurred" + internalError "Encountered timeouts" + True -> do + putStrLn $ "Not OK: " <> show f <> " Got: " <> show res + internalError "Was NOT equivalent" + ) + ] + ] + where + (===>) = assertSolidityComputation + +checkEquivProp :: Prop -> Prop -> IO Bool +checkEquivProp = checkEquivBase (\l r -> PNeg (PImpl l r .&& PImpl r l)) + +checkEquiv :: (Typeable a) => Expr a -> Expr a -> IO Bool +checkEquiv = checkEquivBase (./=) + +checkEquivBase :: Eq a => (a -> a -> Prop) -> a -> a -> IO Bool +checkEquivBase mkprop l r = withSolvers Z3 1 (Just 1) $ \solvers -> do + if l == r + then do + putStrLn "skip" + pure True + else do + let smt = assertPropsNoSimp abstRefineDefault [mkprop l r] + res <- checkSat solvers smt + print res + pure $ case res of + Unsat -> True + EVM.Solvers.Unknown -> True + Sat _ -> False + Error _ -> False + +-- | Takes a runtime code and calls it with the provided calldata + +-- | Takes a creation code and some calldata, runs the creation code, and calls the resulting contract with the provided calldata +runSimpleVM :: ByteString -> ByteString -> IO (Maybe ByteString) +runSimpleVM x ins = do + loadVM x >>= \case + Nothing -> pure Nothing + Just vm -> do + let calldata = (ConcreteBuf ins) + vm' = set (#state % #calldata) calldata vm + res <- Stepper.interpret (Fetch.zero 0 Nothing) vm' Stepper.execFully + case res of + (Right (ConcreteBuf bs)) -> pure $ Just bs + s -> internalError $ show s + +-- | Takes a creation code and returns a vm with the result of executing the creation code +loadVM :: ByteString -> IO (Maybe (VM RealWorld)) +loadVM x = do + vm <- stToIO $ vmForEthrunCreation x + vm1 <- Stepper.interpret (Fetch.zero 0 Nothing) vm Stepper.runFully + case vm1.result of + Just (VMSuccess (ConcreteBuf targetCode)) -> do + let target = vm1.state.contract + vm2 <- Stepper.interpret (Fetch.zero 0 Nothing) vm1 (prepVm target targetCode >> Stepper.run) + pure $ Just vm2 + _ -> pure Nothing + where + prepVm target targetCode = Stepper.evm $ do + replaceCodeOfSelf (RuntimeCode $ ConcreteRuntimeCode targetCode) + resetState + assign (#state % #gas) 0xffffffffffffffff -- kludge + execState (loadContract target) <$> get >>= put + +hex :: ByteString -> ByteString +hex s = + case BS16.decodeBase16 s of + Right x -> x + Left e -> internalError $ T.unpack e + +singleContract :: Text -> Text -> IO (Maybe ByteString) +singleContract x s = + solidity x [i| + pragma experimental ABIEncoderV2; + contract ${x} { ${s} } + |] + +defaultDataLocation :: AbiType -> Text +defaultDataLocation t = + if (case t of + AbiBytesDynamicType -> True + AbiStringType -> True + AbiArrayDynamicType _ -> True + AbiArrayType _ _ -> True + _ -> False) + then "memory" + else "" + +runFunction :: Text -> ByteString -> IO (Maybe ByteString) +runFunction c input = do + Just x <- singleContract "X" c + runSimpleVM x input + +runStatements + :: Text -> [AbiValue] -> AbiType + -> IO (Maybe ByteString) +runStatements stmts args t = do + let params = + T.intercalate ", " + (map (\(x, c) -> abiTypeSolidity (abiValueType x) + <> " " <> defaultDataLocation (abiValueType x) + <> " " <> T.pack [c]) + (zip args "abcdefg")) + s = + "foo(" <> T.intercalate "," + (map (abiTypeSolidity . abiValueType) args) <> ")" + + runFunction [i| + function foo(${params}) public pure returns (${abiTypeSolidity t} ${defaultDataLocation t} x) { + ${stmts} + } + |] (abiMethod s (AbiTuple $ V.fromList args)) + +getStaticAbiArgs :: Int -> VM s -> [Expr EWord] +getStaticAbiArgs n vm = + let cd = vm.state.calldata + in decodeStaticArgs 4 n cd + +-- includes shaving off 4 byte function sig +decodeAbiValues :: [AbiType] -> ByteString -> [AbiValue] +decodeAbiValues types bs = + let xy = case decodeAbiValue (AbiTupleType $ V.fromList types) (BS.fromStrict (BS.drop 4 bs)) of + AbiTuple xy' -> xy' + _ -> internalError "AbiTuple expected" + in V.toList xy + +newtype Bytes = Bytes ByteString + deriving Eq + +instance Show Bytes where + showsPrec _ (Bytes x) _ = show (BS.unpack x) + +instance Arbitrary Bytes where + arbitrary = fmap (Bytes . BS.pack) arbitrary + +newtype RLPData = RLPData RLP + deriving (Eq, Show) + +-- bias towards bytestring to try to avoid infinite recursion +instance Arbitrary RLPData where + arbitrary = frequency + [(5, do + Bytes bytes <- arbitrary + return $ RLPData $ BS bytes) + , (1, do + k <- choose (0,10) + ls <- vectorOf k arbitrary + return $ RLPData $ List [r | RLPData r <- ls]) + ] + +instance Arbitrary Word128 where + arbitrary = liftM2 fromHiAndLo arbitrary arbitrary + +instance Arbitrary Word160 where + arbitrary = liftM2 fromHiAndLo arbitrary arbitrary + +instance Arbitrary Word256 where + arbitrary = liftM2 fromHiAndLo arbitrary arbitrary + +instance Arbitrary W64 where + arbitrary = fmap W64 arbitrary + +instance Arbitrary W256 where + arbitrary = fmap W256 arbitrary + +instance Arbitrary Addr where + arbitrary = fmap Addr arbitrary + +instance Arbitrary (Expr EAddr) where + arbitrary = oneof + [ fmap LitAddr arbitrary + , fmap SymAddr (genName "addr") + ] + +instance Arbitrary (Expr Storage) where + arbitrary = sized genStorage + +instance Arbitrary (Expr EWord) where + arbitrary = sized defaultWord + +instance Arbitrary (Expr Byte) where + arbitrary = sized genByte + +instance Arbitrary (Expr Buf) where + arbitrary = sized defaultBuf + +instance Arbitrary (Expr End) where + arbitrary = sized genEnd + +instance Arbitrary (ContractCode) where + arbitrary = oneof + [ fmap UnknownCode arbitrary + , liftM2 InitCode arbitrary arbitrary + , fmap RuntimeCode arbitrary + ] + +instance Arbitrary (RuntimeCode) where + arbitrary = oneof + [ fmap ConcreteRuntimeCode arbitrary + , fmap SymbolicRuntimeCode arbitrary + ] + +instance Arbitrary (V.Vector (Expr Byte)) where + arbitrary = fmap V.fromList (listOf1 arbitrary) + +instance Arbitrary (Expr EContract) where + arbitrary = sized genEContract + +-- LitOnly +newtype LitOnly a = LitOnly a + deriving (Show, Eq) + +newtype LitWord (sz :: Nat) = LitWord (Expr EWord) + deriving (Show) + +instance (KnownNat sz) => Arbitrary (LitWord sz) where + arbitrary = LitWord <$> genLit (fromInteger v) + where + v = natVal (Proxy @sz) + +instance Arbitrary (LitOnly (Expr Byte)) where + arbitrary = LitOnly . LitByte <$> arbitrary + +instance Arbitrary (LitOnly (Expr EWord)) where + arbitrary = LitOnly . Lit <$> arbitrary + +instance Arbitrary (LitOnly (Expr Buf)) where + arbitrary = LitOnly . ConcreteBuf <$> arbitrary + +genEContract :: Int -> Gen (Expr EContract) +genEContract sz = do + c <- arbitrary + b <- defaultWord sz + n <- arbitrary + s <- genStorage sz + pure $ C c s b n + +-- ZeroDepthWord +newtype ZeroDepthWord = ZeroDepthWord (Expr EWord) + deriving (Show, Eq) + +instance Arbitrary ZeroDepthWord where + arbitrary = do + fmap ZeroDepthWord . sized $ genWord 0 + +-- WriteWordBuf +newtype WriteWordBuf = WriteWordBuf (Expr Buf) + deriving (Show, Eq) + +instance Arbitrary WriteWordBuf where + arbitrary = do + let mkBuf = oneof + [ pure $ ConcreteBuf "" -- empty + , fmap ConcreteBuf arbitrary -- concrete + , sized (genBuf 100) -- overlapping writes + , arbitrary -- sparse writes + ] + fmap WriteWordBuf mkBuf + +-- GenCopySliceBuf +newtype GenCopySliceBuf = GenCopySliceBuf (Expr Buf) + deriving (Show, Eq) + +instance Arbitrary GenCopySliceBuf where + arbitrary = do + let mkBuf = oneof + [ pure $ ConcreteBuf "" + , fmap ConcreteBuf arbitrary + , arbitrary + ] + fmap GenCopySliceBuf mkBuf + +-- GenWriteStorageExpr +newtype GenWriteStorageExpr = GenWriteStorageExpr (Expr EWord, Expr Storage) + deriving (Show, Eq) + +instance Arbitrary GenWriteStorageExpr where + arbitrary = do + slot <- arbitrary + let mkStore = oneof + [ pure $ ConcreteStore mempty + , fmap ConcreteStore arbitrary + , do + -- generate some write chains where we know that at least one + -- write matches either the input addr, or both the input + -- addr and slot + let addWrites :: Expr Storage -> Int -> Gen (Expr Storage) + addWrites b 0 = pure b + addWrites b n = liftM3 SStore arbitrary arbitrary (addWrites b (n - 1)) + s <- arbitrary + addMatch <- fmap (SStore slot) arbitrary + let withMatch = addMatch s + newWrites <- oneof [ pure 0, pure 1, fmap (`mod` 5) arbitrary ] + addWrites withMatch newWrites + , arbitrary + ] + store <- mkStore + pure $ GenWriteStorageExpr (slot, store) + +-- GenWriteByteIdx +newtype GenWriteByteIdx = GenWriteByteIdx (Expr EWord) + deriving (Show, Eq) + +instance Arbitrary GenWriteByteIdx where + arbitrary = do + -- 1st: can never overflow an Int + -- 2nd: can overflow an Int + let mkIdx = frequency [ (10, genLit 1_000_000) , (1, fmap Lit arbitrary) ] + fmap GenWriteByteIdx mkIdx + +newtype LitProp = LitProp Prop + deriving (Show, Eq) + +instance Arbitrary LitProp where + arbitrary = LitProp <$> sized (genProp True) + + +newtype StorageExp = StorageExp (Expr EWord) + deriving (Show, Eq) + +instance Arbitrary StorageExp where + arbitrary = StorageExp <$> (genStorageExp) + +genStorageExp :: Gen (Expr EWord) +genStorageExp = do + fromPos <- genSlot + storage <- genStorageWrites + pure $ SLoad fromPos storage + +genSlot :: Gen (Expr EWord) +genSlot = frequency [ (1, do + buf <- genConcreteBufSlot 64 + case buf of + (ConcreteBuf b) -> do + key <- genLit 10 + pure $ Expr.MappingSlot b key + _ -> internalError "impossible" + ) + -- map element + ,(2, do + l <- genLit 10 + buf <- genConcreteBufSlot 64 + pure $ Add (Keccak buf) l) + -- Array element + ,(2, do + l <- genLit 10 + buf <- genConcreteBufSlot 32 + pure $ Add (Keccak buf) l) + -- member of the Contract + ,(2, pure $ Lit 20) + -- array element + ,(2, do + arrayNum :: Int <- arbitrary + offs :: W256 <- arbitrary + pure $ Lit $ fst (Expr.preImages !! (arrayNum `mod` 3)) + (offs `mod` 3)) + -- random stuff + ,(1, pure $ Lit (maxBound :: W256)) + ] + +-- Generates an N-long buffer, all with the same value, at most 8 different ones +genConcreteBufSlot :: Int -> Gen (Expr Buf) +genConcreteBufSlot len = do + b :: Word8 <- arbitrary + pure $ ConcreteBuf $ BS.pack ([ 0 | _ <- [0..(len-2)]] ++ [b]) + +genStorageWrites :: Gen (Expr Storage) +genStorageWrites = do + toSlot <- genSlot + val <- genLit (maxBound :: W256) + store <- frequency [ (3, pure $ AbstractStore (SymAddr "")) + , (2, genStorageWrites) + ] + pure $ SStore toSlot val store + +instance Arbitrary Prop where + arbitrary = sized (genProp False) + +genProps :: Bool -> Int -> Gen [Prop] +genProps onlyLits sz2 = listOf $ genProp onlyLits sz2 + +genProp :: Bool -> Int -> Gen (Prop) +genProp _ 0 = PBool <$> arbitrary +genProp onlyLits sz = oneof + [ liftM2 PEq subWord subWord + , liftM2 PLT subWord subWord + , liftM2 PGT subWord subWord + , liftM2 PLEq subWord subWord + , liftM2 PGEq subWord subWord + , fmap PNeg subProp + , liftM2 PAnd subProp subProp + , liftM2 POr subProp subProp + , liftM2 PImpl subProp subProp + ] + where + subWord = if onlyLits then frequency [(2, Lit <$> arbitrary) + ,(1, pure $ Lit 0) + ,(1, pure $ Lit Expr.maxLit) + ] + else genWord 1 (sz `div` 2) + subProp = genProp onlyLits (sz `div` 2) + +genByte :: Int -> Gen (Expr Byte) +genByte 0 = fmap LitByte arbitrary +genByte sz = oneof + [ liftM2 IndexWord subWord subWord + , liftM2 ReadByte subWord subBuf + ] + where + subWord = defaultWord (sz `div` 10) + subBuf = defaultBuf (sz `div` 10) + +genLit :: W256 -> Gen (Expr EWord) +genLit bound = do + w <- arbitrary + pure $ Lit (w `mod` bound) + +genNat :: Gen Int +genNat = fmap unsafeInto (arbitrary :: Gen Natural) + +genName :: String -> Gen Text +-- In order not to generate SMT reserved words, we prepend with "esc_" +genName ty = fmap (T.pack . (("esc_" <> ty <> "_") <> )) $ listOf1 (oneof . (fmap pure) $ ['a'..'z'] <> ['A'..'Z']) + +genEnd :: Int -> Gen (Expr End) +genEnd 0 = oneof + [ fmap (Failure mempty mempty . UnrecognizedOpcode) arbitrary + , pure $ Failure mempty mempty IllegalOverflow + , pure $ Failure mempty mempty SelfDestruction + ] +genEnd sz = oneof + [ liftM3 Failure subProp (pure mempty) (fmap Revert subBuf) + , liftM4 Success subProp (pure mempty) subBuf arbitrary + , liftM3 ITE subWord subEnd subEnd + -- TODO Partial + ] + where + subBuf = defaultBuf (sz `div` 2) + subWord = defaultWord (sz `div` 2) + subEnd = genEnd (sz `div` 2) + subProp = genProps False (sz `div` 2) + +genWord :: Int -> Int -> Gen (Expr EWord) +genWord litFreq 0 = frequency + [ (litFreq, do + val <- frequency + [ (10, fmap (`mod` 100) arbitrary) + , (1, pure 0) + , (1, pure Expr.maxLit) + , (1, arbitrary) + ] + pure $ Lit val + ) + , (1, oneof + [ pure Origin + , pure Coinbase + , pure Timestamp + , pure BlockNumber + , pure PrevRandao + , pure GasLimit + , pure ChainId + , pure BaseFee + --, liftM2 SelfBalance arbitrary arbitrary + --, liftM2 Gas arbitrary arbitrary + , fmap Lit arbitrary + , fmap Var (genName "word") + ] + ) + ] +genWord litFreq sz = frequency + [ (litFreq, do + val <- frequency + [ (10, fmap (`mod` 100) arbitrary) + , (1, arbitrary) + ] + pure $ Lit val + ) + , (1, oneof + [ liftM2 Add subWord subWord + , liftM2 Sub subWord subWord + , liftM2 Mul subWord subWord + , liftM2 Div subWord subWord + , liftM2 SDiv subWord subWord + , liftM2 Mod subWord subWord + , liftM2 SMod subWord subWord + --, liftM3 AddMod subWord subWord subWord + --, liftM3 MulMod subWord subWord subWord -- it works, but it's VERY SLOW + --, liftM2 Exp subWord litWord + , liftM2 SEx subWord subWord + , liftM2 Min subWord subWord + , liftM2 LT subWord subWord + , liftM2 GT subWord subWord + , liftM2 LEq subWord subWord + , liftM2 GEq subWord subWord + , liftM2 SLT subWord subWord + --, liftM2 SGT subWord subWord + , liftM2 Eq subWord subWord + , fmap IsZero subWord + , liftM2 And subWord subWord + , liftM2 Or subWord subWord + , liftM2 Xor subWord subWord + , fmap Not subWord + , liftM2 SHL subWord subWord + , liftM2 SHR subWord subWord + , liftM2 SAR subWord subWord + , fmap BlockHash subWord + --, liftM3 Balance arbitrary arbitrary subWord + --, fmap CodeSize subWord + --, fmap ExtCodeHash subWord + , fmap Keccak subBuf + , fmap SHA256 subBuf + , liftM2 SLoad subWord subStore + , liftM2 ReadWord subWord subBuf + , fmap BufLength subBuf + , do + one <- subByte + two <- subByte + three <- subByte + four <- subByte + five <- subByte + six <- subByte + seven <- subByte + eight <- subByte + nine <- subByte + ten <- subByte + eleven <- subByte + twelve <- subByte + thirteen <- subByte + fourteen <- subByte + fifteen <- subByte + sixteen <- subByte + seventeen <- subByte + eighteen <- subByte + nineteen <- subByte + twenty <- subByte + twentyone <- subByte + twentytwo <- subByte + twentythree <- subByte + twentyfour <- subByte + twentyfive <- subByte + twentysix <- subByte + twentyseven <- subByte + twentyeight <- subByte + twentynine <- subByte + thirty <- subByte + thirtyone <- subByte + thirtytwo <- subByte + pure $ JoinBytes + one two three four five six seven eight nine ten + eleven twelve thirteen fourteen fifteen sixteen + seventeen eighteen nineteen twenty twentyone + twentytwo twentythree twentyfour twentyfive + twentysix twentyseven twentyeight twentynine + thirty thirtyone thirtytwo + ]) + ] + where + subWord = genWord litFreq (sz `div` 5) + subBuf = defaultBuf (sz `div` 10) + subStore = genStorage (sz `div` 10) + subByte = genByte (sz `div` 10) + +genWordArith :: Int -> Int -> Gen (Expr EWord) +genWordArith litFreq 0 = frequency + [ (litFreq, fmap Lit arbitrary) + , (1, oneof [ fmap Lit arbitrary ]) + ] +genWordArith litFreq sz = frequency + [ (litFreq, fmap Lit arbitrary) + , (20, frequency + [ (20, liftM2 Add subWord subWord) + , (20, liftM2 Sub subWord subWord) + , (20, liftM2 Mul subWord subWord) + , (20, liftM2 SEx subWord subWord) + , (20, liftM2 Xor subWord subWord) + -- these reduce variability + , (3 , liftM2 Min subWord subWord) + , (3 , liftM2 Div subWord subWord) + , (3 , liftM2 SDiv subWord subWord) + , (3 , liftM2 Mod subWord subWord) + , (3 , liftM2 SMod subWord subWord) + , (3 , liftM2 SHL subWord subWord) + , (3 , liftM2 SHR subWord subWord) + , (3 , liftM2 SAR subWord subWord) + , (3 , liftM2 Or subWord subWord) + -- comparisons, reducing variability greatly + , (1 , liftM2 LEq subWord subWord) + , (1 , liftM2 GEq subWord subWord) + , (1 , liftM2 SLT subWord subWord) + --(1, , liftM2 SGT subWord subWord + , (1 , liftM2 Eq subWord subWord) + , (1 , liftM2 And subWord subWord) + , (1 , fmap IsZero subWord ) + -- Expensive below + --(1, liftM3 AddMod subWord subWord subWord + --(1, liftM3 MulMod subWord subWord subWord + --(1, liftM2 Exp subWord litWord + ]) + ] + where + subWord = genWordArith (litFreq `div` 2) (sz `div` 2) + +-- Used to check for unsimplified expressions +newtype FoundBad = FoundBad { bad :: Bool } deriving (Show) +initFoundBad :: FoundBad +initFoundBad = FoundBad { bad = False } + +-- Finds SLoad -> SStore. This should not occur in most scenarios +-- as we can simplify them away +badStoresInExpr :: Expr a -> Bool +badStoresInExpr expr = bad + where + FoundBad bad = execState (mapExprM findBadStore expr) initFoundBad + findBadStore :: Expr a-> State FoundBad (Expr a) + findBadStore e = case e of + (SLoad _ (SStore _ _ _)) -> do + put (FoundBad { bad = True }) + pure e + _ -> pure e + +defaultBuf :: Int -> Gen (Expr Buf) +defaultBuf = genBuf (4_000_000) + +defaultWord :: Int -> Gen (Expr EWord) +defaultWord = genWord 10 + +maybeBoundedLit :: W256 -> Gen (Expr EWord) +maybeBoundedLit bound = do + o <- (arbitrary :: Gen (Expr EWord)) + pure $ case o of + Lit w -> Lit $ w `mod` bound + _ -> o + +genBuf :: W256 -> Int -> Gen (Expr Buf) +genBuf _ 0 = oneof + [ fmap AbstractBuf (genName "buf") + , fmap ConcreteBuf arbitrary + ] +genBuf bound sz = oneof + [ liftM3 WriteWord (maybeBoundedLit bound) subWord subBuf + , liftM3 WriteByte (maybeBoundedLit bound) subByte subBuf + -- we don't generate copyslice instances where: + -- - size is abstract + -- - size > 100 (due to unrolling in SMT.hs) + -- - literal dstOffsets are > 4,000,000 (due to unrolling in SMT.hs) + -- n.b. that 4,000,000 is the theoretical maximum memory size given a 30,000,000 block gas limit + , liftM5 CopySlice subWord (maybeBoundedLit bound) smolLitWord subBuf subBuf + ] + where + -- copySlice gets unrolled in the generated SMT so we can't go too crazy here + smolLitWord = do + w <- arbitrary + pure $ Lit (w `mod` 100) + subWord = defaultWord (sz `div` 5) + subByte = genByte (sz `div` 10) + subBuf = genBuf bound (sz `div` 10) + +genStorage :: Int -> Gen (Expr Storage) +genStorage 0 = oneof + [ fmap AbstractStore arbitrary + , fmap ConcreteStore arbitrary + ] +genStorage sz = liftM3 SStore subWord subWord subStore + where + subStore = genStorage (sz `div` 10) + subWord = defaultWord (sz `div` 5) + +data Invocation + = SolidityCall Text [AbiValue] + deriving Show + +assertSolidityComputation :: Invocation -> AbiValue -> IO () +assertSolidityComputation (SolidityCall s args) x = + do y <- runStatements s args (abiValueType x) + assertEqual (T.unpack s) + (fmap Bytes (Just (encodeAbiValue x))) + (fmap Bytes y) + +bothM :: (Monad m) => (a -> m b) -> (a, a) -> m (b, b) +bothM f (a, a') = do + b <- f a + b' <- f a' + return (b, b') + +applyPattern :: String -> TestTree -> TestTree +applyPattern p = localOption (TestPattern (parseExpr p)) + +checkBadCheatCode :: Text -> Postcondition s +checkBadCheatCode sig _ = \case + (Failure _ _ (BadCheatCode s)) -> (ConcreteBuf $ into s.unFunctionSelector) ./= (ConcreteBuf $ selector sig) + _ -> PBool True + +allBranchesFail :: ByteString -> Maybe Sig -> IO (Either [SMTCex] (Expr End)) +allBranchesFail = checkPost (Just p) + where + p _ = \case + Success _ _ _ _ -> PBool False + _ -> PBool True + +reachableUserAsserts :: ByteString -> Maybe Sig -> IO (Either [SMTCex] (Expr End)) +reachableUserAsserts = checkPost (Just $ checkAssertions [0x01]) + +checkPost :: Maybe (Postcondition RealWorld) -> ByteString -> Maybe Sig -> IO (Either [SMTCex] (Expr End)) +checkPost post c sig = do + (e, res) <- withSolvers Z3 1 Nothing $ \s -> + verifyContract s c sig [] defaultVeriOpts Nothing post + let cexs = snd <$> mapMaybe getCex res + case cexs of + [] -> pure $ Right e + cs -> pure $ Left cs + +successGen :: [Prop] -> Expr End +successGen props = Success props mempty (ConcreteBuf "") mempty