diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,163 @@ # hevm changelog +## 0.41.0 - 2020-08-19 + +### Changed + +- Switched to [PVP](https://github.com/haskell/pvp/blob/master/pvp-faq.md) for version control, starting now at `0.41.0` (MAJOR.MAJOR.MINOR). +- z3 updated to 4.8.7 +- Generate more interesting values in property based testing, + and implement proper shrinking for all abi values. +- Fixed soundness bug when using KECCAK or SHA256 opcode/precompile +- Fixed an issue in debug mode where backstepping could cause path information to be forgotten +- Ensure that pathconditions are consistent when branching, and end the execution with VMFailure: DeadPath if this is not the case +- Fixed a soundness bug where nonzero jumpconditions were assumed to equal one. +- default `--smttimeout` changed from unlimited to 20 seconds +- `hevm symbolic --debug` now respects `--max-iterations` + +### Added + +- `hevm exec --trace` flag to dump a trace +- Faster backstepping in interactive mode by saving multiple snapshot states. +- Support for symbolic storage for multiple contracts + +## 0.40 - 2020-07-22 + +- hevm is now capable of symbolic execution! + +### Changed +As a result, the types of several registers of the EVM have changed to admit symbolic values as well as concrete ones. + + - state.stack: `Word` -> `SymWord`. + - state.memory: `ByteString` -> `[SWord 8]`. + - state.callvalue: `W256` -> `SymWord`. + - state.caller: `Addr` -> `SAddr`. + - state.returndata: `ByteString` -> `[SWord 8]`. + - state.calldata: `ByteString` -> `([SWord 8], (SWord 32))`. The first element is a list of symbolic bytes, the second is the length of calldata. We have `fst calldata !! i .== 0` for all `snd calldata < i`. + + - tx.value: `W256` -> `SymWord`. + + - contract.storage: `Map Word Word` -> `Storage`, defined as: +```hs +data Storage + = Concrete (Map Word SymWord) + | Symbolic (SArray (WordN 256) (WordN 256)) + deriving (Show) +``` + +### Added +New cli commands: + - `hevm symbolic`: search for assertion violations, or step through a symbolic execution in debug mode. + - `hevm equivalence`: compare two programs for equivalence. + +See the README for details on usage. + +The new module `EVM.SymExec` exposes several library functions dealing with symbolic execution. +In particular, + - `SymExec.interpret`: implements an operational monad script similar to `TTY.interpret` and `Stepper.interpret`, but returns a list of final VM states rather than a single VM. + - `SymExec.verify`: takes a prestate and a postcondition, symbolically executes the prestate and checks that all final states matches the postcondition. + +### Removed + +The concrete versions of a lot of arithmetic operations, replaced with their more general symbolic counterpart. + + +## 0.39 - 2020-07-13 + - Exposes abi encoding to cli + - Added cheat code `hevm.store(address a, bytes32 location, bytes32 value)` + - Removes `ExecMode`, always running as `ExecuteAsBlockchainTest`. This means that `hevm exec` now finalizes transactions as well. + - `--code` is now entirely optional. Not supplying it returns an empty contract, or whatever is stored in `--state`. + +## 0.38 - 2020-04-23 + - Exposes metadata stripping of bytecode to the cli: `hevm strip-metadata --code X`. [357](https://github.com/dapphub/dapptools/pull/357). + - Fixes a bug in the srcmap parsing introduced in 0.37 [356](https://github.com/dapphub/dapptools/pull/356). + - Fixes a bug in the abi-encoding of `bytes` with size > 32[358](https://github.com/dapphub/dapptools/pull/358). + +## 0.37 - 2020-03-24 + - Sourcemap parser now admits `solc-0.6.0` compiled `.sol.json` files. + +## 0.36 - 2020-01-07 + - Implement Istanbul support [318](https://github.com/dapphub/dapptools/pull/318) + - Fix a bug introduced in [280](https://github.com/dapphub/dapptools/pull/280) of rlp encoding of transactions and sender address [320](https://github.com/dapphub/dapptools/pull/320/). + - Make InvalidTx a fatal error for vm tests and ci. + - Suport property based testing in unit tests. [313](https://github.com/dapphub/dapptools/pull/313) Arguments to test functions are randomly generated based on the function abi. Fuzz tests are not present in the graphical debugger. + - Added flags `--replay` and `--fuzz-run` to `hevm dapp-test`, allowing for particular fuzz run cases to be rerun, or for configuration of how many fuzz tests are run. + - Correct gas readouts for unit tests + - Prevent crash when trying to jump to next source code point if source code is missing + +## 0.35 - 2019-11-02 + - Merkle Patricia trie support [280](https://github.com/dapphub/dapptools/pull/280) + - RLP encoding and decoding functions [280](https://github.com/dapphub/dapptools/pull/280) + - Extended support for Solidity ABI encoding [259](https://github.com/dapphub/dapptools/pull/259) + - Bug fixes surrounding unit tests and gas accounting (https://github.com/dapphub/dapptools/commit/574ef401d3e744f2dcf994da056810cf69ef84fe, https://github.com/dapphub/dapptools/commit/5257574dd9df14edc29410786b75e9fb9c59069f) + +## 0.34 - 2019-08-28 + - handle new solc bzzr metadata in codehash for source map + - show VM hex outputs as hexadecimal + - rpc defaults to latest block + - `hevm interactive`: + - fix rpc fetch + - scrollable memory pane + - Fix regression in VMTest compliance. + - `hevm exec` ergonomics: + - Allow code/calldata prefixed with 0x + - create transactions with specific caller nonce + - interactive help pane + - memory pane scrolling + +## 0.33 - 2019-08-06 + - Full compliance with the [General State Tests][245] (with the + BlockchainTest format), using the Yellow and Jello papers as + reference, for Constantinople Fix (aka Petersburg). Including: + - full precompile support + - correct substate accounting, including touched accounts, + selfdestructs and refunds + - memory read/write semantics + - many gas cost corrections + - Show more information for non solc bytecode in interactive view + (trace and storage) + - Help text for all cli options + - Enable `--debug` flag in `hevm dapp-test` + +[245]: https://github.com/dapphub/dapptools/pull/245 + +## 0.32 - 2019-06-14 + - Fix dapp-test [nonce initialisation bug][224] + +[224]: https://github.com/dapphub/dapptools/pull/224 + +## 0.31 - 2019-05-29 + - Precompiles: SHA256, RIPEMD, IDENTITY, MODEXP, ECADD, ECMUL, + ECPAIRING, MODEXP + - Show the hevm version with `hevm version` + - Interactive mode: + - no longer exits on reaching halt + - new shortcuts: 'a' / 'e' for start / end + - allow returning to test picker screen + - Exact integer formatting in dapp-test and tty + +## 0.30 - 2019-05-09 + - Adjustable verbosity level for `dapp-test` with `--verbose={0,1,2}` + - Working stack build + +## 0.29 - 2019-04-03 + - Significant jump in compliance with client tests + - Add support for running GeneralStateTests + +## 0.28 - 2019-03-22 + - Fix delegatecall gas metering, as reported in + https://github.com/dapphub/dapptools/issues/34 + +## 0.27 - 2019-02-06 + - Fix [hevm flatten issue](https://github.com/dapphub/dapptools/issues/127) + related to SemVer ranges in Solidity version pragmas + +## 0.26 - 2019-02-05 + - Format Solidity Error(string) messages in trace + +## 0.25 - 2019-02-04 + - Add SHL, SHR and SAR opcodes + ## 0.24 - 2019-01-23 - Fix STATICCALL for precompiled contracts - Assume Solidity 0.5.2 in tests diff --git a/ethjet/blake2.cc b/ethjet/blake2.cc new file mode 100644 --- /dev/null +++ b/ethjet/blake2.cc @@ -0,0 +1,65 @@ +#include +#include "blake2.h" + +#define ROTR64(x, y) (((x) >> (y)) ^ ((x) << (64 - (y)))) + +#define B2B_G(a, b, c, d, x, y) \ + v[a] = v[a] + v[b] + x; \ + v[d] = ROTR64(v[d] ^ v[a], 32); \ + v[c] = v[c] + v[d]; \ + v[b] = ROTR64(v[b] ^ v[c], 24); \ + v[a] = v[a] + v[b] + y; \ + v[d] = ROTR64(v[d] ^ v[a], 16); \ + v[c] = v[c] + v[d]; \ + v[b] = ROTR64(v[b] ^ v[c], 63); + +static const uint64_t blake2b_iv[8] = { + 0x6A09E667F3BCC908, 0xBB67AE8584CAA73B, + 0x3C6EF372FE94F82B, 0xA54FF53A5F1D36F1, + 0x510E527FADE682D1, 0x9B05688C2B3E6C1F, + 0x1F83D9ABFB41BD6B, 0x5BE0CD19137E2179 +}; + +static const uint8_t sigma[10][16] = { + { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 }, + { 14, 10, 4, 8, 9, 15, 13, 6, 1, 12, 0, 2, 11, 7, 5, 3 }, + { 11, 8, 12, 0, 5, 2, 15, 13, 10, 14, 3, 6, 7, 1, 9, 4 }, + { 7, 9, 3, 1, 13, 12, 11, 14, 2, 6, 5, 10, 4, 0, 15, 8 }, + { 9, 0, 5, 7, 2, 4, 10, 15, 14, 1, 11, 12, 6, 8, 3, 13 }, + { 2, 12, 6, 10, 0, 11, 8, 3, 4, 13, 7, 5, 15, 14, 1, 9 }, + { 12, 5, 1, 15, 14, 13, 4, 10, 0, 7, 6, 3, 9, 2, 8, 11 }, + { 13, 11, 7, 14, 12, 1, 3, 9, 5, 0, 15, 4, 8, 6, 2, 10 }, + { 6, 15, 14, 9, 11, 3, 0, 8, 12, 2, 13, 7, 1, 4, 10, 5 }, + { 10, 2, 8, 4, 7, 6, 1, 5, 15, 11, 9, 14, 3, 12, 13, 0 } +}; + +void blake2b_compress(uint64_t *h, uint64_t *m, uint64_t *t, char f, uint32_t rounds) { + uint32_t i; + uint64_t v[16]; + + for (i = 0; i < 8; i++) { + v[i] = h[i]; + v[i+8] = blake2b_iv[i]; + } + + v[12] ^= t[0]; + v[13] ^= t[1]; + + if (f) v[14] = ~v[14]; + + int index; + for (i = 0; i < rounds; i++) { + index = i % 10; + B2B_G( 0, 4, 8, 12, m[sigma[index][ 0]], m[sigma[index][ 1]]); + B2B_G( 1, 5, 9, 13, m[sigma[index][ 2]], m[sigma[index][ 3]]); + B2B_G( 2, 6, 10, 14, m[sigma[index][ 4]], m[sigma[index][ 5]]); + B2B_G( 3, 7, 11, 15, m[sigma[index][ 6]], m[sigma[index][ 7]]); + B2B_G( 0, 5, 10, 15, m[sigma[index][ 8]], m[sigma[index][ 9]]); + B2B_G( 1, 6, 11, 12, m[sigma[index][10]], m[sigma[index][11]]); + B2B_G( 2, 7, 8, 13, m[sigma[index][12]], m[sigma[index][13]]); + B2B_G( 3, 4, 9, 14, m[sigma[index][14]], m[sigma[index][15]]); + } + + for (i = 0; i < 8; ++i) + h[i] ^= v[i] ^ v[i+8]; +} diff --git a/ethjet/blake2.h b/ethjet/blake2.h new file mode 100644 --- /dev/null +++ b/ethjet/blake2.h @@ -0,0 +1,17 @@ +#ifndef BLAKE2_H +#define BLAKE2_H + +#include + +#ifdef __cplusplus +extern "C" { +#endif + +void +blake2b_compress(uint64_t *h, uint64_t *m, uint64_t *t, char f, uint32_t rounds); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/ethjet/ethjet-ff.cc b/ethjet/ethjet-ff.cc new file mode 100644 --- /dev/null +++ b/ethjet/ethjet-ff.cc @@ -0,0 +1,278 @@ +#include "ethjet.h" + +#include +#include + +#include +#include +#include +#include +#include +#include + +using namespace libff; + +namespace ethjet_ff { + void init() { + libff::inhibit_profiling_info = true; + libff::inhibit_profiling_counters = true; + init_alt_bn128_params(); + } + + // for loading an element of F_q (a coordinate of G_1) + // consumes 32 bytes + alt_bn128_Fq read_Fq_element (uint8_t *in) { + mpz_t x_data; + mpz_init(x_data); + mpz_import(x_data, 32, 1, sizeof(in[0]), 1, 0, in); + + mpz_t q; + mpz_init(q); + alt_bn128_modulus_q.to_mpz(q); + const mp_size_t limbs = alt_bn128_q_limbs; + + if (mpz_cmp(x_data, q) >= 0) + throw 0; + + return Fp_model(bigint(x_data)); + } + + // for loading an element of F_{q^2} (a coordinate of G_2) + // consumes 64 bytes + alt_bn128_Fq2 read_Fq2_element (uint8_t *in) { + // suprising "big-endian" encoding + alt_bn128_Fq x0 = read_Fq_element(in+32); + alt_bn128_Fq x1 = read_Fq_element(in); + + mpz_t q; + mpz_init(q); + alt_bn128_modulus_q.to_mpz(q); + + return Fp2_model(x0, x1); + } + + // for loading an element of F_r (a scalar for G_1) + // consumes 32 bytes + alt_bn128_Fr read_Fr_element (uint8_t *in) { + mpz_t x_data; + mpz_init(x_data); + mpz_import(x_data, 32, 1, sizeof(in[0]), 1, 0, in); + + mpz_t r; + mpz_init(r); + alt_bn128_modulus_r.to_mpz(r); + const mp_size_t limbs = alt_bn128_r_limbs; + + return Fp_model(bigint(x_data)); + } + + // for loading a point in G_1 + // consumes 64 bytes + alt_bn128_G1 read_G1_point (uint8_t *in) { + alt_bn128_Fq ax = read_Fq_element(in); + alt_bn128_Fq ay = read_Fq_element(in+32); + alt_bn128_G1 a; + // create curve point from affine coordinates + // the point at infinity (0,0) is a special case + if (ax.is_zero() && ay.is_zero()) { + a = alt_bn128_G1::G1_zero; + } + else { + a = alt_bn128_G1(ax, ay, alt_bn128_Fq::one()); + } + if (! a.is_well_formed()) { + throw 0; + } + return a; + } + + // for loading a point in G_2 + // consumes 128 bytes + alt_bn128_G2 read_G2_point (uint8_t *in) { + alt_bn128_Fq2 ax = read_Fq2_element(in); + alt_bn128_Fq2 ay = read_Fq2_element(in+64); + alt_bn128_G2 a; + // create curve point from affine coordinates + // the point at infinity (0,0) is a special case + if (ax.is_zero() && ay.is_zero()) { + a = alt_bn128_G2::G2_zero; + return a; + } + a = alt_bn128_G2(ax, ay, alt_bn128_Fq2::one()); + if (! a.is_well_formed()) { + throw 0; + } + // additionally check that the element has the right order + if (-alt_bn128_Fr::one() * a + a != alt_bn128_G2::G2_zero) { + throw 0; + } + return a; + } + + // writes an element of Fq + // produces 32 bytes + void write_Fq_element(uint8_t *out, alt_bn128_Fq x) { + mpz_t x_data; + size_t x_size; + mpz_init(x_data); + + x.as_bigint().to_mpz(x_data); + uint8_t *x_arr = (uint8_t *)mpz_export(NULL, &x_size, 1, 1, 1, 0, x_data); + if (x_size > 32) { + throw 0; + } + // copy the result to the output buffer + // with padding + for (int i = 1; i <= 32; i++) { + if (i <= x_size) + out[32-i] = x_arr[x_size-i]; + else + out[32-i] = 0; + } + return; + } + + // writes an element of F_{q^2} + // produces 64 bytes + void write_Fq2_element(uint8_t *out, alt_bn128_Fq2 x) { + // surprising "big-endian" encoding + write_Fq_element(out+32, x.c0); + write_Fq_element(out, x.c1); + return; + } + + // writes a point of G1 + // produces 64 bytes + void write_G1_point(uint8_t *out, alt_bn128_G1 a) { + // point at infinity is represented as (0,0) + // so treat it as a special case + if (a.is_zero()) { + write_Fq_element(out, alt_bn128_Fq::zero()); + write_Fq_element(out+32, alt_bn128_Fq::zero()); + return; + } + a.to_affine_coordinates(); + write_Fq_element(out, a.X); + write_Fq_element(out+32, a.Y); + return; + } + + // writes a point of G2 + // produces 128 bytes + void write_G2_point(uint8_t *out, alt_bn128_G2 a) { + // point at infinity is represented as (0,0) + // so treat it as a special case + if (a.is_zero()) { + write_Fq2_element(out, alt_bn128_Fq2::zero()); + write_Fq2_element(out+64, alt_bn128_Fq2::zero()); + return; + } + a.to_affine_coordinates(); + write_Fq2_element(out, a.X); + write_Fq2_element(out+64, a.Y); + return; + } + + // writes a bool + // produces 32 bytes + void write_bool(uint8_t *out, bool p) { + out[31] = (int)(p); + for (int i = 2; i <= 32; i++) { + out[32-i] = 0; + } + } +} + +extern "C" { + using namespace ethjet_ff; + + int + ethjet_ecadd (uint8_t *in, size_t in_size, + uint8_t *out, size_t out_size) { + + if (in_size != 128) { + return 0; + } + if (out_size != 64) { + return 0; + } + + init(); + + try { + alt_bn128_G1 a = read_G1_point(in); + alt_bn128_G1 b = read_G1_point(in+64); + alt_bn128_G1 sum = (a + b); + + write_G1_point(out, sum); + } + catch (int e) { + return 0; + } + + return 1; + } + + int + ethjet_ecmul (uint8_t *in, size_t in_size, + uint8_t *out, size_t out_size) { + + if (in_size != 96) { + return 0; + } + if (out_size != 64) { + return 0; + } + + init(); + + try { + alt_bn128_G1 a = read_G1_point(in); + alt_bn128_Fr n = read_Fr_element(in+64); + alt_bn128_G1 na = n * a; + + write_G1_point(out, na); + } + catch (int e) { + return 0; + } + + return 1; + } + + int + ethjet_ecpairing (uint8_t *in, size_t in_size, + uint8_t *out, size_t out_size) { + + if (in_size % 192 != 0) + return 0; + + if (out_size != 32) + return 0; + + init(); + int pairs = in_size / 192; + + try { + alt_bn128_Fq12 x = libff::alt_bn128_Fq12::one(); + for (int i = 0; i < pairs; i++) { + alt_bn128_G1 a = read_G1_point(in + i*192); + alt_bn128_G2 b = read_G2_point(in + i*192 + 64); + if (a.is_zero() || b.is_zero()) + continue; + x = x * alt_bn128_miller_loop(alt_bn128_precompute_G1(a), alt_bn128_precompute_G2(b)); + } + bool result; + if (pairs == 0) + result = true; + else + result = (alt_bn128_final_exponentiation(x) == alt_bn128_GT::one()); + write_bool(out, result); + } + catch (int e) { + return 0; + } + + return 1; + } +} diff --git a/ethjet/ethjet-ff.h b/ethjet/ethjet-ff.h new file mode 100644 --- /dev/null +++ b/ethjet/ethjet-ff.h @@ -0,0 +1,18 @@ +#ifndef ETHJET_FF_H +#define ETHJET_FF_H + +#include + +int +ethjet_ecadd (uint8_t *in, size_t in_size, + uint8_t *out, size_t out_size); + +int +ethjet_ecmul (uint8_t *in, size_t in_size, + uint8_t *out, size_t out_size); + +int +ethjet_ecpairing (uint8_t *in, size_t in_size, + uint8_t *out, size_t out_size); + +#endif diff --git a/ethjet/ethjet.c b/ethjet/ethjet.c --- a/ethjet/ethjet.c +++ b/ethjet/ethjet.c @@ -1,5 +1,7 @@ #include "ethjet.h" +#include "ethjet-ff.h" #include "tinykeccak.h" +#include "blake2.h" #include @@ -68,6 +70,11 @@ input64 = in + 64; recid = in[63] - 27; + /* higher bytes of V should be zero */ + static const char z31 [31]; + if (memcmp (z31, in + 32, 31)) + return 0; + if (recid < 0 || recid > 3) return 0; @@ -90,6 +97,21 @@ return 1; } +int ethjet_blake2(uint8_t *in, size_t in_size, + uint8_t *out, size_t out_size) { + uint32_t rounds = in[0] << 24 | in[1] << 16 | in[2] << 8 | in[3]; + unsigned char f = in[212]; + uint64_t *h = (uint64_t *)&in[4]; + uint64_t *m = (uint64_t *)&in[68]; + uint64_t *t = (uint64_t *)&in[196]; + + blake2b_compress(h, m, t, f, rounds); + + memcpy(out, h, out_size); + + return 1; +} + int ethjet (struct ethjet_context *ctx, enum ethjet_operation op, @@ -103,6 +125,18 @@ case ETHJET_EXAMPLE: return ethjet_example (ctx, in, in_size, out, out_size); + + case ETHJET_ECADD: + return ethjet_ecadd (in, in_size, out, out_size); + + case ETHJET_ECMUL: + return ethjet_ecmul (in, in_size, out, out_size); + + case ETHJET_ECPAIRING: + return ethjet_ecpairing (in, in_size, out, out_size); + + case ETHJET_BLAKE2: + return ethjet_blake2 (in, in_size, out, out_size); default: return 0; diff --git a/ethjet/ethjet.h b/ethjet/ethjet.h --- a/ethjet/ethjet.h +++ b/ethjet/ethjet.h @@ -13,6 +13,10 @@ enum ethjet_operation { ETHJET_ECRECOVER = 1, + ETHJET_ECADD = 6, + ETHJET_ECMUL = 7, + ETHJET_ECPAIRING = 8, + ETHJET_BLAKE2 = 9, ETHJET_EXAMPLE = 0xdeadbeef, }; diff --git a/hevm-cli/hevm-cli.hs b/hevm-cli/hevm-cli.hs --- a/hevm-cli/hevm-cli.hs +++ b/hevm-cli/hevm-cli.hs @@ -1,132 +1,238 @@ -- Main file of the hevm CLI program -{-# Language BangPatterns #-} {-# Language CPP #-} +{-# Language DataKinds #-} +{-# Language FlexibleInstances #-} {-# Language DeriveGeneric #-} -{-# Language GeneralizedNewtypeDeriving #-} +{-# Language GADTs #-} {-# Language LambdaCase #-} {-# Language NumDecimals #-} {-# Language OverloadedStrings #-} -{-# Language TemplateHaskell #-} +{-# Language TypeOperators #-} -import EVM.Concrete (w256) +module Main where -import qualified EVM as EVM +import EVM (StorageModel(..)) +import qualified EVM +import EVM.Concrete (createAddress, w256) +import EVM.Symbolic (forceLitBytes, litBytes, litAddr, w256lit, sw256, SymWord(..), Buffer(..), len) import qualified EVM.FeeSchedule as FeeSchedule import qualified EVM.Fetch import qualified EVM.Flatten import qualified EVM.Stepper -import qualified EVM.TTY as EVM.TTY -import qualified EVM.Emacs as EVM.Emacs +import qualified EVM.TTY +import qualified EVM.Emacs #if MIN_VERSION_aeson(1, 0, 0) import qualified EVM.VMTest as VMTest #endif +import EVM.SymExec import EVM.Debug -import EVM.Exec +import EVM.ABI import EVM.Solidity import EVM.Types hiding (word) import EVM.UnitTest (UnitTestOptions, coverageReport, coverageForUnitTestContract) import EVM.UnitTest (runUnitTestContract) import EVM.UnitTest (getParametersFromEnvironmentVariables, testNumber) -import EVM.Dapp (findUnitTests, dappInfo) - -import qualified EVM.UnitTest as EVM.UnitTest +import EVM.Dapp (findUnitTests, dappInfo, DappInfo) +import EVM.Format (showTraceTree) +import EVM.RLP (rlpdecode) +import qualified EVM.Patricia as Patricia +import Data.Map (Map) -import qualified Paths_hevm as Paths +import qualified EVM.Facts as Facts +import qualified EVM.Facts.Git as Git +import qualified EVM.UnitTest import Control.Concurrent.Async (async, waitCatch) -import Control.Exception (evaluate) -import Control.Lens -import Control.Monad (void, when, forM_) -import Control.Monad.State.Strict (execState) +import Control.Lens hiding (pre) +import Control.Monad (void, when, forM_, unless) +import Control.Monad.State.Strict (execStateT) import Data.ByteString (ByteString) import Data.List (intercalate, isSuffixOf) import Data.Text (Text, unpack, pack) -import Data.Maybe (fromMaybe) +import Data.Text.Encoding (encodeUtf8) +import Data.Text.IO (hPutStr) +import Data.Maybe (fromMaybe, fromJust) +import Data.Version (showVersion) +import Data.SBV hiding (Word, solver, verbose, name) +import Data.SBV.Control hiding (Version, timeout, create) +import System.IO (hFlush, hPrint, stdout, stderr) import System.Directory (withCurrentDirectory, listDirectory) -import System.Exit (die, exitFailure) -import System.IO (hFlush, stdout) +import System.Exit (die, exitFailure, exitWith, ExitCode(..)) +import System.Environment (setEnv) import System.Process (callProcess) -import System.Timeout (timeout) +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Types as JSON +import Data.Aeson (FromJSON (..), (.:)) +import Data.Aeson.Lens hiding (values) +import qualified Data.Vector as V +import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Map as Map -import qualified Options.Generic as Options - -import qualified EVM.Facts as Facts -import qualified EVM.Facts.Git as Git +import qualified Data.Sequence as Seq +import qualified System.Timeout as Timeout +import qualified Paths_hevm as Paths import qualified Text.Regex.TDFA as Regex -import qualified Data.Sequence as Seq +import Options.Generic as Options + -- This record defines the program's command-line options -- automatically via the `optparse-generic` package. -data Command - = Exec - { code :: ByteString - , calldata :: Maybe ByteString - , address :: Maybe Addr - , caller :: Maybe Addr - , origin :: Maybe Addr - , coinbase :: Maybe Addr - , value :: Maybe W256 - , gas :: Maybe W256 - , number :: Maybe W256 - , timestamp :: Maybe W256 - , gaslimit :: Maybe W256 - , gasprice :: Maybe W256 - , difficulty :: Maybe W256 - , debug :: Bool - , state :: Maybe String +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 W256 "Tx: gas amount" + , number :: w ::: Maybe W256 "Block: number" + , timestamp :: w ::: Maybe W256 "Block: timestamp" + , gaslimit :: w ::: Maybe W256 "Tx: gas limit" + , gasprice :: w ::: Maybe W256 "Tx: gas price" + , create :: w ::: Bool "Tx: creation" + , maxcodesize :: w ::: Maybe W256 "Block: max code size" + , difficulty :: w ::: Maybe W256 "Block: difficulty" + , 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 + , jsonFile :: w ::: Maybe String "Filename or path to dapp build output (default: out/*.solc.json)" + , dappRoot :: w ::: Maybe String "Path to dapp project root directory (default: . )" + , storageModel :: w ::: Maybe StorageModel "Select storage model: ConcreteS, SymbolicS (default) or InitialS" + , 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" + , smttimeout :: w ::: Maybe Integer "Timeout given to SMT solver in milliseconds (default: 20000)" + , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" + , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc4" } - | DappTest - { jsonFile :: Maybe String - , dappRoot :: Maybe String - , debug :: Bool - , rpc :: Maybe URL - , verbose :: Bool - , coverage :: Bool - , state :: Maybe String - , match :: Maybe String + | 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" + , smttimeout :: w ::: Maybe Integer "Timeout given to SMT solver in milliseconds (default: 20000)" + , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" + , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc4" } - | Interactive - { jsonFile :: Maybe String - , dappRoot :: Maybe String - , rpc :: Maybe URL - , state :: Maybe String + | 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 W256 "Tx: gas amount" + , number :: w ::: Maybe W256 "Block: number" + , timestamp :: w ::: Maybe W256 "Block: timestamp" + , gaslimit :: w ::: Maybe W256 "Tx: gas limit" + , gasprice :: w ::: Maybe W256 "Tx: gas price" + , create :: w ::: Bool "Tx: creation" + , maxcodesize :: w ::: Maybe W256 "Block: max code size" + , difficulty :: w ::: Maybe W256 "Block: difficulty" + , chainid :: w ::: Maybe W256 "Env: chainId" + , debug :: w ::: Bool "Run interactively" + , trace :: w ::: Bool "Dump trace" + , state :: w ::: Maybe String "Path to state repository" + , rpc :: w ::: Maybe URL "Fetch state from a remote node" + , block :: w ::: Maybe W256 "Block state is be fetched from" + , jsonFile :: w ::: Maybe String "Filename or path to dapp build output (default: out/*.solc.json)" + , dappRoot :: w ::: Maybe String "Path to dapp project root directory (default: . )" } - | VmTest - { file :: String - , test :: [String] - , debug :: Bool + | DappTest -- Run DSTest unit tests + { jsonFile :: w ::: Maybe String "Filename or path to dapp build output (default: out/*.solc.json)" + , dappRoot :: w ::: Maybe String "Path to dapp project root directory (default: . )" + , debug :: w ::: Bool "Run interactively" + , fuzzRuns :: w ::: Maybe Int "Number of times to run fuzz tests" + , 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" + , match :: w ::: Maybe String "Test case filter - only run methods matching regex" } - | VmTestReport - { tests :: String + | Interactive -- Browse & run unit tests interactively + { jsonFile :: w ::: Maybe String "Filename or path to dapp build output (default: out/*.solc.json)" + , dappRoot :: w ::: Maybe String "Path to dapp project root directory (default: . )" + , rpc :: w ::: Maybe URL "Fetch state from a remote node" + , state :: w ::: Maybe String "Path to state repository" + , replay :: w ::: Maybe (Text, ByteString) "Custom fuzz case to run/debug" } - | Flatten - { sourceFile :: String - , jsonFile :: Maybe String - , dappRoot :: Maybe String + | BcTest -- Run an Ethereum Blockhain/GeneralState test + { file :: w ::: String "Path to .json test file" + , test :: w ::: [String] "Test case filter - only run specified test method(s)" + , debug :: w ::: Bool "Run interactively" + , diff :: w ::: Bool "Print expected vs. actual state on failure" + , timeout :: w ::: Maybe Int "Execution timeout (default: 10 sec.)" + } + | Compliance -- Run Ethereum Blockhain compliance report + { tests :: w ::: String "Path to Ethereum Tests directory" + , group :: w ::: Maybe String "Report group to run: VM or Blockchain (default: Blockchain)" + , match :: w ::: Maybe String "Test case filter - only run methods matching regex" + , skip :: w ::: Maybe String "Test case filter - skip tests containing string" + , html :: w ::: Bool "Output html report" + , timeout :: w ::: Maybe Int "Execution timeout (default: 10 sec.)" + } + | Flatten -- Concat all dependencies for a given source file + { sourceFile :: w ::: String "Path to solidity source file e.g. src/contract.sol" + , jsonFile :: w ::: Maybe String "Filename or path to dapp build output (default: out/*.solc.json)" + , dappRoot :: w ::: Maybe String "Path to dapp project root directory (default: . )" } | Emacs - deriving (Show, Options.Generic, Eq) + | Version + | Rlp -- RLP decode a string and print the result + { decode :: w ::: ByteString "RLP encoded hexstring" + } + | Abiencode + { abi :: w ::: Maybe String "Signature of types to decode / encode" + , arg :: w ::: [String] "Values to encode" + } + | MerkleTest -- Insert a set of key values and check against the given root + { file :: w ::: String "Path to .json test file" + } + | StripMetadata -- Remove metadata from contract bytecode + { code :: w ::: Maybe ByteString "Program bytecode" + } + deriving (Options.Generic) + type URL = Text -instance Options.ParseRecord Command where + +-- For some reason haskell can't derive a +-- parseField instance for (Text, ByteString) +instance Options.ParseField (Text, ByteString) + +instance Options.ParseRecord (Command Options.Wrapped) where parseRecord = Options.parseRecordWithModifiers Options.lispCaseModifiers -optsMode :: Command -> Mode +optsMode :: Command Options.Unwrapped -> Mode optsMode x = if debug x then Debug else Run -unitTestOptions :: Command -> IO UnitTestOptions -unitTestOptions cmd = do +unitTestOptions :: Command Options.Unwrapped -> String -> IO UnitTestOptions +unitTestOptions cmd testFile = do + let root = fromMaybe "." (dappRoot cmd) + srcInfo <- readSolc testFile >>= \case + Nothing -> error "Could not read .sol.json file" + Just (contractMap, sourceCache) -> + pure $ dappInfo root contractMap sourceCache + vmModifier <- case state cmd of Nothing -> @@ -137,45 +243,64 @@ params <- getParametersFromEnvironmentVariables + let + testn = testNumber params + block' = if 0 == testn + then EVM.Fetch.Latest + else EVM.Fetch.BlockNumber testn + pure EVM.UnitTest.UnitTestOptions { EVM.UnitTest.oracle = case rpc cmd of - Just url -> EVM.Fetch.http (EVM.Fetch.BlockNumber (testNumber params)) url + Just url -> EVM.Fetch.http block' url Nothing -> EVM.Fetch.zero , EVM.UnitTest.verbose = verbose cmd , EVM.UnitTest.match = pack $ fromMaybe "^test" (match cmd) + , EVM.UnitTest.fuzzRuns = fromMaybe 100 (fuzzRuns cmd) + , EVM.UnitTest.replay = do + arg' <- replay cmd + return (fst arg', LazyByteString.fromStrict (hexByteString "--replay" $ strip0x $ snd arg')) , EVM.UnitTest.vmModifier = vmModifier , EVM.UnitTest.testParams = params + , EVM.UnitTest.dapp = srcInfo } main :: IO () main = do - cmd <- Options.getRecord "hevm -- Ethereum evaluator" + cmd <- Options.unwrapRecord "hevm -- Ethereum evaluator" let root = fromMaybe "." (dappRoot cmd) case cmd of + Version {} -> putStrLn (showVersion Paths.version) + Symbolic {} -> assert cmd + Equivalence {} -> equivalence cmd Exec {} -> launchExec cmd - VmTest {} -> - launchVMTest cmd + Abiencode {} -> + print . ByteStringS $ abiencode (abi cmd) (arg cmd) + BcTest {} -> + launchTest cmd DappTest {} -> withCurrentDirectory root $ do testFile <- findJsonFile (jsonFile cmd) - testOpts <- unitTestOptions cmd - case coverage cmd of - False -> + testOpts <- unitTestOptions cmd testFile + case (coverage cmd, optsMode cmd) of + (False, Run) -> dappTest testOpts (optsMode cmd) testFile - True -> + (False, Debug) -> + EVM.TTY.main testOpts root testFile + (True, _) -> dappCoverage testOpts (optsMode cmd) testFile Interactive {} -> withCurrentDirectory root $ do testFile <- findJsonFile (jsonFile cmd) - testOpts <- unitTestOptions cmd + testOpts <- unitTestOptions cmd testFile EVM.TTY.main testOpts root testFile - VmTestReport {} -> - withCurrentDirectory (tests cmd) $ do - dataDir <- Paths.getDataDir - callProcess "bash" [dataDir ++ "/run-consensus-tests", "."] + Compliance {} -> + case (group cmd) of + Just "Blockchain" -> launchScript "/run-blockchain-tests" cmd + Just "VM" -> launchScript "/run-consensus-tests" cmd + _ -> launchScript "/run-blockchain-tests" cmd Flatten {} -> withCurrentDirectory root $ do theJson <- findJsonFile (jsonFile cmd) @@ -188,7 +313,27 @@ error ("Failed to read Solidity JSON for `" ++ theJson ++ "'") Emacs -> EVM.Emacs.main + Rlp {} -> + case rlpdecode $ hexByteString "--decode" $ strip0x $ decode cmd of + Nothing -> error "Malformed RLP string" + Just c -> print c + MerkleTest {} -> merkleTest cmd + StripMetadata {} -> print . + ByteStringS . stripBytecodeMetadata . hexByteString "bytecode" . strip0x $ fromJust $ code cmd +launchScript :: String -> Command Options.Unwrapped -> IO () +launchScript script cmd = + withCurrentDirectory (tests cmd) $ do + dataDir <- Paths.getDataDir + callProcess "bash" + [ dataDir ++ script + , "." + , show (html cmd) + , fromMaybe "" (match cmd) + , fromMaybe "" (skip cmd) + , show $ fromMaybe 10 (timeout cmd) + ] + findJsonFile :: Maybe String -> IO String findJsonFile (Just s) = pure s findJsonFile Nothing = do @@ -210,12 +355,12 @@ ] dappTest :: UnitTestOptions -> Mode -> String -> IO () -dappTest opts _ solcFile = do +dappTest opts _ solcFile = readSolc solcFile >>= \case Just (contractMap, cache) -> do let matcher = regexMatches (EVM.UnitTest.match opts) - let unitTests = (findUnitTests matcher) (Map.elems contractMap) + unitTests = (findUnitTests matcher) (Map.elems contractMap) results <- mapM (runUnitTestContract opts contractMap cache) unitTests when (any (== False) results) exitFailure Nothing -> @@ -232,8 +377,154 @@ in Regex.matchTest regex . Seq.fromList . unpack +equivalence :: Command Options.Unwrapped -> IO () +equivalence cmd = + do let bytecodeA = hexByteString "--code" . strip0x $ codeA cmd + bytecodeB = hexByteString "--code" . strip0x $ codeB cmd + maybeSignature <- case sig cmd of + Nothing -> return Nothing + Just sig' -> do method' <- functionAbi sig' + return $ Just (view methodSignature method', snd <$> view methodInputs method') + + void . runSMTWithTimeOut (solver cmd) (smttimeout cmd) . query $ + equivalenceCheck bytecodeA bytecodeB (maxIterations cmd) maybeSignature >>= \case + Right vm -> do io $ putStrLn "Not equal!" + io $ putStrLn "Counterexample:" + showCounterexample vm maybeSignature + io $ exitFailure + Left (postAs, postBs) -> io $ do + putStrLn $ "Explored: " <> show (length postAs) + <> " execution paths of A and: " + <> show (length postBs) <> " paths of B." + putStrLn $ "No discrepancies found." + + +-- cvc4 sets timeout via a commandline option instead of smtlib `(set-option)` +runSMTWithTimeOut :: Maybe Text -> Maybe Integer -> Symbolic a -> IO a +runSMTWithTimeOut solver maybeTimeout sym + | solver == Just "cvc4" = do + setEnv "SBV_CVC4_OPTIONS" ("--lang=smt --incremental --interactive --no-interactive-prompt --model-witness-value --tlimit-per=" <> show timeout) + a <- runSMTWith cvc4 sym + setEnv "SBV_CVC4_OPTIONS" "" + return a + | solver == Just "z3" = runwithz3 + | solver == Nothing = runwithz3 + | otherwise = error "Unknown solver. Currently supported solvers; z3, cvc4" + where timeout = fromMaybe 20000 maybeTimeout + runwithz3 = runSMTWith z3 $ (setTimeOut timeout) >> sym + + +checkForVMErrors :: [EVM.VM] -> [String] +checkForVMErrors [] = [] +checkForVMErrors (vm:vms) = + case view EVM.result vm of + Just (EVM.VMFailure EVM.UnexpectedSymbolicArg) -> + ("Unexpected symbolic argument at opcode: " + <> maybe "??" show (EVM.vmOp vm) + <> ". Not supported (yet!)" + ) : checkForVMErrors vms + _ -> + checkForVMErrors vms + +emptyDapp :: DappInfo +emptyDapp = dappInfo "" mempty (SourceCache mempty mempty mempty mempty) + +getSrcInfo :: Command Options.Unwrapped -> IO DappInfo +getSrcInfo cmd = + let root = fromMaybe "." (dappRoot cmd) + in case (jsonFile cmd) of + Nothing -> + pure $ emptyDapp + Just json -> readSolc json >>= \case + Nothing -> + pure $ emptyDapp + Just (contractMap, sourceCache) -> + pure $ dappInfo root contractMap sourceCache + +-- Although it is tempting to fully abstract calldata and give any hints about +-- the nature of the signature doing so results in significant time spent in +-- consulting z3 about rather trivial matters. But with cvc4 it is quite +-- pleasant! + +-- If function signatures are known, they should always be given for best results. +assert :: Command Options.Unwrapped -> IO () +assert cmd = do + let block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) + rpcinfo = (,) block' <$> rpc cmd + model = fromMaybe (if create cmd then InitialS else SymbolicS) (storageModel cmd) + srcInfo <- getSrcInfo cmd + maybesig <- case sig cmd of + Nothing -> + return Nothing + Just sig' -> do + method' <- functionAbi sig' + let typ = snd <$> view methodInputs method' + name = view methodSignature method' + return $ Just (name,typ) + if debug cmd then + runSMTWithTimeOut (solver cmd) (smttimeout cmd) $ query $ do + preState <- symvmFromCommand cmd + smtState <- queryState + io $ void $ EVM.TTY.runFromVM + (maxIterations cmd) + srcInfo + (EVM.Fetch.oracle smtState rpcinfo model) + preState + + else + runSMTWithTimeOut (solver cmd) (smttimeout cmd) $ query $ do + preState <- symvmFromCommand cmd + verify preState (maxIterations cmd) rpcinfo (Just checkAssertions) >>= \case + Right _ -> do + io $ putStrLn "Assertion violation found." + showCounterexample preState maybesig + io $ exitWith (ExitFailure 1) + Left (pre, posts) -> do + io $ putStrLn $ "Explored: " <> show (length posts) + <> " branches without assertion violations" + let vmErrs = checkForVMErrors posts + unless (null vmErrs) $ io $ do + putStrLn $ + "However, " + <> show (length vmErrs) + <> " branch(es) errored while exploring:" + print vmErrs + -- When `--get-models` is passed, we print example vm info for each path + when (getModels cmd) $ + forM_ (zip [1..] posts) $ \(i, postVM) -> do + resetAssertions + constrain (sAnd (view EVM.pathConditions postVM)) + io $ putStrLn $ + "-- Branch (" <> show i <> "/" <> show (length posts) <> ") --" + checkSat >>= \case + Unk -> io $ do putStrLn "Timed out" + print $ view EVM.result postVM + Unsat -> io $ do putStrLn "Inconsistent path conditions: dead path" + print $ view EVM.result postVM + Sat -> do + showCounterexample pre maybesig + case view EVM.result postVM of + Nothing -> + error "internal error; no EVM result" + Just (EVM.VMFailure (EVM.Revert "")) -> io . putStrLn $ + "Reverted" + Just (EVM.VMFailure (EVM.Revert msg)) -> io . putStrLn $ + "Reverted: " <> show (ByteStringS msg) + Just (EVM.VMFailure err) -> io . putStrLn $ + "Failed: " <> show err + Just (EVM.VMSuccess (ConcreteBuffer msg)) -> + if ByteString.null msg + then io $ putStrLn + "Stopped" + else io $ putStrLn $ + "Returned: " <> show (ByteStringS msg) + Just (EVM.VMSuccess (SymbolicBuffer msg)) -> do + out <- mapM (getValue.fromSized) msg + io . putStrLn $ + "Returned: " <> show (ByteStringS (ByteString.pack out)) + dappCoverage :: UnitTestOptions -> Mode -> String -> IO () -dappCoverage opts _ solcFile = do +dappCoverage opts _ solcFile = readSolc solcFile >>= \case Just (contractMap, cache) -> do @@ -262,9 +553,11 @@ Nothing -> error ("Failed to read Solidity JSON for `" ++ solcFile ++ "'") -launchExec :: Command -> IO () +launchExec :: Command Options.Unwrapped -> IO () launchExec cmd = do - let vm = vmFromCommand cmd + dapp <- getSrcInfo cmd + + vm <- vmFromCommand cmd vm1 <- case state cmd of Nothing -> pure vm Just path -> @@ -274,57 +567,248 @@ Facts.apply vm <$> Git.loadFacts (Git.RepoAt path) case optsMode cmd of - Run -> - let vm' = execState exec vm1 - in case view EVM.result vm' of + Run -> do + vm' <- execStateT (interpret fetcher Nothing . void $ EVM.Stepper.execFully) vm1 + when (trace cmd) $ hPutStr stderr (showTraceTree dapp vm') + case view EVM.result vm' of Nothing -> error "internal error; no EVM result" - Just (EVM.VMFailure e) -> do - die (show e) - Just (EVM.VMSuccess x) -> do - let hex = BS16.encode x - if ByteString.null hex then pure () - else do - ByteString.putStr hex - putStrLn "" + Just (EVM.VMFailure (EVM.Revert msg)) -> do + print $ ByteStringS msg + exitWith (ExitFailure 2) + Just (EVM.VMFailure err) -> do + print err + exitWith (ExitFailure 2) + Just (EVM.VMSuccess buf) -> do + let msg = case buf of + SymbolicBuffer msg' -> forceLitBytes msg' + ConcreteBuffer msg' -> msg' + print $ ByteStringS msg case state cmd of Nothing -> pure () Just path -> Git.saveFacts (Git.RepoAt path) (Facts.vmFacts vm') - Debug -> - void (EVM.TTY.runFromVM vm1) + Debug -> void $ EVM.TTY.runFromVM Nothing dapp fetcher vm1 + where fetcher = maybe EVM.Fetch.zero (EVM.Fetch.http block') (rpc cmd) + block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) -vmFromCommand :: Command -> EVM.VM -vmFromCommand cmd = - vm1 & EVM.env . EVM.contracts . ix address' . EVM.balance +~ (w256 value') +data Testcase = Testcase { + _entries :: [(Text, Maybe Text)], + _root :: Text +} deriving Show + +parseTups :: JSON.Value -> JSON.Parser [(Text, Maybe Text)] +parseTups (JSON.Array arr) = do + tupList <- mapM parseJSON (V.toList arr) + mapM (\[k, v] -> do + rhs <- parseJSON v + lhs <- parseJSON k + return (lhs, rhs)) + tupList +parseTups invalid = JSON.typeMismatch "Malformed array" invalid + + +parseTrieTest :: JSON.Object -> JSON.Parser Testcase +parseTrieTest p = do + kvlist <- p .: "in" + entries <- parseTups kvlist + root <- p .: "root" + return $ Testcase entries root + +instance FromJSON Testcase where + parseJSON (JSON.Object p) = parseTrieTest p + parseJSON invalid = JSON.typeMismatch "Merkle test case" invalid + +parseTrieTests :: Lazy.ByteString -> Either String (Map String Testcase) +parseTrieTests = JSON.eitherDecode' + +merkleTest :: Command Options.Unwrapped -> IO () +merkleTest cmd = do + parsed <- parseTrieTests <$> LazyByteString.readFile (file cmd) + case parsed of + Left err -> print err + Right testcases -> mapM_ runMerkleTest testcases + +runMerkleTest :: Testcase -> IO () +runMerkleTest (Testcase entries root) = + case Patricia.calcRoot entries' of + Nothing -> + error "Test case failed" + Just n -> + case n == strip0x (hexText root) of + True -> + putStrLn "Test case success" + False -> + error ("Test case failure; expected " <> show root + <> " but got " <> show (ByteStringS n)) + where entries' = fmap (\(k, v) -> + (tohexOrText k, + tohexOrText (fromMaybe mempty v))) + entries + +tohexOrText :: Text -> ByteString +tohexOrText s = case "0x" `Char8.isPrefixOf` encodeUtf8 s of + True -> hexText s + False -> encodeUtf8 s + +-- | Creates a (concrete) VM from command line options +vmFromCommand :: Command Options.Unwrapped -> IO EVM.VM +vmFromCommand cmd = do + vm <- case (rpc cmd, address cmd) of + (Just url, Just addr') -> do + EVM.Fetch.fetchContractFrom block' url addr' >>= \case + Nothing -> error $ "contract not found: " <> show address' + Just contract' -> case code cmd of + Nothing -> return (vm1 contract') + -- if both code and url is given, + -- fetch the contract and overwrite the code + Just c -> return . vm1 $ + EVM.initialContract (codeType $ hexByteString "--code" $ strip0x c) + & set EVM.storage (view EVM.storage contract') + & set EVM.balance (view EVM.balance contract') + & set EVM.nonce (view EVM.nonce contract') + & set EVM.external (view EVM.external contract') + + _ -> return . vm1 . EVM.initialContract . codeType $ bytes code "" + + return $ vm & EVM.env . EVM.contracts . ix address' . EVM.balance +~ (w256 value') + where + decipher = hexByteString "bytes" . strip0x + block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) + value' = word value 0 + caller' = addr caller 0 + origin' = addr origin 0 + calldata' = ConcreteBuffer $ bytes calldata "" + codeType = if create cmd then EVM.InitCode else EVM.RuntimeCode + address' = if create cmd + then createAddress origin' (word nonce 0) + else addr address 0xacab + + vm1 c = EVM.makeVm $ EVM.VMOpts + { EVM.vmoptContract = c + , EVM.vmoptCalldata = (calldata', literal . num $ len calldata') + , EVM.vmoptValue = w256lit value' + , EVM.vmoptAddress = address' + , EVM.vmoptCaller = litAddr caller' + , EVM.vmoptOrigin = origin' + , EVM.vmoptGas = word gas 0 + , EVM.vmoptGaslimit = word gas 0 + , EVM.vmoptCoinbase = addr coinbase 0 + , EVM.vmoptNumber = word number 0 + , EVM.vmoptTimestamp = word timestamp 0 + , EVM.vmoptBlockGaslimit = word gaslimit 0 + , EVM.vmoptGasprice = word gasprice 0 + , EVM.vmoptMaxCodeSize = word maxcodesize 0xffffffff + , EVM.vmoptDifficulty = word difficulty 0 + , EVM.vmoptSchedule = FeeSchedule.istanbul + , EVM.vmoptChainId = word chainid 1 + , EVM.vmoptCreate = create cmd + , EVM.vmoptStorageModel = ConcreteS + } + word 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 -> Query EVM.VM +symvmFromCommand cmd = do + caller' <- maybe (SAddr <$> freshVar_) (return . litAddr) (caller cmd) + callvalue' <- maybe (sw256 <$> freshVar_) (return . w256lit) (value cmd) + (calldata', cdlen, pathCond) <- case (calldata cmd, sig cmd) of + -- fully abstract calldata (up to 1024 bytes) + (Nothing, Nothing) -> do + cd <- sbytes256 + len <- freshVar_ + return (SymbolicBuffer cd, len, len .<= 256) + -- fully concrete calldata + (Just c, Nothing) -> + let cd = ConcreteBuffer $ decipher c + in return (cd, num (len cd), sTrue) + -- calldata according to given abi with possible specializations from the `arg` list + (Nothing, Just sig') -> do + method' <- io $ functionAbi sig' + let typs = snd <$> view methodInputs method' + (cd, cdlen) <- symCalldata (view methodSignature method') typs (arg cmd) + return (SymbolicBuffer cd, cdlen, sTrue) + + _ -> error "incompatible options: calldata and abi" + + store <- case storageModel cmd of + -- InitialS and SymbolicS can read and write to symbolic locations + -- ConcreteS cannot (instead values can be fetched from rpc!) + -- Initial defaults to 0 for uninitialized storage slots, + -- whereas the values of SymbolicS are unconstrained. + Just InitialS -> EVM.Symbolic <$> freshArray_ (Just 0) + Just ConcreteS -> return (EVM.Concrete mempty) + Just SymbolicS -> EVM.Symbolic <$> freshArray_ Nothing + Nothing -> EVM.Symbolic <$> freshArray_ (if create cmd then (Just 0) else Nothing) + + vm <- case (rpc cmd, address cmd, code cmd) of + (Just url, Just addr', _) -> + io (EVM.Fetch.fetchContractFrom block' url addr') >>= \case + Nothing -> + error $ "contract not found." + Just contract' -> + return $ + vm1 cdlen calldata' callvalue' caller' (contract'' & set EVM.storage store) + where + contract'' = case code cmd of + Nothing -> contract' + -- if both code and url is given, + -- fetch the contract and overwrite the code + Just c -> EVM.initialContract (codeType $ decipher c) + & set EVM.storage (view EVM.storage contract') + & set EVM.origStorage (view EVM.origStorage contract') + & set EVM.balance (view EVM.balance contract') + & set EVM.nonce (view EVM.nonce contract') + & set EVM.external (view EVM.external contract') + + (_, _, Just c) -> + return $ + vm1 cdlen calldata' callvalue' caller' $ + (EVM.initialContract . codeType $ decipher c) & set EVM.storage store + (_, _, Nothing) -> + error $ "must provide at least (rpc + address) or code" + + return $ vm & over EVM.pathConditions (<> [pathCond]) + where - value' = word value 0 - address' = addr address 1 - vm1 = EVM.makeVm $ EVM.VMOpts - { EVM.vmoptCode = hexByteString "--code" (code cmd) - , EVM.vmoptCalldata = maybe "" (hexByteString "--calldata") - (calldata cmd) - , EVM.vmoptValue = value' - , EVM.vmoptAddress = address' - , EVM.vmoptCaller = addr caller 2 - , EVM.vmoptOrigin = addr origin 3 - , EVM.vmoptGas = word gas 0 - , EVM.vmoptCoinbase = addr coinbase 0 - , EVM.vmoptNumber = word number 0 - , EVM.vmoptTimestamp = word timestamp 0 - , EVM.vmoptGaslimit = word gaslimit 0 - , EVM.vmoptGasprice = word gasprice 0 - , EVM.vmoptDifficulty = word difficulty 0 - , EVM.vmoptSchedule = FeeSchedule.metropolis + decipher = hexByteString "bytes" . strip0x + block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) + origin' = addr origin 0 + codeType = if create cmd then EVM.InitCode else EVM.RuntimeCode + address' = if create cmd + then createAddress origin' (word nonce 0) + else addr address 0xacab + vm1 cdlen calldata' callvalue' caller' c = EVM.makeVm $ EVM.VMOpts + { EVM.vmoptContract = c + , EVM.vmoptCalldata = (calldata', cdlen) + , EVM.vmoptValue = callvalue' + , EVM.vmoptAddress = address' + , EVM.vmoptCaller = caller' + , EVM.vmoptOrigin = origin' + , EVM.vmoptGas = word gas 0xffffffffffffffff + , EVM.vmoptGaslimit = word gas 0xffffffffffffffff + , EVM.vmoptCoinbase = addr coinbase 0 + , EVM.vmoptNumber = word number 0 + , EVM.vmoptTimestamp = word timestamp 0 + , EVM.vmoptBlockGaslimit = word gaslimit 0 + , EVM.vmoptGasprice = word gasprice 0 + , EVM.vmoptMaxCodeSize = word maxcodesize 0xffffffff + , EVM.vmoptDifficulty = word difficulty 0 + , EVM.vmoptSchedule = FeeSchedule.istanbul + , EVM.vmoptChainId = word chainid 1 + , EVM.vmoptCreate = create cmd + , EVM.vmoptStorageModel = fromMaybe SymbolicS (storageModel cmd) } - word f def = maybe def id (f cmd) - addr f def = maybe def id (f cmd) + word f def = fromMaybe def (f cmd) + addr f def = fromMaybe def (f cmd) -launchVMTest :: Command -> IO () -launchVMTest cmd = +launchTest :: Command Options.Unwrapped -> IO () +launchTest cmd = do #if MIN_VERSION_aeson(1, 0, 0) - VMTest.parseSuite <$> LazyByteString.readFile (file cmd) >>= - \case + parsed <- VMTest.parseBCSuite <$> LazyByteString.readFile (file cmd) + case parsed of + Left "No cases to check." -> putStrLn "no-cases ok" Left err -> print err Right allTests -> let testFilter = @@ -332,40 +816,55 @@ then id else filter (\(x, _) -> elem x (test cmd)) in - mapM_ (runVMTest (optsMode cmd)) $ + mapM_ (runVMTest (diff cmd) (optsMode cmd) (timeout cmd)) $ testFilter (Map.toList allTests) #else putStrLn "Not supported" #endif #if MIN_VERSION_aeson(1, 0, 0) -runVMTest :: Mode -> (String, VMTest.Case) -> IO Bool -runVMTest mode (name, x) = do - let - vm0 = VMTest.vmForCase x - m = void EVM.Stepper.execFully >> EVM.Stepper.evm EVM.finalize - +runVMTest :: Bool -> Mode -> Maybe Int -> (String, VMTest.Case) -> IO Bool +runVMTest diffmode mode timelimit (name, x) = + do + let vm0 = VMTest.vmForCase x putStr (name ++ " ") hFlush stdout result <- do action <- async $ case mode of Run -> - timeout (1e6) . evaluate $ do - execState (VMTest.interpret m) vm0 + Timeout.timeout (1e6 * (fromMaybe 10 timelimit)) $ + execStateT (EVM.Stepper.interpret EVM.Fetch.zero . void $ EVM.Stepper.execFully) vm0 Debug -> - Just <$> EVM.TTY.runFromVM vm0 + Just <$> EVM.TTY.runFromVM Nothing emptyDapp EVM.Fetch.zero vm0 waitCatch action case result of Right (Just vm1) -> do - ok <- VMTest.checkExpectation x vm1 + ok <- VMTest.checkExpectation diffmode x vm1 putStrLn (if ok then "ok" else "") return ok Right Nothing -> do putStrLn "timeout" return False - Left _ -> do - putStrLn "error" + Left e -> do + putStrLn $ "error: " ++ if diffmode + then show e + else (head . lines . show) e return False #endif + +parseAbi :: (AsValue s) => s -> (Text, [AbiType]) +parseAbi abijson = + (signature abijson, snd + <$> parseMethodInput + <$> V.toList + (fromMaybe (error "Malformed function abi") (abijson ^? key "inputs" . _Array))) + +abiencode :: (AsValue s) => Maybe s -> [String] -> ByteString +abiencode Nothing _ = error "missing required argument: abi" +abiencode (Just abijson) args = + let (sig', declarations) = parseAbi abijson + in if length declarations == length args + then abiMethod sig' $ AbiTuple . V.fromList $ zipWith makeAbiValue declarations args + else error $ "wrong number of arguments:" <> show (length args) <> ": " <> show args diff --git a/hevm.cabal b/hevm.cabal --- a/hevm.cabal +++ b/hevm.cabal @@ -1,7 +1,8 @@ +cabal-version: 2.2 name: hevm version: - 0.24 + 0.41.0 synopsis: Ethereum virtual machine evaluator description: @@ -12,20 +13,19 @@ homepage: https://github.com/dapphub/dapptools license: - AGPL-3 + AGPL-3.0-only license-file: COPYING author: - Mikael Brockman + Mikael Brockman, Martin Lundfall maintainer: - mikael@brockman.se + mikael@brockman.se, martin.lundfall@gmail.com category: Ethereum build-type: Simple -cabal-version: - >=1.10 data-files: + run-blockchain-tests run-consensus-tests extra-source-files: CHANGELOG.md @@ -38,6 +38,7 @@ EVM.Dapp, EVM.Dev, EVM.Debug, + EVM.Demand, EVM.Emacs, EVM.Exec, EVM.Facts, @@ -47,73 +48,88 @@ EVM.Fetch, EVM.FeeSchedule, EVM.Hexdump, + EVM.Keccak, EVM.Op, + EVM.Patricia, EVM.Precompiled, - EVM.Keccak, + EVM.RLP, EVM.Solidity, EVM.Stepper, EVM.StorageLayout, + EVM.Symbolic, + EVM.SymExec + EVM.Transaction, EVM.TTY, EVM.TTYCenteredList, EVM.Types, EVM.UnitTest, - EVM.VMTest, + EVM.VMTest + other-modules: Paths_hevm + autogen-modules: + Paths_hevm ghc-options: -Wall -Wno-deprecations extra-libraries: - secp256k1 + secp256k1, ff c-sources: - ethjet/ethjet.c, ethjet/tinykeccak.c + ethjet/tinykeccak.c, ethjet/ethjet.c + cxx-sources: + ethjet/ethjet-ff.cc, ethjet/blake2.cc + cxx-options: + -std=c++0x install-includes: - ethjet/ethjet.h, ethjet/tinykeccak.h + ethjet/tinykeccak.h, ethjet/ethjet.h, ethjet/ethjet-ff.h, ethjet/blake2.h build-depends: - QuickCheck >= 2.9, - abstract-par >= 0.3, - aeson >= 1.0, - ansi-wl-pprint >= 0.6, - base >= 4.9 && < 5, - base16-bytestring >= 0.1, - base64-bytestring >= 1.0, - binary >= 0.8, - brick >= 0.18, - bytestring >= 0.10, - cereal >= 0.5, - containers >= 0.5, - cryptonite >= 0.21, - data-dword >= 0.3, - deepseq >= 1.4, - directory >= 1.3, - filepath >= 1.4, - fgl >= 5.0, - ghci-pretty >= 0.0, - haskeline >= 0.7, - time >= 1.8, - transformers >= 0.5, - lens >= 4.15, - lens-aeson >= 1.0, - megaparsec >= 6.0, - memory >= 0.14, - monad-par >= 0.3, - mtl >= 2.2, - multiset >= 0.3, - operational >= 0.2, - optparse-generic >= 1.1, - process >= 1.4, - quickcheck-text >= 0.1, - readline >= 1.0, - restless-git >= 0.7, - rosezipper >= 0.2, - scientific >= 0.3, - s-cargot >= 0.1, - temporary >= 1.2, - text >= 1.2, - text-format >= 0.3, + QuickCheck >= 2.13.2 && < 2.14, + containers >= 0.6.0 && < 0.7, + deepseq >= 1.4.4 && < 1.5, + time >= 1.8.0 && < 1.9, + transformers >= 0.5.6 && < 0.6, tree-view == 0.5, - unordered-containers >= 0.2, - vector >= 0.11, - vty >= 5.15, - wreq >= 0.5 + abstract-par >= 0.3.3 && < 0.4, + aeson >= 1.4.6 && < 1.5, + bytestring >= 0.10.8 && < 0.11, + scientific >= 0.3.6 && < 0.4, + binary >= 0.8.6 && < 0.9, + text >= 1.2.3 && < 1.3, + unordered-containers >= 0.2.10 && < 0.3, + vector >= 0.12.1 && < 0.13, + ansi-wl-pprint >= 0.6.9 && < 0.7, + base16-bytestring >= 0.1.1 && < 0.2, + brick >= 0.47.1 && < 0.48, + megaparsec >= 7.0.5 && < 7.1, + mtl >= 2.2.2 && < 2.3, + directory >= 1.3.3 && < 1.4, + filepath >= 1.4.2 && < 1.5, + vty >= 5.25.1 && < 5.26, + cborg >= 0.2.2 && < 0.3, + cereal >= 0.5.8 && < 0.6, + cryptonite >= 0.25 && < 0.26, + memory >= 0.14.18 && < 0.15, + data-dword >= 0.3.1 && < 0.4, + fgl >= 5.7.0 && < 5.8, + free >= 5.1.3 && < 5.2, + haskeline >= 0.7.4 && < 0.8, + process >= 1.6.5 && < 1.7, + lens >= 4.17.1 && < 4.18, + lens-aeson >= 1.0.2 && < 1.1, + monad-par >= 0.3.5 && < 0.4, + multiset >= 0.3.4 && < 0.4, + operational >= 0.2.3 && < 0.3, + optparse-generic >= 1.3.1 && < 1.4, + quickcheck-text >= 0.1.2 && < 0.2, + restless-git >= 0.7 && < 0.8, + rosezipper >= 0.2 && < 0.3, + s-cargot >= 0.1.4 && < 0.2, + sbv >= 8.7.5 && < 8.8, + semver-range >= 0.2.7 && < 0.3, + temporary >= 1.3 && < 1.4, + text-format >= 0.3.2 && < 0.4, + witherable >= 0.3.5 && < 0.4, + wreq >= 0.5.3 && < 0.6, + regex-tdfa >= 1.2.3 && < 1.3, + base >= 4.9 && < 5 hs-source-dirs: src default-language: @@ -140,40 +156,44 @@ hevm-cli.hs ghc-options: -Wall -threaded -with-rtsopts=-N + other-modules: + Paths_hevm + if os(darwin) + ld-options: -Wl,-keep_dwarf_unwind build-depends: - QuickCheck >= 2.9, - aeson >= 1.0, - ansi-wl-pprint >= 0.6, - async == 2.*, - base >= 4.9 && < 5, - base16-bytestring >= 0.1, - base64-bytestring >= 1.0, - binary >= 0.8, - brick >= 0.18, - bytestring >= 0.10, - containers >= 0.5, - cryptonite >= 0.21, - data-dword >= 0.3, - deepseq >= 1.4, - directory >= 1.3, - filepath >= 1.4, - ghci-pretty >= 0.0, + QuickCheck, + aeson, + ansi-wl-pprint, + async, + base, + base16-bytestring, + binary, + brick, + bytestring, + containers, + cryptonite, + data-dword, + deepseq, + directory, + filepath, + free, hevm, - lens >= 4.15, - lens-aeson >= 1.0, - memory >= 0.14, - mtl >= 2.2, - optparse-generic >= 1.1, - process >= 1.4, - quickcheck-text >= 0.1, - readline >= 1.0, - regex-tdfa >= 1.2, - temporary >= 1.2, - text >= 1.2, - text-format >= 0.3, - unordered-containers >= 0.2, - vector >= 0.11, - vty >= 5.15 + lens, + lens-aeson, + memory, + mtl, + optparse-generic, + operational, + process, + quickcheck-text, + regex-tdfa, + sbv, + temporary, + text, + text-format, + unordered-containers, + vector, + vty test-suite test default-language: @@ -190,18 +210,20 @@ secp256k1 build-depends: HUnit >= 1.6, - QuickCheck >= 2.9, - base >= 4.9 && < 5, - base16-bytestring >= 0.1, - ghci-pretty >= 0.0.2, + QuickCheck, + base, + base16-bytestring, + binary, + containers, + bytestring, + free, + here, hevm, + lens, + mtl, tasty >= 1.0, tasty-hunit >= 0.10, tasty-quickcheck >= 0.9, - mtl >= 2.2, - lens >= 4.16, - text >= 1.2, - here >= 1.2, - bytestring >= 0.10, - vector >= 0.12, - binary >= 0.8 + text, + vector, + sbv diff --git a/run-blockchain-tests b/run-blockchain-tests new file mode 100644 --- /dev/null +++ b/run-blockchain-tests @@ -0,0 +1,136 @@ +#!/usr/bin/env bash +set -e + +# Invoke with hevm e.g. +# hevm compliance --tests ~/ethereum-tests --skip modexp --timeout 20 --html + +HEVM=${HEVM:-hevm} + +if [[ "$#" -lt 1 ]]; then + echo >&2 "usage: $(basename "$0") " + exit 1 +fi + +tests=$1 +html=$2 +match=$3 +skip=$4 +timeout=${5:-10} + +_html () { +cat <<. + +hevm test results + +
+

hevm consensus test report

+

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

+

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

+(Test suite: GeneralStateTests for Istanbul) +
+

Failed tests

+ + +$(echo $noncefailed) +$(echo $storagefailed) +$(echo $failed) +
+

Failed tests (due to balance only)

+ + +$(echo $balancefailed) +
+

Timeout tests

+ + +$(echo $timeouts) +
+

Skipped tests

+ + +$(echo $skipped) +
+

Passed tests

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

hevm consensus test report

-

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

-. - - wc -l <<<"$passed" - echo "passed, " - wc -l <<<"$failed" - echo "failed" - - cat <<. -

-(Test suite: VMTests for Homestead) +

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

+

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

+(Test suite: VMTests for ConstantinopleFix)

Failed tests

-. - echo "$failed" - cat <<. +$(echo $failed)
+

Skipped tests

+ + +$(echo $skipped) +

Passed tests

-. - echo "$passed" - cat <<. +$(echo $passed)
. +} + +{ + cd "$tests" + for x in VMTests/*/*; do + if [[ $x =~ .*$match.* ]] && [[ -n $skip && $x =~ .*$skip.* ]]; then + for job in $(<$x jq '.|keys[]' -r); do + echo "$x $job skip" + done + elif [[ $x =~ .*$match.* ]]; then + echo -n "$x " ; "$HEVM" vm-test --file $x --timeout $timeout 2>&1 + fi + done +} | { + while read path test outcome; do + echo >&2 "$path $test $outcome" + category=$(dirname "$path") + testcase=$(basename "${path%.json}") + row="$testcase$outcome$category" + row+=$'\n' + case $outcome in + ok) passed+=$row ;; + skip) skipped+=$row ;; + timeout) timouts+=row ;; + *) failed+=$row ;; + esac + done + + sum () { echo -ne "$1" | wc -l | awk '{print $1}'; } + + nfail=$(sum "$failed") + npass=$(sum "$passed") + nskip=$(sum "$skipped") + ntime=$(sum "$timeouts") + + echo >&2 "passed: $npass" + echo >&2 "failed: $nfail" + echo >&2 "timeout: $ntime" + echo >&2 "skipped: $nskip" + + if [[ $html == "True" ]]; then + _html + fi + + [[ $nfail -gt 0 ]] && exit 1 || exit 0 } diff --git a/src/EVM.hs b/src/EVM.hs --- a/src/EVM.hs +++ b/src/EVM.hs @@ -1,1719 +1,2609 @@ {-# Language ImplicitParams #-} {-# Language ConstraintKinds #-} {-# Language FlexibleInstances #-} -{-# Language GADTs #-} -{-# Language RecordWildCards #-} -{-# Language ScopedTypeVariables #-} -{-# Language StandaloneDeriving #-} -{-# Language StrictData #-} -{-# Language TemplateHaskell #-} -{-# Language TypeOperators #-} -{-# Language ViewPatterns #-} - -module EVM where - -import Prelude hiding ((^), log, Word, exponent) - -import EVM.ABI -import EVM.Types -import EVM.Solidity -import EVM.Keccak -import EVM.Concrete -import EVM.Op -import EVM.FeeSchedule (FeeSchedule (..)) - -import qualified EVM.Precompiled - -import Data.Binary.Get (runGetOrFail) -import Data.Bits (bit, testBit, complement) -import Data.Bits (xor, shiftR, (.&.), (.|.), FiniteBits (..)) -import Data.Text (Text) -import Data.Word (Word8, Word32) - -import Control.Lens hiding (op, (:<), (|>)) -import Control.Monad.State.Strict hiding (state) - -import Data.ByteString (ByteString) -import Data.ByteString.Lazy (fromStrict) -import Data.Map.Strict (Map) -import Data.Maybe (fromMaybe, isNothing) -import Data.Semigroup (Semigroup (..)) -import Data.Sequence (Seq) -import Data.Vector.Storable (Vector) -import Data.Foldable (toList) - -import Data.Tree - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as Char8 -import qualified Data.Map.Strict as Map -import qualified Data.Sequence as Seq -import qualified Data.Tree.Zipper as Zipper -import qualified Data.Vector.Storable as Vector -import qualified Data.Vector.Storable.Mutable as Vector - -import qualified Data.Vector as RegularVector - --- * Data types - -data Error - = BalanceTooLow Word Word - | UnrecognizedOpcode Word8 - | SelfDestruction - | StackUnderrun - | BadJumpDestination - | Revert ByteString - | NoSuchContract Addr - | OutOfGas Word Word - | BadCheatCode Word32 - | StackLimitExceeded - | IllegalOverflow - | Query Query - | PrecompiledContractError Int - | StateChangeWhileStatic - -deriving instance Show Error - --- | The possible result states of a VM -data VMResult - = VMFailure Error -- ^ An operation failed - | VMSuccess ByteString -- ^ Reached STOP, RETURN, or end-of-code - -deriving instance Show VMResult - --- | The state of a stepwise EVM execution -data VM = VM - { _result :: Maybe VMResult - , _state :: FrameState - , _frames :: [Frame] - , _env :: Env - , _block :: Block - , _tx :: TxState - , _logs :: Seq Log - , _traces :: Zipper.TreePos Zipper.Empty Trace - , _cache :: Cache - , _execMode :: ExecMode - , _burned :: Word - } - -data Trace = Trace - { _traceCodehash :: W256 - , _traceOpIx :: Int - , _traceData :: TraceData - } - -data TraceData - = EventTrace Log - | FrameTrace FrameContext - | QueryTrace Query - | ErrorTrace Error - | EntryTrace Text - | ReturnTrace ByteString FrameContext - -data ExecMode = ExecuteNormally | ExecuteAsVMTest - -data Query where - PleaseFetchContract :: Addr -> (Contract -> EVM ()) -> Query - PleaseFetchSlot :: Addr -> Word -> (Word -> EVM ()) -> Query - -instance Show Query where - showsPrec _ = \case - PleaseFetchContract addr _ -> - (("") ++) - PleaseFetchSlot addr slot _ -> - (("") ++) - --- | Alias for the type of e.g. @exec1@. -type EVM a = State VM a - --- | The cache is data that can be persisted for efficiency: --- any expensive query that is constant at least within a block. -data Cache = Cache - { _fetched :: Map Addr Contract - } - --- | A way to specify an initial VM state -data VMOpts = VMOpts - { vmoptCode :: ByteString - , vmoptCalldata :: ByteString - , vmoptValue :: W256 - , vmoptAddress :: Addr - , vmoptCaller :: Addr - , vmoptOrigin :: Addr - , vmoptGas :: W256 - , vmoptNumber :: W256 - , vmoptTimestamp :: W256 - , vmoptCoinbase :: Addr - , vmoptDifficulty :: W256 - , vmoptGaslimit :: W256 - , vmoptGasprice :: W256 - , vmoptSchedule :: FeeSchedule Word - } deriving Show - --- | A log entry -data Log = Log Addr ByteString [Word] - --- | An entry in the VM's "call/create stack" -data Frame = Frame - { _frameContext :: FrameContext - , _frameState :: FrameState - } - --- | Call/create info -data FrameContext - = CreationContext - { creationContextCodehash :: W256 } - | CallContext - { callContextOffset :: Word - , callContextSize :: Word - , callContextCodehash :: W256 - , callContextAbi :: Maybe Word - , callContextData :: ByteString - , callContextReversion :: Map Addr Contract - } - --- | The "registers" of the VM along with memory and data stack -data FrameState = FrameState - { _contract :: Addr - , _codeContract :: Addr - , _code :: ByteString - , _pc :: Int - , _stack :: [Word] - , _memory :: ByteString - , _memorySize :: Int - , _calldata :: ByteString - , _callvalue :: Word - , _caller :: Addr - , _gas :: Word - , _returndata :: ByteString - , _static :: Bool - } - --- | The state that spans a whole transaction -data TxState = TxState - { _selfdestructs :: [Addr] - , _refunds :: [(Addr, Word)] - } - --- | The state of a contract -data Contract = Contract - { _bytecode :: ByteString - , _storage :: Map Word Word - , _balance :: Word - , _nonce :: Word - , _codehash :: W256 - , _codesize :: Int -- (redundant?) - , _opIxMap :: Vector Int - , _codeOps :: RegularVector.Vector (Int, Op) - , _external :: Bool - } - -deriving instance Show Contract -deriving instance Eq Contract - --- | Various environmental data -data Env = Env - { _contracts :: Map Addr Contract - , _sha3Crack :: Map Word ByteString - , _origin :: Addr - } - - --- | Data about the block -data Block = Block - { _coinbase :: Addr - , _timestamp :: Word - , _number :: Word - , _difficulty :: Word - , _gaslimit :: Word - , _gasprice :: Word - , _schedule :: FeeSchedule Word - } - -blankState :: FrameState -blankState = FrameState - { _contract = 0 - , _codeContract = 0 - , _code = mempty - , _pc = 0 - , _stack = mempty - , _memory = mempty - , _memorySize = 0 - , _calldata = mempty - , _callvalue = 0 - , _caller = 0 - , _gas = 0 - , _returndata = mempty - , _static = False - } - -makeLenses ''FrameState -makeLenses ''Frame -makeLenses ''Block -makeLenses ''TxState -makeLenses ''Contract -makeLenses ''Env -makeLenses ''Cache -makeLenses ''Trace -makeLenses ''VM - -instance Semigroup Cache where - a <> b = Cache - { _fetched = mappend (view fetched a) (view fetched b) } - -instance Monoid Cache where - mempty = Cache { _fetched = mempty } - --- * Data accessors - -currentContract :: VM -> Maybe Contract -currentContract vm = - view (env . contracts . at (view (state . codeContract) vm)) vm - --- * Data constructors - -makeVm :: VMOpts -> VM -makeVm o = VM - { _result = Nothing - , _frames = mempty - , _tx = TxState - { _selfdestructs = mempty - , _refunds = mempty - } - , _logs = mempty - , _traces = Zipper.fromForest [] - , _block = Block - { _coinbase = vmoptCoinbase o - , _timestamp = w256 $ vmoptTimestamp o - , _number = w256 $ vmoptNumber o - , _difficulty = w256 $ vmoptDifficulty o - , _gaslimit = w256 $ vmoptGaslimit o - , _gasprice = w256 $ vmoptGasprice o - , _schedule = vmoptSchedule o - } - , _state = FrameState - { _pc = 0 - , _stack = mempty - , _memory = mempty - , _memorySize = 0 - , _code = vmoptCode o - , _contract = vmoptAddress o - , _codeContract = vmoptAddress o - , _calldata = vmoptCalldata o - , _callvalue = w256 $ vmoptValue o - , _caller = vmoptCaller o - , _gas = w256 $ vmoptGas o - , _returndata = mempty - , _static = False - } - , _env = Env - { _sha3Crack = mempty - , _origin = vmoptOrigin o - , _contracts = Map.fromList - [(vmoptAddress o, initialContract (vmoptCode o))] - } - , _cache = mempty - , _execMode = ExecuteNormally - , _burned = 0 - } - -initialContract :: ByteString -> Contract -initialContract theCode = Contract - { _bytecode = theCode - , _codesize = BS.length theCode - , _codehash = - if BS.null theCode then 0 else - keccak (stripBytecodeMetadata theCode) - , _storage = mempty - , _balance = 0 - , _nonce = 0 - , _opIxMap = mkOpIxMap theCode - , _codeOps = mkCodeOps theCode - , _external = False - } - --- * Opcode dispatch (exec1) - -next :: (?op :: Word8) => EVM () -next = modifying (state . pc) (+ (opSize ?op)) - -exec1 :: EVM () -exec1 = do - vm <- get - - let - -- Convenience function to access parts of the current VM state. - -- Arcane type signature needed to avoid monomorphism restriction. - the :: (b -> VM -> Const a VM) -> ((a -> Const a a) -> b) -> a - the f g = view (f . g) vm - - -- Convenient aliases - mem = the state memory - stk = the state stack - self = the state contract - this = fromMaybe (error "internal error: state contract") (preview (ix (the state contract)) (the env contracts)) - - fees@(FeeSchedule {..}) = the block schedule - - doStop = finishFrame (FrameReturned "") - - if the state pc >= num (BS.length (the state code)) - then - doStop - - else do - let ?op = BS.index (the state code) (the state pc) - - case ?op of - - -- op: PUSH - x | x >= 0x60 && x <= 0x7f -> do - let !n = num x - 0x60 + 1 - !xs = BS.take n (BS.drop (1 + the state pc) - (the state code)) - limitStack 1 $ - burn g_verylow $ do - next - push (w256 (word xs)) - - -- op: DUP - x | x >= 0x80 && x <= 0x8f -> do - let !i = x - 0x80 + 1 - case preview (ix (num i - 1)) stk of - Nothing -> underrun - Just y -> do - limitStack 1 $ - burn g_verylow $ do - next - push y - - -- op: SWAP - x | x >= 0x90 && x <= 0x9f -> do - let i = num (x - 0x90 + 1) - if length stk < i + 1 - then underrun - else - burn g_verylow $ do - next - zoom (state . stack) $ do - assign (ix 0) (stk ^?! ix i) - assign (ix i) (stk ^?! ix 0) - - -- op: LOG - x | x >= 0xa0 && x <= 0xa4 -> - notStatic $ - let n = (num x - 0xa0) in - case stk of - (xOffset:xSize:xs) -> - if length xs < n - then underrun - else do - let (topics, xs') = splitAt n xs - bytes = readMemory (num xOffset) (num xSize) vm - log = Log self bytes topics - - burn (g_log + g_logdata * xSize + num n * g_logtopic) $ do - accessMemoryRange fees xOffset xSize $ do - traceLog log - next - assign (state . stack) xs' - pushToSequence logs log - _ -> - underrun - - -- op: STOP - 0x00 -> doStop - - -- op: ADD - 0x01 -> stackOp2 (const g_verylow) (uncurry (+)) - -- op: MUL - 0x02 -> stackOp2 (const g_low) (uncurry (*)) - -- op: SUB - 0x03 -> stackOp2 (const g_verylow) (uncurry (-)) - - -- op: DIV - 0x04 -> stackOp2 (const g_low) $ - \case (_, 0) -> 0 - (x, y) -> div x y - - -- op: SDIV - 0x05 -> - stackOp2 (const g_low) (uncurry (sdiv)) - - -- op: MOD - 0x06 -> stackOp2 (const g_low) $ \case - (_, 0) -> 0 - (x, y) -> mod x y - - -- op: SMOD - 0x07 -> stackOp2 (const g_low) $ uncurry smod - -- op: ADDMOD - 0x08 -> stackOp3 (const g_mid) $ (\(x, y, z) -> addmod x y z) - -- op: MULMOD - 0x09 -> stackOp3 (const g_mid) $ (\(x, y, z) -> mulmod x y z) - - -- op: LT - 0x10 -> stackOp2 (const g_verylow) $ \(x, y) -> if x < y then 1 else 0 - -- op: GT - 0x11 -> stackOp2 (const g_verylow) $ \(x, y) -> if x > y then 1 else 0 - -- op: SLT - 0x12 -> stackOp2 (const g_verylow) $ uncurry slt - -- op: SGT - 0x13 -> stackOp2 (const g_verylow) $ uncurry sgt - - -- op: EQ - 0x14 -> stackOp2 (const g_verylow) $ \(x, y) -> if x == y then 1 else 0 - -- op: ISZERO - 0x15 -> stackOp1 (const g_verylow) $ \case 0 -> 1; _ -> 0 - - -- op: AND - 0x16 -> stackOp2 (const g_verylow) $ uncurry (.&.) - -- op: OR - 0x17 -> stackOp2 (const g_verylow) $ uncurry (.|.) - -- op: XOR - 0x18 -> stackOp2 (const g_verylow) $ uncurry xor - -- op: NOT - 0x19 -> stackOp1 (const g_verylow) complement - - -- op: BYTE - 0x1a -> stackOp2 (const g_verylow) $ \case - (n, _) | n >= 32 -> - 0 - (n, x) -> - 0xff .&. shiftR x (8 * (31 - num n)) - - -- op: SHA3 - 0x20 -> - case stk of - ((num -> xOffset) : (num -> xSize) : xs) -> do - let bytes = readMemory xOffset xSize vm - hash = keccakBlob bytes - burn (g_sha3 + g_sha3word * ceilDiv (num xSize) 32) $ - accessMemoryRange fees xOffset xSize $ do - next - assign (state . stack) (hash : xs) - assign (env . sha3Crack . at hash) (Just bytes) - _ -> underrun - - -- op: ADDRESS - 0x30 -> - limitStack 1 $ - burn g_base (next >> push (num (the state contract))) - - -- op: BALANCE - 0x31 -> - case stk of - (x:xs) -> do - burn g_balance $ do - touchAccount (num x) $ \c -> do - next - assign (state . stack) xs - push (view balance c) - [] -> - underrun - - -- op: ORIGIN - 0x32 -> - limitStack 1 . burn g_base $ - next >> push (num (the env origin)) - - -- op: CALLER - 0x33 -> - limitStack 1 . burn g_base $ - next >> push (num (the state caller)) - - -- op: CALLVALUE - 0x34 -> - limitStack 1 . burn g_base $ - next >> push (the state callvalue) - - -- op: CALLDATALOAD - 0x35 -> stackOp1 (const g_verylow) $ - \x -> readBlobWord x (the state calldata) - - -- op: CALLDATASIZE - 0x36 -> - limitStack 1 . burn g_base $ - next >> push (blobSize (the state calldata)) - - -- op: CALLDATACOPY - 0x37 -> - case stk of - ((num -> xTo) : (num -> xFrom) : (num -> xSize) :xs) -> do - burn (g_verylow + g_copy * ceilDiv xSize 32) $ do - accessMemoryRange fees xTo xSize $ do - next - assign (state . stack) xs - copyBytesToMemory (the state calldata) xSize xFrom xTo - _ -> underrun - - -- op: CODESIZE - 0x38 -> - limitStack 1 . burn g_base $ - next >> push (num (BS.length (the state code))) - - -- op: CODECOPY - 0x39 -> - case stk of - ((num -> memOffset) : (num -> codeOffset) : (num -> n) : xs) -> do - burn (g_verylow + g_copy * ceilDiv (num n) 32) $ do - accessMemoryRange fees memOffset n $ do - next - assign (state . stack) xs - copyBytesToMemory (view bytecode this) - n codeOffset memOffset - _ -> underrun - - -- op: GASPRICE - 0x3a -> - limitStack 1 . burn g_base $ - next >> push (the block gasprice) - - -- op: EXTCODESIZE - 0x3b -> - case stk of - (x:xs) -> do - if x == num cheatCode - then do - next - assign (state . stack) xs - push (w256 1) - else - burn g_extcode $ do - touchAccount (num x) $ \c -> do - next - assign (state . stack) xs - push (num (view codesize c)) - [] -> - underrun - - -- op: EXTCODECOPY - 0x3c -> - case stk of - ( extAccount - : (num -> memOffset) - : (num -> codeOffset) - : (num -> codeSize) - : xs ) -> do - burn (g_extcode + g_copy * ceilDiv (num codeSize) 32) $ - accessMemoryRange fees memOffset codeSize $ do - touchAccount (num extAccount) $ \c -> do - next - assign (state . stack) xs - copyBytesToMemory (view bytecode c) - codeSize codeOffset memOffset - _ -> underrun - - -- op: RETURNDATASIZE - 0x3d -> - limitStack 1 . burn g_base $ - next >> push (blobSize (the state returndata)) - - -- op: RETURNDATACOPY - 0x3e -> - case stk of - ((num -> xTo) : (num -> xFrom) : (num -> xSize) :xs) -> do - burn (g_verylow + g_copy * ceilDiv xSize 32) $ do - accessMemoryRange fees xTo xSize $ do - next - assign (state . stack) xs - copyBytesToMemory (the state returndata) xSize xFrom xTo - _ -> underrun - - -- op: BLOCKHASH - 0x40 -> do - -- We adopt the fake block hash scheme of the VMTests, - -- so that blockhash(i) is the hash of i as decimal ASCII. - stackOp1 (const g_blockhash) $ - \i -> - if i + 256 < the block number || i >= the block number - then 0 - else - (num i :: Integer) - & show & Char8.pack & keccak & num - - -- op: COINBASE - 0x41 -> - limitStack 1 . burn g_base $ - next >> push (num (the block coinbase)) - - -- op: TIMESTAMP - 0x42 -> - limitStack 1 . burn g_base $ - next >> push (the block timestamp) - - -- op: NUMBER - 0x43 -> - limitStack 1 . burn g_base $ - next >> push (the block number) - - -- op: DIFFICULTY - 0x44 -> - limitStack 1 . burn g_base $ - next >> push (the block difficulty) - - -- op: GASLIMIT - 0x45 -> - limitStack 1 . burn g_base $ - next >> push (the block gaslimit) - - -- op: POP - 0x50 -> - case stk of - (_:xs) -> burn g_base (next >> assign (state . stack) xs) - _ -> underrun - - -- op: MLOAD - 0x51 -> - case stk of - (x:xs) -> do - burn g_verylow $ - accessMemoryWord fees x $ do - next - assign (state . stack) (view (word256At (num x)) mem : xs) - _ -> underrun - - -- op: MSTORE - 0x52 -> - case stk of - (x:y:xs) -> do - burn g_verylow $ - accessMemoryWord fees x $ do - next - assign (state . memory . word256At (num x)) y - assign (state . stack) xs - _ -> underrun - - -- op: MSTORE8 - 0x53 -> - case stk of - (x:y:xs) -> do - burn g_verylow $ - accessMemoryRange fees x 1 $ do - next - modifying (state . memory) (setMemoryByte x (wordToByte y)) - assign (state . stack) xs - _ -> underrun - - -- op: SLOAD - 0x54 -> - case stk of - (x:xs) -> - burn g_sload $ - accessStorage self x $ \y -> do - next - assign (state . stack) (y:xs) - _ -> underrun - - -- op: SSTORE - 0x55 -> - notStatic $ - case stk of - (x:new:xs) -> do - accessStorage self x $ \old -> do - -- Gas cost is higher when changing from zero to nonzero. - let cost = if old == 0 && new /= 0 then g_sset else g_sreset - - burn cost $ do - next - assign (state . stack) xs - assign (env . contracts . ix (the state contract) . storage . at x) - (Just new) - - -- Give gas refund if clearing the storage slot. - if old /= 0 && new == 0 then refund r_sclear else noop - - _ -> underrun - - -- op: JUMP - 0x56 -> - case stk of - (x:xs) -> do - burn g_mid $ do - checkJump x xs - _ -> underrun - - -- op: JUMPI - 0x57 -> do - case stk of - (x:y:xs) -> do - burn g_high $ do - if y == 0 - then assign (state . stack) xs >> next - else checkJump x xs - _ -> underrun - - -- op: PC - 0x58 -> - limitStack 1 . burn g_base $ - next >> push (num (the state pc)) - - -- op: MSIZE - 0x59 -> - limitStack 1 . burn g_base $ - next >> push (num (the state memorySize)) - - -- op: GAS - 0x5a -> - limitStack 1 . burn g_base $ - next >> push (the state gas - g_base) - - -- op: JUMPDEST - 0x5b -> burn g_jumpdest next - - -- op: EXP - 0x0a -> - let cost (_, exponent) = - if exponent == 0 - then g_exp - else g_exp + g_expbyte * num (ceilDiv (1 + log2 exponent) 8) - in stackOp2 cost (uncurry exponentiate) - - -- op: SIGNEXTEND - 0x0b -> - stackOp2 (const g_low) $ \(bytes, x) -> - if bytes >= 32 then x - else let n = num bytes * 8 + 7 in - if testBit x n - then x .|. complement (bit n - 1) - else x .&. (bit n - 1) - - -- op: CREATE - 0xf0 -> - notStatic $ - case stk of - (xValue:xOffset:xSize:xs) -> - burn g_create $ do - accessMemoryRange fees xOffset xSize $ do - if xValue > view balance this - then do - assign (state . stack) (0 : xs) - next - else do - let - newAddr = - newContractAddress self (wordValue (view nonce this)) - case view execMode vm of - ExecuteAsVMTest -> do - assign (state . stack) (num newAddr : xs) - next - - ExecuteNormally -> do - let - newCode = - readMemory (num xOffset) (num xSize) vm - newContract = - initialContract newCode - newContext = - CreationContext (view codehash newContract) - - zoom (env . contracts) $ do - assign (at newAddr) (Just newContract) - assign (ix newAddr . balance) xValue - modifying (ix self . balance) (flip (-) xValue) - modifying (ix self . nonce) succ - - pushTrace (FrameTrace newContext) - next - vm' <- get - pushTo frames $ Frame - { _frameContext = newContext - , _frameState = (set stack xs) (view state vm') - } - - assign state $ - blankState - & set contract newAddr - & set codeContract newAddr - & set code newCode - & set callvalue xValue - & set caller self - & set gas (view (state . gas) vm') - - _ -> underrun - - -- op: CALL - 0xf1 -> - case stk of - ( xGas - : (num -> xTo) - : xValue - : xInOffset - : xInSize - : xOutOffset - : xOutSize - : xs - ) -> - case xTo of - n | n > 0 && n <= 8 -> precompiledContract - n | num n == cheatCode -> - do - assign (state . stack) xs - cheat (xInOffset, xInSize) (xOutOffset, xOutSize) - _ -> - let - availableGas = the state gas - recipient = view (env . contracts . at xTo) vm - (cost, gas') = costOfCall fees recipient xValue availableGas xGas - in burn (cost - gas') $ - (if xValue > 0 then notStatic else id) $ - if xValue > view balance this - then do - assign (state . stack) (0 : xs) - next - else - case view execMode vm of - ExecuteAsVMTest -> do - assign (state . stack) (1 : xs) - next - ExecuteNormally -> do - delegateCall fees gas' xTo xInOffset xInSize xOutOffset xOutSize xs $ do - zoom state $ do - assign callvalue xValue - assign caller (the state contract) - assign contract xTo - assign memorySize 0 - zoom (env . contracts) $ do - ix self . balance -= xValue - ix xTo . balance += xValue - _ -> - underrun - - -- op: CALLCODE - 0xf2 -> - error "CALLCODE not supported (use DELEGATECALL)" - - -- op: RETURN - 0xf3 -> - case stk of - (xOffset:xSize:_) -> - accessMemoryRange fees xOffset xSize $ do - let output = readMemory (num xOffset) (num xSize) vm - finishFrame (FrameReturned output) - _ -> underrun - - -- op: DELEGATECALL - 0xf4 -> - case stk of - (xGas:xTo:xInOffset:xInSize:xOutOffset:xOutSize:xs) -> - if num xTo == cheatCode - then do - assign (state . stack) xs - cheat (xInOffset, xInSize) (xOutOffset, xOutSize) - else - burn (num g_call) $ do - delegateCall fees xGas (num xTo) xInOffset xInSize xOutOffset xOutSize xs - (return ()) - _ -> underrun - - -- op: STATICCALL - 0xfa -> - case stk of - (xGas : (num -> xTo) : xInOffset : xInSize : xOutOffset : xOutSize : xs) -> - case xTo of - n | n > 0 && n <= 8 -> precompiledContract - _ -> - let - availableGas = the state gas - recipient = view (env . contracts . at xTo) vm - (cost, gas') = costOfCall fees recipient 0 availableGas xGas - in burn (cost - gas') $ - case view execMode vm of - ExecuteAsVMTest -> do - assign (state . stack) (1 : xs) - next - ExecuteNormally -> do - delegateCall fees gas' xTo xInOffset xInSize xOutOffset xOutSize xs $ do - zoom state $ do - assign callvalue 0 - assign caller (the state contract) - assign contract xTo - assign memorySize 0 - assign static True - _ -> - underrun - - -- op: SELFDESTRUCT - 0xff -> - notStatic $ - case stk of - [] -> underrun - (x:_) -> do - touchAccount (num x) $ \_ -> do - pushTo (tx . selfdestructs) self - assign (env . contracts . ix self . balance) 0 - modifying - (env . contracts . ix (num x) . balance) - (+ (vm ^?! env . contracts . ix self . balance)) - doStop - - -- op: REVERT - 0xfd -> - case stk of - (xOffset:xSize:_) -> - accessMemoryRange fees xOffset xSize $ do - let output = readMemory (num xOffset) (num xSize) vm - finishFrame (FrameReverted output) - _ -> underrun - - xxx -> - vmError (UnrecognizedOpcode xxx) - -precompiledContract :: (?op :: Word8) => EVM () -precompiledContract = do - vm <- get - fees <- use (block . schedule) - stk <- use (state . stack) - - case (?op, stk) of - -- CALL (includes value) - (0xf1, (_:(num -> op):_:inOffset:inSize:outOffset:outSize:xs)) -> - doIt vm fees op inOffset inSize outOffset outSize xs - -- STATICCALL (does not include value) - (0xfa, (_:(num -> op):inOffset:inSize:outOffset:outSize:xs)) -> - doIt vm fees op inOffset inSize outOffset outSize xs - _ -> - underrun - - where - doIt vm fees op inOffset inSize outOffset outSize xs = - let - input = readMemory (num inOffset) (num inSize) vm - in - case EVM.Precompiled.execute op input (num outSize) of - Nothing -> do - assign (state . stack) (0 : xs) - vmError (PrecompiledContractError op) - Just output -> do - let - cost = - case op of - 1 -> 3000 - _ -> error ("unimplemented precompiled contract " ++ show op) - accessMemoryRange fees inOffset inSize $ - accessMemoryRange fees outOffset outSize $ - burn cost $ do - assign (state . stack) (1 : xs) - modifying (state . memory) - (writeMemory output outSize 0 outOffset) - next - --- * Opcode helper actions - -noop :: Monad m => m () -noop = pure () - -pushTo :: MonadState s m => ASetter s s [a] [a] -> a -> m () -pushTo f x = f %= (x :) - -pushToSequence :: MonadState s m => ASetter s s (Seq a) (Seq a) -> a -> m () -pushToSequence f x = f %= (Seq.|> x) - -touchAccount :: Addr -> (Contract -> EVM ()) -> EVM () -touchAccount addr continue = do - use (env . contracts . at addr) >>= \case - Just c -> continue c - Nothing -> - use (cache . fetched . at addr) >>= \case - Just c -> do - assign (env . contracts . at addr) (Just c) - continue c - Nothing -> - assign result . Just . VMFailure . Query $ - PleaseFetchContract addr - (\c -> do assign (cache . fetched . at addr) (Just c) - assign (env . contracts . at addr) (Just c) - assign result Nothing - continue c) - -accessStorage - :: Addr -- ^ Contract address - -> Word -- ^ Storage slot key - -> (Word -> EVM ()) -- ^ Continuation - -> EVM () -accessStorage addr slot continue = - use (env . contracts . at addr) >>= \case - Just c -> - case view (storage . at slot) c of - Just value -> - continue value - Nothing -> - if view external c - then - assign result . Just . VMFailure . Query $ - PleaseFetchSlot addr slot - (\x -> do - assign (cache . fetched . ix addr . storage . at slot) (Just x) - assign (env . contracts . ix addr . storage . at slot) (Just x) - assign result Nothing - continue x) - else do - assign (env . contracts . ix addr . storage . at slot) (Just 0) - continue 0 - Nothing -> - touchAccount addr $ \_ -> - accessStorage addr slot continue - --- | Replace a contract's code, like when CREATE returns --- from the constructor code. -replaceCode :: Addr -> ByteString -> EVM () -replaceCode target newCode = do - zoom (env . contracts . at target) $ do - if BS.null newCode - then put Nothing - else do - Just now <- get - put . Just $ - initialContract newCode - & set storage (view storage now) - & set balance (view balance now) - & set nonce (view nonce now) - -replaceCodeOfSelf :: ByteString -> EVM () -replaceCodeOfSelf newCode = do - vm <- get - replaceCode (view (state . contract) vm) newCode - -resetState :: EVM () -resetState = do - assign result Nothing - assign frames [] - assign state blankState - -finalize :: EVM () -finalize = do - destroyedAddresses <- use (tx . selfdestructs) - modifying (env . contracts) - (Map.filterWithKey (\k _ -> not (elem k destroyedAddresses))) - -loadContract :: Addr -> EVM () -loadContract target = - preuse (env . contracts . ix target . bytecode) >>= - \case - Nothing -> - error "Call target doesn't exist" - Just targetCode -> do - assign (state . contract) target - assign (state . code) targetCode - assign (state . codeContract) target - -limitStack :: Int -> EVM () -> EVM () -limitStack n continue = do - stk <- use (state . stack) - if length stk + n > 1024 - then vmError StackLimitExceeded - else continue - -notStatic :: EVM () -> EVM () -notStatic continue = do - bad <- use (state . static) - if bad - then vmError StateChangeWhileStatic - else continue - -burn :: Word -> EVM () -> EVM () -burn n continue = do - available <- use (state . gas) - if n <= available - then do - state . gas -= n - burned += n - continue - else - vmError (OutOfGas available n) - -refund :: Word -> EVM () -refund n = do - self <- use (state . contract) - pushTo (tx . refunds) (self, n) - - --- * Cheat codes - --- The cheat code is 7109709ecfa91a80626ff3989d68f67f5b1dd12d. --- Call this address using one of the cheatActions below to do --- special things, e.g. changing the block timestamp. Beware that --- these are necessarily hevm specific. -cheatCode :: Addr -cheatCode = num (keccak "hevm cheat code") - -cheat - :: (?op :: Word8) - => (Word, Word) -> (Word, Word) - -> EVM () -cheat (inOffset, inSize) (outOffset, outSize) = do - mem <- use (state . memory) - let - abi = - num (wordValue (readMemoryWord32 inOffset mem)) - input = - sliceMemory (inOffset + 4) (inSize - 4) mem - case Map.lookup abi cheatActions of - Nothing -> - vmError (BadCheatCode abi) - Just (argTypes, action) -> do - case runGetOrFail - (getAbiSeq (length argTypes) argTypes) - (fromStrict input) of - Right ("", _, args) -> do - action (toList args) >>= \case - Nothing -> do - next - push 1 - Just (encodeAbiValue -> bs) -> do - next - modifying (state . memory) - (writeMemory bs outSize 0 outOffset) - push 1 - Left _ -> - vmError (BadCheatCode abi) - Right _ -> - vmError (BadCheatCode abi) - -type CheatAction = ([AbiType], [AbiValue] -> EVM (Maybe AbiValue)) - -cheatActions :: Map Word32 CheatAction -cheatActions = - Map.fromList - [ action "warp(uint256)" [AbiUIntType 256] $ - \[AbiUInt 256 x] -> do - assign (block . timestamp) (w256 (W256 x)) - return Nothing - ] - where - action s ts f = (abiKeccak s, (ts, f)) - - --- * General call implementation ("delegateCall") - -delegateCall - :: (?op :: Word8) - => FeeSchedule Word - -> Word -> Addr -> Word -> Word -> Word -> Word -> [Word] - -> EVM () - -> EVM () -delegateCall fees xGas xTo xInOffset xInSize xOutOffset xOutSize xs continue = - touchAccount xTo . const $ - preuse (env . contracts . ix xTo) >>= - \case - Nothing -> vmError (NoSuchContract xTo) - Just target -> - accessMemoryRange fees xInOffset xInSize $ do - accessMemoryRange fees xOutOffset xOutSize $ do - burn xGas $ do - vm0 <- get - - let newContext = CallContext - { callContextOffset = xOutOffset - , callContextSize = xOutSize - , callContextCodehash = view codehash target - , callContextReversion = view (env . contracts) vm0 - , callContextAbi = - if xInSize >= 4 - then - let - w = wordValue - (readMemoryWord32 xInOffset (view (state . memory) vm0)) - in Just $! num w - else Nothing - , callContextData = (readMemory (num xInOffset) (num xInSize) vm0) - } - - pushTrace (FrameTrace newContext) - next - vm1 <- get - - pushTo frames $ Frame - { _frameState = (set stack xs) (view state vm1) - , _frameContext = newContext - } - - zoom state $ do - assign gas xGas - assign pc 0 - assign code (view bytecode target) - assign codeContract xTo - assign stack mempty - assign memory mempty - assign calldata (readMemory (num xInOffset) (num xInSize) vm0) - - continue - - --- * VM error implementation - -underrun :: EVM () -underrun = vmError StackUnderrun - --- | A stack frame can be popped in three ways. -data FrameResult - = FrameReturned ByteString -- ^ STOP, RETURN, or no more code - | FrameReverted ByteString -- ^ REVERT - | FrameErrored Error -- ^ Any other error - deriving Show - --- | This function defines how to pop the current stack frame in either of --- the ways specified by 'FrameResult'. --- --- It also handles the case when the current stack frame is the only one; --- in this case, we set the final '_result' of the VM execution. -finishFrame :: FrameResult -> EVM () -finishFrame how = do - oldVm <- get - - case view frames oldVm of - -- Is the current frame the only one? - [] -> - assign result . Just $ - case how of - FrameReturned output -> VMSuccess output - FrameReverted output -> VMFailure (Revert output) - FrameErrored e -> VMFailure e - - -- Are there some remaining frames? - nextFrame : remainingFrames -> do - - -- Pop the top frame. - assign frames remainingFrames - -- Install the state of the frame to which we shall return. - assign state (view frameState nextFrame) - -- Insert a debug trace. - insertTrace $ - case how of - FrameErrored e -> - ErrorTrace e - FrameReverted output -> - ErrorTrace (Revert output) - FrameReturned output -> - ReturnTrace output (view frameContext nextFrame) - -- Pop to the previous level of the debug trace stack. - popTrace - - let remainingGas = view (state . gas) oldVm - - -- Now dispatch on whether we were creating or calling, - -- and whether we shall return, revert, or error (six cases). - case view frameContext nextFrame of - - -- Were we calling? - CallContext (num -> outOffset) (num -> outSize) _ _ _ reversion -> do - - let - -- When entering a call, the gas allowance is counted as burned - -- in advance; this unburns the remainder and adds it to the - -- parent frame. - reclaimRemainingGasAllowance = do - modifying burned (subtract remainingGas) - modifying (state . gas) (+ remainingGas) - - revertContracts = assign (env . contracts) reversion - - case how of - -- Case 1: Returning from a call? - FrameReturned output -> do - assign (state . returndata) output - copyBytesToMemory output outSize 0 outOffset - reclaimRemainingGasAllowance - push 1 - - -- Case 2: Reverting during a call? - FrameReverted output -> do - revertContracts - assign (state . returndata) output - reclaimRemainingGasAllowance - push 0 - - -- Case 3: Error during a call? - FrameErrored _ -> do - revertContracts - push 0 - - -- Or were we creating? - CreationContext _ -> do - let - createe = view (state . contract) oldVm - destroy = assign (env . contracts . at createe) Nothing - - case how of - -- Case 4: Returning during a creation? - FrameReturned output -> do - replaceCode createe output - assign (state . gas) remainingGas - push (num createe) - - -- Case 5: Reverting during a creation? - FrameReverted output -> do - destroy - assign (state . returndata) output - assign (state . gas) remainingGas - push 0 - - -- Case 6: Error during a creation? - FrameErrored _ -> do - destroy - assign (state . gas) 0 - push 0 - - -vmError :: Error -> EVM () -vmError e = finishFrame (FrameErrored e) - --- * Memory helpers - -accessMemoryRange - :: FeeSchedule Word - -> Word - -> Word - -> EVM () - -> EVM () -accessMemoryRange _ _ 0 continue = continue -accessMemoryRange fees f l continue = do - m0 <- num <$> use (state . memorySize) - if f + l < l - then vmError IllegalOverflow - else do - let m1 = 32 * ceilDiv (max m0 (f + l)) 32 - burn (memoryCost fees m1 - memoryCost fees m0) $ do - assign (state . memorySize) (num m1) - continue - -accessMemoryWord - :: FeeSchedule Word -> Word -> EVM () -> EVM () -accessMemoryWord fees x continue = accessMemoryRange fees x 32 continue - -copyBytesToMemory - :: ByteString -> Word -> Word -> Word -> EVM () -copyBytesToMemory bs size xOffset yOffset = - if size == 0 then noop - else do - mem <- use (state . memory) - assign (state . memory) $ - writeMemory bs size xOffset yOffset mem - -readMemory :: Word -> Word -> VM -> ByteString -readMemory offset size vm = sliceMemory offset size (view (state . memory) vm) - -word256At - :: Functor f - => Word -> (Word -> f Word) - -> ByteString -> f ByteString -word256At i = lens getter setter where - getter m = readMemoryWord i m - setter m x = setMemoryWord i x m - --- * Tracing - -withTraceLocation - :: (MonadState VM m) => TraceData -> m Trace -withTraceLocation x = do - vm <- get - let - Just this = - preview (env . contracts . ix (view (state . codeContract) vm)) vm - pure Trace - { _traceData = x - , _traceCodehash = view codehash this - , _traceOpIx = (view opIxMap this) Vector.! (view (state . pc) vm) - } - -pushTrace :: TraceData -> EVM () -pushTrace x = do - trace <- withTraceLocation x - modifying traces $ - \t -> Zipper.children $ Zipper.insert (Node trace []) t - -insertTrace :: TraceData -> EVM () -insertTrace x = do - trace <- withTraceLocation x - modifying traces $ - \t -> Zipper.nextSpace $ Zipper.insert (Node trace []) t - -popTrace :: EVM () -popTrace = - modifying traces $ - \t -> case Zipper.parent t of - Nothing -> error "internal error (trace root)" - Just t' -> Zipper.nextSpace t' - -zipperRootForest :: Zipper.TreePos Zipper.Empty a -> Forest a -zipperRootForest z = - case Zipper.parent z of - Nothing -> Zipper.toForest z - Just z' -> zipperRootForest (Zipper.nextSpace z') - -traceForest :: VM -> Forest Trace -traceForest vm = - view (traces . to zipperRootForest) vm - -traceLog :: (MonadState VM m) => Log -> m () -traceLog log = do - trace <- withTraceLocation (EventTrace log) - modifying traces $ - \t -> Zipper.nextSpace (Zipper.insert (Node trace []) t) - --- * Stack manipulation - -push :: Word -> EVM () -push x = state . stack %= (x :) - -stackOp1 - :: (?op :: Word8) - => (Word -> Word) - -> (Word -> Word) - -> EVM () -stackOp1 cost f = - use (state . stack) >>= \case - (x:xs) -> - burn (cost x) $ do - next - let !y = f x - state . stack .= y : xs - _ -> - underrun - -stackOp2 - :: (?op :: Word8) - => ((Word, Word) -> Word) - -> ((Word, Word) -> Word) - -> EVM () -stackOp2 cost f = - use (state . stack) >>= \case - (x:y:xs) -> - burn (cost (x, y)) $ do - next - state . stack .= f (x, y) : xs - _ -> - underrun - -stackOp3 - :: (?op :: Word8) - => ((Word, Word, Word) -> Word) - -> ((Word, Word, Word) -> Word) - -> EVM () -stackOp3 cost f = - use (state . stack) >>= \case - (x:y:z:xs) -> - burn (cost (x, y, z)) $ do - next - state . stack .= f (x, y, z) : xs - _ -> - underrun - --- * Bytecode data functions - -checkJump :: (Integral n) => n -> [Word] -> EVM () -checkJump x xs = do - theCode <- use (state . code) - if x < num (BS.length theCode) && BS.index theCode (num x) == 0x5b - then - insidePushData (num x) >>= - \case - True -> - vmError BadJumpDestination - _ -> do - state . stack .= xs - state . pc .= num x - else vmError BadJumpDestination - -insidePushData :: Int -> EVM Bool -insidePushData i = - -- If the operation index for the code pointer is the same - -- as for the previous code pointer, then it's inside push data. - if i == 0 - then pure False - else do - self <- use (state . codeContract) - Just x <- preuse (env . contracts . ix self . opIxMap) - pure ((x Vector.! i) == (x Vector.! (i - 1))) - -opSize :: Word8 -> Int -opSize x | x >= 0x60 && x <= 0x7f = num x - 0x60 + 2 -opSize _ = 1 - --- Index 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 :: ByteString -> Vector Int -mkOpIxMap xs = Vector.create $ Vector.new (BS.length xs) >>= \v -> - -- Loop over the byte string accumulating a vector-mutating action. - -- This is somewhat obfuscated, but should be fast. - let (_, _, _, m) = - BS.foldl' (go v) (0 :: Word8, 0, 0, return ()) xs - in m >> return v - where - go v (0, !i, !j, !m) x | x >= 0x60 && x <= 0x7f = - {- Start of PUSH op. -} (x - 0x60 + 1, i + 1, j, m >> Vector.write v i j) - go v (1, !i, !j, !m) _ = - {- End of PUSH op. -} (0, i + 1, j + 1, m >> Vector.write v i j) - go v (0, !i, !j, !m) _ = - {- Other op. -} (0, i + 1, j + 1, m >> Vector.write v i j) - go v (n, !i, !j, !m) _ = - {- PUSH data. -} (n - 1, i + 1, j, m >> Vector.write v i j) - -vmOp :: VM -> Maybe Op -vmOp vm = - let i = vm ^. state . pc - xs = BS.drop i (vm ^. state . code) - op = BS.index xs 0 - in if BS.null xs - then Nothing - else Just (readOp op (BS.drop 1 xs)) - -vmOpIx :: VM -> Maybe Int -vmOpIx vm = - do self <- currentContract vm - (view opIxMap self) Vector.!? (view (state . pc) vm) - -opParams :: VM -> Map String Word -opParams vm = - case vmOp vm of - Just OpCreate -> - params $ words "value offset size" - Just OpCall -> - params $ words "gas to value in-offset in-size out-offset out-size" - Just OpSstore -> - params $ words "index value" - Just OpCodecopy -> - params $ words "mem-offset code-offset code-size" - Just OpSha3 -> - params $ words "offset size" - Just OpCalldatacopy -> - params $ words "to from size" - Just OpExtcodecopy -> - params $ words "account mem-offset code-offset code-size" - Just OpReturn -> - params $ words "offset size" - Just OpJumpi -> - params $ words "destination condition" - _ -> mempty - where - params xs = - if length (vm ^. state . stack) >= length xs - then Map.fromList (zip xs (vm ^. state . stack)) - else mempty - -readOp :: Word8 -> ByteString -> Op -readOp x _ | x >= 0x80 && x <= 0x8f = OpDup (x - 0x80 + 1) -readOp x _ | x >= 0x90 && x <= 0x9f = OpSwap (x - 0x90 + 1) -readOp x _ | x >= 0xa0 && x <= 0xa4 = OpLog (x - 0xa0) -readOp x xs | x >= 0x60 && x <= 0x7f = - let n = x - 0x60 + 1 - xs' = BS.take (num n) xs - in OpPush (word xs') -readOp x _ = case x of - 0x00 -> OpStop - 0x01 -> OpAdd - 0x02 -> OpMul - 0x03 -> OpSub - 0x04 -> OpDiv - 0x05 -> OpSdiv - 0x06 -> OpMod - 0x07 -> OpSmod - 0x08 -> OpAddmod - 0x09 -> OpMulmod - 0x0a -> OpExp - 0x0b -> OpSignextend - 0x10 -> OpLt - 0x11 -> OpGt - 0x12 -> OpSlt - 0x13 -> OpSgt - 0x14 -> OpEq - 0x15 -> OpIszero - 0x16 -> OpAnd - 0x17 -> OpOr - 0x18 -> OpXor - 0x19 -> OpNot - 0x1a -> OpByte - 0x20 -> OpSha3 - 0x30 -> OpAddress - 0x31 -> OpBalance - 0x32 -> OpOrigin - 0x33 -> OpCaller - 0x34 -> OpCallvalue - 0x35 -> OpCalldataload - 0x36 -> OpCalldatasize - 0x37 -> OpCalldatacopy - 0x38 -> OpCodesize - 0x39 -> OpCodecopy - 0x3a -> OpGasprice - 0x3b -> OpExtcodesize - 0x3c -> OpExtcodecopy - 0x3d -> OpReturndatasize - 0x3e -> OpReturndatacopy - 0x40 -> OpBlockhash - 0x41 -> OpCoinbase - 0x42 -> OpTimestamp - 0x43 -> OpNumber - 0x44 -> OpDifficulty - 0x45 -> OpGaslimit - 0x50 -> OpPop - 0x51 -> OpMload - 0x52 -> OpMstore - 0x53 -> OpMstore8 - 0x54 -> OpSload - 0x55 -> OpSstore - 0x56 -> OpJump - 0x57 -> OpJumpi - 0x58 -> OpPc - 0x59 -> OpMsize - 0x5a -> OpGas - 0x5b -> OpJumpdest - 0xf0 -> OpCreate - 0xf1 -> OpCall - 0xf2 -> OpCallcode - 0xf3 -> OpReturn - 0xf4 -> OpDelegatecall - 0xfd -> OpRevert - 0xfa -> OpStaticcall - 0xff -> OpSelfdestruct - _ -> (OpUnknown x) - -mkCodeOps :: ByteString -> RegularVector.Vector (Int, Op) -mkCodeOps bytes = RegularVector.fromList . toList $ go 0 bytes - where - go !i !xs = - case BS.uncons xs of - Nothing -> - mempty - Just (x, xs') -> - let j = opSize x - in (i, readOp x xs') Seq.<| go (i + j) (BS.drop j xs) - --- * Gas cost calculation helpers - --- Gas cost function for CALL, transliterated from the Yellow Paper. -costOfCall - :: FeeSchedule Word - -> Maybe a -> Word -> Word -> Word - -> (Word, Word) -costOfCall (FeeSchedule {..}) recipient xValue availableGas xGas = - (c_gascap + c_extra, c_callgas) - where - c_extra = - num g_call + c_xfer + c_new - c_xfer = - if xValue /= 0 then num g_callvalue else 0 - c_new = - if isNothing recipient then num g_newaccount else 0 - c_callgas = - if xValue /= 0 then c_gascap + num g_callstipend else c_gascap - c_gascap = - if availableGas >= c_extra - then min xGas (allButOne64th (availableGas - c_extra)) - else xGas - -memoryCost :: FeeSchedule Word -> Word -> Word -memoryCost FeeSchedule{..} byteCount = - let - wordCount = ceilDiv byteCount 32 - linearCost = g_memory * wordCount - quadraticCost = div (wordCount * wordCount) 512 - in - if byteCount > exponentiate 2 32 - then maxBound - else linearCost + quadraticCost +{-# Language DataKinds #-} +{-# Language GADTs #-} +{-# Language RecordWildCards #-} +{-# Language ScopedTypeVariables #-} +{-# Language StandaloneDeriving #-} +{-# Language StrictData #-} +{-# Language TemplateHaskell #-} +{-# Language TypeOperators #-} +{-# Language ViewPatterns #-} + +module EVM where + +import Prelude hiding (log, Word, exponent) + +import Data.SBV hiding (Word, output, Unknown) +import Data.Proxy (Proxy(..)) +import EVM.ABI +import EVM.Types +import EVM.Solidity +import EVM.Keccak +import EVM.Concrete (Word(..), w256, createAddress, wordValue, keccakBlob, create2Address) +import EVM.Symbolic +import EVM.Op +import EVM.FeeSchedule (FeeSchedule (..)) +import Options.Generic as Options +import qualified EVM.Precompiled + +import Data.Binary.Get (runGetOrFail) +import Data.Text (Text) +import Data.Word (Word8, Word32) +import Control.Lens hiding (op, (:<), (|>), (.>)) +import Control.Monad.State.Strict hiding (state) + +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (fromStrict) +import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe) +import Data.Semigroup (Semigroup (..)) +import Data.Sequence (Seq) +import Data.Vector.Storable (Vector) +import Data.Foldable (toList) + +import Data.Tree + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LS +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteArray as BA +import qualified Data.Map.Strict as Map +import qualified Data.Sequence as Seq +import qualified Data.Tree.Zipper as Zipper +import qualified Data.Vector.Storable as Vector +import qualified Data.Vector.Storable.Mutable as Vector + +import qualified Data.Vector as RegularVector + +import Crypto.Number.ModArithmetic (expFast) +import Crypto.Hash (Digest, SHA256, RIPEMD160) +import qualified Crypto.Hash as Crypto + +-- * Data types + +-- | EVM failure modes +data Error + = BalanceTooLow Word Word + | UnrecognizedOpcode Word8 + | SelfDestruction + | StackUnderrun + | BadJumpDestination + | Revert ByteString + | NoSuchContract Addr + | OutOfGas Word Word + | BadCheatCode (Maybe Word32) + | StackLimitExceeded + | IllegalOverflow + | Query Query + | Choose Choose + | StateChangeWhileStatic + | InvalidMemoryAccess + | CallDepthLimitReached + | MaxCodeSizeExceeded Word Word + | PrecompileFailure + | UnexpectedSymbolicArg + | DeadPath +deriving instance Show Error + +-- | The possible result states of a VM +data VMResult + = VMFailure Error -- ^ An operation failed + | VMSuccess Buffer -- ^ Reached STOP, RETURN, or end-of-code + +deriving instance Show VMResult + +-- | The state of a stepwise EVM execution +data VM = VM + { _result :: Maybe VMResult + , _state :: FrameState + , _frames :: [Frame] + , _env :: Env + , _block :: Block + , _tx :: TxState + , _logs :: Seq Log + , _traces :: Zipper.TreePos Zipper.Empty Trace + , _cache :: Cache + , _burned :: Word + , _pathConditions :: [SBool] + , _iterations :: Map CodeLocation Int + } + +data Trace = Trace + { _traceCodehash :: W256 + , _traceOpIx :: Int + , _traceData :: TraceData + } + +data TraceData + = EventTrace Log + | FrameTrace FrameContext + | QueryTrace Query + | ErrorTrace Error + | EntryTrace Text + | ReturnTrace Buffer FrameContext + +-- | Queries halt execution until resolved through RPC calls or SMT queries +data Query where + PleaseFetchContract :: Addr -> (Contract -> EVM ()) -> Query + PleaseFetchSlot :: Addr -> Word -> (Word -> EVM ()) -> Query + PleaseAskSMT :: SymWord -> [SBool] -> (JumpCondition -> EVM ()) -> Query + +data Choose where + PleaseChoosePath :: (Bool -> EVM ()) -> Choose + +instance Show Query where + showsPrec _ = \case + PleaseFetchContract addr _ -> + (("") ++) + PleaseFetchSlot addr slot _ -> + (("") ++) + PleaseAskSMT condition pathConditions _ -> + (("") ++) + +instance Show Choose where + showsPrec _ = \case + PleaseChoosePath _ -> + ((" b = Cache + { _fetched = mappend (view fetched a) (view fetched b), + _path = mappend (view path a) (view path b) + } + +instance Monoid Cache where + mempty = Cache { _fetched = mempty, + _path = mempty + } + +-- * Data accessors + +currentContract :: VM -> Maybe Contract +currentContract vm = + view (env . contracts . at (view (state . codeContract) vm)) vm + +-- * Data constructors + +makeVm :: VMOpts -> VM +makeVm o = VM + { _result = Nothing + , _frames = mempty + , _tx = TxState + { _gasprice = w256 $ vmoptGasprice o + , _txgaslimit = w256 $ vmoptGaslimit o + , _origin = vmoptOrigin o + , _toAddr = vmoptAddress o + , _value = vmoptValue o + , _substate = SubState mempty mempty mempty + , _isCreate = vmoptCreate o + , _txReversion = Map.fromList + [(vmoptAddress o, vmoptContract o)] + } + , _logs = mempty + , _traces = Zipper.fromForest [] + , _block = Block + { _coinbase = vmoptCoinbase o + , _timestamp = w256 $ vmoptTimestamp o + , _number = w256 $ vmoptNumber o + , _difficulty = w256 $ vmoptDifficulty o + , _maxCodeSize = w256 $ vmoptMaxCodeSize o + , _gaslimit = w256 $ vmoptBlockGaslimit o + , _schedule = vmoptSchedule o + } + , _state = FrameState + { _pc = 0 + , _stack = mempty + , _memory = mempty + , _memorySize = 0 + , _code = theCode + , _contract = vmoptAddress o + , _codeContract = vmoptAddress o + , _calldata = vmoptCalldata o + , _callvalue = vmoptValue o + , _caller = vmoptCaller o + , _gas = w256 $ vmoptGas o + , _returndata = mempty + , _static = False + } + , _env = Env + { _sha3Crack = mempty + , _chainId = w256 $ vmoptChainId o + , _contracts = Map.fromList + [(vmoptAddress o, vmoptContract o)] + , _keccakUsed = mempty + , _storageModel = vmoptStorageModel o + } + , _cache = Cache (Map.fromList + [(vmoptAddress o, vmoptContract o)]) + mempty + , _burned = 0 + , _pathConditions = [] + , _iterations = mempty + } where theCode = case _contractcode (vmoptContract o) of + InitCode b -> b + RuntimeCode b -> b + +-- | Initialize empty contract with given code +initialContract :: ContractCode -> Contract +initialContract theContractCode = Contract + { _contractcode = theContractCode + , _codehash = + if BS.null theCode then 0 else + keccak (stripBytecodeMetadata theCode) + , _storage = Concrete mempty + , _balance = 0 + , _nonce = 0 + , _opIxMap = mkOpIxMap theCode + , _codeOps = mkCodeOps theCode + , _external = False + , _origStorage = mempty + } where theCode = case theContractCode of + InitCode b -> b + RuntimeCode b -> b + +contractWithStore :: ContractCode -> Storage -> Contract +contractWithStore theContractCode store = + initialContract theContractCode & set storage store + +-- * 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 + -- Convenience function to access parts of the current VM state. + -- Arcane type signature needed to avoid monomorphism restriction. + the :: (b -> VM -> Const a VM) -> ((a -> Const a a) -> b) -> a + the f g = view (f . g) vm + + -- Convenient aliases + mem = the state memory + stk = the state stack + self = the state contract + this = fromMaybe (error "internal error: state contract") (preview (ix self) (the env contracts)) + + fees@FeeSchedule {..} = the block schedule + + doStop = finishFrame (FrameReturned mempty) + + if self > 0x0 && self <= 0x9 then do + -- call to precompile + let ?op = 0x00 -- dummy value + let + calldatasize = snd (the state calldata) + case unliteral calldatasize of + Nothing -> vmError UnexpectedSymbolicArg + Just calldatasize' -> do + copyBytesToMemory (fst $ the state calldata) (num calldatasize') 0 0 + executePrecompile self (the state gas) 0 (num calldatasize') 0 0 [] + vmx <- get + case view (state.stack) vmx of + (x:_) -> case maybeLitWord x of + Just 0 -> do + fetchAccount self $ \_ -> do + touchAccount self + vmError PrecompileFailure + Just _ -> + fetchAccount self $ \_ -> do + touchAccount self + out <- use (state . returndata) + finishFrame (FrameReturned out) + Nothing -> vmError UnexpectedSymbolicArg + _ -> + underrun + + else if the state pc >= num (BS.length (the state code)) + then doStop + + else do + let ?op = BS.index (the state code) (the state pc) + + case ?op of + + -- op: PUSH + x | x >= 0x60 && x <= 0x7f -> do + let !n = num x - 0x60 + 1 + !xs = BS.take n (BS.drop (1 + the state pc) + (the state code)) + limitStack 1 $ + burn g_verylow $ do + next + push (w256 (word xs)) + + -- op: DUP + x | x >= 0x80 && x <= 0x8f -> do + let !i = x - 0x80 + 1 + case preview (ix (num i - 1)) stk of + Nothing -> underrun + Just y -> + limitStack 1 $ + burn g_verylow $ do + next + pushSym y + + -- op: SWAP + x | x >= 0x90 && x <= 0x9f -> do + let i = num (x - 0x90 + 1) + if length stk < i + 1 + then underrun + else + burn g_verylow $ do + next + zoom (state . stack) $ do + assign (ix 0) (stk ^?! ix i) + assign (ix i) (stk ^?! ix 0) + + -- op: LOG + x | x >= 0xa0 && x <= 0xa4 -> + notStatic $ + let n = (num x - 0xa0) in + case stk of + (xOffset':xSize':xs) -> + if length xs < n + then underrun + else + forceConcrete2 (xOffset', xSize') $ \(xOffset, xSize) -> do + let (topics, xs') = splitAt n xs + bytes = readMemory (num xOffset) (num xSize) vm + log = Log self bytes topics + + burn (g_log + g_logdata * xSize + num n * g_logtopic) $ + accessMemoryRange fees xOffset xSize $ do + traceLog log + next + assign (state . stack) xs' + pushToSequence logs log + _ -> + underrun + + -- op: STOP + 0x00 -> doStop + + -- op: ADD + 0x01 -> stackOp2 (const g_verylow) (uncurry (+)) + -- op: MUL + 0x02 -> stackOp2 (const g_low) (uncurry (*)) + -- op: SUB + 0x03 -> stackOp2 (const g_verylow) (uncurry (-)) + + -- op: DIV + 0x04 -> stackOp2 (const g_low) (uncurry (sDiv)) + + -- op: SDIV + 0x05 -> + stackOp2 (const g_low) (uncurry sdiv) + + -- op: MOD + 0x06 -> stackOp2 (const g_low) $ \(x, y) -> ite (y .== 0) 0 (x `sMod` y) + + -- op: SMOD + 0x07 -> stackOp2 (const g_low) $ uncurry smod + -- op: ADDMOD + 0x08 -> stackOp3 (const g_mid) (\(x, y, z) -> addmod x y z) + -- op: MULMOD + 0x09 -> stackOp3 (const g_mid) (\(x, y, z) -> mulmod x y z) + + -- op: LT + 0x10 -> stackOp2 (const g_verylow) $ \(x, y) -> ite (x .< y) 1 0 + -- op: GT + 0x11 -> stackOp2 (const g_verylow) $ \(x, y) -> ite (x .> y) 1 0 + -- op: SLT + 0x12 -> stackOp2 (const g_verylow) $ uncurry slt + -- op: SGT + 0x13 -> stackOp2 (const g_verylow) $ uncurry sgt + + -- op: EQ + 0x14 -> stackOp2 (const g_verylow) $ \(x, y) -> ite (x .== y) 1 0 + -- op: ISZERO + 0x15 -> stackOp1 (const g_verylow) $ \x -> ite (x .== 0) 1 0 + + -- op: AND + 0x16 -> stackOp2 (const g_verylow) $ uncurry (.&.) + -- op: OR + 0x17 -> stackOp2 (const g_verylow) $ uncurry (.|.) + -- op: XOR + 0x18 -> stackOp2 (const g_verylow) $ uncurry xor + -- op: NOT + 0x19 -> stackOp1 (const g_verylow) complement + + -- op: BYTE + 0x1a -> stackOp2 (const g_verylow) $ \case + (n, _) | (forceLit n) >= 32 -> 0 + (n, x) | otherwise -> 0xff .&. shiftR x (8 * (31 - num (forceLit n))) + + -- op: SHL + 0x1b -> stackOp2 (const g_verylow) $ \((S _ n), (S _ x)) -> sw256 $ sShiftLeft x n + -- op: SHR + 0x1c -> stackOp2 (const g_verylow) $ \((S _ n), (S _ x)) -> sw256 $ sShiftRight x n + -- op: SAR + 0x1d -> stackOp2 (const g_verylow) $ \((S _ n), (S _ x)) -> sw256 $ sSignedShiftArithRight x n + + -- op: SHA3 + -- more accurately refered to as KECCAK + 0x20 -> + case stk of + (xOffset' : xSize' : xs) -> + forceConcrete xOffset' $ + \xOffset -> forceConcrete xSize' $ \xSize -> do + (hash, invMap) <- case readMemory xOffset xSize vm of + ConcreteBuffer bs -> pure (litWord $ keccakBlob bs, Map.singleton (keccakBlob bs) bs) + + -- Although we would like to simply assert that the uninterpreted function symkeccak' + -- is injective, this proves to cause a lot of concern for our smt solvers, probably + -- due to the introduction of universal quantifiers into the queries. + + -- Instead, we keep track of all of the particular invocations of symkeccak' we see + -- (similarly to sha3Crack), and simply assert that injectivity holds for these + -- particular invocations. + + SymbolicBuffer bs -> do + let hash' = symkeccak' bs + previousUsed = view (env . keccakUsed) vm + env . keccakUsed <>= [(bs, hash')] + pathConditions <>= fmap (\(preimage, image) -> + image .== hash' .=> preimage .== bs) + previousUsed + return (sw256 hash', mempty) + + burn (g_sha3 + g_sha3word * ceilDiv (num xSize) 32) $ + accessMemoryRange fees xOffset xSize $ do + next + assign (state . stack) (hash : xs) + (env . sha3Crack) <>= invMap + _ -> underrun + + -- op: ADDRESS + 0x30 -> + limitStack 1 $ + burn g_base (next >> push (num self)) + + -- op: BALANCE + 0x31 -> + case stk of + (x':xs) -> forceConcrete x' $ \x -> + burn g_balance $ + fetchAccount (num x) $ \c -> do + next + assign (state . stack) xs + push (view balance c) + [] -> + underrun + + -- op: ORIGIN + 0x32 -> + limitStack 1 . burn g_base $ + next >> push (num (the tx origin)) + + -- op: CALLER + 0x33 -> + limitStack 1 . burn g_base $ + let toSymWord = sw256 . sFromIntegral . saddressWord160 + in next >> pushSym (toSymWord (the state caller)) + + -- op: CALLVALUE + 0x34 -> + limitStack 1 . burn g_base $ + next >> pushSym (the state callvalue) + + -- op: CALLDATALOAD + 0x35 -> stackOp1 (const g_verylow) $ + \(S _ x) -> uncurry (readSWordWithBound (sFromIntegral x)) (the state calldata) + + -- op: CALLDATASIZE + 0x36 -> + limitStack 1 . burn g_base $ + next >> pushSym (sw256 . zeroExtend . snd $ (the state calldata)) + + -- op: CALLDATACOPY + 0x37 -> + case stk of + (xTo' : xFrom' : xSize' : xs) -> forceConcrete3 (xTo',xFrom',xSize') $ \(xTo,xFrom,xSize) -> + burn (g_verylow + g_copy * ceilDiv xSize 32) $ + accessUnboundedMemoryRange fees xTo xSize $ do + next + assign (state . stack) xs + case the state calldata of + (SymbolicBuffer cd, cdlen) -> copyBytesToMemory (SymbolicBuffer [ite (i .<= cdlen) x 0 | (x, i) <- zip cd [1..]]) xSize xFrom xTo + -- when calldata is concrete, + -- the bound should always be equal to the bytestring length + (cd, _) -> copyBytesToMemory cd xSize xFrom xTo + _ -> underrun + + -- op: CODESIZE + 0x38 -> + limitStack 1 . burn g_base $ + next >> push (num (BS.length (the state code))) + + -- op: CODECOPY + 0x39 -> + case stk of + (memOffset' : codeOffset' : n' : xs) -> forceConcrete3 (memOffset',codeOffset',n') $ \(memOffset,codeOffset,n) -> do + burn (g_verylow + g_copy * ceilDiv (num n) 32) $ + accessUnboundedMemoryRange fees memOffset n $ do + next + assign (state . stack) xs + copyBytesToMemory (ConcreteBuffer (the state code)) + n codeOffset memOffset + _ -> underrun + + -- op: GASPRICE + 0x3a -> + limitStack 1 . burn g_base $ + next >> push (the tx gasprice) + + -- op: EXTCODESIZE + 0x3b -> + case stk of + (x':xs) -> forceConcrete x' $ \x -> + if x == num cheatCode + then do + next + assign (state . stack) xs + push (w256 1) + else + burn g_extcode $ + fetchAccount (num x) $ \c -> do + next + assign (state . stack) xs + push (num (BS.length (view bytecode c))) + [] -> + underrun + + -- op: EXTCODECOPY + 0x3c -> + case stk of + ( extAccount' + : memOffset' + : codeOffset' + : codeSize' + : xs ) -> + forceConcrete4 (extAccount', memOffset', codeOffset', codeSize') $ + \(extAccount, memOffset, codeOffset, codeSize) -> + burn (g_extcode + g_copy * ceilDiv (num codeSize) 32) $ + accessUnboundedMemoryRange fees memOffset codeSize $ + fetchAccount (num extAccount) $ \c -> do + next + assign (state . stack) xs + copyBytesToMemory (ConcreteBuffer (view bytecode c)) + codeSize codeOffset memOffset + _ -> underrun + + -- op: RETURNDATASIZE + 0x3d -> + limitStack 1 . burn g_base $ + next >> push (num $ len (the state returndata)) + + -- op: RETURNDATACOPY + 0x3e -> + case stk of + (xTo' : xFrom' : xSize' :xs) -> forceConcrete3 (xTo', xFrom', xSize') $ + \(xTo, xFrom, xSize) -> + burn (g_verylow + g_copy * ceilDiv xSize 32) $ + accessUnboundedMemoryRange fees xTo xSize $ do + next + assign (state . stack) xs + if len (the state returndata) < num xFrom + num xSize + then vmError InvalidMemoryAccess + else copyBytesToMemory (the state returndata) xSize xFrom xTo + _ -> underrun + + -- op: EXTCODEHASH + 0x3f -> + case stk of + (x':xs) -> forceConcrete x' $ \x -> + burn g_extcodehash $ do + next + assign (state . stack) xs + fetchAccount (num x) $ \c -> + if accountEmpty c + then push (num (0 :: Int)) + else push (num (keccak (view bytecode c))) + [] -> + underrun + + -- op: BLOCKHASH + 0x40 -> do + -- We adopt the fake block hash scheme of the VMTests, + -- so that blockhash(i) is the hash of i as decimal ASCII. + stackOp1 (const g_blockhash) $ + \(forceLit -> i) -> + if i + 256 < the block number || i >= the block number + then 0 + else + (num i :: Integer) + & show & Char8.pack & keccak & num + + -- op: COINBASE + 0x41 -> + limitStack 1 . burn g_base $ + next >> push (num (the block coinbase)) + + -- op: TIMESTAMP + 0x42 -> + limitStack 1 . burn g_base $ + next >> push (the block timestamp) + + -- op: NUMBER + 0x43 -> + limitStack 1 . burn g_base $ + next >> push (the block number) + + -- op: DIFFICULTY + 0x44 -> + limitStack 1 . burn g_base $ + next >> push (the block difficulty) + + -- op: GASLIMIT + 0x45 -> + limitStack 1 . burn g_base $ + next >> push (the block gaslimit) + + -- op: CHAINID + 0x46 -> + limitStack 1 . burn g_base $ + next >> push (the env chainId) + + -- op: SELFBALANCE + 0x47 -> + limitStack 1 . burn g_low $ + next >> push (view balance this) + + -- op: POP + 0x50 -> + case stk of + (_:xs) -> burn g_base (next >> assign (state . stack) xs) + _ -> underrun + + -- op: MLOAD + 0x51 -> + case stk of + (x':xs) -> forceConcrete x' $ \x -> + burn g_verylow $ + accessMemoryWord fees x $ do + next + assign (state . stack) (view (word256At (num x)) mem : xs) + _ -> underrun + + -- op: MSTORE + 0x52 -> + case stk of + (x':y:xs) -> forceConcrete x' $ \x -> + burn g_verylow $ + accessMemoryWord fees x $ do + next + assign (state . memory . word256At (num x)) y + assign (state . stack) xs + _ -> underrun + + -- op: MSTORE8 + 0x53 -> + case stk of + (x':(S _ y):xs) -> forceConcrete x' $ \x -> + burn g_verylow $ + accessMemoryRange fees x 1 $ do + let yByte = bvExtract (Proxy :: Proxy 7) (Proxy :: Proxy 0) y + next + modifying (state . memory) (setMemoryByte x yByte) + assign (state . stack) xs + _ -> underrun + + -- op: SLOAD + 0x54 -> + case stk of + (x:xs) -> + burn g_sload $ + accessStorage self x $ \y -> do + next + assign (state . stack) (y:xs) + _ -> underrun + + -- op: SSTORE + 0x55 -> + 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 view storage this of + Concrete _ -> fromMaybe 0 (Map.lookup (forceLit x) (view origStorage this)) + Symbolic _ -> 0 -- we don't use this value anywhere anyway + 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 + + burn 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 r_sclear + else do + when (original /= 0) $ + if new' == 0 + then refund r_sclear + else unRefund r_sclear + 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 + + -- op: JUMP + 0x56 -> + case stk of + (x:xs) -> + burn g_mid $ forceConcrete x $ \x' -> + checkJump x' xs + _ -> underrun + + -- op: JUMPI + 0x57 -> do + case stk of + (x:y:xs) -> forceConcrete x $ \x' -> + burn g_high $ + let jump :: Bool -> EVM () + jump True = assign (state . stack) xs >> next + jump _ = checkJump x' xs + in case maybeLitWord y of + Just y' -> jump (0 == y') + -- if the jump condition is symbolic, an smt query has to be made. + Nothing -> askSMT (self, the state pc) y jump + _ -> underrun + + -- op: PC + 0x58 -> + limitStack 1 . burn g_base $ + next >> push (num (the state pc)) + + -- op: MSIZE + 0x59 -> + limitStack 1 . burn g_base $ + next >> push (num (the state memorySize)) + + -- op: GAS + 0x5a -> + limitStack 1 . burn g_base $ + next >> push (the state gas - g_base) + + -- op: JUMPDEST + 0x5b -> burn g_jumpdest next + + -- op: EXP + 0x0a -> + let cost (_ ,(forceLit -> exponent)) = + if exponent == 0 + then g_exp + else g_exp + g_expbyte * num (ceilDiv (1 + log2 exponent) 8) + in stackOp2 cost $ \((S _ x),(S _ y)) -> sw256 $ x .^ y + + -- op: SIGNEXTEND + 0x0b -> + stackOp2 (const g_low) $ \((forceLit -> bytes), w@(S _ x)) -> + if bytes >= 32 then w + else let n = num bytes * 8 + 7 in + sw256 $ ite (sTestBit x n) + (x .|. complement (bit n - 1)) + (x .&. (bit n - 1)) + + -- op: CREATE + 0xf0 -> + notStatic $ + case stk of + (xValue' : xOffset' : xSize' : xs) -> forceConcrete3 (xValue', xOffset', xSize') $ + \(xValue, xOffset, xSize) -> do + accessMemoryRange fees xOffset xSize $ do + availableGas <- use (state . gas) + let + newAddr = createAddress self (wordValue (view nonce this)) + (cost, gas') = costOfCreate fees availableGas 0 + burn (cost - gas') $ forceConcreteBuffer (readMemory (num xOffset) (num xSize) vm) $ \initCode -> + create self this gas' xValue xs newAddr initCode + _ -> underrun + + -- op: CALL + 0xf1 -> + case stk of + ( xGas' + : xTo' + : (forceLit -> xValue) + : xInOffset' + : xInSize' + : xOutOffset' + : xOutSize' + : xs + ) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ + \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> + (if xValue > 0 then notStatic else id) $ + case xTo of + n | n > 0 && n <= 9 -> + precompiledContract this xGas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs + n | num n == cheatCode -> + do + assign (state . stack) xs + cheat (xInOffset, xInSize) (xOutOffset, xOutSize) + _ -> delegateCall this xGas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ do + zoom state $ do + assign callvalue (litWord xValue) + assign caller (litAddr self) + assign contract xTo + zoom (env . contracts) $ do + ix self . balance -= xValue + ix xTo . balance += xValue + touchAccount self + touchAccount xTo + _ -> + underrun + + -- op: CALLCODE + 0xf2 -> + case stk of + ( xGas' + : xTo' + : (forceLit -> xValue) + : xInOffset' + : xInSize' + : xOutOffset' + : xOutSize' + : xs + ) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ + \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> + case xTo of + n | n > 0 && n <= 9 -> + precompiledContract this xGas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs + _ -> delegateCall this xGas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs $ do + zoom state $ do + assign callvalue (litWord xValue) + assign caller (litAddr self) + touchAccount self + _ -> + underrun + + -- op: RETURN + 0xf3 -> + case stk of + (xOffset' : xSize' :_) -> forceConcrete2 (xOffset', xSize') $ \(xOffset, xSize) -> + accessMemoryRange fees xOffset xSize $ do + let + output = readMemory xOffset xSize vm + codesize = num (len output) + maxsize = the block maxCodeSize + case view frames vm of + [] -> + case (the tx isCreate) of + True -> + if codesize > maxsize + then + finishFrame (FrameErrored (MaxCodeSizeExceeded maxsize codesize)) + else + burn (g_codedeposit * codesize) $ + finishFrame (FrameReturned output) + False -> + finishFrame (FrameReturned output) + (frame: _) -> do + let + context = view frameContext frame + case context of + CreationContext {} -> + if codesize > maxsize + then + finishFrame (FrameErrored (MaxCodeSizeExceeded maxsize codesize)) + else + burn (g_codedeposit * codesize) $ + finishFrame (FrameReturned output) + CallContext {} -> + finishFrame (FrameReturned output) + _ -> underrun + + -- op: DELEGATECALL + 0xf4 -> + case stk of + (xGas' + :xTo' + :xInOffset' + :xInSize' + :xOutOffset' + :xOutSize' + :xs) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ + \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> + case xTo of + n | n > 0 && n <= 9 -> + precompiledContract this xGas xTo self 0 xInOffset xInSize xOutOffset xOutSize xs + n | num n == cheatCode -> do + assign (state . stack) xs + cheat (xInOffset, xInSize) (xOutOffset, xOutSize) + _ -> do + delegateCall this xGas xTo self 0 xInOffset xInSize xOutOffset xOutSize xs $ do + touchAccount self + _ -> underrun + + -- op: CREATE2 + 0xf5 -> notStatic $ + case stk of + (xValue' + :xOffset' + :xSize' + :xSalt' + :xs) -> forceConcrete4 (xValue', xOffset', xSize', xSalt') $ + \(xValue, xOffset, xSize, xSalt) -> + accessMemoryRange fees xOffset xSize $ do + availableGas <- use (state . gas) + forceConcreteBuffer (readMemory (num xOffset) (num xSize) vm) $ \initCode -> + let + newAddr = create2Address self (num xSalt) initCode + (cost, gas') = costOfCreate fees availableGas xSize + in burn (cost - gas') $ + create self this gas' xValue xs newAddr initCode + _ -> underrun + + -- op: STATICCALL + 0xfa -> + case stk of + (xGas' + :xTo' + :xInOffset' + :xInSize' + :xOutOffset' + :xOutSize' + :xs) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ + \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> + case xTo of + n | n > 0 && n <= 9 -> + precompiledContract this xGas xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs + _ -> delegateCall this xGas xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs $ do + zoom state $ do + assign callvalue 0 + assign caller (litAddr self) + assign contract xTo + assign static True + touchAccount self + touchAccount xTo + _ -> + underrun + + -- op: SELFDESTRUCT + 0xff -> + notStatic $ + case stk of + [] -> underrun + (xTo':_) -> forceConcrete xTo' $ \(num -> xTo) -> + let + funds = view balance this + recipientExists = accountExists xTo vm + c_new = if not recipientExists && funds /= 0 + then num g_selfdestruct_newaccount + else 0 + in burn (g_selfdestruct + c_new) $ do + destructs <- use (tx . substate . selfdestructs) + unless (elem self destructs) $ refund r_selfdestruct + 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 + + -- op: REVERT + 0xfd -> + case stk of + (xOffset':xSize':_) -> forceConcrete2 (xOffset', xSize') $ \(xOffset, xSize) -> + accessMemoryRange fees xOffset xSize $ do + let output = readMemory xOffset xSize vm + finishFrame (FrameReverted output) + _ -> underrun + + xxx -> + vmError (UnrecognizedOpcode xxx) + +-- | Checks a *CALL for failure; OOG, too many callframes, memory access etc. +callChecks + :: (?op :: Word8) + => Contract -> Word -> Addr -> Word -> Word -> Word -> Word -> Word -> [SymWord] + -- continuation with gas avail for call + -> (Word -> EVM ()) + -> EVM () +callChecks this xGas xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue = do + vm <- get + let fees = view (block . schedule) vm + accessMemoryRange fees xInOffset xInSize $ + accessMemoryRange fees xOutOffset xOutSize $ do + availableGas <- use (state . gas) + let recipientExists = accountExists xContext vm + (cost, gas') = costOfCall fees recipientExists xValue availableGas xGas + burn (cost - gas') $ do + if xValue > view balance this + then do + assign (state . stack) (0 : xs) + assign (state . returndata) mempty + pushTrace $ ErrorTrace $ BalanceTooLow xValue (view balance this) + next + else if length (view frames vm) >= 1024 + then do + assign (state . stack) (0 : xs) + assign (state . returndata) mempty + pushTrace $ ErrorTrace $ CallDepthLimitReached + next + else continue gas' + +precompiledContract + :: (?op :: Word8) + => Contract + -> Word + -> Addr + -> Addr + -> Word + -> Word -> Word -> Word -> Word + -> [SymWord] + -> EVM () +precompiledContract this xGas precompileAddr recipient xValue inOffset inSize outOffset outSize xs = + callChecks this xGas recipient xValue inOffset inSize outOffset outSize xs $ \gas' -> + do + executePrecompile precompileAddr gas' inOffset inSize outOffset outSize xs + self <- use (state . contract) + stk <- use (state . stack) + case stk of + (x:_) -> case maybeLitWord x of + Just 0 -> + return () + Just 1 -> + fetchAccount recipient $ \_ -> do + + zoom (env . contracts) $ do + ix self . balance -= xValue + ix recipient . balance += xValue + touchAccount self + touchAccount recipient + touchAccount precompileAddr + _ -> vmError UnexpectedSymbolicArg + _ -> underrun + +executePrecompile + :: (?op :: Word8) + => Addr + -> Word -> Word -> Word -> Word -> Word -> [SymWord] + -> EVM () +executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = do + vm <- get + let input = readMemory (num inOffset) (num inSize) vm + fees = view (block . schedule) vm + cost = costOfPrecompile fees preCompileAddr input + notImplemented = error $ "precompile at address " <> show preCompileAddr <> " not yet implemented" + precompileFail = burn (gasCap - cost) $ do + assign (state . stack) (0 : xs) + pushTrace $ ErrorTrace $ PrecompileFailure + next + if cost > gasCap then + burn gasCap $ do + assign (state . stack) (0 : xs) + next + else + burn cost $ + case preCompileAddr of + -- ECRECOVER + 0x1 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> + case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of + Nothing -> do + -- return no output for invalid signature + assign (state . stack) (1 : xs) + assign (state . returndata) mempty + next + Just output -> do + assign (state . stack) (1 : xs) + assign (state . returndata) (ConcreteBuffer output) + copyBytesToMemory (ConcreteBuffer output) outSize 0 outOffset + next + + -- SHA2-256 + 0x2 -> + let + hash = case input of + ConcreteBuffer input' -> ConcreteBuffer $ BS.pack $ BA.unpack $ (Crypto.hash input' :: Digest SHA256) + SymbolicBuffer input' -> SymbolicBuffer $ symSHA256 input' + in do + assign (state . stack) (1 : xs) + assign (state . returndata) hash + copyBytesToMemory hash outSize 0 outOffset + next + + -- RIPEMD-160 + 0x3 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> + + let + padding = BS.pack $ replicate 12 0 + hash' = BS.pack $ BA.unpack (Crypto.hash input' :: Digest RIPEMD160) + hash = ConcreteBuffer $ padding <> hash' + in do + assign (state . stack) (1 : xs) + assign (state . returndata) hash + copyBytesToMemory hash outSize 0 outOffset + next + + -- IDENTITY + 0x4 -> do + assign (state . stack) (1 : xs) + assign (state . returndata) input + copyCallBytesToMemory input outSize 0 outOffset + next + + -- MODEXP + 0x5 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> + + let + (lenb, lene, lenm) = parseModexpLength input' + + output = ConcreteBuffer $ + case (isZero (96 + lenb + lene) lenm input') of + True -> + truncpadlit (num lenm) (asBE (0 :: Int)) + False -> + let + b = asInteger $ lazySlice 96 lenb $ input' + e = asInteger $ lazySlice (96 + lenb) lene $ input' + m = asInteger $ lazySlice (96 + lenb + lene) lenm $ input' + in + padLeft (num lenm) (asBE (expFast b e m)) + in do + assign (state . stack) (1 : xs) + assign (state . returndata) output + copyBytesToMemory output outSize 0 outOffset + next + + -- ECADD + 0x6 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> + case EVM.Precompiled.execute 0x6 (truncpadlit 128 input') 64 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output + assign (state . stack) (1 : xs) + assign (state . returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput outSize 0 outOffset + next + + -- ECMUL + 0x7 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> + + case EVM.Precompiled.execute 0x7 (truncpadlit 96 input') 64 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output + assign (state . stack) (1 : xs) + assign (state . returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput outSize 0 outOffset + next + + -- ECPAIRING + 0x8 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> + + case EVM.Precompiled.execute 0x8 input' 32 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuffer $ truncpadlit 32 output + assign (state . stack) (1 : xs) + assign (state . returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput outSize 0 outOffset + next + + -- BLAKE2 + 0x9 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \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 = ConcreteBuffer $ truncpadlit 64 output + assign (state . stack) (1 : xs) + assign (state . returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput outSize 0 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 :: Word -> Word -> ByteString -> LS.ByteString +lazySlice offset size bs = + let bs' = LS.take (num size) (LS.drop (num offset) (fromStrict bs)) + in bs' <> LS.replicate ((num size) - LS.length bs') 0 + +parseModexpLength :: ByteString -> (Word, Word, Word) +parseModexpLength input = + let lenb = w256 $ word $ LS.toStrict $ lazySlice 0 32 input + lene = w256 $ word $ LS.toStrict $ lazySlice 32 64 input + lenm = w256 $ word $ LS.toStrict $ lazySlice 64 96 input + in (lenb, lene, lenm) + +isZero :: Word -> Word -> ByteString -> Bool +isZero offset size bs = + LS.all (== 0) $ + LS.take (num size) $ + LS.drop (num offset) $ + fromStrict bs + +asInteger :: LS.ByteString -> Integer +asInteger xs = if xs == mempty then 0 + else 256 * asInteger (LS.init xs) + + num (LS.last xs) + +-- * Opcode helper actions + +noop :: Monad m => m () +noop = pure () + +pushTo :: MonadState s m => ASetter s s [a] [a] -> a -> m () +pushTo f x = f %= (x :) + +pushToSequence :: MonadState s m => ASetter s s (Seq a) (Seq a) -> a -> m () +pushToSequence f x = f %= (Seq.|> x) + +getCodeLocation :: VM -> CodeLocation +getCodeLocation vm = (view (state . contract) vm, view (state . pc) vm) + +-- | Construct SMT Query and halt execution until resolved +askSMT :: CodeLocation -> SymWord -> (Bool -> EVM ()) -> EVM () +askSMT codeloc jumpcondition continue = do + -- We keep track of how many times we have come across this particular + -- (contract, pc) combination in the `iteration` mapping. + iteration <- use (iterations . at codeloc . non 0) + + -- If we are backstepping, the result of this query should be cached + -- already. So we first check the cache to see if the result is known + use (cache . path . at (codeloc, iteration)) >>= \case + -- If the query has been done already, select path or select the only available + Just w -> choosePath (Iszero w) + -- If this is a new query, run the query, cache the result + -- increment the iterations and select appropriate path + Nothing -> do pathconds <- use pathConditions + assign result . Just . VMFailure . Query $ PleaseAskSMT + jumpcondition pathconds choosePath + + where -- Only one path is possible + choosePath :: JumpCondition -> EVM () + choosePath (Iszero v) = do assign result Nothing + pathConditions <>= if v then [litWord 0 .== jumpcondition] else [litWord 0 ./= jumpcondition] + iteration <- use (iterations . at codeloc . non 0) + assign (cache . path . at (codeloc, iteration)) (Just v) + assign (iterations . at codeloc) (Just (iteration + 1)) + continue v + -- Both paths are possible; we ask for more input + choosePath Unknown = assign result . Just . VMFailure . Choose . PleaseChoosePath $ choosePath . Iszero + -- None of the paths are possible; fail this branch + choosePath Inconsistent = vmError DeadPath + +-- | Construct RPC Query and halt execution until resolved +fetchAccount :: Addr -> (Contract -> EVM ()) -> EVM () +fetchAccount addr continue = + use (env . contracts . at addr) >>= \case + Just c -> continue c + Nothing -> + use (cache . fetched . at addr) >>= \case + Just c -> do + assign (env . contracts . at addr) (Just c) + continue c + Nothing -> + assign result . Just . VMFailure . Query $ + PleaseFetchContract addr + (\c -> do assign (cache . fetched . at addr) (Just c) + assign (env . contracts . at addr) (Just c) + assign result Nothing + tryContinue c) + where + tryContinue c = + if (view external c) && (accountEmpty c) + then vmError . NoSuchContract $ addr + else continue c + +readStorage :: Storage -> SymWord -> Maybe (SymWord) +readStorage (Symbolic s) (S _ loc) = Just . sw256 $ readArray s loc +readStorage (Concrete s) loc = Map.lookup (forceLit loc) s + +writeStorage :: SymWord -> SymWord -> Storage -> Storage +writeStorage (S _ loc) (S _ val) (Symbolic s) = Symbolic (writeArray s loc val) +writeStorage loc val (Concrete s) = Concrete (Map.insert (forceLit loc) val s) + +accessStorage + :: Addr -- ^ Contract address + -> SymWord -- ^ Storage slot key + -> (SymWord -> EVM ()) -- ^ Continuation + -> EVM () +accessStorage addr slot continue = + use (env . contracts . at addr) >>= \case + Just c -> + case readStorage (view storage c) slot of + -- Notice that if storage is symbolic, we always continue straight away + Just x -> + continue x + Nothing -> + if view external c + then + -- check if the slot is cached + use (cache . fetched . at addr) >>= \case + Nothing -> mkQuery + Just cachedContract -> + maybe mkQuery continue (readStorage (view storage cachedContract) slot) + else do + modifying (env . contracts . ix addr . storage) (writeStorage slot 0) + continue 0 + Nothing -> + fetchAccount addr $ \_ -> + accessStorage addr slot continue + where + mkQuery = assign result . Just . VMFailure . Query $ + PleaseFetchSlot addr (forceLit slot) + (\(litWord -> x) -> do + modifying (cache . fetched . ix addr . storage) (writeStorage slot x) + modifying (env . contracts . ix addr . storage) (writeStorage slot x) + assign result Nothing + continue x) + +accountExists :: Addr -> VM -> Bool +accountExists addr vm = + case view (env . contracts . at addr) vm of + Just c -> not (accountEmpty c) + Nothing -> False + +-- EIP 161 +accountEmpty :: Contract -> Bool +accountEmpty c = + (view contractcode c == RuntimeCode mempty) + && (view nonce c == 0) + && (view balance c == 0) + +-- * How to finalize a transaction +finalize :: EVM () +finalize = do + let + burnRemainingGas = use (state . gas) >>= flip burn noop + revertContracts = use (tx . txReversion) >>= assign (env . contracts) + revertSubstate = assign (tx . substate) (SubState mempty mempty mempty) + + use result >>= \case + Nothing -> + error "Finalising an unfinished tx." + Just (VMFailure (Revert _)) -> do + revertContracts + revertSubstate + Just (VMFailure _) -> do + burnRemainingGas + revertContracts + revertSubstate + Just (VMSuccess output) -> do + -- deposit the code from a creation tx + creation <- use (tx . isCreate) + createe <- use (state . contract) + createeExists <- (Map.member createe) <$> use (env . contracts) + + when (creation && createeExists) $ forceConcreteBuffer output $ \code' -> replaceCode createe (RuntimeCode code') + + -- compute and pay the refund to the caller and the + -- corresponding payment to the miner + txOrigin <- use (tx . origin) + sumRefunds <- (sum . (snd <$>)) <$> (use (tx . substate . refunds)) + miner <- use (block . coinbase) + blockReward <- r_block <$> (use (block . schedule)) + gasPrice <- use (tx . gasprice) + gasLimit <- use (tx . txgaslimit) + gasRemaining <- use (state . gas) + + let + gasUsed = gasLimit - gasRemaining + cappedRefund = min (quot gasUsed 2) sumRefunds + originPay = (gasRemaining + cappedRefund) * gasPrice + minerPay = gasPrice * (gasUsed - cappedRefund) + + modifying (env . contracts) + (Map.adjust (over balance (+ originPay)) txOrigin) + modifying (env . contracts) + (Map.adjust (over balance (+ minerPay)) miner) + touchAccount miner + + -- pay out the block reward, recreating the miner if necessary + preuse (env . contracts . ix miner) >>= \case + Nothing -> modifying (env . contracts) + (Map.insert miner (initialContract (EVM.RuntimeCode mempty))) + Just _ -> noop + modifying (env . contracts) + (Map.adjust (over balance (+ blockReward)) miner) + + -- perform state trie clearing (EIP 161), of selfdestructs + -- and touched accounts. addresses are cleared if they have + -- a) selfdestructed, or + -- b) been touched and + -- c) are empty. + -- (see Yellow Paper "Accrued Substate") + -- + -- remove any destructed addresses + destroyedAddresses <- use (tx . substate . selfdestructs) + modifying (env . contracts) + (Map.filterWithKey (\k _ -> (notElem k destroyedAddresses))) + -- then, clear any remaining empty and touched addresses + touchedAddresses <- use (tx . substate . touchedAccounts) + modifying (env . contracts) + (Map.filterWithKey + (\k a -> not ((elem k touchedAddresses) && accountEmpty a))) + +-- | Loads the selected contract as the current contract to execute +loadContract :: Addr -> EVM () +loadContract target = + preuse (env . contracts . ix target . contractcode) >>= + \case + Nothing -> + error "Call target doesn't exist" + Just (InitCode targetCode) -> do + assign (state . contract) target + assign (state . code) targetCode + assign (state . codeContract) target + Just (RuntimeCode 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 :: Word -> EVM () -> EVM () +burn n continue = do + available <- use (state . gas) + if n <= available + then do + state . gas -= n + burned += n + continue + else + vmError (OutOfGas available n) + +forceConcreteAddr :: SAddr -> (Addr -> EVM ()) -> EVM () +forceConcreteAddr n continue = case maybeLitAddr n of + Nothing -> vmError UnexpectedSymbolicArg + Just c -> continue c + +forceConcrete :: SymWord -> (Word -> EVM ()) -> EVM () +forceConcrete n continue = case maybeLitWord n of + Nothing -> vmError UnexpectedSymbolicArg + Just c -> continue c + +forceConcrete2 :: (SymWord, SymWord) -> ((Word, Word) -> EVM ()) -> EVM () +forceConcrete2 (n,m) continue = case (maybeLitWord n, maybeLitWord m) of + (Just c, Just d) -> continue (c, d) + _ -> vmError UnexpectedSymbolicArg + +forceConcrete3 :: (SymWord, SymWord, SymWord) -> ((Word, Word, Word) -> EVM ()) -> EVM () +forceConcrete3 (k,n,m) continue = case (maybeLitWord k, maybeLitWord n, maybeLitWord m) of + (Just c, Just d, Just f) -> continue (c, d, f) + _ -> vmError UnexpectedSymbolicArg + +forceConcrete4 :: (SymWord, SymWord, SymWord, SymWord) -> ((Word, Word, Word, Word) -> EVM ()) -> EVM () +forceConcrete4 (k,l,n,m) continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord n, maybeLitWord m) of + (Just b, Just c, Just d, Just f) -> continue (b, c, d, f) + _ -> vmError UnexpectedSymbolicArg + +forceConcrete5 :: (SymWord, SymWord, SymWord, SymWord, SymWord) -> ((Word, Word, Word, Word, Word) -> EVM ()) -> EVM () +forceConcrete5 (k,l,m,n,o) 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) + _ -> vmError UnexpectedSymbolicArg + +forceConcrete6 :: (SymWord, SymWord, SymWord, SymWord, SymWord, SymWord) -> ((Word, Word, Word, Word, Word, Word) -> EVM ()) -> EVM () +forceConcrete6 (k,l,m,n,o,p) 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) + _ -> vmError UnexpectedSymbolicArg + +forceConcreteBuffer :: Buffer -> (ByteString -> EVM ()) -> EVM () +forceConcreteBuffer (SymbolicBuffer b) continue = case maybeLitBytes b of + Nothing -> vmError UnexpectedSymbolicArg + Just bs -> continue bs +forceConcreteBuffer (ConcreteBuffer b) continue = continue b + +-- * Substate manipulation +refund :: Word -> EVM () +refund n = do + self <- use (state . contract) + pushTo (tx . substate . refunds) (self, n) + +unRefund :: Word -> 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) + +-- * Cheat codes + +-- The cheat code is 7109709ecfa91a80626ff3989d68f67f5b1dd12d. +-- Call this address using one of the cheatActions below to do +-- special things, e.g. changing the block timestamp. Beware that +-- these are necessarily hevm specific. +cheatCode :: Addr +cheatCode = num (keccak "hevm cheat code") + +cheat + :: (?op :: Word8) + => (Word, Word) -> (Word, Word) + -> EVM () +cheat (inOffset, inSize) (outOffset, outSize) = do + mem <- use (state . memory) + vm <- get + let + abi = readMemoryWord32 inOffset mem + input = readMemory (inOffset + 4) (inSize - 4) vm + case fromSized <$> unliteral abi of + Nothing -> vmError UnexpectedSymbolicArg + Just abi -> + case Map.lookup abi cheatActions of + Nothing -> + vmError (BadCheatCode (Just abi)) + Just (argTypes, action) -> + case input of + SymbolicBuffer _ -> vmError UnexpectedSymbolicArg + ConcreteBuffer input' -> + case runGetOrFail + (getAbiSeq (length argTypes) argTypes) + (LS.fromStrict input') of + Right ("", _, args) -> + action (toList args) >>= \case + Nothing -> do + next + push 1 + Just (encodeAbiValue -> bs) -> do + next + modifying (state . memory) + (writeMemory (ConcreteBuffer bs) outSize 0 outOffset) + push 1 + _ -> + vmError (BadCheatCode (Just abi)) + +type CheatAction = ([AbiType], [AbiValue] -> EVM (Maybe AbiValue)) + +cheatActions :: Map Word32 CheatAction +cheatActions = + Map.fromList + [ action "warp(uint256)" [AbiUIntType 256] $ + \[AbiUInt 256 x] -> do + assign (block . timestamp) (w256 (W256 x)) + return Nothing, + action "store(address,bytes32,bytes32)" [AbiAddressType, AbiBytesType 32, AbiBytesType 32] $ + \[AbiAddress a, AbiBytes 32 x, AbiBytes 32 y] -> do + let slot = w256lit $ word x + new = w256lit $ word y + fetchAccount a $ \_ -> do + modifying (env . contracts . ix a . storage) (writeStorage slot new) + return Nothing + ] + where + action s ts f = (abiKeccak s, (ts, f)) + +-- * General call implementation ("delegateCall") +delegateCall + :: (?op :: Word8) + => Contract -> Word -> Addr -> Addr -> Word -> Word -> Word -> Word -> Word -> [SymWord] + -> EVM () + -> EVM () +delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue = + callChecks this gasGiven xContext xValue xInOffset xInSize xOutOffset xOutSize xs $ + \xGas -> do + vm0 <- get + fetchAccount xTo . const $ + preuse (env . contracts . ix xTo) >>= \case + Nothing -> + vmError (NoSuchContract xTo) + Just target -> + burn xGas $ do + let newContext = CallContext + { callContextOffset = xOutOffset + , callContextSize = xOutSize + , callContextCodehash = view codehash target + , callContextReversion = view (env . contracts) vm0 + , callContextSubState = view (tx . substate) vm0 + , callContextAbi = + if xInSize >= 4 + then case unliteral $ readMemoryWord32 xInOffset (view (state . memory) vm0) + of Nothing -> Nothing + Just abi -> Just . w256 $ num abi + else Nothing + , callContextData = (readMemory (num xInOffset) (num xInSize) vm0) + } + + pushTrace (FrameTrace newContext) + next + vm1 <- get + + pushTo frames $ Frame + { _frameState = (set stack xs) (view state vm1) + , _frameContext = newContext + } + + zoom state $ do + assign gas xGas + assign pc 0 + assign code (view bytecode target) + assign codeContract xTo + assign stack mempty + assign memory mempty + assign memorySize 0 + assign returndata mempty + assign calldata (readMemory (num xInOffset) (num xInSize) vm0, literal (num xInSize)) + + continue + +-- -- * Contract creation + +-- EIP 684 +collision :: Maybe Contract -> Bool +collision c' = case c' of + Just c -> (view contractcode c /= RuntimeCode mempty) || (view nonce c /= 0) + Nothing -> False + +create :: (?op :: Word8) + => Addr -> Contract + -> Word -> Word -> [SymWord] -> Addr -> ByteString -> EVM () +create self this xGas xValue xs newAddr initCode = do + vm0 <- get + if xValue > view balance this + then do + assign (state . stack) (0 : xs) + assign (state . returndata) mempty + pushTrace $ ErrorTrace $ BalanceTooLow xValue (view balance this) + next + else if length (view frames vm0) >= 1024 + then do + assign (state . stack) (0 : xs) + assign (state . returndata) mempty + pushTrace $ ErrorTrace $ CallDepthLimitReached + next + else if collision $ view (env . contracts . at newAddr) vm0 + then burn xGas $ do + assign (state . stack) (0 : xs) + modifying (env . contracts . ix self . nonce) succ + next + else burn xGas $ do + touchAccount self + touchAccount newAddr + let + store = case view (env . storageModel) vm0 of + ConcreteS -> Concrete mempty + SymbolicS -> Symbolic $ sListArray 0 [] + InitialS -> Symbolic $ sListArray 0 [] + newContract = + initialContract (InitCode initCode) & set storage store + newContext = + CreationContext { creationContextCodehash = view codehash newContract + , creationContextReversion = view (env . contracts) vm0 + , creationContextSubstate = view (tx . substate) vm0 + } + + zoom (env . contracts) $ do + oldAcc <- use (at newAddr) + let oldBal = case oldAcc of + Nothing -> 0 + Just c -> view balance c + assign (at newAddr) (Just newContract) + assign (ix newAddr . balance) (oldBal + xValue) + assign (ix newAddr . nonce) 1 + modifying (ix self . balance) (flip (-) xValue) + modifying (ix self . nonce) succ + + pushTrace (FrameTrace newContext) + next + vm1 <- get + pushTo frames $ Frame + { _frameContext = newContext + , _frameState = (set stack xs) (view state vm1) + } + + assign state $ + blankState + & set contract newAddr + & set codeContract newAddr + & set code initCode + & set callvalue (litWord 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 (view contractcode now) of + InitCode _ -> + put . Just $ + initialContract newCode + & set storage (view storage now) + & set balance (view balance now) + & set nonce (view nonce now) + RuntimeCode _ -> + error "internal error: can't replace code of deployed contract" + Nothing -> + error "internal error: can't replace code of nonexistent contract" + +replaceCodeOfSelf :: ContractCode -> EVM () +replaceCodeOfSelf newCode = do + vm <- get + replaceCode (view (state . contract) vm) newCode + +resetState :: EVM () +resetState = do + assign result Nothing + assign frames [] + assign state blankState + + +-- * VM error implementation + +vmError :: Error -> EVM () +vmError e = finishFrame (FrameErrored e) + +underrun :: EVM () +underrun = vmError StackUnderrun + +-- | A stack frame can be popped in three ways. +data FrameResult + = FrameReturned Buffer -- ^ STOP, RETURN, or no more code + | FrameReverted Buffer -- ^ REVERT + | FrameErrored Error -- ^ Any other error + deriving Show + +-- | This function defines how to pop the current stack frame in either of +-- the ways specified by 'FrameResult'. +-- +-- It also handles the case when the current stack frame is the only one; +-- in this case, we set the final '_result' of the VM execution. +finishFrame :: FrameResult -> EVM () +finishFrame how = do + oldVm <- get + + case view frames oldVm of + -- Is the current frame the only one? + [] -> do + case how of + FrameReturned output -> assign result . Just $ VMSuccess output + FrameReverted buffer -> forceConcreteBuffer buffer $ \out -> assign result . Just $ VMFailure (Revert out) + FrameErrored e -> assign result . Just $ VMFailure e + finalize + + -- Are there some remaining frames? + nextFrame : remainingFrames -> do + + -- Pop the top frame. + assign frames remainingFrames + -- Install the state of the frame to which we shall return. + assign state (view frameState nextFrame) + -- Insert a debug trace. + insertTrace $ + case how of + FrameErrored e -> + ErrorTrace e + FrameReverted (ConcreteBuffer output) -> + ErrorTrace (Revert output) + FrameReverted (SymbolicBuffer output) -> + ErrorTrace (Revert (forceLitBytes output)) + FrameReturned output -> + ReturnTrace output (view frameContext nextFrame) + -- Pop to the previous level of the debug trace stack. + popTrace + + -- When entering a call, the gas allowance is counted as burned + -- in advance; this unburns the remainder and adds it to the + -- parent frame. + let remainingGas = view (state . gas) oldVm + reclaimRemainingGasAllowance = do + modifying burned (subtract remainingGas) + modifying (state . gas) (+ remainingGas) + + FeeSchedule {..} = view ( block . schedule ) oldVm + + -- Now dispatch on whether we were creating or calling, + -- and whether we shall return, revert, or error (six cases). + case view frameContext nextFrame of + + -- Were we calling? + CallContext (num -> outOffset) (num -> outSize) _ _ _ reversion substate' -> do + + let + 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 0 outOffset + reclaimRemainingGasAllowance + push 1 + + -- Case 2: Reverting during a call? + FrameReverted output -> do + revertContracts + revertSubstate + assign (state . returndata) output + copyCallBytesToMemory output outSize 0 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 = view (state . contract) oldVm + 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 -> + forceConcreteBuffer output $ \output' -> do + replaceCode createe (RuntimeCode output') + assign (state . returndata) mempty + reclaimRemainingGasAllowance + push (num createe) + + -- 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 + :: FeeSchedule Word + -> Word + -> Word + -> EVM () + -> EVM () +accessUnboundedMemoryRange _ _ 0 continue = continue +accessUnboundedMemoryRange fees f l continue = do + m0 <- num <$> use (state . memorySize) + do + let m1 = 32 * ceilDiv (max m0 (num f + num l)) 32 + burn (memoryCost fees m1 - memoryCost fees m0) $ do + assign (state . memorySize) (num m1) + continue + +accessMemoryRange + :: FeeSchedule Word + -> Word + -> Word + -> EVM () + -> EVM () +accessMemoryRange _ _ 0 continue = continue +accessMemoryRange fees f l continue = + if f + l < l + then vmError IllegalOverflow + else accessUnboundedMemoryRange fees f l continue + +accessMemoryWord + :: FeeSchedule Word -> Word -> EVM () -> EVM () +accessMemoryWord fees x = accessMemoryRange fees x 32 + +copyBytesToMemory + :: Buffer -> Word -> Word -> Word -> EVM () +copyBytesToMemory bs size xOffset yOffset = + if size == 0 then noop + else do + mem <- use (state . memory) + assign (state . memory) $ + writeMemory bs size xOffset yOffset mem + +copyCallBytesToMemory + :: Buffer -> Word -> Word -> Word -> EVM () +copyCallBytesToMemory bs size xOffset yOffset = + if size == 0 then noop + else do + mem <- use (state . memory) + assign (state . memory) $ + writeMemory bs (min size (num (len bs))) xOffset yOffset mem + +readMemory :: Word -> Word -> VM -> Buffer +readMemory offset size vm = sliceWithZero (num offset) (num size) (view (state . memory) vm) + +word256At + :: Functor f + => Word -> (SymWord -> f (SymWord)) + -> Buffer -> f Buffer +word256At i = lens getter setter where + getter = readMemoryWord i + setter m x = setMemoryWord i x m + +-- * Tracing + +withTraceLocation + :: (MonadState VM m) => TraceData -> m Trace +withTraceLocation x = do + vm <- get + let + Just this = + preview (env . contracts . ix (view (state . codeContract) vm)) vm + pure Trace + { _traceData = x + , _traceCodehash = view codehash this + , _traceOpIx = (view opIxMap this) Vector.! (view (state . pc) vm) + } + +pushTrace :: TraceData -> EVM () +pushTrace x = do + trace <- withTraceLocation x + modifying traces $ + \t -> Zipper.children $ Zipper.insert (Node trace []) t + +insertTrace :: TraceData -> EVM () +insertTrace x = do + trace <- withTraceLocation x + modifying traces $ + \t -> Zipper.nextSpace $ Zipper.insert (Node trace []) t + +popTrace :: EVM () +popTrace = + modifying traces $ + \t -> case Zipper.parent t of + Nothing -> error "internal error (trace root)" + Just t' -> Zipper.nextSpace t' + +zipperRootForest :: Zipper.TreePos Zipper.Empty a -> Forest a +zipperRootForest z = + case Zipper.parent z of + Nothing -> Zipper.toForest z + Just z' -> zipperRootForest (Zipper.nextSpace z') + +traceForest :: VM -> Forest Trace +traceForest = view (traces . to zipperRootForest) + +traceLog :: (MonadState VM m) => Log -> m () +traceLog log = do + trace <- withTraceLocation (EventTrace log) + modifying traces $ + \t -> Zipper.nextSpace (Zipper.insert (Node trace []) t) + +-- * Stack manipulation + +push :: Word -> EVM () +push = pushSym . w256lit . num + +pushSym :: SymWord -> EVM () +pushSym x = state . stack %= (x :) + + +stackOp1 + :: (?op :: Word8) + => ((SymWord) -> Word) + -> ((SymWord) -> (SymWord)) + -> EVM () +stackOp1 cost f = + use (state . stack) >>= \case + (x:xs) -> + burn (cost x) $ do + next + let !y = f x + state . stack .= y : xs + _ -> + underrun + +stackOp2 + :: (?op :: Word8) + => (((SymWord), (SymWord)) -> Word) + -> (((SymWord), (SymWord)) -> (SymWord)) + -> EVM () +stackOp2 cost f = + use (state . stack) >>= \case + (x:y:xs) -> + burn (cost (x, y)) $ do + next + state . stack .= f (x, y) : xs + _ -> + underrun + +stackOp3 + :: (?op :: Word8) + => (((SymWord), (SymWord), (SymWord)) -> Word) + -> (((SymWord), (SymWord), (SymWord)) -> (SymWord)) + -> EVM () +stackOp3 cost f = + use (state . stack) >>= \case + (x:y:z:xs) -> + burn (cost (x, y, z)) $ do + next + state . stack .= f (x, y, z) : xs + _ -> + underrun + +-- * Bytecode data functions + +checkJump :: (Integral n) => n -> [SymWord] -> EVM () +checkJump x xs = do + theCode <- use (state . code) + self <- use (state . codeContract) + theCodeOps <- use (env . contracts . ix self . codeOps) + if x < num (BS.length theCode) && BS.index theCode (num x) == 0x5b + then + case RegularVector.find (\(i, op) -> i == num x && op == OpJumpdest) theCodeOps of + Nothing -> vmError BadJumpDestination + _ -> do + state . stack .= xs + state . pc .= num x + else vmError BadJumpDestination + +opSize :: Word8 -> Int +opSize x | x >= 0x60 && x <= 0x7f = num x - 0x60 + 2 +opSize _ = 1 + +-- Index 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 :: ByteString -> Vector Int +mkOpIxMap xs = Vector.create $ Vector.new (BS.length xs) >>= \v -> + -- Loop over the byte string accumulating a vector-mutating action. + -- This is somewhat obfuscated, but should be fast. + let (_, _, _, m) = + BS.foldl' (go v) (0 :: Word8, 0, 0, return ()) xs + in m >> return v + where + go v (0, !i, !j, !m) x | x >= 0x60 && x <= 0x7f = + {- Start of PUSH op. -} (x - 0x60 + 1, i + 1, j, m >> Vector.write v i j) + go v (1, !i, !j, !m) _ = + {- End of PUSH op. -} (0, i + 1, j + 1, m >> Vector.write v i j) + go v (0, !i, !j, !m) _ = + {- Other op. -} (0, i + 1, j + 1, m >> Vector.write v i j) + go v (n, !i, !j, !m) _ = + {- PUSH data. -} (n - 1, i + 1, j, m >> Vector.write v i j) + +vmOp :: VM -> Maybe Op +vmOp vm = + let i = vm ^. state . pc + xs = BS.drop i (vm ^. state . code) + op = BS.index xs 0 + in if BS.null xs + then Nothing + else Just (readOp op (BS.drop 1 xs)) + +vmOpIx :: VM -> Maybe Int +vmOpIx vm = + do self <- currentContract vm + (view opIxMap self) Vector.!? (view (state . pc) vm) + +opParams :: VM -> Map String (SymWord) +opParams vm = + case vmOp vm of + Just OpCreate -> + params $ words "value offset size" + Just OpCall -> + params $ words "gas to value in-offset in-size out-offset out-size" + Just OpSstore -> + params $ words "index value" + Just OpCodecopy -> + params $ words "mem-offset code-offset code-size" + Just OpSha3 -> + params $ words "offset size" + Just OpCalldatacopy -> + params $ words "to from size" + Just OpExtcodecopy -> + params $ words "account mem-offset code-offset code-size" + Just OpReturn -> + params $ words "offset size" + Just OpJumpi -> + params $ words "destination condition" + _ -> mempty + where + params xs = + if length (vm ^. state . stack) >= length xs + then Map.fromList (zip xs (vm ^. state . stack)) + else mempty + +readOp :: Word8 -> ByteString -> Op +readOp x _ | x >= 0x80 && x <= 0x8f = OpDup (x - 0x80 + 1) +readOp x _ | x >= 0x90 && x <= 0x9f = OpSwap (x - 0x90 + 1) +readOp x _ | x >= 0xa0 && x <= 0xa4 = OpLog (x - 0xa0) +readOp x xs | x >= 0x60 && x <= 0x7f = + let n = x - 0x60 + 1 + xs' = BS.take (num n) xs + in OpPush (word xs') +readOp x _ = case x of + 0x00 -> OpStop + 0x01 -> OpAdd + 0x02 -> OpMul + 0x03 -> OpSub + 0x04 -> OpDiv + 0x05 -> OpSdiv + 0x06 -> OpMod + 0x07 -> OpSmod + 0x08 -> OpAddmod + 0x09 -> OpMulmod + 0x0a -> OpExp + 0x0b -> OpSignextend + 0x10 -> OpLt + 0x11 -> OpGt + 0x12 -> OpSlt + 0x13 -> OpSgt + 0x14 -> OpEq + 0x15 -> OpIszero + 0x16 -> OpAnd + 0x17 -> OpOr + 0x18 -> OpXor + 0x19 -> OpNot + 0x1a -> OpByte + 0x1b -> OpShl + 0x1c -> OpShr + 0x1d -> OpSar + 0x20 -> OpSha3 + 0x30 -> OpAddress + 0x31 -> OpBalance + 0x32 -> OpOrigin + 0x33 -> OpCaller + 0x34 -> OpCallvalue + 0x35 -> OpCalldataload + 0x36 -> OpCalldatasize + 0x37 -> OpCalldatacopy + 0x38 -> OpCodesize + 0x39 -> OpCodecopy + 0x3a -> OpGasprice + 0x3b -> OpExtcodesize + 0x3c -> OpExtcodecopy + 0x3d -> OpReturndatasize + 0x3e -> OpReturndatacopy + 0x3f -> OpExtcodehash + 0x40 -> OpBlockhash + 0x41 -> OpCoinbase + 0x42 -> OpTimestamp + 0x43 -> OpNumber + 0x44 -> OpDifficulty + 0x45 -> OpGaslimit + 0x46 -> OpChainid + 0x47 -> OpSelfbalance + 0x50 -> OpPop + 0x51 -> OpMload + 0x52 -> OpMstore + 0x53 -> OpMstore8 + 0x54 -> OpSload + 0x55 -> OpSstore + 0x56 -> OpJump + 0x57 -> OpJumpi + 0x58 -> OpPc + 0x59 -> OpMsize + 0x5a -> OpGas + 0x5b -> OpJumpdest + 0xf0 -> OpCreate + 0xf1 -> OpCall + 0xf2 -> OpCallcode + 0xf3 -> OpReturn + 0xf4 -> OpDelegatecall + 0xf5 -> OpCreate2 + 0xfd -> OpRevert + 0xfa -> OpStaticcall + 0xff -> OpSelfdestruct + _ -> OpUnknown x + +mkCodeOps :: ByteString -> RegularVector.Vector (Int, Op) +mkCodeOps bytes = RegularVector.fromList . toList $ go 0 bytes + where + go !i !xs = + case BS.uncons xs of + Nothing -> + mempty + Just (x, xs') -> + let j = opSize x + in (i, readOp x xs') Seq.<| go (i + j) (BS.drop j xs) + +-- * Gas cost calculation helpers + +-- Gas cost function for CALL, transliterated from the Yellow Paper. +costOfCall + :: FeeSchedule Word + -> Bool -> Word -> Word -> Word + -> (Word, Word) +costOfCall (FeeSchedule {..}) recipientExists xValue availableGas xGas = + (c_gascap + c_extra, c_callgas) + where + c_extra = + num g_call + c_xfer + c_new + c_xfer = + if xValue /= 0 then num g_callvalue else 0 + c_callgas = + if xValue /= 0 then c_gascap + num g_callstipend else c_gascap + c_new = + if not recipientExists && xValue /= 0 + then num g_newaccount + else 0 + c_gascap = + if availableGas >= c_extra + then min xGas (allButOne64th (availableGas - c_extra)) + else xGas + +-- Gas cost of create, including hash cost if needed +costOfCreate + :: FeeSchedule Word + -> Word -> Word -> (Word, Word) +costOfCreate (FeeSchedule {..}) availableGas hashSize = + (createCost + initGas, initGas) + where + createCost = g_create + hashCost + hashCost = g_sha3word * ceilDiv (hashSize) 32 + initGas = allButOne64th (availableGas - createCost) + +-- Gas cost of precompiles +costOfPrecompile :: FeeSchedule Word -> Addr -> Buffer -> Word +costOfPrecompile (FeeSchedule {..}) precompileAddr input = + case precompileAddr of + -- ECRECOVER + 0x1 -> 3000 + -- SHA2-256 + 0x2 -> num $ (((len input + 31) `div` 32) * 12) + 60 + -- RIPEMD-160 + 0x3 -> num $ (((len input + 31) `div` 32) * 120) + 600 + -- IDENTITY + 0x4 -> num $ (((len input + 31) `div` 32) * 3) + 15 + -- MODEXP + 0x5 -> num $ (f (num (max lenm lenb)) * num (max lene' 1)) `div` (num g_quaddivisor) + where input' = case input of + SymbolicBuffer _ -> error "unsupported: symbolic MODEXP gas cost calc" + ConcreteBuffer b -> b + (lenb, lene, lenm) = parseModexpLength input' + lene' | lene <= 32 && ez = 0 + | lene <= 32 = num (log2 e') + | e' == 0 = 8 * (lene - 32) + | otherwise = num (log2 e') + 8 * (lene - 32) + + ez = isZero (96 + lenb) lene input' + e' = w256 $ word $ LS.toStrict $ + lazySlice (96 + lenb) (min 32 lene) input' + + f :: Integer -> Integer + f x | x <= 64 = x * x + | x <= 1024 = (x * x) `div` 4 + 96 * x - 3072 + | otherwise = (x * x) `div` 16 + 480 * x - 199680 + -- ECADD + 0x6 -> g_ecadd + -- ECMUL + 0x7 -> g_ecmul + -- ECPAIRING + 0x8 -> num $ ((len input) `div` 192) * (num g_pairing_point) + (num g_pairing_base) + -- BLAKE2 + 0x9 -> let input' = case input of + SymbolicBuffer _ -> error "unsupported: symbolic BLAKE2B gas cost calc" + ConcreteBuffer b -> b + in g_fround * (num $ asInteger $ lazySlice 0 4 input') + _ -> error ("unimplemented precompiled contract " ++ show precompileAddr) + +-- Gas cost of memory expansion +memoryCost :: FeeSchedule Word -> Word -> Word +memoryCost FeeSchedule{..} byteCount = + let + wordCount = ceilDiv byteCount 32 + linearCost = g_memory * wordCount + quadraticCost = div (wordCount * wordCount) 512 + in + linearCost + quadraticCost + +-- * Uninterpreted functions + +symSHA256N :: SInteger -> SInteger -> SWord 256 +symSHA256N = uninterpret "sha256" + +symkeccakN :: SInteger -> SInteger -> SWord 256 +symkeccakN = uninterpret "keccak" + +toSInt :: [SWord 8] -> SInteger +toSInt bs = sum $ zipWith (\a i -> sFromIntegral a * 256 ^ i) bs [0..] + +-- | Although we'd like to define this directly as an uninterpreted function, +-- we cannot because [a] is not a symbolic type. We must convert the list into a suitable +-- symbolic type first. The only important property of this conversion is that it is injective. +-- We embedd the bytestring as a pair of symbolic integers, this is a fairly easy solution. +symkeccak' :: [SWord 8] -> SWord 256 +symkeccak' bytes = case length bytes of + 0 -> literal $ toSizzle $ keccak "" + n -> symkeccakN (num n) (toSInt bytes) + +symSHA256 :: [SWord 8] -> [SWord 8] +symSHA256 bytes = case length bytes of + 0 -> litBytes $ BS.pack $ BA.unpack $ (Crypto.hash BS.empty :: Digest SHA256) + n -> toBytes $ symSHA256N (num n) (toSInt bytes) + -- * Arithmetic diff --git a/src/EVM/ABI.hs b/src/EVM/ABI.hs --- a/src/EVM/ABI.hs +++ b/src/EVM/ABI.hs @@ -25,9 +25,7 @@ -} -{-# Language DeriveAnyClass #-} {-# Language StrictData #-} -{-# Language TemplateHaskell #-} module EVM.ABI ( AbiValue (..) @@ -38,35 +36,47 @@ , putAbi , getAbi , getAbiSeq + , genAbiValue , abiValueType , abiTypeSolidity , abiCalldata + , abiMethod + , emptyAbi , encodeAbiValue + , decodeAbiValue , parseTypeName + , makeAbiValue + , parseAbiValue + , selector ) where import EVM.Keccak (abiKeccak) -import EVM.Types () +import EVM.Types import Control.Monad (replicateM, replicateM_, forM_, void) -import Data.Binary.Get (Get, label, getWord8, getWord32be, skip) +import Data.Binary.Get (Get, runGet, label, getWord8, getWord32be, skip) import Data.Binary.Put (Put, runPut, putWord8, putWord32be) import Data.Bits (shiftL, shiftR, (.&.)) import Data.ByteString (ByteString) -import Data.DoubleWord (Word256, Int256, Word160, signedWord) +import Data.DoubleWord (Word256, Int256, signedWord) +import Data.Functor (($>)) import Data.Monoid ((<>)) import Data.Text (Text, pack) import Data.Text.Encoding (encodeUtf8) import Data.Vector (Vector) -import Data.Word (Word32, Word8) +import Data.Word (Word32) +import Data.List (intercalate) import GHC.Generics import Test.QuickCheck hiding ((.&.), label) +import Text.ParserCombinators.ReadP +import Control.Applicative -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSLazy -import qualified Data.Text as Text -import qualified Data.Vector as Vector +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString.Lazy as BSLazy +import qualified Data.Text as Text +import qualified Data.Vector as Vector import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P @@ -74,15 +84,32 @@ data AbiValue = AbiUInt Int Word256 | AbiInt Int Int256 - | AbiAddress Word160 + | AbiAddress Addr | AbiBool Bool | AbiBytes Int BS.ByteString | AbiBytesDynamic BS.ByteString | AbiString BS.ByteString | AbiArrayDynamic AbiType (Vector AbiValue) | AbiArray Int AbiType (Vector AbiValue) - deriving (Show, Read, Eq, Ord, Generic) + | AbiTuple (Vector AbiValue) + deriving (Read, Eq, Ord, Generic) +-- | Pretty-print some 'AbiValue'. +instance Show AbiValue where + show (AbiUInt _ n) = show n + show (AbiInt _ n) = show n + show (AbiAddress n) = show n + show (AbiBool b) = if b then "true" else "false" + show (AbiBytes _ b) = show (ByteStringS b) + show (AbiBytesDynamic b) = show (ByteStringS b) + show (AbiString s) = show s + show (AbiArrayDynamic _ v) = + "[" ++ intercalate ", " (show <$> Vector.toList v) ++ "]" + show (AbiArray _ _ v) = + "[" ++ intercalate ", " (show <$> Vector.toList v) ++ "]" + show (AbiTuple v) = + "(" ++ intercalate ", " (show <$> Vector.toList v) ++ ")" + data AbiType = AbiUIntType Int | AbiIntType Int @@ -93,8 +120,12 @@ | AbiStringType | AbiArrayDynamicType AbiType | AbiArrayType Int AbiType - deriving (Show, Read, Eq, Ord, Generic) + | AbiTupleType (Vector AbiType) + deriving (Read, Eq, Ord, Generic) +instance Show AbiType where + show = Text.unpack . abiTypeSolidity + data AbiKind = Dynamic | Static deriving (Show, Read, Eq, Ord, Generic) @@ -111,6 +142,7 @@ AbiStringType -> Dynamic AbiArrayDynamicType _ -> Dynamic AbiArrayType _ t -> abiKind t + AbiTupleType ts -> if Dynamic `elem` (abiKind <$> ts) then Dynamic else Static _ -> Static abiValueType :: AbiValue -> AbiType @@ -124,6 +156,7 @@ AbiString _ -> AbiStringType AbiArrayDynamic t _ -> AbiArrayDynamicType t AbiArray n t _ -> AbiArrayType n t + AbiTuple v -> AbiTupleType (abiValueType <$> v) abiTypeSolidity :: AbiType -> Text abiTypeSolidity = \case @@ -136,6 +169,7 @@ AbiStringType -> "string" AbiArrayDynamicType t -> abiTypeSolidity t <> "[]" AbiArrayType n t -> abiTypeSolidity t <> "[" <> pack (show n) <> "]" + AbiTupleType ts -> "(" <> (Text.intercalate "," . Vector.toList $ abiTypeSolidity <$> ts) <> ")" getAbi :: AbiType -> Get AbiValue getAbi t = label (Text.unpack (abiTypeSolidity t)) $ @@ -169,11 +203,13 @@ AbiArrayDynamic t' <$> label "array body" (getAbiSeq (fromIntegral n) (repeat t')) + AbiTupleType ts -> + AbiTuple <$> getAbiSeq (Vector.length ts) (Vector.toList ts) + putAbi :: AbiValue -> Put putAbi = \case - AbiUInt n x -> do - let word32Count = div (roundTo256Bits n) 4 - forM_ (reverse [0 .. word32Count - 1]) $ \i -> + AbiUInt _ x -> + forM_ (reverse [0 .. 7]) $ \i -> putWord32be (fromIntegral (shiftR x (i * 32) .&. 0xffffffff)) AbiInt n x -> putAbi (AbiUInt n (fromIntegral x)) @@ -182,7 +218,7 @@ AbiBytes n xs -> do forM_ [0 .. n-1] (putWord8 . BS.index xs) - replicateM_ (roundTo256Bits n - n) (putWord8 0) + replicateM_ (roundTo32Bytes n - n) (putWord8 0) AbiBytesDynamic xs -> do let n = BS.length xs @@ -199,6 +235,9 @@ putAbi (AbiUInt 256 (fromIntegral (Vector.length xs))) putAbiSeq xs + AbiTuple v -> + putAbiSeq v + getAbiSeq :: Int -> [AbiType] -> Get (Vector AbiValue) getAbiSeq n ts = label "sequence" $ do hs <- label "sequence head" (getAbiHead n ts) @@ -209,7 +248,7 @@ -> Get [Either AbiType AbiValue] getAbiHead 0 _ = pure [] getAbiHead _ [] = fail "ran out of types" -getAbiHead n (t:ts) = do +getAbiHead n (t:ts) = case abiKind t of Dynamic -> (Left t :) <$> (skip 32 *> getAbiHead (n - 1) ts) @@ -227,17 +266,18 @@ abiValueSize :: AbiValue -> Int abiValueSize x = case x of - AbiUInt n _ -> roundTo256Bits n - AbiInt n _ -> roundTo256Bits n - AbiBytes n _ -> roundTo256Bits n + AbiUInt _ _ -> 32 + AbiInt _ _ -> 32 + AbiBytes n _ -> roundTo32Bytes n AbiAddress _ -> 32 AbiBool _ -> 32 AbiArray _ _ xs -> Vector.sum (Vector.map abiHeadSize xs) + Vector.sum (Vector.map abiTailSize xs) - AbiBytesDynamic xs -> 32 + roundTo256Bits (BS.length xs) + AbiBytesDynamic xs -> 32 + roundTo32Bytes (BS.length xs) AbiArrayDynamic _ xs -> 32 + Vector.sum (Vector.map abiHeadSize xs) + Vector.sum (Vector.map abiTailSize xs) - AbiString s -> 32 + roundTo256Bits (BS.length s) + AbiString s -> 32 + roundTo32Bytes (BS.length s) + AbiTuple v -> sum (abiValueSize <$> v) abiTailSize :: AbiValue -> Int abiTailSize x = @@ -245,11 +285,15 @@ Static -> 0 Dynamic -> case x of - AbiString s -> 32 + roundTo256Bits (BS.length s) - AbiBytesDynamic s -> 32 + roundTo256Bits (BS.length s) + AbiString s -> 32 + roundTo32Bytes (BS.length s) + AbiBytesDynamic s -> 32 + roundTo32Bytes (BS.length s) AbiArrayDynamic _ xs -> 32 + Vector.sum (Vector.map abiValueSize xs) AbiArray _ _ xs -> Vector.sum (Vector.map abiValueSize xs) + AbiTuple v -> sum (headSize <$> v) + sum (abiTailSize <$> v) _ -> error "impossible" + where headSize y = if abiKind (abiValueType y) == Static + then abiValueSize y + else 32 abiHeadSize :: AbiValue -> Int abiHeadSize x = @@ -257,9 +301,9 @@ Dynamic -> 32 Static -> case x of - AbiUInt n _ -> roundTo256Bits n - AbiInt n _ -> roundTo256Bits n - AbiBytes n _ -> roundTo256Bits n + AbiUInt _ _ -> 32 + AbiInt _ _ -> 32 + AbiBytes n _ -> roundTo32Bytes n AbiAddress _ -> 32 AbiBool _ -> 32 AbiArray _ _ xs -> Vector.sum (Vector.map abiHeadSize xs) + @@ -267,6 +311,8 @@ AbiBytesDynamic _ -> 32 AbiArrayDynamic _ _ -> 32 AbiString _ -> 32 + AbiTuple v -> sum (abiHeadSize <$> v) + + sum (abiTailSize <$> v) putAbiSeq :: Vector AbiValue -> Put putAbiSeq xs = @@ -283,17 +329,28 @@ encodeAbiValue :: AbiValue -> BS.ByteString encodeAbiValue = BSLazy.toStrict . runPut . putAbi +decodeAbiValue :: AbiType -> BSLazy.ByteString -> AbiValue +decodeAbiValue = runGet . getAbi + +selector :: Text -> BS.ByteString +selector s = BSLazy.toStrict . runPut $ putWord32be (abiKeccak (encodeUtf8 s)) + +abiMethod :: Text -> AbiValue -> BS.ByteString +abiMethod s args = BSLazy.toStrict . runPut $ do + putWord32be (abiKeccak (encodeUtf8 s)) + putAbi args + abiCalldata :: Text -> Vector AbiValue -> BS.ByteString abiCalldata s xs = BSLazy.toStrict . runPut $ do putWord32be (abiKeccak (encodeUtf8 s)) putAbiSeq xs -parseTypeName :: Text -> Maybe AbiType -parseTypeName = P.parseMaybe typeWithArraySuffix +parseTypeName :: Vector AbiType -> Text -> Maybe AbiType +parseTypeName = P.parseMaybe . typeWithArraySuffix -typeWithArraySuffix :: P.Parsec () Text AbiType -typeWithArraySuffix = do - base <- basicType +typeWithArraySuffix :: Vector AbiType -> P.Parsec () Text AbiType +typeWithArraySuffix v = do + base <- basicType v sizes <- P.many $ P.between @@ -301,24 +358,25 @@ (P.many P.digitChar) let - parseSize :: AbiType -> [Char] -> AbiType + parseSize :: AbiType -> String -> AbiType parseSize t "" = AbiArrayDynamicType t parseSize t s = AbiArrayType (read s) t pure (foldl parseSize base sizes) -basicType :: P.Parsec () Text AbiType -basicType = +basicType :: Vector AbiType -> P.Parsec () Text AbiType +basicType v = P.choice - [ P.string "address" *> pure AbiAddressType - , P.string "bool" *> pure AbiBoolType - , P.string "string" *> pure AbiStringType + [ P.string "address" $> AbiAddressType + , P.string "bool" $> AbiBoolType + , P.string "string" $> AbiStringType , sizedType "uint" AbiUIntType , sizedType "int" AbiIntType , sizedType "bytes" AbiBytesType - , P.string "bytes" *> pure AbiBytesDynamicType + , P.string "bytes" $> AbiBytesDynamicType + , P.string "tuple" $> AbiTupleType v ] where @@ -332,24 +390,22 @@ sum [ shiftL x ((n - i) * 32) | (x, i) <- zip (map fromIntegral xs) [1..] ] -pack8 :: Int -> [Word8] -> Word256 -pack8 n xs = - sum [ shiftL x ((n - i) * 8) - | (x, i) <- zip (map fromIntegral xs) [1..] ] - asUInt :: Integral i => Int -> (i -> a) -> Get a asUInt n f = (\(AbiUInt _ x) -> f (fromIntegral x)) <$> getAbi (AbiUIntType n) getWord256 :: Get Word256 getWord256 = pack32 8 <$> replicateM 8 getWord32be -roundTo256Bits :: Integral a => a -> a -roundTo256Bits n = 32 * div (n + 255) 256 +roundTo32Bytes :: Integral a => a -> a +roundTo32Bytes n = 32 * div (n + 31) 32 +emptyAbi :: AbiValue +emptyAbi = AbiTuple mempty + getBytesWith256BitPadding :: Integral a => a -> Get ByteString getBytesWith256BitPadding i = (BS.pack <$> replicateM n getWord8) - <* skip ((roundTo256Bits n) - n) + <* skip ((roundTo32Bytes n) - n) where n = fromIntegral i -- QuickCheck instances @@ -358,9 +414,9 @@ genAbiValue = \case AbiUIntType n -> genUInt n AbiIntType n -> - do AbiUInt _ x <- genUInt n - b <- arbitrary - pure $ AbiInt n (signedWord x * if b then 1 else -1) + do a <- genUInt n + let AbiUInt _ x = a + pure $ AbiInt n (signedWord x) AbiAddressType -> (\(AbiUInt _ x) -> AbiAddress (fromIntegral x)) <$> genUInt 20 AbiBoolType -> @@ -378,14 +434,13 @@ AbiArrayType n t -> AbiArray n t . Vector.fromList <$> replicateM n (scale (`div` 2) (genAbiValue t)) + AbiTupleType ts -> + AbiTuple <$> mapM genAbiValue ts where - genUInt n = - do x <- pack8 (div n 8) <$> replicateM n arbitrary - pure . AbiUInt n $ - if n == 256 then x else mod x (2 ^ n) + genUInt n = AbiUInt n <$> arbitraryIntegralWithMax n instance Arbitrary AbiType where - arbitrary = oneof + arbitrary = sized $ \n -> oneof $ -- prevent empty tuples [ (AbiUIntType . (* 8)) <$> choose (1, 32) , (AbiIntType . (* 8)) <$> choose (1, 32) , pure AbiAddressType @@ -397,7 +452,10 @@ , AbiArrayType <$> (getPositive <$> arbitrary) <*> scale (`div` 2) arbitrary - ] + ] <> + [AbiTupleType + <$> scale (`div` 2) (Vector.fromList <$> arbitrary) + | n /= 0] instance Arbitrary AbiValue where arbitrary = arbitrary >>= genAbiValue @@ -406,8 +464,83 @@ 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) + + +-- Bool synonym with custom read instance +-- to be able to parse lower case 'false' and 'true' +data Boolz = Boolz Bool + +instance Read Boolz where + readsPrec _ ('T':'r':'u':'e':x) = [(Boolz True, x)] + readsPrec _ ('t':'r':'u':'e':x) = [(Boolz True, x)] + readsPrec _ ('f':'a':'l':'s':'e':x) = [(Boolz False, x)] + readsPrec _ ('F':'a':'l':'s':'e':x) = [(Boolz False, x)] + readsPrec _ [] = [] + readsPrec n (_:t) = readsPrec n t + +makeAbiValue :: AbiType -> String -> AbiValue +makeAbiValue typ str = case readP_to_S (parseAbiValue typ) str of + [] -> error "could not parse abi arguments" + ((val,_):_) -> val + +parseAbiValue :: AbiType -> ReadP AbiValue +parseAbiValue (AbiUIntType n) = do W256 w256 <- readS_to_P reads + return $ AbiUInt n w256 +parseAbiValue (AbiIntType n) = do W256 w256 <- readS_to_P reads + return $ AbiInt n (num w256) +parseAbiValue AbiAddressType = AbiAddress <$> readS_to_P reads +parseAbiValue AbiBoolType = (do W256 w256 <- readS_to_P reads + return $ AbiBool (w256 /= 0)) + <|> (do Boolz b <- readS_to_P reads + return $ AbiBool b) +parseAbiValue (AbiBytesType n) = AbiBytes n <$> do ByteStringS bytes <- readS_to_P reads + return bytes +parseAbiValue AbiBytesDynamicType = AbiBytesDynamic <$> do ByteStringS bytes <- readS_to_P reads + return bytes +parseAbiValue AbiStringType = AbiString <$> do Char8.pack <$> readS_to_P reads +parseAbiValue (AbiArrayDynamicType typ) = + AbiArrayDynamic typ <$> do a <- listP (parseAbiValue typ) + return $ Vector.fromList a +parseAbiValue (AbiArrayType n typ) = + AbiArray n typ <$> do a <- listP (parseAbiValue typ) + return $ Vector.fromList a +parseAbiValue (AbiTupleType _) = error "tuple types not supported" + +listP :: ReadP a -> ReadP [a] +listP parser = between (char '[') (char ']') ((do skipSpaces + a <- parser + skipSpaces + return a) `sepBy` (char ',')) + + +-- A modification of 'arbitrarySizedBoundedIntegral' quickcheck library +-- which takes the maxbound explicitly rather than relying on a Bounded instance. +-- Essentially a mix between three types of generators: +-- one that strongly prefers values close to 0, one that prefers values close to max +-- and one that chooses uniformly. +arbitraryIntegralWithMax :: (Integral a) => Int -> Gen a +arbitraryIntegralWithMax maxbound = + sized $ \s -> + do let mn = 0 :: Int + mx = maxbound + bits n | n `quot` 2 == 0 = 0 + | otherwise = 1 + bits (n `quot` 2) + k = 2^(s*(bits mn `max` bits mx `max` 40) `div` 100) + smol <- choose (toInteger mn `max` (-k), toInteger mx `min` k) + mid <- choose (0, maxbound) + elements [fromIntegral smol, fromIntegral mid, fromIntegral (maxbound - (fromIntegral smol))] diff --git a/src/EVM/Concrete.hs b/src/EVM/Concrete.hs --- a/src/EVM/Concrete.hs +++ b/src/EVM/Concrete.hs @@ -1,19 +1,17 @@ {-# Language FlexibleInstances #-} -{-# Language StandaloneDeriving #-} {-# Language StrictData #-} module EVM.Concrete where -import Prelude hiding (Word, (^)) +import Prelude hiding (Word) -import EVM.Types (W256 (..), num, toWord512, fromWord512) -import EVM.Types (word, padRight, byteAt) import EVM.Keccak (keccak) +import EVM.RLP +import EVM.Types (Addr, W256 (..), num, word, padRight, word160Bytes, word256Bytes) import Control.Lens ((^?), ix) -import Data.Bits (Bits (..), FiniteBits (..)) +import Data.Bits (Bits (..), FiniteBits (..), shiftL, shiftR) import Data.ByteString (ByteString) -import Data.DoubleWord (signedWord, unsignedWord) import Data.Maybe (fromMaybe) import Data.Semigroup ((<>)) import Data.Word (Word8) @@ -24,9 +22,6 @@ wordAt i bs = word (padRight 32 (BS.drop i bs)) -word256Bytes :: W256 -> ByteString -word256Bytes x = BS.pack [byteAt x (31 - i) | i <- [0..31]] - readByteOrZero :: Int -> ByteString -> Word8 readByteOrZero i bs = fromMaybe 0 (bs ^? ix i) @@ -34,84 +29,49 @@ 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 -data Whiff = Dull | FromKeccak ByteString +-- | This type can give insight into the provenance of a term +data Whiff = Dull + | FromKeccak ByteString + | Var String + | InfixBinOp String Whiff Whiff + | BinOp String Whiff Whiff + | UnOp String Whiff deriving Show w256 :: W256 -> Word w256 = C Dull -data Word = C Whiff W256 - -wordToByte :: Word -> Word8 -wordToByte (C _ x) = num (x .&. 0xff) - -exponentiate :: Word -> Word -> Word -exponentiate (C _ x) (C _ y) = w256 (x ^ y) - -sdiv :: Word -> Word -> Word -sdiv _ (C _ (W256 0)) = 0 -sdiv (C _ (W256 x)) (C _ (W256 y)) = - let sx = signedWord x - sy = signedWord y - in w256 . W256 . unsignedWord $ quot sx sy - -smod :: Word -> Word -> Word -smod _ (C _ (W256 0)) = 0 -smod (C _ (W256 x)) (C _ (W256 y)) = - let sx = signedWord x - sy = signedWord y - in w256 . W256 . unsignedWord $ rem sx sy - -addmod :: Word -> Word -> Word -> Word -addmod _ _ (C _ (W256 0)) = 0 -addmod (C _ x) (C _ y) (C _ z) = - w256 $ - fromWord512 - ((toWord512 x + toWord512 y) `mod` (toWord512 z)) - -mulmod :: Word -> Word -> Word -> Word -mulmod _ _ (C _ (W256 0)) = 0 -mulmod (C _ x) (C _ y) (C _ z) = - w256 $ - fromWord512 - ((toWord512 x * toWord512 y) `mod` (toWord512 z)) - -slt :: Word -> Word -> Word -slt (C _ (W256 x)) (C _ (W256 y)) = - if signedWord x < signedWord y then w256 1 else w256 0 - -sgt :: Word -> Word -> Word -sgt (C _ (W256 x)) (C _ (W256 y)) = - if signedWord x > signedWord y then w256 1 else w256 0 +data Word = C Whiff W256 --maybe to remove completely in the future wordValue :: Word -> W256 wordValue (C _ x) = x sliceMemory :: (Integral a, Integral b) => a -> b -> ByteString -> ByteString -sliceMemory o s m = - byteStringSliceWithDefaultZeroes (num o) (num s) m +sliceMemory o s = + byteStringSliceWithDefaultZeroes (num o) (num s) writeMemory :: ByteString -> Word -> Word -> Word -> ByteString -> ByteString writeMemory bs1 (C _ n) (C _ src) (C _ dst) bs0 = - if src > num (BS.length bs1) - then - let - (a, b) = BS.splitAt (num dst) bs0 - c = BS.replicate (num n) 0 - b' = BS.drop (num n) b - in - a <> c <> b' - else - let - (a, b) = BS.splitAt (num dst) bs0 - c = BS.take (num n) (BS.drop (num src) bs1) - b' = BS.drop (num n) b - in - a <> BS.replicate (num dst - BS.length a) 0 <> c <> b' + let + (a, b) = BS.splitAt (num dst) bs0 + a' = BS.replicate (num dst - BS.length a) 0 + -- sliceMemory should work for both cases, but we are using 256 bit + -- words, whereas ByteString is only defined up to 64 bit. For large n, + -- src, dst this will cause problems (often in GeneralStateTests). + -- Later we could reimplement ByteString for 256 bit arguments. + c = if src > num (BS.length bs1) + then BS.replicate (num n) 0 + else sliceMemory src n bs1 + b' = BS.drop (num n) b + in + a <> a' <> c <> b' readMemoryWord :: Word -> ByteString -> Word readMemoryWord (C _ i) m = @@ -119,7 +79,7 @@ go !a (-1) = a go !a !n = go (a + shiftL (num $ readByteOrZero (num i + n) m) (8 * (31 - n))) (n - 1) - in {-# SCC readMemoryWord #-} + in {-# SCC "readMemoryWord" #-} w256 $ go (0 :: W256) (31 :: Int) readMemoryWord32 :: Word -> ByteString -> Word @@ -128,16 +88,16 @@ go !a (-1) = a go !a !n = go (a + shiftL (num $ readByteOrZero (num i + n) m) (8 * (3 - n))) (n - 1) - in {-# SCC readMemoryWord32 #-} + in {-# SCC "readMemoryWord32" #-} w256 $ go (0 :: W256) (3 :: Int) setMemoryWord :: Word -> Word -> ByteString -> ByteString -setMemoryWord (C _ i) (C _ x) m = - writeMemory (word256Bytes x) 32 0 (num i) m +setMemoryWord (C _ i) (C _ x) = + writeMemory (word256Bytes x) 32 0 (num i) setMemoryByte :: Word -> Word8 -> ByteString -> ByteString -setMemoryByte (C _ i) x m = - writeMemory (BS.singleton x) 1 0 (num i) m +setMemoryByte (C _ i) x = + writeMemory (BS.singleton x) 1 0 (num i) readBlobWord :: Word -> ByteString -> Word readBlobWord (C _ i) x = @@ -153,6 +113,10 @@ instance Show Word where show (C Dull x) = show x + show (C (Var var) x) = var ++ ": " ++ show x + show (C (InfixBinOp symbol x y) z) = show x ++ symbol ++ show y ++ ": " ++ show z + show (C (BinOp symbol x y) z) = symbol ++ show x ++ show y ++ ": " ++ show z + show (C (UnOp symbol x) z) = symbol ++ show x ++ ": " ++ show z show (C whiff x) = show whiff ++ ": " ++ show x instance Read Word where @@ -171,7 +135,7 @@ bitSize (C _ x) = bitSize x bitSizeMaybe (C _ x) = bitSizeMaybe x isSigned (C _ x) = isSigned x - testBit (C _ x) i = testBit x i + testBit (C _ x) = testBit x bit i = w256 (bit i) popCount (C _ x) = popCount x @@ -225,3 +189,10 @@ 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 = num $ keccak $ rlpList [rlpWord160 a, rlpWord256 n] + +create2Address :: Addr -> W256 -> ByteString -> Addr +create2Address a s b = num $ keccak $ mconcat + [BS.singleton 0xff, word160Bytes a, word256Bytes $ num 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 @@ -3,11 +3,11 @@ module EVM.Dapp where import EVM (Trace, traceCodehash, traceOpIx) -import EVM.ABI (Event) +import EVM.ABI (Event, AbiType) import EVM.Debug (srcMapCodePos) import EVM.Keccak (abiKeccak) import EVM.Solidity (SolcContract, CodeType (..), SourceCache, SrcMap) -import EVM.Solidity (contractName) +import EVM.Solidity (contractName, methodInputs) import EVM.Solidity (runtimeCodehash, creationCodehash, abiMap) import EVM.Solidity (runtimeSrcmap, creationSrcmap, eventMap) import EVM.Solidity (methodSignature, contractAst, astIdMap, astSrcMap) @@ -19,8 +19,8 @@ import Data.Map (Map) import Data.Monoid ((<>)) import Data.Word (Word32) -import Data.List (sort) +import Control.Applicative ((<$>)) import Control.Arrow ((>>>)) import Control.Lens @@ -31,10 +31,10 @@ , _dappSolcByName :: Map Text SolcContract , _dappSolcByHash :: Map W256 (CodeType, SolcContract) , _dappSources :: SourceCache - , _dappUnitTests :: [(Text, [Text])] + , _dappUnitTests :: [(Text, [(Text, [AbiType])])] , _dappEventMap :: Map W256 Event , _dappAstIdMap :: Map Int Value - , _dappAstSrcMap :: (SrcMap -> Maybe Value) + , _dappAstSrcMap :: SrcMap -> Maybe Value } makeLenses ''DappInfo @@ -70,24 +70,23 @@ unitTestMarkerAbi :: Word32 unitTestMarkerAbi = abiKeccak (encodeUtf8 "IS_TEST()") -findUnitTests :: (Text -> Bool) -> ([SolcContract] -> [(Text, [Text])]) +findUnitTests :: (Text -> Bool) -> ([SolcContract] -> [(Text, [(Text, [AbiType])])]) findUnitTests matcher = concatMap $ \c -> case preview (abiMap . ix unitTestMarkerAbi) c of Nothing -> [] Just _ -> - let testNames = (unitTestMethods matcher) c - in if null testNames - then [] - else [(view contractName c, testNames)] + let testNames = unitTestMethodsFiltered matcher c + in ([(view contractName c, testNames) | not (null testNames)]) -unitTestMethods :: (Text -> Bool) -> (SolcContract -> [Text]) -unitTestMethods matcher = - view abiMap - >>> Map.elems - >>> map (view methodSignature) - >>> filter matcher - >>> sort +unitTestMethodsFiltered :: (Text -> Bool) -> (SolcContract -> [(Text, [AbiType])]) +unitTestMethodsFiltered matcher c = filter (matcher . fst) $ unitTestMethods c + +unitTestMethods :: SolcContract -> [(Text, [AbiType])] +unitTestMethods = view abiMap + >>> Map.elems + >>> map (\f -> (view methodSignature f, + snd <$> view methodInputs f)) traceSrcMap :: DappInfo -> Trace -> Maybe SrcMap traceSrcMap dapp trace = diff --git a/src/EVM/Debug.hs b/src/EVM/Debug.hs --- a/src/EVM/Debug.hs +++ b/src/EVM/Debug.hs @@ -1,9 +1,7 @@ module EVM.Debug where -import EVM (Contract, storage, nonce, balance) -import EVM (bytecode, codehash, bytecode) -import EVM.Solidity (SrcMap, srcMapFile, srcMapOffset, srcMapLength) -import EVM.Solidity (SourceCache, sourceFiles) +import EVM (Contract, storage, nonce, balance, bytecode, codehash) +import EVM.Solidity (SrcMap, srcMapFile, srcMapOffset, srcMapLength, SourceCache, sourceFiles) import EVM.Types (Addr) import Control.Arrow (second) @@ -29,7 +27,7 @@ prettyContract :: Contract -> Doc prettyContract c = - object $ + object [ (text "codesize", int (ByteString.length (c ^. bytecode))) , (text "codehash", text (show (c ^. codehash))) , (text "balance", int (fromIntegral (c ^. balance))) @@ -40,7 +38,7 @@ prettyContracts :: Map Addr Contract -> Doc prettyContracts x = - object $ + object (map (\(a, b) -> (text (show a), prettyContract b)) (Map.toList x)) diff --git a/src/EVM/Demand.hs b/src/EVM/Demand.hs new file mode 100644 --- /dev/null +++ b/src/EVM/Demand.hs @@ -0,0 +1,13 @@ +module EVM.Demand (demand) where + +import Control.DeepSeq (NFData, force) +import Control.Exception.Base (evaluate) +import Control.Monad.IO.Class (MonadIO, liftIO) + +-- | This is an easy way to force full evaluation of a value inside of +-- the IO monad, being essentially just the composition of @evaluate@ +-- and @force@. +demand :: (MonadIO m, NFData a) => a -> m () +demand x = do + _ <- liftIO (evaluate (force x)) + return () diff --git a/src/EVM/Dev.hs b/src/EVM/Dev.hs --- a/src/EVM/Dev.hs +++ b/src/EVM/Dev.hs @@ -11,17 +11,21 @@ import qualified EVM.Emacs import qualified EVM.Facts as Facts import qualified EVM.Facts.Git as Git +import qualified EVM.Stepper +import qualified EVM.VMTest as VMTest +import Control.Monad.State.Strict (execStateT) import Data.Text (isPrefixOf) import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as LazyByteString loadDappInfo :: String -> String -> IO DappInfo loadDappInfo path file = withCurrentDirectory path $ readSolc file >>= \case - Just (contractMap, cache) -> do + Just (contractMap, cache) -> pure (dappInfo "." contractMap cache) _ -> error "nope, sorry" @@ -40,8 +44,11 @@ let opts = UnitTestOptions { oracle = EVM.Fetch.zero - , verbose = False + , verbose = Nothing + , maxIter = Nothing , match = "" + , fuzzRuns = 100 + , replay = Nothing , vmModifier = loadFacts , testParams = params } @@ -53,6 +60,26 @@ Nothing -> error ("Failed to read Solidity JSON for `" ++ path ++ "'") +runBCTest :: (String, VMTest.Case) -> IO Bool +runBCTest (name, x) = do + let vm0 = VMTest.vmForCase x + putStr (name ++ " ") + result <- + execStateT (EVM.Stepper.interpret EVM.Fetch.zero EVM.Stepper.execFully) vm0 + ok <- VMTest.checkExpectation False x result + putStrLn (if ok then "ok" else "") + return ok + +ghciBCTest :: String -> IO () +ghciBCTest file = do + let parser = VMTest.parseBCSuite + parsed <- parser <$> LazyByteString.readFile file + case parsed of + Left "No cases to check." -> putStrLn "no-cases ok" + Left err -> print err + Right allTests -> + mapM_ runBCTest (Map.toList allTests) + ghciTty :: String -> String -> Maybe String -> IO () ghciTty root path state = withCurrentDirectory root $ do @@ -67,8 +94,10 @@ let testOpts = UnitTestOptions { oracle = EVM.Fetch.zero - , verbose = False + , verbose = Nothing , match = "" + , fuzzRuns = 100 + , replay = Nothing , vmModifier = loadFacts , testParams = params } diff --git a/src/EVM/Emacs.hs b/src/EVM/Emacs.hs --- a/src/EVM/Emacs.hs +++ b/src/EVM/Emacs.hs @@ -1,5 +1,6 @@ {-# Language ImplicitParams #-} {-# Language TemplateHaskell #-} +{-# Language DataKinds #-} {-# Language FlexibleInstances #-} module EVM.Emacs where @@ -15,22 +16,30 @@ import Data.SCargot.Language.HaskLike import Data.SCargot.Repr import Data.SCargot.Repr.Basic +import Data.Set (Set) import Data.Text (Text, pack, unpack) +import Data.SBV hiding (Word, output) import EVM +import EVM.ABI import EVM.Concrete +import EVM.Symbolic import EVM.Dapp +import EVM.Debug (srcMapCodePos) import EVM.Fetch (Fetcher) +import EVM.Op import EVM.Solidity import EVM.Stepper (Stepper) import EVM.TTY (currentSrcMap) import EVM.Types -import EVM.UnitTest hiding (interpret) +import EVM.UnitTest import Prelude hiding (Word) import System.Directory import System.IO import qualified Control.Monad.Operational as Operational -import qualified Data.ByteString as BS +import qualified Data.List as List import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Vector as Vector import qualified EVM.Fetch as Fetch import qualified EVM.Stepper as Stepper @@ -43,6 +52,7 @@ , _uiVmFirstState :: UiVmState , _uiVmFetcher :: Fetcher , _uiVmMessage :: Maybe Text + , _uiVmSentHashes :: Set W256 } makeLenses ''UiVmState @@ -105,12 +115,12 @@ -- but stopping before the next instruction. interpret StepNone (k r) - StepMany 0 -> do + StepMany 0 -> -- Finish the continuation until the next instruction; -- then, pause & await user. interpret StepNone restart - StepMany i -> do + StepMany i -> -- Run one instruction. interpret StepOne restart >>= \case @@ -155,17 +165,9 @@ vm0 <- use uiVm let (r, vm1) = runState m vm0 modify (flip updateUiVmState vm1) + modify updateSentHashes interpret mode (k r) - -- Stepper wants to emit a message. - Stepper.Note s -> do - assign uiVmMessage (Just s) - interpret mode (k ()) - - -- Stepper wants to exit because of a failure. - Stepper.Fail e -> - error ("VM error: " ++ show e) - stepOneOpcode :: UiVmState -> UiVmState stepOneOpcode ui = let @@ -178,6 +180,11 @@ updateUiVmState ui vm = ui & set uiVm vm +updateSentHashes :: UiVmState -> UiVmState +updateSentHashes ui = + let sent = allHashes (view uiVm ui) in + ui & set uiVmSentHashes sent + type Sexp = WellFormedSExpr HaskLikeAtom prompt :: Console (Maybe Sexp) @@ -251,35 +258,77 @@ _ -> output (L [A ("unrecognized-command" :: Text)]) -handleCmd (UiDappLoaded dapp) = \case +handleCmd (UiDappLoaded _) = \case ("run-test", [WFSAtom (HSString contractPath), WFSAtom (HSString testName)]) -> do opts <- defaultUnitTestOptions - put (UiVm (initialStateForTest opts dapp (contractPath, testName))) + put (UiVm (initialStateForTest opts (contractPath, testName))) outputVm _ -> output (L [A ("unrecognized-command" :: Text)]) handleCmd (UiVm s) = \case - ("step", [WFSAtom (HSString modeName)]) -> do + ("step", [WFSAtom (HSString modeName)]) -> case parseStepMode s modeName of Just mode -> do takeStep s StepNormally mode outputVm Nothing -> output (L [A ("unrecognized-command" :: Text)]) + ("step", [WFSList [ WFSAtom (HSString "file-line") + , WFSAtom (HSString fileName) + , WFSAtom (HSInt (fromIntegral -> lineNumber)) + ]]) -> + case view uiVmDapp s of + Nothing -> + output (L [A ("impossible" :: Text)]) + Just dapp -> do + takeStep s StepNormally + (StepUntil (atFileLine dapp fileName lineNumber)) + outputVm _ -> output (L [A ("unrecognized-command" :: Text)]) +atFileLine :: DappInfo -> Text -> Int -> VM -> Bool +atFileLine dapp wantedFileName wantedLineNumber vm = + case currentSrcMap dapp vm of + Nothing -> False + Just sm -> + case view (dappSources . sourceFiles . at (srcMapFile sm)) dapp of + Nothing -> False + Just _ -> + let + (currentFileName, currentLineNumber) = + fromJust (srcMapCodePos (view dappSources dapp) sm) + in + currentFileName == wantedFileName && + currentLineNumber == wantedLineNumber + +codeByHash :: W256 -> VM -> Maybe ByteString +codeByHash h vm = do + let cs = view (env . contracts) vm + c <- List.find (\c -> h == (view codehash c)) (Map.elems cs) + return (view bytecode c) + +allHashes :: VM -> Set W256 +allHashes vm = let cs = view (env . contracts) vm + in Set.fromList ((view codehash) <$> Map.elems cs) + +prettifyCode :: ByteString -> String +prettifyCode b = List.intercalate "\n" (opString <$> (Vector.toList (EVM.mkCodeOps b))) + outputVm :: Console () outputVm = do UiVm s <- get - let - noMap = - output $ + let vm = view uiVm s + sendHashes = Set.difference (allHashes vm) (view uiVmSentHashes s) + sendCodes = Map.fromSet (`codeByHash` vm) sendHashes + noMap = + output $ L [ A "step" - , L [A ("pc" :: Text), A (txt (view (uiVm . state . pc) s))]] - + , L [A ("vm" :: Text), sexp (view uiVm s)] + , L [A ("newCodes" :: Text), sexp ((fmap prettifyCode) <$> sendCodes)] + ] fromMaybe noMap $ do dapp <- view uiVmDapp s sm <- currentSrcMap dapp (view uiVm s) @@ -293,6 +342,7 @@ , A (txt (srcMapLength sm)) , A (txt (srcMapJump sm)) ] + , L [A ("newCodes" :: Text), sexp ((fmap prettifyCode) <$> sendCodes)] ] @@ -328,7 +378,7 @@ case runState m ui of - (Stepped stepper, ui') -> do + (Stepped stepper, ui') -> put (UiVm (ui' & set uiVmNextStep stepper)) (Blocked blocker, ui') -> @@ -369,6 +419,10 @@ instance SDisplay (SExpr Text) where sexp = id +instance SDisplay Storage where + sexp (Symbolic _) = error "idk" + sexp (Concrete d) = sexp d + instance SDisplay VM where sexp x = L [ L [A "result", sexp (view result x)] @@ -381,7 +435,7 @@ quoted x = "\"" <> x <> "\"" instance SDisplay Addr where - sexp = A . quoted . pack . showAddrWith0x + sexp = A . quoted . pack . show instance SDisplay Contract where sexp x = @@ -394,6 +448,23 @@ instance SDisplay W256 where sexp x = A (txt (txt x)) +-- no idea what's going on here +instance SDisplay (SWord 256) where + sexp x = A (txt (txt x)) + +-- no idea what's going on here +instance SDisplay (SymWord) where + sexp x = A (txt (txt x)) + +-- no idea what's going on here +instance SDisplay (SWord 8) where + sexp x = A (txt (txt x)) + +-- no idea what's going on here +instance SDisplay Buffer where + sexp (SymbolicBuffer x) = sexp x + sexp (ConcreteBuffer x) = sexp x + instance (SDisplay k, SDisplay v) => SDisplay (Map k v) where sexp x = L [L [sexp k, sexp v] | (k, v) <- Map.toList x] @@ -425,18 +496,22 @@ instance SDisplay a => SDisplay [a] where sexp = L . map sexp +-- this overlaps the neighbouring [a] instance +instance {-# OVERLAPPING #-} SDisplay String where + sexp x = A (txt x) + instance SDisplay Word where - sexp (C Dull x) = A (quoted (txt x)) sexp (C (FromKeccak bs) x) = L [A "hash", A (txt x), sexp bs] + sexp (C _ x) = A (quoted (txt x)) instance SDisplay ByteString where - sexp = A . txt . pack . showByteStringWith0x + sexp = A . txt . pack . show . ByteStringS -sexpMemory :: ByteString -> SExpr Text +sexpMemory :: Buffer -> SExpr Text sexpMemory bs = - if BS.length bs > 1024 - then L [A "large-memory", A (txt (BS.length bs))] + if len bs > 1024 + then L [A "large-memory", A (txt (len bs))] else sexp bs defaultUnitTestOptions :: MonadIO m => m UnitTestOptions @@ -444,39 +519,41 @@ params <- liftIO getParametersFromEnvironmentVariables pure UnitTestOptions { oracle = Fetch.zero - , verbose = False + , verbose = Nothing + , maxIter = Nothing , match = "" + , fuzzRuns = 100 + , replay = Nothing , vmModifier = id , testParams = params } initialStateForTest :: UnitTestOptions - -> DappInfo -> (Text, Text) -> UiVmState -initialStateForTest opts@(UnitTestOptions {..}) dapp (contractPath, testName) = +initialStateForTest opts@(UnitTestOptions {..}) (contractPath, testName) = ui1 where script = do Stepper.evm . pushTrace . EntryTrace $ "test " <> testName <> " (" <> contractPath <> ")" initializeUnitTest opts - void (runUnitTest opts testName) + void (runUnitTest opts testName (AbiTuple mempty)) ui0 = UiVmState { _uiVm = vm0 , _uiVmNextStep = script , _uiVmSolc = Just testContract - , _uiVmDapp = Just dapp , _uiVmStepCount = 0 , _uiVmFirstState = undefined , _uiVmFetcher = oracle , _uiVmMessage = Nothing + , _uiVmSentHashes = Set.empty } Just testContract = view (dappSolcByName . at contractPath) dapp vm0 = - initialUnitTestVm opts testContract (Map.elems (view dappSolcByName dapp)) + initialUnitTestVm opts testContract ui1 = updateUiVmState ui0 vm0 & set uiVmFirstState ui1 diff --git a/src/EVM/Exec.hs b/src/EVM/Exec.hs --- a/src/EVM/Exec.hs +++ b/src/EVM/Exec.hs @@ -1,7 +1,8 @@ module EVM.Exec where import EVM -import EVM.Keccak (newContractAddress) +import EVM.Concrete (createAddress) +import EVM.Symbolic (litAddr) import EVM.Types import qualified EVM.FeeSchedule as FeeSchedule @@ -20,28 +21,39 @@ vmForEthrunCreation :: ByteString -> VM vmForEthrunCreation creationCode = (makeVm $ VMOpts - { vmoptCode = creationCode - , vmoptCalldata = "" + { vmoptContract = initialContract (InitCode creationCode) + , vmoptCalldata = (mempty, 0) , vmoptValue = 0 - , vmoptAddress = newContractAddress ethrunAddress 1 - , vmoptCaller = ethrunAddress + , vmoptAddress = createAddress ethrunAddress 1 + , vmoptCaller = litAddr ethrunAddress , vmoptOrigin = ethrunAddress , vmoptCoinbase = 0 , vmoptNumber = 0 , vmoptTimestamp = 0 - , vmoptGaslimit = 0 + , vmoptBlockGaslimit = 0 , vmoptGasprice = 0 , vmoptDifficulty = 0 , vmoptGas = 0xffffffffffffffff - , vmoptSchedule = FeeSchedule.metropolis + , vmoptGaslimit = 0xffffffffffffffff + , vmoptMaxCodeSize = 0xffffffff + , vmoptSchedule = FeeSchedule.istanbul + , vmoptChainId = 1 + , vmoptCreate = False + , vmoptStorageModel = ConcreteS }) & set (env . contracts . at ethrunAddress) - (Just (initialContract mempty)) + (Just (initialContract (RuntimeCode mempty))) exec :: MonadState VM m => m VMResult exec = use EVM.result >>= \case Nothing -> State.state (runState exec1) >> exec Just x -> return x + +run :: MonadState VM m => m VM +run = + use EVM.result >>= \case + Nothing -> State.state (runState exec1) >> run + Just _ -> State.get execWhile :: MonadState VM m => (VM -> Bool) -> m Int execWhile p = go 0 diff --git a/src/EVM/Facts.hs b/src/EVM/Facts.hs --- a/src/EVM/Facts.hs +++ b/src/EVM/Facts.hs @@ -1,7 +1,6 @@ {-# Language PartialTypeSignatures #-} {-# Language FlexibleInstances #-} {-# Language ExtendedDefaultRules #-} -{-# Language NamedFieldPuns #-} {-# Language PatternSynonyms #-} {-# Language RecordWildCards #-} {-# Language ScopedTypeVariables #-} @@ -36,14 +35,16 @@ import EVM (VM, Contract) import EVM.Concrete (Word) -import EVM (balance, nonce, storage, bytecode, env, contracts) +import EVM.Symbolic (litWord, SymWord, forceLit) +import EVM (balance, nonce, storage, bytecode, env, contracts, contract, state) import EVM.Types (Addr) -import qualified EVM as EVM +import qualified EVM import Prelude hiding (Word) -import Control.Lens (view, set, at, ix, (&)) +import Control.Lens (view, set, at, ix, (&), over, assign) +import Control.Monad.State.Strict (execState, when) import Data.ByteString (ByteString) import Data.Monoid ((<>)) import Data.Ord (comparing) @@ -117,12 +118,14 @@ ] storageFacts :: Addr -> Contract -> [Fact] -storageFacts a x = map f (Map.toList (view storage x)) +storageFacts a x = case view storage x of + EVM.Symbolic _ -> [] + EVM.Concrete s -> map f (Map.toList s) where - f :: (Word, Word) -> Fact + f :: (Word, SymWord) -> Fact f (k, v) = StorageFact { addr = a - , what = fromIntegral v + , what = fromIntegral (forceLit v) , which = fromIntegral k } @@ -141,10 +144,11 @@ apply1 :: VM -> Fact -> VM apply1 vm fact = case fact of - CodeFact {..} -> - vm & set (env . contracts . at addr) (Just (EVM.initialContract blob)) + CodeFact {..} -> flip execState vm $ do + assign (env . contracts . at addr) (Just (EVM.initialContract (EVM.RuntimeCode blob))) + when (view (state . contract) vm == addr) $ EVM.loadContract addr StorageFact {..} -> - vm & set (env . contracts . ix addr . storage . at which) (Just what) + vm & over (env . contracts . ix addr . storage) (EVM.writeStorage (litWord which) (litWord what)) BalanceFact {..} -> vm & set (env . contracts . ix addr . balance) what NonceFact {..} -> @@ -162,9 +166,9 @@ -- Applies a set of facts to a VM. apply :: VM -> Set Fact -> VM -apply vm = +apply = -- The set's ordering is relevant; see `apply1`. - foldl apply1 vm + foldl apply1 factToFile :: Fact -> File factToFile fact = case fact of diff --git a/src/EVM/Facts/Git.hs b/src/EVM/Facts/Git.hs --- a/src/EVM/Facts/Git.hs +++ b/src/EVM/Facts/Git.hs @@ -1,4 +1,3 @@ -{-# Language ViewPatterns #-} -- This is a backend for the fact representation that uses a Git -- repository as the store. @@ -9,8 +8,7 @@ , RepoAt (..) ) where -import EVM.Facts (Fact (..), File (..), Path (..), Data (..)) -import EVM.Facts (fileToFact, factToFile) +import EVM.Facts (Fact (..), File (..), Path (..), Data (..), fileToFact, factToFile) import Control.Lens import Data.Set (Set) @@ -30,11 +28,11 @@ where f :: File -> Git.File f (File (Path ps p) (Data x)) = - (Git.File (Git.Path ps p) 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)) + File (Path ps p) (Data x) saveFacts :: RepoAt -> Set Fact -> IO () saveFacts (RepoAt repo) facts = diff --git a/src/EVM/FeeSchedule.hs b/src/EVM/FeeSchedule.hs --- a/src/EVM/FeeSchedule.hs +++ b/src/EVM/FeeSchedule.hs @@ -1,6 +1,6 @@ module EVM.FeeSchedule where -data Num n => FeeSchedule n = FeeSchedule +data FeeSchedule n = FeeSchedule { g_zero :: n , g_base :: n , g_verylow :: n @@ -14,8 +14,9 @@ , g_sset :: n , g_sreset :: n , r_sclear :: n + , g_selfdestruct :: n + , g_selfdestruct_newaccount :: n , r_selfdestruct :: n - , r_selfdestruct_newaccount :: n , g_create :: n , g_codedeposit :: n , g_call :: n @@ -36,6 +37,14 @@ , g_sha3word :: n , g_copy :: n , g_blockhash :: n + , g_extcodehash :: n + , g_quaddivisor :: n + , g_ecadd :: n + , g_ecmul :: n + , g_pairing_point :: n + , g_pairing_base :: n + , g_fround :: n + , r_block :: n } deriving Show -- For the purposes of this module, we define an EIP as just a fee @@ -50,8 +59,8 @@ , g_balance = 400 , g_sload = 200 , g_call = 700 - , r_selfdestruct = 5000 - , r_selfdestruct_newaccount = 25000 + , g_selfdestruct = 5000 + , g_selfdestruct_newaccount = 25000 } -- EIP160: EXP cost increase @@ -75,8 +84,9 @@ , g_sset = 20000 , g_sreset = 5000 , r_sclear = 15000 - , r_selfdestruct = 0 - , r_selfdestruct_newaccount = 0 + , g_selfdestruct = 0 + , g_selfdestruct_newaccount = 0 + , r_selfdestruct = 24000 , g_create = 32000 , g_codedeposit = 200 , g_call = 40 @@ -97,7 +107,54 @@ , g_sha3word = 6 , g_copy = 3 , g_blockhash = 20 + , g_extcodehash = 400 + , g_quaddivisor = 20 + , g_ecadd = 500 + , g_ecmul = 40000 + , g_pairing_point = 80000 + , g_pairing_base = 100000 + , g_fround = 1 + , r_block = 2000000000000000000 } 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 diff --git a/src/EVM/Fetch.hs b/src/EVM/Fetch.hs --- a/src/EVM/Fetch.hs +++ b/src/EVM/Fetch.hs @@ -5,14 +5,18 @@ import Prelude hiding (Word) -import EVM.Types (Addr, W256, showAddrWith0x, showWordWith0x, hexText) +import EVM.Types (Addr, W256, hexText) import EVM.Concrete (Word, w256) -import EVM (EVM, Contract, initialContract, nonce, balance, external) +import EVM (EVM, Contract, StorageModel, initialContract, nonce, balance, external) -import qualified EVM as EVM +import qualified EVM import Control.Lens hiding ((.=)) +import Control.Monad.Reader import Control.Monad.Trans.Maybe +import Data.SBV.Trans.Control +import qualified Data.SBV.Internals as SBV +import Data.SBV.Trans hiding (Word) import Data.Aeson import Data.Aeson.Lens import Data.ByteString (ByteString) @@ -28,14 +32,12 @@ QueryBalance :: Addr -> RpcQuery W256 QueryNonce :: Addr -> RpcQuery W256 QuerySlot :: Addr -> W256 -> RpcQuery W256 + QueryChainId :: RpcQuery W256 data BlockNumber = Latest | BlockNumber W256 deriving instance Show (RpcQuery a) -mkr :: Addr -mkr = 0xc66ea802717bfb9833400264dd12c2bceaa34a6d - rpc :: String -> [String] -> Value rpc method args = object [ "jsonrpc" .= ("2.0" :: String) @@ -48,14 +50,14 @@ toRPC :: a -> String instance ToRPC Addr where - toRPC = showAddrWith0x + toRPC = show instance ToRPC W256 where - toRPC = showWordWith0x + toRPC = show instance ToRPC BlockNumber where toRPC Latest = "latest" - toRPC (BlockNumber n) = showWordWith0x n + toRPC (BlockNumber n) = show n readText :: Read a => Text -> a readText = read . unpack @@ -68,7 +70,7 @@ -> IO (Maybe a) fetchQuery n f q = do x <- case q of - QueryCode addr -> do + QueryCode addr -> fmap hexText <$> f (rpc "eth_getCode" [toRPC addr, toRPC n]) QueryNonce addr -> @@ -80,6 +82,9 @@ QuerySlot addr slot -> fmap readText <$> f (rpc "eth_getStorageAt" [toRPC addr, toRPC slot, toRPC n]) + QueryChainId -> + fmap readText <$> + f (rpc "eth_chainId" [toRPC n]) return x fetchWithSession :: Text -> Session -> Value -> IO (Maybe Text) @@ -88,8 +93,8 @@ return (r ^? responseBody . key "result" . _String) fetchContractWithSession - :: BlockNumber -> Text -> Session -> Addr -> IO (Maybe Contract) -fetchContractWithSession n url sess addr = runMaybeT $ do + :: BlockNumber -> Text -> Addr -> Session -> IO (Maybe Contract) +fetchContractWithSession n url addr sess = runMaybeT $ do let fetch :: Show a => RpcQuery a -> IO (Maybe a) fetch = fetchQuery n (fetchWithSession url sess) @@ -99,46 +104,113 @@ theBalance <- MaybeT $ fetch (QueryBalance addr) return $ - initialContract theCode + initialContract (EVM.RuntimeCode theCode) & set nonce (w256 theNonce) & set balance (w256 theBalance) & set external True fetchSlotWithSession :: BlockNumber -> Text -> Session -> Addr -> W256 -> IO (Maybe Word) -fetchSlotWithSession n url sess addr slot = do +fetchSlotWithSession n url sess addr slot = fmap w256 <$> fetchQuery n (fetchWithSession url sess) (QuerySlot addr slot) fetchContractFrom :: BlockNumber -> Text -> Addr -> IO (Maybe Contract) fetchContractFrom n url addr = Session.withAPISession - (flip (fetchContractWithSession n url) addr) + (fetchContractWithSession n url addr) fetchSlotFrom :: BlockNumber -> Text -> Addr -> W256 -> IO (Maybe Word) fetchSlotFrom n url addr slot = Session.withAPISession (\s -> fetchSlotWithSession n url s addr slot) -http :: BlockNumber -> Text -> EVM.Query -> IO (EVM ()) -http n url q = do +http :: BlockNumber -> Text -> Fetcher +http n url q = case q of EVM.PleaseFetchContract addr continue -> fetchContractFrom n url addr >>= \case - Just x -> do + Just x -> return (continue x) Nothing -> error ("oracle error: " ++ show q) EVM.PleaseFetchSlot addr slot continue -> fetchSlotFrom n url addr (fromIntegral slot) >>= \case Just x -> return (continue x) Nothing -> error ("oracle error: " ++ show q) + EVM.PleaseAskSMT _ _ _ -> error "smt calls not available for this oracle" -zero :: Monad m => EVM.Query -> m (EVM ()) -zero q = do +zero :: Fetcher +zero q = case q of EVM.PleaseFetchContract _ continue -> - return (continue (initialContract "")) + return (continue (initialContract (EVM.RuntimeCode mempty))) EVM.PleaseFetchSlot _ _ continue -> return (continue 0) + EVM.PleaseAskSMT _ _ continue -> + return $ continue EVM.Unknown + + type Fetcher = EVM.Query -> IO (EVM ()) + +-- smtsolving + (http or zero) +oracle :: SBV.State -> Maybe (BlockNumber, Text) -> StorageModel -> Fetcher +oracle state info model q = do + case q of + EVM.PleaseAskSMT jumpcondition pathconditions continue -> + flip runReaderT state $ SBV.runQueryT $ do + let pathconds = sAnd pathconditions + noJump <- checksat $ pathconds .&& jumpcondition ./= 0 + case noJump of + -- Unsat means condition + -- cannot be nonzero + Unsat -> do jump <- checksat $ pathconds .&& jumpcondition .== 0 + -- can it be zero? + case jump of + -- No. We are on an inconsistent path. + Unsat -> return $ continue EVM.Inconsistent + -- Yes. It must be 0. + Sat -> return $ continue (EVM.Iszero True) + -- Assume 0 is still possible. + Unk -> return $ continue (EVM.Iszero True) + -- Sat means its possible for condition + -- to be nonzero. + Sat -> do jump <- checksat $ pathconds .&& jumpcondition .== 0 + -- can it also be zero? + case jump of + -- No. It must be nonzero + Unsat -> return $ continue (EVM.Iszero False) + -- Yes. Both branches possible + Sat -> return $ continue EVM.Unknown + -- Explore both branches in case of timeout + Unk -> return $ continue EVM.Unknown + + -- If the query times out, we simply explore both paths + Unk -> return $ continue EVM.Unknown + -- if we are using a symbolic storage model, + -- we generate a new array to the fetched contract here + EVM.PleaseFetchContract addr continue -> do + contract <- case info of + Nothing -> return $ Just (initialContract (EVM.RuntimeCode mempty)) + Just (n, url) -> fetchContractFrom n url addr + case contract of + Just x -> case model of + EVM.ConcreteS -> return $ continue x + EVM.InitialS -> return $ continue $ x & set EVM.storage (EVM.Symbolic $ SBV.sListArray 0 []) + EVM.SymbolicS -> + flip runReaderT state $ SBV.runQueryT $ do + store <- freshArray_ Nothing + return $ continue $ x & set EVM.storage (EVM.Symbolic store) + Nothing -> error ("oracle error: " ++ show q) + + --- for other queries (there's only slot left right now) we default to zero or http + _ -> case info of + Nothing -> zero q + Just (n, url) -> http n url q + +checksat :: SBool -> Query CheckSatResult +checksat b = do resetAssertions + constrain b + m <- checkSat + resetAssertions + return m diff --git a/src/EVM/Flatten.hs b/src/EVM/Flatten.hs --- a/src/EVM/Flatten.hs +++ b/src/EVM/Flatten.hs @@ -12,6 +12,7 @@ import EVM.Dapp (DappInfo, dappSources) import EVM.Solidity (sourceAsts) +import EVM.Demand (demand) -- We query and alter the Solidity code using the compiler's AST. -- The AST is a deep JSON structure, so we use Aeson and Lens. @@ -26,14 +27,19 @@ import qualified Data.Graph.Inductive.Query.BFS as Fgl import qualified Data.Graph.Inductive.Query.DFS as Fgl +-- The Solidity version pragmas can be arbitrary SemVer ranges, +-- so we use this library to parse them. +import Data.SemVer (SemVerRange, parseSemVerRange) +import qualified Data.SemVer as SemVer + import Control.Monad (forM) import Data.ByteString (ByteString) import Data.Foldable (foldl', toList) -import Data.List (sort) +import Data.List (sort, nub) import Data.Map (Map, (!)) -import Data.Maybe (mapMaybe, isJust, fromMaybe) +import Data.Maybe (mapMaybe, isJust) import Data.Monoid ((<>)) -import Data.Text (Text, unpack, pack, intercalate) +import Data.Text (Text, unpack, pack) import Data.Text.Encoding (encodeUtf8) import Text.Read (readMaybe) @@ -122,6 +128,10 @@ , stripImportsAndPragmas src (asts ! path), "\n" ] + -- Force all evaluation before any printing happens, to avoid + -- partial output. + demand target; demand pragma; demand sources + -- Finally print the whole concatenation. putStrLn $ "// hevm: flattened sources of " <> unpack target putStrLn (unpack pragma) @@ -134,14 +144,20 @@ case mapMaybe versions asts of [] -> error "no Solidity version pragmas in any source files" xs -> - "pragma solidity ^" - <> intercalate "." (map (pack . show) (maximum xs)) + "pragma solidity " + <> pack (show (rangeIntersection xs)) <> ";\n" where - -- Get the version components from a source file's pragma, + -- Simple way to combine many SemVer ranges. We don't actually + -- optimize these boolean expressions, so the resulting pragma + -- might be redundant, like ">=0.4.23 >=0.5.0 <0.6.0". + rangeIntersection :: [SemVerRange] -> SemVerRange + rangeIntersection = foldr1 SemVer.And . nub . sort + + -- Get the semantic version range from a source file's pragma, -- or nothing if no pragma present. - versions :: Value -> Maybe [Int] + versions :: Value -> Maybe SemVerRange versions ast = fmap grok components where pragma :: Maybe Value @@ -155,14 +171,16 @@ components = fmap toList (pragma >>= preview (key "attributes" . key "literals" . _Array)) - grok :: [Value] -> [Int] + grok :: [Value] -> SemVerRange grok = \case - [String "solidity", String _prefix, String a, String b] -> - map - (fromMaybe - (error . Text.unpack $ "bad Solidity version: " <> a <> b) - . readAs) - (Text.splitOn "." (a <> b)) + String "solidity" : xs -> + let + rangeText = mconcat [x | String x <- xs] + in + case parseSemVerRange rangeText of + Right r -> r + Left _ -> + error ("failed to parse SemVer range " ++ show rangeText) x -> error ("unrecognized pragma: " ++ show x) diff --git a/src/EVM/Format.hs b/src/EVM/Format.hs --- a/src/EVM/Format.hs +++ b/src/EVM/Format.hs @@ -1,3 +1,5 @@ +{-# Language DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} module EVM.Format where import Prelude hiding (Word) @@ -5,14 +7,14 @@ import EVM (VM, cheatCode, traceForest, traceData, Error (..)) import EVM (Trace, TraceData (..), Log (..), Query (..), FrameContext (..)) import EVM.Dapp (DappInfo, dappSolcByHash, showTraceLocation, dappEventMap) -import EVM.Concrete (Word (..)) +import EVM.Concrete (Word (..), wordValue) +import EVM.Symbolic (maybeLitWord, Buffer(..), len) import EVM.Types (W256 (..), num) import EVM.ABI (AbiValue (..), Event (..), AbiType (..)) -import EVM.ABI (Indexed (Indexed, NotIndexed), getAbiSeq, getAbi) -import EVM.ABI (abiTypeSolidity, parseTypeName) +import EVM.ABI (Indexed (NotIndexed), getAbiSeq, getAbi) +import EVM.ABI (parseTypeName) import EVM.Solidity (SolcContract, contractName, abiMap) import EVM.Solidity (methodOutput, methodSignature) -import EVM.Concrete (wordValue) import Control.Arrow ((>>>)) import Control.Lens (view, preview, ix, _2, to, _Just) @@ -22,24 +24,23 @@ import Data.ByteString.Lazy (toStrict, fromStrict) import Data.DoubleWord (signedWord) import Data.Foldable (toList) -import Data.Map (Map) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text, pack, unpack, intercalate) import Data.Text (dropEnd, splitOn) import Data.Text.Encoding (decodeUtf8, decodeUtf8') import Data.Tree.View (showTree) -import Data.Vector (Vector) +import Data.Vector (Vector, fromList) import Numeric (showHex) import qualified Data.ByteString as BS import qualified Data.Char as Char import qualified Data.Map as Map -import qualified Data.Scientific as Scientific import qualified Data.Text as Text data Signedness = Signed | Unsigned + deriving (Show) showDec :: Signedness -> W256 -> Text showDec signed (W256 w) = @@ -47,36 +48,25 @@ i = case signed of Signed -> num (signedWord w) Unsigned -> num w - in if i == num cheatCode then "" - else - if abs i > 1000000000000 - then - "~" <> pack (Scientific.formatScientific - Scientific.Generic - (Just 8) - (fromIntegral i)) - else - showDecExact i - -showDecExact :: Integer -> Text -showDecExact = humanizeInteger + else if (i :: Integer) == 2 ^ (256 :: Integer) - 1 + then "MAX_UINT256" + else Text.pack (show (i :: Integer)) showWordExact :: Word -> Text showWordExact (C _ (W256 w)) = humanizeInteger w humanizeInteger :: (Num a, Integral a, Show a) => a -> Text humanizeInteger = - ( Text.intercalate "," + Text.intercalate "," . reverse . map Text.reverse . Text.chunksOf 3 . Text.reverse . Text.pack . show - ) -- TODO: make polymorphic showAbiValues :: Vector AbiValue -> Text @@ -106,6 +96,8 @@ showAbiArray xs showAbiValue (AbiArrayDynamic _ xs) = showAbiArray xs +showAbiValue (AbiTuple v) = + showAbiValues v isPrintable :: ByteString -> Bool isPrintable = @@ -121,16 +113,28 @@ then formatQString s else formatBinary b +formatSBytes :: Buffer -> Text +formatSBytes (SymbolicBuffer b) = "<" <> pack (show (length b)) <> " symbolic bytes>" +formatSBytes (ConcreteBuffer b) = formatBytes b + formatQString :: ByteString -> Text formatQString = pack . show formatString :: ByteString -> Text formatString bs = decodeUtf8 (fst (BS.spanEnd (== 0) bs)) +formatSString :: Buffer -> Text +formatSString (SymbolicBuffer bs) = "<" <> pack (show (length bs)) <> " symbolic bytes (string)>" +formatSString (ConcreteBuffer bs) = formatString bs + formatBinary :: ByteString -> Text formatBinary = (<>) "0x" . decodeUtf8 . toStrict . toLazyByteString . byteStringHex +formatSBinary :: Buffer -> Text +formatSBinary (SymbolicBuffer bs) = "<" <> pack (show (length bs)) <> " symbolic bytes>" +formatSBinary (ConcreteBuffer bs) = formatBinary bs + showTraceTree :: DappInfo -> VM -> Text showTraceTree dapp = traceForest @@ -148,58 +152,68 @@ in case view traceData trace of EventTrace (Log _ bytes topics) -> case topics of - (t:_) -> - let event = getEvent t (view dappEventMap dapp) - -- indexed types are in the remaining topics - types = getEventUnindexedTypes event - in case event of - -- todo: catch ds-note in Anonymous case - Just (Event name _ _) -> - mconcat - [ "\x1b[36m" - , name - , showEvent types bytes - , "\x1b[0m" - ] <> pos - Nothing -> - mconcat - [ "\x1b[36m" - , " " - , formatBinary bytes - , mconcat (map (pack . show) topics) - , "\x1b[0m" - ] <> pos - _ -> - "log" <> pos + [] -> + mconcat + [ "\x1b[36m" + , "log0(" + , formatSBinary bytes + , ")" + , "\x1b[0m" + ] <> pos + (topic:_) -> + let unknownTopic = -- todo: catch ds-note + mconcat + [ "\x1b[36m" + , "log" <> (pack (show (length topics))) <> "(" + , formatSBinary bytes <> ", " + , intercalate ", " (map (pack . show) topics) <> ")" + , "\x1b[0m" + ] <> pos + + in case maybeLitWord topic of + Just top -> case Map.lookup (wordValue top) (view dappEventMap dapp) of + Just (Event name _ types) -> + mconcat + [ "\x1b[36m" + , name + , showValues [t | (t, NotIndexed) <- types] bytes + -- todo: show indexed + , "\x1b[0m" + ] <> pos + Nothing -> unknownTopic + Nothing -> unknownTopic + QueryTrace q -> case q of PleaseFetchContract addr _ -> "fetch contract " <> pack (show addr) <> pos PleaseFetchSlot addr slot _ -> "fetch storage slot " <> pack (show slot) <> " from " <> pack (show addr) <> pos + PleaseAskSMT _ _ _ -> + "ask smt" <> pos ErrorTrace e -> case e of - Revert output -> - "\x1b[91merror\x1b[0m " <> "Revert " <> formatBinary output <> pos + Revert out -> + "\x1b[91merror\x1b[0m " <> "Revert " <> showError out <> pos _ -> "\x1b[91merror\x1b[0m " <> pack (show e) <> pos - ReturnTrace output (CallContext _ _ hash (Just abi) _ _) -> + ReturnTrace out (CallContext _ _ hash (Just abi) _ _ _) -> case getAbiMethodOutput dapp hash abi of Nothing -> - "← " <> formatBinary output + "← " <> formatSBinary out Just (_, t) -> - "← " <> abiTypeSolidity t <> " " <> showValue t output - ReturnTrace output (CallContext {}) -> - "← " <> formatBinary output - ReturnTrace output (CreationContext {}) -> - "← " <> pack (show (BS.length output)) <> " bytes of code" + "← " <> pack (show t) <> " " <> showValue t out + ReturnTrace out (CallContext {}) -> + "← " <> formatSBinary out + ReturnTrace out (CreationContext {}) -> + "← " <> pack (show (len out)) <> " bytes of code" EntryTrace t -> t - FrameTrace (CreationContext hash) -> + FrameTrace (CreationContext hash _ _ ) -> "create " <> maybeContractName (preview (dappSolcByHash . ix hash . _2) dapp) <> pos - FrameTrace (CallContext _ _ hash abi calldata _) -> + FrameTrace (CallContext _ _ hash abi calldata _ _) -> case preview (dappSolcByHash . ix hash . _2) dapp of Nothing -> "call [unknown]" <> pos @@ -208,10 +222,10 @@ <> "\x1b[1m" <> view (contractName . to contractNamePart) solc <> "::" - <> maybe ("[fallback function]") - (\x -> maybe "[unknown method]" id (maybeAbiName solc x)) + <> maybe "[fallback function]" + (fromMaybe "[unknown method]" . maybeAbiName solc) abi - <> maybe ("(" <> formatBinary calldata <> ")") + <> maybe ("(" <> formatSBinary calldata <> ")") -- todo: if unknown method, then just show raw calldata (\x -> showCall (catMaybes x) calldata) (abi >>= fmap getAbiTypes . maybeAbiName solc) @@ -229,28 +243,32 @@ dapp getAbiTypes :: Text -> [Maybe AbiType] -getAbiTypes abi = map parseTypeName types +getAbiTypes abi = map (parseTypeName mempty) types where types = filter (/= "") $ splitOn "," (dropEnd 1 (last (splitOn "(" abi))) -showCall :: [AbiType] -> ByteString -> Text -showCall ts bs = - case runGetOrFail (getAbiSeq (length ts) ts) - (fromStrict (BS.drop 4 bs)) of +showCall :: [AbiType] -> Buffer -> Text +showCall ts (SymbolicBuffer bs) = showValues ts $ SymbolicBuffer (drop 4 bs) +showCall ts (ConcreteBuffer bs) = showValues ts $ ConcreteBuffer (BS.drop 4 bs) + +showError :: ByteString -> Text +showError bs = case BS.take 4 bs of + -- Method ID for Error(string) + "\b\195y\160" -> showCall [AbiStringType] (ConcreteBuffer bs) + _ -> formatBinary bs + +showValues :: [AbiType] -> Buffer -> Text +showValues ts (SymbolicBuffer sbs) = "symbolic: " <> (pack . show $ AbiTupleType (fromList ts)) +showValues ts (ConcreteBuffer bs) = + case runGetOrFail (getAbiSeq (length ts) ts) (fromStrict bs) of Right (_, _, xs) -> showAbiValues xs Left (_, _, _) -> formatBinary bs -showEvent :: [AbiType] -> ByteString -> Text -showEvent ts bs = - case runGetOrFail (getAbiSeq (length ts) ts) - (fromStrict bs) of - Right (_, _, abivals) -> showAbiValues abivals - Left (_,_,_) -> error "lol" - -showValue :: AbiType -> ByteString -> Text -showValue t bs = +showValue :: AbiType -> Buffer -> Text +showValue t (SymbolicBuffer _) = "symbolic: " <> (pack $ show t) +showValue t (ConcreteBuffer bs) = case runGetOrFail (getAbi t) (fromStrict bs) of Right (_, _, x) -> showAbiValue x Left (_, _, _) -> formatBinary bs @@ -267,18 +285,3 @@ contractPathPart :: Text -> Text contractPathPart x = Text.split (== ':') x !! 0 - -getEvent :: Word -> Map W256 Event -> Maybe Event -getEvent w events = Map.lookup (wordValue w) events - -getEventName :: Maybe Event -> Text -getEventName (Just (Event name _ _)) = name -getEventName Nothing = "" - -getEventUnindexedTypes :: Maybe Event -> [AbiType] -getEventUnindexedTypes Nothing = [] -getEventUnindexedTypes (Just (Event _ _ xs)) = [x | (x, NotIndexed) <- xs] - -getEventIndexedTypes :: Maybe Event -> [AbiType] -getEventIndexedTypes Nothing = [] -getEventIndexedTypes (Just (Event _ _ xs)) = [x | (x, Indexed) <- xs] diff --git a/src/EVM/Keccak.hs b/src/EVM/Keccak.hs --- a/src/EVM/Keccak.hs +++ b/src/EVM/Keccak.hs @@ -1,10 +1,4 @@ -{-# Language CPP #-} - -#ifdef __GHCJS__ -{-# Language JavaScriptFFI #-} -#endif - -module EVM.Keccak (keccak, abiKeccak, newContractAddress) where +module EVM.Keccak (keccak, abiKeccak) where import EVM.Types @@ -12,55 +6,24 @@ import Data.Bits import Data.ByteString (ByteString) + import qualified Data.ByteString as BS import Data.Word -#ifdef __GHCJS__ -import qualified Data.JSString as JS -import qualified Data.Text.Encoding as Text -import qualified Data.Text as Text -import qualified Data.ByteString.Base64 as BS64 - -foreign import javascript unsafe - "keccakBase64($1)" - keccakBase64 :: JS.JSString -> JS.JSString - -keccakBytes = - BS64.encode - >>> Text.decodeUtf8 - >>> Text.unpack - >>> JS.pack - >>> keccakBase64 - >>> JS.unpack - >>> Text.pack - >>> Text.encodeUtf8 - >>> BS64.decodeLenient - -#else import Crypto.Hash import qualified Data.ByteArray as BA +keccakBytes :: ByteString -> ByteString keccakBytes = (hash :: ByteString -> Digest Keccak_256) >>> BA.unpack >>> BS.pack -#endif -keccakBytes :: ByteString -> ByteString - word32 :: [Word8] -> Word32 word32 xs = sum [ fromIntegral x `shiftL` (8*n) | (n, x) <- zip [0..] (reverse xs) ] -octets :: W256 -> [Word8] -octets x = - dropWhile (== 0) [fromIntegral (shiftR x (8 * i)) | i <- reverse [0..31]] - -octets160 :: Addr -> [Word8] -octets160 x = - dropWhile (== 0) [fromIntegral (shiftR x (8 * i)) | i <- reverse [0..19]] - keccak :: ByteString -> W256 keccak = keccakBytes @@ -73,30 +36,3 @@ >>> BS.take 4 >>> BS.unpack >>> word32 - -rlpWord256 :: W256 -> ByteString -rlpWord256 0 = BS.pack [0x80] -rlpWord256 x | x <= 0x7f = BS.pack [fromIntegral x] -rlpWord256 x = - let xs = octets x - in BS.pack ([0x80 + fromIntegral (length xs)] ++ xs) - -rlpWord160 :: Addr -> ByteString -rlpWord160 0 = BS.pack [0x80] -rlpWord160 x = - let xs = octets160 x - in BS.pack ([0x80 + fromIntegral (length xs)] ++ xs) - -rlpList :: [ByteString] -> ByteString -rlpList xs = - let n = sum (map BS.length xs) - in if n <= 55 - then BS.cons (fromIntegral (0xc0 + n)) (BS.concat xs) - else - let ns = rlpWord256 (fromIntegral n) - in BS.cons (fromIntegral (0xf7 + BS.length ns)) (BS.concat (ns : xs)) - -newContractAddress :: Addr -> W256 -> Addr -newContractAddress a n = - fromIntegral - (keccak $ rlpList [rlpWord160 a, rlpWord256 n]) diff --git a/src/EVM/Op.hs b/src/EVM/Op.hs --- a/src/EVM/Op.hs +++ b/src/EVM/Op.hs @@ -1,7 +1,11 @@ -module EVM.Op (Op (..)) where +module EVM.Op + ( Op (..) + , opString + ) where import EVM.Types (W256) import Data.Word (Word8) +import Numeric (showHex) data Op = OpStop @@ -27,6 +31,9 @@ | OpXor | OpNot | OpByte + | OpShl + | OpShr + | OpSar | OpSha3 | OpAddress | OpBalance @@ -43,12 +50,15 @@ | OpExtcodecopy | OpReturndatasize | OpReturndatacopy + | OpExtcodehash | OpBlockhash | OpCoinbase | OpTimestamp | OpNumber | OpDifficulty | OpGaslimit + | OpChainid + | OpSelfbalance | OpPop | OpMload | OpMstore @@ -67,6 +77,7 @@ | OpCallcode | OpReturn | OpDelegatecall + | OpCreate2 | OpRevert | OpSelfdestruct | OpDup !Word8 @@ -75,3 +86,85 @@ | OpPush !W256 | OpUnknown Word8 deriving (Show, Eq) + +opString :: (Integral a, Show a) => (a, Op) -> String +opString (i, o) = let showPc x | x < 0x10 = '0' : showHex x "" + | otherwise = showHex x "" + in showPc i <> " " ++ case o of + OpStop -> "STOP" + OpAdd -> "ADD" + OpMul -> "MUL" + OpSub -> "SUB" + OpDiv -> "DIV" + OpSdiv -> "SDIV" + OpMod -> "MOD" + OpSmod -> "SMOD" + OpAddmod -> "ADDMOD" + OpMulmod -> "MULMOD" + OpExp -> "EXP" + OpSignextend -> "SIGNEXTEND" + OpLt -> "LT" + OpGt -> "GT" + OpSlt -> "SLT" + OpSgt -> "SGT" + OpEq -> "EQ" + OpIszero -> "ISZERO" + OpAnd -> "AND" + OpOr -> "OR" + OpXor -> "XOR" + OpNot -> "NOT" + OpByte -> "BYTE" + OpShl -> "SHL" + OpShr -> "SHR" + OpSar -> "SAR" + OpSha3 -> "SHA3" + OpAddress -> "ADDRESS" + OpBalance -> "BALANCE" + OpOrigin -> "ORIGIN" + OpCaller -> "CALLER" + OpCallvalue -> "CALLVALUE" + OpCalldataload -> "CALLDATALOAD" + OpCalldatasize -> "CALLDATASIZE" + OpCalldatacopy -> "CALLDATACOPY" + OpCodesize -> "CODESIZE" + OpCodecopy -> "CODECOPY" + OpGasprice -> "GASPRICE" + OpExtcodesize -> "EXTCODESIZE" + OpExtcodecopy -> "EXTCODECOPY" + OpReturndatasize -> "RETURNDATASIZE" + OpReturndatacopy -> "RETURNDATACOPY" + OpExtcodehash -> "EXTCODEHASH" + OpBlockhash -> "BLOCKHASH" + OpCoinbase -> "COINBASE" + OpTimestamp -> "TIMESTAMP" + OpNumber -> "NUMBER" + OpDifficulty -> "DIFFICULTY" + OpGaslimit -> "GASLIMIT" + OpChainid -> "CHAINID" + OpSelfbalance -> "SELFBALANCE" + OpPop -> "POP" + OpMload -> "MLOAD" + OpMstore -> "MSTORE" + OpMstore8 -> "MSTORE8" + OpSload -> "SLOAD" + OpSstore -> "SSTORE" + OpJump -> "JUMP" + OpJumpi -> "JUMPI" + OpPc -> "PC" + OpMsize -> "MSIZE" + OpGas -> "GAS" + OpJumpdest -> "JUMPDEST" + OpCreate -> "CREATE" + OpCall -> "CALL" + OpStaticcall -> "STATICCALL" + OpCallcode -> "CALLCODE" + OpReturn -> "RETURN" + OpDelegatecall -> "DELEGATECALL" + OpCreate2 -> "CREATE2" + OpSelfdestruct -> "SELFDESTRUCT" + OpDup x -> "DUP" ++ show x + OpSwap x -> "SWAP" ++ show x + OpLog x -> "LOG" ++ show x + OpPush x -> "PUSH " ++ show x + OpRevert -> "REVERT" + OpUnknown x -> "UNKNOWN " ++ show x diff --git a/src/EVM/Patricia.hs b/src/EVM/Patricia.hs new file mode 100644 --- /dev/null +++ b/src/EVM/Patricia.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} + +module EVM.Patricia where + +import EVM.Keccak +import EVM.RLP +import EVM.Types + +import Control.Monad.Free +import Control.Monad.State +import Data.ByteString (ByteString) +import Data.Foldable (toList) +import Data.List (stripPrefix) +import Data.Monoid ((<>)) +import Data.Sequence (Seq) + +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import qualified Data.Sequence as Seq + +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) = return 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 return $ Literal node + else do + insertDB digest node + return $ Hash digest + +getNode :: Ref -> NodeDB Node +getNode (Hash d) = lookupDB d +getNode (Literal n) = return n + +lookupPath :: Ref -> Path -> NodeDB ByteString +lookupPath root path = getNode root >>= getVal path + +getVal :: Path -> Node -> NodeDB ByteString +getVal _ Empty = return BS.empty +getVal path (Shortcut nodePath ref) = + case (stripPrefix nodePath path, ref) of + (Just [], Right value) -> return value + (Just remaining, Left key) -> lookupPath key remaining + _ -> return BS.empty + +getVal [] (Full _ val) = return val +getVal (p:ps) (Full refs _) = lookupPath (refs `Seq.index` (num p)) ps + +emptyRef :: Ref +emptyRef = Literal Empty + +emptyRefs :: Seq Ref +emptyRefs = Seq.replicate 16 emptyRef + +addPrefix :: Path -> Node -> NodeDB Node +addPrefix _ Empty = return Empty +addPrefix [] node = return node +addPrefix path (Shortcut p v) = return $ 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 = return $ Shortcut p (Right new) +update (Full refs _) [] new = return (Full refs new) +update (Full refs old) (p:ps) new = do + newRef <- insertRef (refs `Seq.index` (num p)) ps new + return $ Full (Seq.update (num p) newRef refs) old +update (Shortcut (o:os) (Right old)) [] new = do + newRef <- insertRef emptyRef os old + return $ Full (Seq.update (num o) newRef emptyRefs) new +update (Shortcut [] (Right old)) (p:ps) new = do + newRef <- insertRef emptyRef ps new + return $ Full (Seq.update (num p) newRef emptyRefs) old +update (Shortcut [] (Right _)) [] new = + return $ 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 (num p) newRef $ Seq.update (num o) oldRef emptyRefs + return $ Full refs BS.empty +update (Shortcut (o:os) (Left ref)) [] new = do + newRef <- getNode ref >>= addPrefix os >>= putNode + return $ Full (Seq.update (num o) newRef emptyRefs) new +update (Shortcut cut (Left ref)) ps new = do + newRef <- insertRef ref ps new + return $ Shortcut cut (Left newRef) + +delete :: Node -> Path -> NodeDB Node +delete Empty _ = return Empty +delete (Shortcut [] (Right _)) [] = return Empty +delete n@(Shortcut [] (Right _)) _ = return n +delete (Shortcut [] (Left ref)) p = do node <- getNode ref + delete node p +delete n@(Shortcut _ _) [] = return n +delete n@(Shortcut (o:os) to) (p:ps) | p == o + = delete (Shortcut os to) ps >>= addPrefix [o] + | otherwise + = return n +delete (Full refs _) [] | refs == emptyRefs + = return Empty + | otherwise + = return (Full refs BS.empty) +delete (Full refs val) (p:ps) = do + newRef <- insertRef (refs `Seq.index` (num p)) ps BS.empty + let newRefs = Seq.update (num p) newRef refs + nonEmpties = filter (\(_, ref) -> ref /= emptyRef) $ zip [0..15] $ toList newRefs + case (nonEmpties, BS.null val) of + ([], True) -> return Empty + ([(n, ref)], True) -> getNode ref >>= addPrefix [Nibble n] + _ -> return $ 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/RLP.hs b/src/EVM/RLP.hs new file mode 100644 --- /dev/null +++ b/src/EVM/RLP.hs @@ -0,0 +1,79 @@ +module EVM.RLP where + +import Prelude hiding (drop, head) +import EVM.Types +import Data.Bits (shiftR) +import Data.ByteString (ByteString, drop, head) +import qualified Data.ByteString as BS + +data RLP = BS ByteString | List [RLP] deriving Eq + +instance Show RLP where + show (BS str) = show (ByteStringS str) + show (List list) = show list + +slice :: Int -> Int -> ByteString -> ByteString +slice offset size bs = BS.take size $ BS.drop offset bs + +-- helper function returning (the length of the prefix, the length of the content, isList boolean, optimal boolean) +itemInfo :: ByteString -> (Int, Int, Bool, Bool) +itemInfo bs | bs == mempty = (0, 0, False, False) + | otherwise = case head bs of + x | 0 <= x && x < 128 -> (0, 1, False, True) -- directly encoded byte + x | 128 <= x && x < 184 -> (1, num x - 128, False, (BS.length bs /= 2) || (127 < (head $ drop 1 bs))) -- short string + x | 184 <= x && x < 192 -> (1 + pre, len, False, (len > 55) && head (drop 1 bs) /= 0) -- long string + where pre = num $ x - 183 + len = num $ word $ slice 1 pre bs + x | 192 <= x && x < 248 -> (1, num $ x - 192, True, True) -- short list + x -> (1 + pre, len, True, (len > 55) && head (drop 1 bs) /= 0) -- long list + where pre = num $ x - 247 + len = num $ word $ slice 1 pre bs + +rlpdecode :: ByteString -> Maybe RLP +rlpdecode bs | optimal && pre + len == BS.length bs = if isList + then do + items <- mapM + (\(s, e) -> rlpdecode $ slice s e content) $ + rlplengths content 0 len + Just (List items) + else Just (BS content) + | otherwise = Nothing + where (pre, len, isList, optimal) = itemInfo bs + content = drop pre bs + +rlplengths :: ByteString -> Int -> Int -> [(Int,Int)] +rlplengths bs acc top | acc < top = let (pre, len, _, _) = itemInfo bs + in (acc, pre + len) : rlplengths (drop (pre + len) bs) (acc + pre + len) top + | otherwise = [] + +rlpencode :: RLP -> ByteString +rlpencode (BS bs) = if BS.length bs == 1 && head bs < 128 then bs + else encodeLen 128 bs +rlpencode (List items) = encodeLen 192 (mconcat $ map rlpencode items) + +encodeLen :: Int -> ByteString -> ByteString +encodeLen offset bs | BS.length bs <= 55 = prefix (BS.length bs) <> bs + | otherwise = prefix lenLen <> lenBytes <> bs + where + lenBytes = asBE $ BS.length bs + prefix n = BS.singleton $ num $ offset + n + lenLen = BS.length lenBytes + 55 + +rlpList :: [RLP] -> ByteString +rlpList n = rlpencode $ List n + +octets :: W256 -> ByteString +octets x = + BS.pack $ dropWhile (== 0) [fromIntegral (shiftR x (8 * i)) | i <- reverse [0..31]] + +octets160 :: Addr -> ByteString +octets160 x = + BS.pack $ dropWhile (== 0) [fromIntegral (shiftR x (8 * i)) | i <- reverse [0..19]] + +rlpWord256 :: W256 -> RLP +rlpWord256 0 = BS mempty +rlpWord256 n = BS $ octets n + +rlpWord160 :: Addr -> RLP +rlpWord160 0 = BS mempty +rlpWord160 n = BS $ octets160 n diff --git a/src/EVM/Solidity.hs b/src/EVM/Solidity.hs --- a/src/EVM/Solidity.hs +++ b/src/EVM/Solidity.hs @@ -1,15 +1,19 @@ {-# Language DeriveAnyClass #-} {-# Language StrictData #-} {-# Language TemplateHaskell #-} +{-# Language OverloadedStrings #-} module EVM.Solidity ( solidity + , solcRuntime , JumpType (..) , SolcContract (..) + , StorageItem (..) , SourceCache (..) , SrcMap (..) , CodeType (..) , Method (..) + , SlotType (..) , methodName , methodSignature , methodInputs @@ -19,8 +23,10 @@ , contractName , constructorInputs , creationCode + , functionAbi , makeSrcMaps , readSolc + , readJSON , runtimeCode , snippetCache , runtimeCodehash @@ -32,6 +38,8 @@ , sourceLines , sourceAsts , stripBytecodeMetadata + , signature + , parseMethodInput , lineSubrange , astIdMap , astSrcMap @@ -41,15 +49,23 @@ import EVM.Keccak import EVM.Types +import Codec.CBOR.Term (decodeTerm) +import Codec.CBOR.Read (deserialiseFromBytes) import Control.Applicative import Control.Lens hiding (Indexed) import Data.Aeson (Value (..)) import Data.Aeson.Lens +import Data.Scientific +import Data.Binary.Get (runGet, getWord16be) import Data.ByteString (ByteString) -import Data.Char (isDigit, digitToInt) +import Data.ByteString.Lazy (fromStrict) +import Data.Char (isDigit) +import Data.Either (isRight) import Data.Foldable import Data.Map.Strict (Map) import Data.Maybe +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty import Data.Semigroup import Data.Sequence (Seq) import Data.Text (Text, pack, intercalate) @@ -71,6 +87,45 @@ import qualified Data.Text as Text import qualified Data.Vector as Vector +data StorageItem = StorageItem { + _type :: SlotType, + _offset :: Int, + _slot :: Int + } deriving (Show, Eq) + +data SlotType + -- Note that mapping keys can only be elementary; + -- that excludes arrays, contracts, and mappings. + = StorageMapping (NonEmpty AbiType) AbiType + | StorageValue AbiType +-- | StorageArray AbiType + deriving Eq + +instance Show SlotType where + show (StorageValue t) = show t + show (StorageMapping (s NonEmpty.:| ss) t) = + "mapping(" + <> show s + <> " => " + <> foldr + (\x y -> + "mapping(" + <> show x + <> " => " + <> y + <> ")") + (show t) ss + <> ")" + +instance Read SlotType where + readsPrec _ ('m':'a':'p':'p':'i':'n':'g':'(':s) = + let (lhs:rhs) = Text.splitOn " => " (pack s) + first = fromJust $ parseTypeName mempty lhs + target = fromJust $ parseTypeName mempty (Text.replace ")" "" (last rhs)) + rest = fmap (fromJust . (parseTypeName mempty . (Text.replace "mapping(" ""))) (take (length rhs - 1) rhs) + in [(StorageMapping (first NonEmpty.:| rest) target, "")] + readsPrec _ s = [(StorageValue $ fromMaybe (error "could not parse storage item") (parseTypeName mempty (pack s)),"")] + data SolcContract = SolcContract { _runtimeCodehash :: W256 , _creationCodehash :: W256 @@ -80,6 +135,7 @@ , _constructorInputs :: [(Text, AbiType)] , _abiMap :: Map Word32 Method , _eventMap :: Map W256 Event + , _storageLayout :: Maybe (Map Text StorageItem) , _runtimeSrcmap :: Seq SrcMap , _creationSrcmap :: Seq SrcMap , _contractAst :: Value @@ -112,15 +168,16 @@ srcMapOffset :: {-# UNPACK #-} Int, srcMapLength :: {-# UNPACK #-} Int, srcMapFile :: {-# UNPACK #-} Int, - srcMapJump :: JumpType + srcMapJump :: JumpType, + srcMapModifierDepth :: {-# UNPACK #-} Int } deriving (Show, Eq, Ord, Generic) data SrcMapParseState - = F1 [Int] Int - | F2 Int [Int] Int - | F3 Int Int [Int] Int - | F4 Int Int Int - | F5 SrcMap + = F1 String Int + | F2 Int String Int + | F3 Int Int String Int + | F4 Int Int Int (Maybe JumpType) + | F5 Int Int Int JumpType String | Fe deriving Show @@ -134,45 +191,51 @@ -- Obscure but efficient parser for the Solidity sourcemap format. makeSrcMaps :: Text -> Maybe (Seq SrcMap) makeSrcMaps = (\case (_, Fe, _) -> Nothing; x -> Just (done x)) - . Text.foldl' (\x y -> go y x) (mempty, F1 [] 1, SM 0 0 0 JumpRegular) + . Text.foldl' (flip go) (mempty, F1 [] 1, SM 0 0 0 JumpRegular 0) where - digits ds = digits' (0 :: Int) (0 :: Int) ds - digits' !x _ [] = x - digits' !x !n (d:ds) = digits' (x + d * 10 ^ n) (n + 1) ds - done (xs, s, p) = let (xs', _, _) = go ';' (xs, s, p) in xs' + readR = read . reverse - go ':' (xs, F1 [] _, p@(SM a _ _ _)) = (xs, F2 a [] 1, p) - go ':' (xs, F1 ds k, p) = (xs, F2 (k * digits ds) [] 1, p) + go :: Char -> (Seq SrcMap, SrcMapParseState, SrcMap) -> (Seq SrcMap, SrcMapParseState, SrcMap) + go ':' (xs, F1 [] _, p@(SM a _ _ _ _)) = (xs, F2 a [] 1, p) + go ':' (xs, F1 ds k, p) = (xs, F2 (k * (readR ds)) [] 1, p) go '-' (xs, F1 [] _, p) = (xs, F1 [] (-1), p) - go d (xs, F1 ds k, p) | isDigit d = (xs, F1 (digitToInt d : ds) k, p) + go d (xs, F1 ds k, p) | isDigit d = (xs, F1 (d : ds) k, p) go ';' (xs, F1 [] k, p) = (xs |> p, F1 [] k, p) - go ';' (xs, F1 ds k, SM _ b c d) = let p' = SM (k * digits ds) b c d in - (xs |> p', F1 [] 1, p') + go ';' (xs, F1 ds k, SM _ b c d e) = let p' = SM (k * (readR ds)) b c d e in (xs |> p', F1 [] 1, p') go '-' (xs, F2 a [] _, p) = (xs, F2 a [] (-1), p) - go d (xs, F2 a ds k, p) | isDigit d = (xs, F2 a (digitToInt d : ds) k, p) - go ':' (xs, F2 a [] _, p@(SM _ b _ _)) = (xs, F3 a b [] 1, p) - go ':' (xs, F2 a ds k, p) = (xs, F3 a (k * digits ds) [] 1, p) - go ';' (xs, F2 a [] _, SM _ b c d) = let p' = SM a b c d in (xs |> p', F1 [] 1, p') - go ';' (xs, F2 a ds k, SM _ _ c d) = let p' = SM a (k * digits ds) c d in + go d (xs, F2 a ds k, p) | isDigit d = (xs, F2 a (d : ds) k, p) + go ':' (xs, F2 a [] _, p@(SM _ b _ _ _)) = (xs, F3 a b [] 1, p) + go ':' (xs, F2 a ds k, p) = (xs, F3 a (k * (readR ds)) [] 1, p) + go ';' (xs, F2 a [] _, SM _ b c d e) = let p' = SM a b c d e in (xs |> p', F1 [] 1, p') + go ';' (xs, F2 a ds k, SM _ _ c d e) = let p' = SM a (k * (readR ds)) c d e in (xs |> p', F1 [] 1, p') - go d (xs, F3 a b ds k, p) | isDigit d = (xs, F3 a b (digitToInt d : ds) k, p) - go '-' (xs, F3 a b [] _, p) = (xs, F3 a b [] (-1), p) - go ':' (xs, F3 a b [] _, p@(SM _ _ c _)) = (xs, F4 a b c, p) - go ':' (xs, F3 a b ds k, p) = (xs, F4 a b (k * digits ds), p) - go ';' (xs, F3 a b [] _, SM _ _ c d) = let p' = SM a b c d in (xs |> p', F1 [] 1, p') - go ';' (xs, F3 a b ds k, SM _ _ _ d) = let p' = SM a b (k * digits ds) d in - (xs |> p', F1 [] 1, p') + go d (xs, F3 a b ds k, p) | isDigit d = (xs, F3 a b (d : ds) k, p) + go '-' (xs, F3 a b [] _, p) = (xs, F3 a b [] (-1), p) + go ':' (xs, F3 a b [] _, p@(SM _ _ c _ _)) = (xs, F4 a b c Nothing, p) + go ':' (xs, F3 a b ds k, p) = (xs, F4 a b (k * (readR ds)) Nothing, p) + go ';' (xs, F3 a b [] _, SM _ _ c d e) = let p' = SM a b c d e in (xs |> p', F1 [] 1, p') + go ';' (xs, F3 a b ds k, SM _ _ _ d e) = let p' = SM a b (k * (readR ds)) d e in + (xs |> p', F1 [] 1, p') - go 'i' (xs, F4 a b c, p) = (xs, F5 (SM a b c JumpInto), p) - go 'o' (xs, F4 a b c, p) = (xs, F5 (SM a b c JumpFrom), p) - go '-' (xs, F4 a b c, p) = (xs, F5 (SM a b c JumpRegular), p) - go ';' (xs, F5 s, _) = (xs |> s, F1 [] 1, s) + go 'i' (xs, F4 a b c Nothing, p) = (xs, F4 a b c (Just JumpInto), p) + go 'o' (xs, F4 a b c Nothing, p) = (xs, F4 a b c (Just JumpFrom), p) + go '-' (xs, F4 a b c Nothing, p) = (xs, F4 a b c (Just JumpRegular), p) + go ':' (xs, F4 a b c (Just d), p) = (xs, F5 a b c d [], p) + go ':' (xs, F4 a b c _, p@(SM _ _ _ d _)) = (xs, F5 a b c d [], p) + go ';' (xs, F4 a b c _, SM _ _ _ d e) = let p' = SM a b c d e in + (xs |> p', F1 [] 1, p') - go c (xs, _, p) = (xs, error ("srcmap: y u " ++ show c ++ "?!?"), p) + go d (xs, F5 a b c j ds, p) | isDigit d = (xs, F5 a b c j (d : ds), p) + go ';' (xs, F5 a b c j [], _) = let p' = SM a b c j (-1) in -- solc <0.6 + (xs |> p', F1 [] 1, p') + go ';' (xs, F5 a b c j ds, _) = let p' = SM a b c j (readR ds) in -- solc >=0.6 + (xs |> p', F1 [] 1, p') + go c (xs, state, p) = (xs, error ("srcmap: y u " ++ show c ++ " in state" ++ show state ++ "?!?"), p) + makeSourceCache :: [Text] -> Map Text Value -> IO SourceCache makeSourceCache paths asts = do xs <- mapM (BS.readFile . Text.unpack) paths @@ -214,6 +277,20 @@ let Just (solc, _, _) = readJSON json return (solc ^? ix (path <> ":" <> contract) . creationCode) +solcRuntime :: Text -> Text -> IO (Maybe ByteString) +solcRuntime contract src = do + (json, path) <- solidity' src + let Just (solc, _, _) = readJSON json + return (solc ^? ix (path <> ":" <> contract) . runtimeCode) + +functionAbi :: Text -> IO Method +functionAbi f = do + (json, path) <- solidity' ("contract ABI { function " <> f <> " public {}}") + let Just (solc, _, _) = readJSON json + case Map.toList $ solc ^?! ix (path <> ":ABI") . abiMap of + [(_,b)] -> return b + _ -> error "hevm internal error: unexpected abi format" + force :: String -> Maybe a -> a force s = fromMaybe (error s) @@ -244,7 +321,7 @@ _contractAst = fromMaybe (error "JSON lacks abstract syntax trees.") - (preview (ix (Text.split (== ':') s !! 0) . key "AST") asts), + (preview (ix (head (Text.split (== ':') s)) . key "AST") asts), _constructorInputs = let @@ -284,14 +361,30 @@ (case abi ^?! key "anonymous" . _Bool of True -> Anonymous False -> NotAnonymous) - (map (\y -> ( force "internal error: type" (parseTypeName (y ^?! key "type" . _String)) + (map (\y -> ( force "internal error: type" (parseTypeName' y) , if y ^?! key "indexed" . _Bool then Indexed else NotIndexed )) (toList $ abi ^?! key "inputs" . _Array)) - ) + ), + _storageLayout = mkStorageLayout $ x ^? key "storage-layout" . _String }) +mkStorageLayout :: Maybe Text -> Maybe (Map Text StorageItem) +mkStorageLayout Nothing = Nothing +mkStorageLayout (Just json) = do items <- json ^? key "storage" . _Array + types <- json ^? key "types" + Map.fromList <$> mapM + (\item -> do name <- item ^? key "label" . _String + offset <- item ^? key "offset" . _Number >>= toBoundedInteger + slot <- item ^? key "slot" . _String + typ <- item ^? key "type" . _String + slotType <- types ^?! key typ ^? key "label" . _String + return (name, StorageItem (read $ Text.unpack slotType) offset (read $ Text.unpack slot)) + + ) + (Vector.toList items) + signature :: AsValue s => s -> Text signature abi = case abi ^?! key "type" of @@ -305,11 +398,19 @@ ")" ] +-- Helper function to convert the fields to the desired type +parseTypeName' :: AsValue s => s -> Maybe AbiType +parseTypeName' x = + parseTypeName + (fromMaybe mempty $ x ^? key "components" . _Array . to parseComponents) + (x ^?! key "type" . _String) + where parseComponents = fmap $ snd . parseMethodInput + -- This actually can also parse a method output! :O -parseMethodInput :: (Show s, AsValue s) => s -> (Text, AbiType) +parseMethodInput :: AsValue s => s -> (Text, AbiType) parseMethodInput x = ( x ^?! key "name" . _String - , force "internal error: method type" (parseTypeName (x ^?! key "type" . _String)) + , force "internal error: method type" (parseTypeName' x) ) toCode :: Text -> ByteString @@ -318,11 +419,11 @@ solidity' :: Text -> IO (Text, Text) solidity' src = withSystemTempFile "hevm.sol" $ \path handle -> do hClose handle - writeFile path ("pragma solidity ^0.5.2;\n" <> src) + writeFile path ("pragma solidity ^0.6.7;\n" <> src) x <- pack <$> readProcess "solc" - ["--combined-json=bin-runtime,bin,srcmap,srcmap-runtime,abi,ast", path] + ["--combined-json=bin-runtime,bin,srcmap,srcmap-runtime,abi,ast,storage-layout", path] "" return (x, pack path) @@ -339,14 +440,14 @@ -- as the codehash matches otherwise, we don't care if there is some -- difference there. stripBytecodeMetadata :: ByteString -> ByteString -stripBytecodeMetadata bs = - let (_, b) = BS.breakSubstring bzzrPrefix (BS.reverse bs) - in BS.reverse b - -bzzrPrefix :: ByteString -bzzrPrefix = - -- a1 65 "bzzr0" 0x58 0x20 - BS.reverse $ BS.pack [0xa1, 0x65, 98, 122, 122, 114, 48, 0x58, 0x20] +stripBytecodeMetadata bc | BS.length cl /= 2 = bc + | BS.length h >= cl' && (isRight . deserialiseFromBytes decodeTerm $ fromStrict cbor) = bc' + | otherwise = bc + where + l = BS.length bc + (h, cl) = BS.splitAt (l - 2) bc + cl' = fromIntegral . runGet getWord16be $ fromStrict cl + (bc', cbor) = BS.splitAt (BS.length h - cl') h -- | Every node in the AST has an ID, and other nodes reference those -- IDs. This function recurses through the tree looking for objects @@ -366,13 +467,13 @@ astSrcMap :: Map Int Value -> (SrcMap -> Maybe Value) astSrcMap astIds = - \(SM i n f _) -> Map.lookup (i, n, f) tmp + \(SM i n f _ _) -> Map.lookup (i, n, f) tmp where tmp :: Map (Int, Int, Int) Value tmp = - ( Map.fromList - . catMaybes - . map (\v -> + Map.fromList + . mapMaybe + (\v -> case preview (key "src" . _String) v of Just src -> case map (readMaybe . Text.unpack) (Text.split (== ':') src) of @@ -384,4 +485,3 @@ Nothing) . Map.elems $ astIds - ) diff --git a/src/EVM/Stepper.hs b/src/EVM/Stepper.hs --- a/src/EVM/Stepper.hs +++ b/src/EVM/Stepper.hs @@ -1,20 +1,18 @@ {-# Language GADTs #-} -{-# Language NamedFieldPuns #-} +{-# Language DataKinds #-} module EVM.Stepper ( Action (..) - , Failure (..) , Stepper , exec , execFully - , execFullyOrFail - , decode - , fail + , runFully , wait + , ask , evm - , note , entering , enter + , interpret ) where @@ -28,14 +26,20 @@ import Prelude hiding (fail) -import Control.Monad.Operational (Program, singleton) +import Control.Monad.Operational (Program(..), singleton, view, ProgramViewT(..), ProgramView) +import Control.Monad.State.Strict (runState, liftIO, StateT) +import qualified Control.Monad.State.Class as State +import qualified EVM.Exec +import Control.Lens (use) import Data.Binary.Get (runGetOrFail) import Data.Text (Text) +import EVM.Symbolic (Buffer) -import EVM (EVM, VMResult (VMFailure, VMSuccess), Error (Query), Query) +import EVM (EVM, VM, VMResult (VMFailure, VMSuccess), Error (Query, Choose), Query, Choose) import qualified EVM import EVM.ABI (AbiType, AbiValue, getAbi) +import qualified EVM.Fetch as Fetch import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LazyByteString @@ -44,27 +48,20 @@ data Action a where -- | Keep executing until an intermediate result is reached - Exec :: Action VMResult - - -- | Short-circuit with a failure - Fail :: Failure -> Action a - + Exec :: Action VMResult + + -- | Keep executing until an intermediate state is reached + Run :: Action VM + -- | Wait for a query to be resolved Wait :: Query -> Action () + -- | Multiple things can happen + Ask :: Choose -> Action () + -- | Embed a VM state transformation EVM :: EVM a -> Action a - -- | Write something to the log or terminal - Note :: Text -> Action () - --- | Some failure raised by a stepper -data Failure - = ContractNotFound - | DecodingError - | VMFailed Error - deriving Show - -- | Type alias for an operational monad of @Action@ type Stepper a = Program Action a @@ -73,42 +70,43 @@ exec :: Stepper VMResult exec = singleton Exec -fail :: Failure -> Stepper a -fail = singleton . Fail +run :: Stepper VM +run = singleton Run wait :: Query -> Stepper () wait = singleton . Wait +ask :: Choose -> Stepper () +ask = singleton . Ask + evm :: EVM a -> Stepper a evm = singleton . EVM -note :: Text -> Stepper () -note = singleton . Note - -- | Run the VM until final result, resolving all queries -execFully :: Stepper (Either Error ByteString) +execFully :: Stepper (Either Error Buffer) execFully = exec >>= \case VMFailure (Query q) -> wait q >> execFully + VMFailure (Choose q) -> + ask q >> execFully VMFailure x -> pure (Left x) VMSuccess x -> pure (Right x) -execFullyOrFail :: Stepper ByteString -execFullyOrFail = execFully >>= either (fail . VMFailed) pure - --- | Decode a blob as an ABI value, failing if ABI encoding wrong -decode :: AbiType -> ByteString -> Stepper AbiValue -decode abiType bytes = - case runGetOrFail (getAbi abiType) (LazyByteString.fromStrict bytes) of - Right ("", _, x) -> - pure x - Right _ -> - fail DecodingError - Left _ -> - fail DecodingError +-- | Run the VM until its final state +runFully :: Stepper EVM.VM +runFully = do + vm <- run + case EVM._result vm of + Nothing -> error "should not occur" + Just (VMFailure (Query q)) -> + wait q >> runFully + Just (VMFailure (Choose q)) -> + ask q >> runFully + Just _ -> + pure vm entering :: Text -> Stepper a -> Stepper a entering t stepper = do @@ -118,5 +116,31 @@ pure x enter :: Text -> Stepper () -enter t = do - evm (EVM.pushTrace (EVM.EntryTrace t)) +enter t = evm (EVM.pushTrace (EVM.EntryTrace t)) + +interpret :: Fetch.Fetcher -> Stepper a -> StateT VM IO a +interpret fetcher = + eval . view + + where + eval + :: ProgramView Action a + -> StateT VM IO a + + eval (Return x) = + pure x + + eval (action :>>= k) = + case action of + Exec -> + EVM.Exec.exec >>= interpret fetcher . k + Run -> + EVM.Exec.run >>= interpret fetcher . k + Wait q -> + do m <- liftIO (fetcher q) + State.state (runState m) >> interpret fetcher (k ()) + Ask _ -> + error "cannot make choices with this interpreter" + EVM m -> do + r <- State.state (runState m) + interpret fetcher (k r) diff --git a/src/EVM/StorageLayout.hs b/src/EVM/StorageLayout.hs --- a/src/EVM/StorageLayout.hs +++ b/src/EVM/StorageLayout.hs @@ -3,21 +3,18 @@ -- Figures out the layout of storage slots for Solidity contracts. import EVM.Dapp (DappInfo, dappAstSrcMap, dappAstIdMap) -import EVM.Solidity (SolcContract, creationSrcmap) -import EVM.ABI (AbiType (..), parseTypeName, abiTypeSolidity) +import EVM.Solidity (SolcContract, creationSrcmap, SlotType(..)) +import EVM.ABI (AbiType (..), parseTypeName) import Data.Aeson (Value (Number)) import Data.Aeson.Lens import Control.Lens -import Data.Text (Text, unpack, words) +import Data.Text (Text, unpack, pack, words) import Data.Foldable (toList) import Data.Maybe (fromMaybe, isJust) -import Data.Monoid ((<>)) - -import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Sequence as Seq @@ -80,7 +77,7 @@ [ variableName , " (", name, ")" , "\n", " Type: " - , slotTypeSolidity (slotTypeForDeclaration x) + , pack $ show (slotTypeForDeclaration x) ] Nothing -> error "malformed variable declaration" @@ -98,32 +95,6 @@ nodeIs "VariableDeclaration" x && preview (key "attributes" . key "constant" . _Bool) x /= Just True -data SlotType - -- Note that mapping keys can only be elementary; - -- that excludes arrays, contracts, and mappings. - = StorageMapping (NonEmpty AbiType) AbiType - | StorageValue AbiType - deriving Show - -slotTypeSolidity :: SlotType -> Text -slotTypeSolidity = - \case - StorageValue t -> - abiTypeSolidity t - StorageMapping (s NonEmpty.:| ss) t -> - "mapping(" - <> abiTypeSolidity s - <> " => " - <> foldr - (\x y -> - "mapping(" - <> abiTypeSolidity x - <> " => " - <> y - <> ")") - (abiTypeSolidity t) ss - <> ")" - slotTypeForDeclaration :: Value -> SlotType slotTypeForDeclaration node = case toList <$> preview (key "children" . _Array) node of @@ -165,10 +136,8 @@ , preview (key "attributes" . key "type" . _String) x ) of (Just "ElementaryTypeName", _, Just typeName) -> - case parseTypeName (head (words typeName)) of - Just t -> t - Nothing -> - error ("ungrokked value type: " ++ show typeName) + fromMaybe (error ("ungrokked value type: " ++ show typeName)) + (parseTypeName mempty (head (words typeName))) (Just "UserDefinedTypeName", _, _) -> AbiAddressType (Just "ArrayTypeName", fmap toList -> Just [t], _)-> diff --git a/src/EVM/SymExec.hs b/src/EVM/SymExec.hs new file mode 100644 --- /dev/null +++ b/src/EVM/SymExec.hs @@ -0,0 +1,317 @@ +{-# Language DataKinds #-} +{-# Language OverloadedStrings #-} +{-# Language TypeApplications #-} + +module EVM.SymExec where + + +import Prelude hiding (Word) + +import Control.Lens hiding (pre) +import EVM hiding (Query, push) +import EVM.Exec +import qualified EVM.Fetch as Fetch +import EVM.ABI +import EVM.Stepper (Stepper) +import qualified EVM.Stepper as Stepper +import qualified Control.Monad.Operational as Operational +import EVM.Types hiding (Word) +import EVM.Symbolic (litBytes, SymWord(..), sw256, Buffer(..)) +import EVM.Concrete (createAddress, Word) +import qualified EVM.FeeSchedule as FeeSchedule +import Data.SBV.Trans.Control +import Data.SBV.Trans hiding (distinct, Word) +import Data.SBV hiding (runSMT, newArray_, addAxiom, distinct, sWord8s, Word) +import Data.Vector (toList, fromList) + +import Control.Monad.IO.Class +import qualified Control.Monad.State.Class as State +import Data.ByteString (ByteString, pack) +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString as BS +import Data.Text (Text, splitOn, unpack) +import Control.Monad.State.Strict (runStateT, runState, StateT, get, put, zipWithM) +import Control.Applicative + +-- | Convenience functions for generating large symbolic byte strings +sbytes32, sbytes256, sbytes512, sbytes1024 :: Query ([SWord 8]) +sbytes32 = toBytes <$> freshVar_ @ (WordN 256) +sbytes128 = toBytes <$> freshVar_ @ (WordN 1024) +sbytes256 = liftA2 (++) sbytes128 sbytes128 +sbytes512 = liftA2 (++) sbytes256 sbytes256 +sbytes1024 = liftA2 (++) sbytes512 sbytes512 + +-- | Abstract calldata argument generation +-- We don't assume input types are restricted to their proper range here; +-- such assumptions should instead be given as preconditions. +-- This could catch some interesting calldata mismanagement errors. +symAbiArg :: AbiType -> Query ([SWord 8], SWord 32) +symAbiArg (AbiUIntType n) | n `mod` 8 == 0 && n <= 256 = do x <- sbytes32 + return (x, 32) + | otherwise = error "bad type" + +symAbiArg (AbiIntType n) | n `mod` 8 == 0 && n <= 256 = do x <- sbytes32 + return (x, 32) + | otherwise = error "bad type" +symAbiArg AbiBoolType = do x <- sbytes32 + return (x, 32) + +symAbiArg AbiAddressType = do x <- sbytes32 + return (x, 32) + +symAbiArg (AbiBytesType n) | n <= 32 = do x <- sbytes32 + return (x, 32) + | otherwise = error "bad type" + +-- TODO: is this encoding correct? +symAbiArg (AbiArrayType len typ) = + do args <- mapM symAbiArg (replicate len typ) + return (litBytes (encodeAbiValue (AbiUInt 256 (fromIntegral len))) <> (concat $ fst <$> args), + 32 + (sum $ snd <$> args)) + +symAbiArg (AbiTupleType tuple) = + do args <- mapM symAbiArg (toList tuple) + return (concat $ fst <$> args, sum $ snd <$> args) +symAbiArg n = + error $ "Unsupported symbolic abiencoding for" + <> show n + <> ". Please file an issue at https://github.com/dapphub/dapptools if you really need this." + +-- | Generates calldata matching given type signature, optionally specialized +-- with concrete arguments. +-- Any argument given as "" or omitted at the tail of the list are +-- kept symbolic. +symCalldata :: Text -> [AbiType] -> [String] -> Query ([SWord 8], SWord 32) +symCalldata sig typesignature concreteArgs = + let args = concreteArgs <> replicate (length typesignature - length concreteArgs) "" + mkArg typ "" = symAbiArg typ + mkArg typ arg = let n = litBytes . encodeAbiValue $ makeAbiValue typ arg + in return (n, num (length n)) + sig' = litBytes $ selector sig + in do calldatas <- zipWithM mkArg typesignature args + return (sig' <> concat (fst <$> calldatas), 4 + (sum $ snd <$> calldatas)) + +abstractVM :: Maybe (Text, [AbiType]) -> [String] -> ByteString -> StorageModel -> Query VM +abstractVM typesignature concreteArgs x storagemodel = do + (cd', cdlen, cdconstraint) <- + case typesignature of + Nothing -> do cd <- sbytes256 + len <- freshVar_ + return (cd, len, len .<= 256) + Just (name, typs) -> do (cd, cdlen) <- symCalldata name typs concreteArgs + return (cd, cdlen, sTrue) + symstore <- case storagemodel of + SymbolicS -> Symbolic <$> freshArray_ Nothing + InitialS -> Symbolic <$> freshArray_ (Just 0) + ConcreteS -> return $ Concrete mempty + c <- SAddr <$> freshVar_ + value' <- sw256 <$> freshVar_ + return $ loadSymVM (RuntimeCode x) symstore storagemodel c value' (SymbolicBuffer cd', cdlen) & over pathConditions ((<>) [cdconstraint]) + +loadSymVM :: ContractCode -> Storage -> StorageModel -> SAddr -> SymWord -> (Buffer, SWord 32) -> VM +loadSymVM x initStore model addr callvalue' calldata' = + (makeVm $ VMOpts + { vmoptContract = contractWithStore x initStore + , vmoptCalldata = calldata' + , vmoptValue = callvalue' + , vmoptAddress = createAddress ethrunAddress 1 + , vmoptCaller = addr + , vmoptOrigin = ethrunAddress --todo: generalize + , vmoptCoinbase = 0 + , vmoptNumber = 0 + , vmoptTimestamp = 0 + , vmoptBlockGaslimit = 0 + , vmoptGasprice = 0 + , vmoptDifficulty = 0 + , vmoptGas = 0xffffffffffffffff + , vmoptGaslimit = 0xffffffffffffffff + , vmoptMaxCodeSize = 0xffffffff + , vmoptSchedule = FeeSchedule.istanbul + , vmoptChainId = 1 + , vmoptCreate = False + , vmoptStorageModel = model + }) & set (env . contracts . at (createAddress ethrunAddress 1)) + (Just (contractWithStore x initStore)) + +-- | Interpreter which explores all paths at +-- | branching points. +-- | returns a list of possible final evm states +interpret + :: Fetch.Fetcher + -> Maybe Integer --max iterations + -> Stepper a + -> StateT VM IO [a] +interpret fetcher maxIter = + eval . Operational.view + + where + eval + :: Operational.ProgramView Stepper.Action a + -> StateT VM IO [a] + + eval (Operational.Return x) = + pure [x] + + eval (action Operational.:>>= k) = + case action of + Stepper.Exec -> + exec >>= interpret fetcher maxIter . k + Stepper.Run -> + run >>= interpret fetcher maxIter . k + Stepper.Ask (EVM.PleaseChoosePath continue) -> do + vm <- get + case maxIterationsReached vm maxIter of + Nothing -> do a <- interpret fetcher maxIter (Stepper.evm (continue True) >>= k) + put vm + b <- interpret fetcher maxIter (Stepper.evm (continue False) >>= k) + return $ a <> b + Just n -> interpret fetcher maxIter (Stepper.evm (continue (not n)) >>= k) + Stepper.Wait q -> + do m <- liftIO (fetcher q) + interpret fetcher maxIter (Stepper.evm m >>= k) + Stepper.EVM m -> + State.state (runState m) >>= interpret fetcher maxIter . k + +maxIterationsReached :: VM -> Maybe Integer -> Maybe Bool +maxIterationsReached _ Nothing = Nothing +maxIterationsReached vm (Just maxIter) = + let codelocation = getCodeLocation vm + iters = view (iterations . at codelocation . non 0) vm + in if num maxIter <= iters + then view (cache . path . at (codelocation, iters - 1)) vm + else Nothing + +type Precondition = VM -> SBool +type Postcondition = (VM, VM) -> SBool + +checkAssert :: ContractCode -> Maybe Integer -> Maybe (Text, [AbiType]) -> [String] -> Query (Either (VM, [VM]) VM) +checkAssert c maxIter signature' concreteArgs = verifyContract c maxIter signature' concreteArgs SymbolicS (const sTrue) (Just checkAssertions) + +checkAssertions :: Postcondition +checkAssertions (_, out) = case view result out of + Just (EVM.VMFailure (EVM.UnrecognizedOpcode 254)) -> sFalse + _ -> sTrue + +verifyContract :: ContractCode -> Maybe Integer -> Maybe (Text, [AbiType]) -> [String] -> StorageModel -> Precondition -> Maybe Postcondition -> Query (Either (VM, [VM]) VM) +verifyContract code' maxIter signature' concreteArgs storagemodel pre maybepost = do + preStateRaw <- abstractVM signature' concreteArgs theCode storagemodel + -- add the pre condition to the pathconditions to ensure that we are only exploring valid paths + let preState = over pathConditions ((++) [pre preStateRaw]) preStateRaw + verify preState maxIter Nothing maybepost + where theCode = case code' of + InitCode b -> b + RuntimeCode b -> b + +pruneDeadPaths :: [VM] -> [VM] +pruneDeadPaths = + filter $ \vm -> case view result vm of + Just (VMFailure DeadPath) -> False + _ -> True + +-- | Symbolically execute the VM and check all endstates against the postcondition, if available. +-- Returns `Right VM` if the postcondition can be violated, where `VM` is a prestate counterexample, +-- or `Left (VM, [VM])`, a pair of `prestate` and post vm states. +verify :: VM -> Maybe Integer -> Maybe (Fetch.BlockNumber, Text) -> Maybe Postcondition -> Query (Either (VM, [VM]) VM) +verify preState maxIter rpcinfo maybepost = do + let model = view (env . storageModel) preState + smtState <- queryState + results <- io $ fst <$> runStateT (interpret (Fetch.oracle smtState rpcinfo model) maxIter Stepper.runFully) preState + case maybepost of + (Just post) -> do + let livePaths = pruneDeadPaths results + postC = sOr $ fmap (\postState -> (sAnd (view pathConditions postState)) .&& sNot (post (preState, postState))) livePaths + -- is there any path which can possibly violate + -- the postcondition? + resetAssertions + constrain postC + io $ putStrLn "checking postcondition..." + checkSat >>= \case + Unk -> do io $ putStrLn "postcondition query timed out" + return $ Left (preState, livePaths) + Unsat -> do io $ putStrLn "Q.E.D." + return $ Left (preState, livePaths) + Sat -> return $ Right preState + + Nothing -> do io $ putStrLn "Q.E.D." + return $ Left (preState, pruneDeadPaths results) + +-- | Compares two contract runtimes for trace equivalence by running two VMs and comparing the end states. +equivalenceCheck :: ByteString -> ByteString -> Maybe Integer -> Maybe (Text, [AbiType]) -> Query (Either ([VM], [VM]) VM) +equivalenceCheck bytecodeA bytecodeB maxiter signature' = do + preStateA <- abstractVM signature' [] bytecodeA SymbolicS + + let preself = preStateA ^. state . contract + precaller = preStateA ^. state . caller + callvalue' = preStateA ^. state . callvalue + prestorage = preStateA ^?! env . contracts . ix preself . storage + (calldata', cdlen) = view (state . calldata) preStateA + pathconds = view pathConditions preStateA + preStateB = loadSymVM (RuntimeCode bytecodeB) prestorage SymbolicS precaller callvalue' (calldata', cdlen) & set pathConditions pathconds + + smtState <- queryState + (aVMs, bVMs) <- both (\x -> io $ fst <$> runStateT (interpret (Fetch.oracle smtState Nothing SymbolicS) maxiter Stepper.runFully) x) + (preStateA, preStateB) + -- Check each pair of endstates for equality: + let differingEndStates = uncurry distinct <$> [(a,b) | a <- pruneDeadPaths aVMs, b <- pruneDeadPaths bVMs] + distinct a b = + let (aPath, bPath) = both' (view pathConditions) (a, b) + (aSelf, bSelf) = both' (view (state . contract)) (a, b) + (aEnv, bEnv) = both' (view (env . contracts)) (a, b) + (aResult, bResult) = both' (view result) (a, b) + (Symbolic aStorage, Symbolic bStorage) = (view storage (aEnv ^?! ix aSelf), view storage (bEnv ^?! ix bSelf)) + differingResults = case (aResult, bResult) of + + (Just (VMSuccess aOut), Just (VMSuccess bOut)) -> + aOut ./= bOut .|| aStorage ./= bStorage .|| fromBool (aSelf /= bSelf) + + (Just (VMFailure UnexpectedSymbolicArg), _) -> + error $ "Unexpected symbolic argument at opcode: " <> maybe "??" show (vmOp a) <> ". Not supported (yet!)" + + (_, Just (VMFailure UnexpectedSymbolicArg)) -> + error $ "Unexpected symbolic argument at opcode: " <> maybe "??" show (vmOp a) <> ". Not supported (yet!)" + + (Just (VMFailure _), Just (VMFailure _)) -> sFalse + + (Just _, Just _) -> sTrue + + _ -> error "Internal error during symbolic execution (should not be possible)" + + in sAnd aPath .&& sAnd bPath .&& differingResults + -- If there exists a pair of endstates where this is not the case, + -- the following constraint is satisfiable + resetAssertions + constrain $ sOr differingEndStates + + checkSat >>= \case + Unk -> error "solver said unknown!" + Sat -> return $ Right preStateA + Unsat -> return $ Left (pruneDeadPaths aVMs, pruneDeadPaths bVMs) + +both' :: (a -> b) -> (a, a) -> (b, b) +both' f (x, y) = (f x, f y) + +showCounterexample :: VM -> Maybe (Text, [AbiType]) -> Query () +showCounterexample vm maybesig = do + let (calldata', cdlen) = view (EVM.state . EVM.calldata) vm + S _ cvalue = view (EVM.state . EVM.callvalue) vm + SAddr caller' = view (EVM.state . EVM.caller) vm + cdlen' <- num <$> getValue cdlen + calldatainput <- case calldata' of + SymbolicBuffer cd -> mapM (getValue.fromSized) (take cdlen' cd) >>= return . pack + ConcreteBuffer cd -> return $ BS.take cdlen' cd + callvalue' <- num <$> getValue cvalue + caller'' <- num <$> getValue caller' + io $ do + putStrLn "Calldata:" + print $ ByteStringS calldatainput + + -- pretty print calldata input if signature is available + case maybesig of + Just (name, types) -> putStrLn $ unpack (head (splitOn "(" name)) ++ + show (decodeAbiValue (AbiTupleType (fromList types)) $ Lazy.fromStrict (BS.drop 4 calldatainput)) + Nothing -> return () + + putStrLn "Caller:" + print (Addr caller'') + putStrLn "Callvalue:" + print callvalue' diff --git a/src/EVM/Symbolic.hs b/src/EVM/Symbolic.hs new file mode 100644 --- /dev/null +++ b/src/EVM/Symbolic.hs @@ -0,0 +1,300 @@ +{-# Language NamedFieldPuns #-} +{-# Language DataKinds #-} +{-# Language OverloadedStrings #-} +{-# Language TypeApplications #-} + +module EVM.Symbolic where + +import Prelude hiding (Word) +import qualified Data.ByteString as BS +import Data.ByteString (ByteString) +import Control.Lens hiding (op, (:<), (|>), (.>)) +import Data.Maybe (fromMaybe, fromJust) + +import EVM.Types +import EVM.Concrete (Word (..), Whiff(..)) +import qualified EVM.Concrete as Concrete +import Data.SBV hiding (runSMT, newArray_, addAxiom, Word) + + +-- | Symbolic words of 256 bits, possibly annotated with additional +-- "insightful" information +data SymWord = S Whiff (SWord 256) + +-- | Convenience functions transporting between the concrete and symbolic realm +sw256 :: SWord 256 -> SymWord +sw256 = S Dull + +litWord :: Word -> (SymWord) +litWord (C whiff a) = S whiff (literal $ toSizzle a) + +w256lit :: W256 -> SymWord +w256lit = S Dull . literal . toSizzle + +litAddr :: Addr -> SAddr +litAddr = SAddr . literal . toSizzle + +litBytes :: ByteString -> [SWord 8] +litBytes bs = fmap (toSized . literal) (BS.unpack bs) + +maybeLitWord :: SymWord -> Maybe Word +maybeLitWord (S whiff a) = fmap (C whiff . fromSizzle) (unliteral a) + +maybeLitAddr :: SAddr -> Maybe Addr +maybeLitAddr (SAddr a) = fmap fromSizzle (unliteral a) + +maybeLitBytes :: [SWord 8] -> Maybe ByteString +maybeLitBytes xs = fmap (\x -> BS.pack (fmap fromSized x)) (mapM unliteral xs) + +-- | Note: these forms are crude and in general, +-- the continuation passing style `forceConcrete` +-- alternatives should be prefered for better error +-- handling when used during EVM execution + +forceLit :: SymWord -> Word +forceLit (S whiff a) = case unliteral a of + Just c -> C whiff (fromSizzle c) + Nothing -> error "unexpected symbolic argument" + +forceLitBytes :: [SWord 8] -> ByteString +forceLitBytes = BS.pack . fmap (fromSized . fromJust . unliteral) + + +-- | Arithmetic operations on SymWord + +sdiv :: SymWord -> SymWord -> SymWord +sdiv (S _ x) (S _ y) = let sx, sy :: SInt 256 + sx = sFromIntegral x + sy = sFromIntegral y + in sw256 $ sFromIntegral (sx `sQuot` sy) + +smod :: SymWord -> SymWord -> SymWord +smod (S _ x) (S _ y) = let sx, sy :: SInt 256 + sx = sFromIntegral x + sy = sFromIntegral y + in sw256 $ ite (y .== 0) 0 (sFromIntegral (sx `sRem` sy)) + +addmod :: SymWord -> SymWord -> SymWord -> SymWord +addmod (S _ x) (S _ y) (S _ z) = let to512 :: SWord 256 -> SWord 512 + to512 = sFromIntegral + in sw256 $ sFromIntegral $ ((to512 x) + (to512 y)) `sMod` (to512 z) + +mulmod :: SymWord -> SymWord -> SymWord -> SymWord +mulmod (S _ x) (S _ y) (S _ z) = let to512 :: SWord 256 -> SWord 512 + to512 = sFromIntegral + in sw256 $ sFromIntegral $ ((to512 x) * (to512 y)) `sMod` (to512 z) + +slt :: SymWord -> SymWord -> SymWord +slt (S _ x) (S _ y) = + sw256 $ ite (sFromIntegral x .< (sFromIntegral y :: (SInt 256))) 1 0 + +sgt :: SymWord -> SymWord -> SymWord +sgt (S _ x) (S _ y) = + sw256 $ ite (sFromIntegral x .> (sFromIntegral y :: (SInt 256))) 1 0 + +-- | Operations over symbolic memory (list of symbolic bytes) +swordAt :: Int -> [SWord 8] -> SymWord +swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs + +readByteOrZero' :: Int -> [SWord 8] -> SWord 8 +readByteOrZero' i bs = fromMaybe 0 (bs ^? ix i) + +sliceWithZero' :: Int -> Int -> [SWord 8] -> [SWord 8] +sliceWithZero' o s m = truncpad s $ drop o m + +writeMemory' :: [SWord 8] -> Word -> Word -> Word -> [SWord 8] -> [SWord 8] +writeMemory' bs1 (C _ n) (C _ src) (C _ dst) bs0 = + let + (a, b) = splitAt (num dst) bs0 + a' = replicate (num dst - length a) 0 + c = if src > num (length bs1) + then replicate (num n) 0 + else sliceWithZero' (num src) (num n) bs1 + b' = drop (num (n)) b + in + a <> a' <> c <> b' + +readMemoryWord' :: Word -> [SWord 8] -> SymWord +readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) + +readMemoryWord32' :: Word -> [SWord 8] -> SWord 32 +readMemoryWord32' (C _ i) m = fromBytes $ truncpad 4 (drop (num i) m) + +setMemoryWord' :: Word -> SymWord -> [SWord 8] -> [SWord 8] +setMemoryWord' (C _ i) (S _ x) = + writeMemory' (toBytes x) 32 0 (num i) + +setMemoryByte' :: Word -> SWord 8 -> [SWord 8] -> [SWord 8] +setMemoryByte' (C _ i) x = + writeMemory' [x] 1 0 (num i) + +readSWord' :: Word -> [SWord 8] -> SymWord +readSWord' (C _ i) x = + if i > num (length x) + then 0 + else swordAt (num i) x + + +select' :: (Ord b, Num b, SymVal b, Mergeable a) => [a] -> a -> SBV b -> a +select' xs err ind = walk xs ind err + where walk [] _ acc = acc + walk (e:es) i acc = walk es (i-1) (ite (i .== 0) e acc) + +-- Generates a ridiculously large set of constraints (roughly 25k) when +-- the index is symbolic, but it still seems (kind of) manageable +-- for the solvers. +readSWordWithBound :: SWord 32 -> Buffer -> SWord 32 -> SymWord +readSWordWithBound ind (SymbolicBuffer xs) bound = + let boundedList = [ite (i .<= bound) x 0 | (x, i) <- zip xs [1..]] + in sw256 . fromBytes $ [select' boundedList 0 (ind + j) | j <- [0..31]] +readSWordWithBound ind (ConcreteBuffer xs) bound = + case fromSized <$> unliteral ind of + Nothing -> readSWordWithBound ind (SymbolicBuffer (litBytes xs)) bound + Just x' -> + -- INVARIANT: bound should always be length xs for concrete bytes + -- so we should be able to safely ignore it here + litWord $ Concrete.readMemoryWord (num x') xs + + +-- | Operations over buffers (concrete or symbolic) + +-- | A buffer is a list of bytes. For concrete execution, this is simply `ByteString`. +-- In symbolic settings, it is a list of symbolic bitvectors of size 8. +data Buffer + = ConcreteBuffer ByteString + | SymbolicBuffer [SWord 8] + deriving (Show) + +instance Semigroup Buffer where + ConcreteBuffer a <> ConcreteBuffer b = ConcreteBuffer (a <> b) + ConcreteBuffer a <> SymbolicBuffer b = SymbolicBuffer (litBytes a <> b) + SymbolicBuffer a <> ConcreteBuffer b = SymbolicBuffer (a <> litBytes b) + SymbolicBuffer a <> SymbolicBuffer b = SymbolicBuffer (a <> b) + +instance Monoid Buffer where + mempty = ConcreteBuffer mempty + +instance EqSymbolic Buffer where + ConcreteBuffer a .== ConcreteBuffer b = literal (a == b) + ConcreteBuffer a .== SymbolicBuffer b = litBytes a .== b + SymbolicBuffer a .== ConcreteBuffer b = a .== litBytes b + SymbolicBuffer a .== SymbolicBuffer b = a .== b + + +-- a whole foldable instance seems overkill, but length is always good to have! +len :: Buffer -> Int +len (SymbolicBuffer bs) = length bs +len (ConcreteBuffer bs) = BS.length bs + +grab :: Int -> Buffer -> Buffer +grab n (SymbolicBuffer bs) = SymbolicBuffer $ take n bs +grab n (ConcreteBuffer bs) = ConcreteBuffer $ BS.take n bs + +ditch :: Int -> Buffer -> Buffer +ditch n (SymbolicBuffer bs) = SymbolicBuffer $ drop n bs +ditch n (ConcreteBuffer bs) = ConcreteBuffer $ BS.drop n bs + +readByteOrZero :: Int -> Buffer -> SWord 8 +readByteOrZero i (SymbolicBuffer bs) = readByteOrZero' i bs +readByteOrZero i (ConcreteBuffer bs) = num $ Concrete.readByteOrZero i bs + +sliceWithZero :: Int -> Int -> Buffer -> Buffer +sliceWithZero o s (SymbolicBuffer m) = SymbolicBuffer (sliceWithZero' o s m) +sliceWithZero o s (ConcreteBuffer m) = ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes o s m) + +writeMemory :: Buffer -> Word -> Word -> Word -> Buffer -> Buffer +writeMemory (ConcreteBuffer bs1) n src dst (ConcreteBuffer bs0) = + ConcreteBuffer (Concrete.writeMemory bs1 n src dst bs0) +writeMemory (ConcreteBuffer bs1) n src dst (SymbolicBuffer bs0) = + SymbolicBuffer (writeMemory' (litBytes bs1) n src dst bs0) +writeMemory (SymbolicBuffer bs1) n src dst (ConcreteBuffer bs0) = + SymbolicBuffer (writeMemory' bs1 n src dst (litBytes bs0)) +writeMemory (SymbolicBuffer bs1) n src dst (SymbolicBuffer bs0) = + SymbolicBuffer (writeMemory' bs1 n src dst bs0) + +readMemoryWord :: Word -> Buffer -> SymWord +readMemoryWord i (SymbolicBuffer m) = readMemoryWord' i m +readMemoryWord i (ConcreteBuffer m) = litWord $ Concrete.readMemoryWord i m + +readMemoryWord32 :: Word -> Buffer -> SWord 32 +readMemoryWord32 i (SymbolicBuffer m) = readMemoryWord32' i m +readMemoryWord32 i (ConcreteBuffer m) = num $ Concrete.readMemoryWord32 i m + +setMemoryWord :: Word -> SymWord -> Buffer -> Buffer +setMemoryWord i x (SymbolicBuffer z) = SymbolicBuffer $ setMemoryWord' i x z +setMemoryWord i x (ConcreteBuffer z) = case maybeLitWord x of + Just x' -> ConcreteBuffer $ Concrete.setMemoryWord i x' z + Nothing -> SymbolicBuffer $ setMemoryWord' i x (litBytes z) + +setMemoryByte :: Word -> SWord 8 -> Buffer -> Buffer +setMemoryByte i x (SymbolicBuffer m) = SymbolicBuffer $ setMemoryByte' i x m +setMemoryByte i x (ConcreteBuffer m) = case fromSized <$> unliteral x of + Nothing -> SymbolicBuffer $ setMemoryByte' i x (litBytes m) + Just x' -> ConcreteBuffer $ Concrete.setMemoryByte i x' m + +readSWord :: Word -> Buffer -> SymWord +readSWord i (SymbolicBuffer x) = readSWord' i x +readSWord i (ConcreteBuffer x) = num $ Concrete.readMemoryWord i x + +-- | Custom instances for SymWord, many of which have direct +-- analogues for concrete words defined in Concrete.hs + +instance Show SymWord where + show s@(S Dull _) = case maybeLitWord s of + Nothing -> "" + Just w -> show w + show (S (Var var) x) = var ++ ": " ++ show x + show (S (InfixBinOp symbol x y) z) = show x ++ symbol ++ show y ++ ": " ++ show z + show (S (BinOp symbol x y) z) = symbol ++ show x ++ show y ++ ": " ++ show z + show (S (UnOp symbol x) z) = symbol ++ show x ++ ": " ++ show z + show (S whiff x) = show whiff ++ ": " ++ show x + +instance EqSymbolic SymWord where + (.==) (S _ x) (S _ y) = x .== y + +instance Num SymWord where + (S _ x) + (S _ y) = sw256 (x + y) + (S _ x) * (S _ y) = sw256 (x * y) + abs (S _ x) = sw256 (abs x) + signum (S _ x) = sw256 (signum x) + fromInteger x = sw256 (fromInteger x) + negate (S _ x) = sw256 (negate x) + +instance Bits SymWord where + (S _ x) .&. (S _ y) = sw256 (x .&. y) + (S _ x) .|. (S _ y) = sw256 (x .|. y) + (S _ x) `xor` (S _ y) = sw256 (x `xor` y) + complement (S _ x) = sw256 (complement x) + shift (S _ x) i = sw256 (shift x i) + rotate (S _ x) i = sw256 (rotate x i) + bitSize (S _ x) = bitSize x + bitSizeMaybe (S _ x) = bitSizeMaybe x + isSigned (S _ x) = isSigned x + testBit (S _ x) i = testBit x i + bit i = sw256 (bit i) + popCount (S _ x) = popCount x + +instance SDivisible SymWord where + sQuotRem (S _ x) (S _ y) = let (a, b) = x `sQuotRem` y + in (sw256 a, sw256 b) + sDivMod (S _ x) (S _ y) = let (a, b) = x `sDivMod` y + in (sw256 a, sw256 b) + +instance Mergeable SymWord where + symbolicMerge a b (S _ x) (S _ y) = sw256 $ symbolicMerge a b x y + select xs (S _ x) b = let ys = fmap (\(S _ y) -> y) xs + in sw256 $ select ys x b + +instance Bounded SymWord where + minBound = sw256 minBound + maxBound = sw256 maxBound + +instance Eq SymWord where + (S _ x) == (S _ y) = x == y + +instance Enum SymWord where + toEnum i = sw256 (toEnum i) + fromEnum (S _ x) = fromEnum x + +instance OrdSymbolic SymWord where + (.<) (S _ x) (S _ y) = (.<) x y diff --git a/src/EVM/TTY.hs b/src/EVM/TTY.hs --- a/src/EVM/TTY.hs +++ b/src/EVM/TTY.hs @@ -1,9 +1,9 @@ {-# Language TemplateHaskell #-} {-# Language ImplicitParams #-} - +{-# Language DataKinds #-} module EVM.TTY where -import Prelude hiding (Word) +import Prelude hiding (lookup, Word) import Brick import Brick.Widgets.Border @@ -11,22 +11,21 @@ import Brick.Widgets.List import EVM -import EVM.ABI (abiTypeSolidity) -import EVM.Concrete (Word (C)) +import EVM.ABI (abiTypeSolidity, decodeAbiValue, AbiType(..), emptyAbi) +import EVM.Symbolic (SymWord(..), Buffer(..)) +import EVM.SymExec (maxIterationsReached) import EVM.Dapp (DappInfo, dappInfo) -import EVM.Dapp (dappUnitTests, dappSolcByName, dappSolcByHash, dappSources) +import EVM.Dapp (dappUnitTests, unitTestMethods, dappSolcByName, dappSolcByHash, dappSources) import EVM.Dapp (dappAstSrcMap) import EVM.Debug import EVM.Format (Signedness (..), showDec, showWordExact) -import EVM.Format (showTraceTree) -import EVM.Format (contractNamePart, contractPathPart) +import EVM.Format (contractNamePart, contractPathPart, showTraceTree) import EVM.Hexdump (prettyHex) import EVM.Op import EVM.Solidity import EVM.Types hiding (padRight) import EVM.UnitTest (UnitTestOptions (..)) -import EVM.UnitTest (initialUnitTestVm) -import EVM.UnitTest (initializeUnitTest, runUnitTest) +import EVM.UnitTest (initialUnitTestVm, initializeUnitTest, runUnitTest) import EVM.StorageLayout import EVM.Stepper (Stepper) @@ -34,62 +33,65 @@ import qualified Control.Monad.Operational as Operational import EVM.Fetch (Fetcher) -import qualified EVM.Fetch as Fetch import Control.Lens import Control.Monad.State.Strict hiding (state) import Data.Aeson.Lens import Data.ByteString (ByteString) -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (isJust, fromJust, fromMaybe) +import Data.Map (Map, insert, lookupLT, singleton) import Data.Monoid ((<>)) import Data.Text (Text, unpack, pack) import Data.Text.Encoding (decodeUtf8) -import Data.List (sort) -import Numeric (showHex) +import Data.List (sort, lookup) +import Data.Version (showVersion) +import Data.SBV hiding (solver) import qualified Data.ByteString as BS import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.Vector as Vec import qualified Data.Vector.Storable as SVec -import qualified Graphics.Vty as Vty +import qualified Graphics.Vty as V import qualified System.Console.Haskeline as Readline import qualified EVM.TTYCenteredList as Centered +import qualified Paths_hevm as Paths + data Name = AbiPane | StackPane | BytecodePane | TracePane | SolidityPane - | SolidityViewport | TestPickerPane | BrowserPane + | Pager deriving (Eq, Show, Ord) type UiWidget = Widget Name data UiVmState = UiVmState - { _uiVm :: VM - , _uiVmNextStep :: Stepper () - , _uiVmStackList :: List Name (Int, Word) - , _uiVmBytecodeList :: List Name (Int, Op) - , _uiVmTraceList :: List Name Text - , _uiVmSolidityList :: List Name (Int, ByteString) - , _uiVmSolc :: Maybe SolcContract - , _uiVmDapp :: Maybe DappInfo - , _uiVmStepCount :: Int - , _uiVmFirstState :: UiVmState - , _uiVmMessage :: Maybe String - , _uiVmNotes :: [String] - , _uiVmShowMemory :: Bool + { _uiVm :: VM + , _uiStep :: Int + , _uiSnapshots :: Map Int (VM, Stepper ()) + , _uiStepper :: Stepper () + , _uiStackList :: List Name (Int, (SymWord)) + , _uiBytecodeList :: List Name (Int, Op) + , _uiTraceList :: List Name Text + , _uiSolidityList :: List Name (Int, ByteString) + , _uiMessage :: Maybe String + , _uiShowMemory :: Bool + , _uiSolc :: Maybe SolcContract + , _uiTestOpts :: UnitTestOptions } data UiTestPickerState = UiTestPickerState { _testPickerList :: List Name (Text, Text) , _testPickerDapp :: DappInfo + , _testOpts :: UnitTestOptions } data UiBrowserState = UiBrowserState @@ -98,37 +100,41 @@ } data UiState - = UiVmScreen UiVmState - | UiVmBrowserScreen UiBrowserState - | UiTestPickerScreen UiTestPickerState + = ViewVm UiVmState + | ViewContracts UiBrowserState + | ViewPicker UiTestPickerState + | ViewHelp UiVmState makeLenses ''UiVmState makeLenses ''UiTestPickerState makeLenses ''UiBrowserState makePrisms ''UiState +-- caching VM states lets us backstep efficiently +snapshotInterval :: Int +snapshotInterval = 50 + type Pred a = a -> Bool data StepMode - = StepOne -- ^ Finish after one opcode step - | StepMany !Int -- ^ Run a specific number of steps - | StepNone -- ^ Finish before the next opcode - | StepUntil (Pred VM) -- ^ Finish when a VM predicate holds + = 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 StepOutcome a - = Returned a -- ^ Program finished - | Stepped (Stepper a) -- ^ Took one step; more steps to go - | Blocked (IO (Stepper a)) -- ^ Came across blocking request +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) + :: (?fetcher :: Fetcher + , ?maxIter :: Maybe Integer) => StepMode -> Stepper a - -> State UiVmState (StepOutcome a) + -> StateT UiVmState IO (Continuation a) interpret mode = -- Like the similar interpreters in @EVM.UnitTest@ and @EVM.VMTest@, @@ -138,10 +144,10 @@ where eval :: Operational.ProgramView Stepper.Action a - -> State UiVmState (StepOutcome a) + -> StateT UiVmState IO (Continuation a) eval (Operational.Return x) = - pure (Returned x) + pure (Stopped x) eval (action Operational.:>>= k) = case action of @@ -149,138 +155,121 @@ -- Stepper wants to keep executing? Stepper.Exec -> do - let - -- When pausing during exec, we should later restart - -- the exec with the same continuation. - restart = Stepper.exec >>= k - - case mode of - StepNone -> - -- 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 (Stepped (Operational.singleton action >>= k)) - - StepOne -> do - -- Run an instruction - modify stepOneOpcode - - use (uiVm . result) >>= \case - Nothing -> - -- If instructions remain, then pause & await user. - pure (Stepped restart) - Just r -> - -- If returning, proceed directly the continuation, - -- but stopping before the next instruction. - interpret StepNone (k r) - - StepMany 0 -> do - -- Finish the continuation until the next instruction; - -- then, pause & await user. - interpret StepNone restart + -- Have we reached the final result of this action? + use (uiVm . result) >>= \case + Just r -> + -- Yes, proceed with the next action. + interpret mode (k r) + Nothing -> do + -- No, keep performing the current action + let restart = Stepper.exec >>= k - StepMany i -> do - -- Run one instruction. - interpret StepOne restart >>= - \case - Stepped stepper -> - interpret (StepMany (i - 1)) stepper + 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) - -- This shouldn't happen, because re-stepping needs - -- to avoid blocking and halting. - r -> pure r + Step i -> do + -- Run one instruction and recurse + stepOneOpcode restart + interpret (Step (i - 1)) restart - StepUntil p -> do - vm <- use uiVm - case p vm of - True -> - interpret StepNone restart - False -> - interpret StepOne restart >>= - \case - Stepped stepper -> - interpret (StepUntil p) stepper + StepUntil p -> do + vm <- use uiVm + case p vm of + True -> + interpret (Step 0) restart + False -> do + -- Run one instruction and recurse + stepOneOpcode restart + interpret (StepUntil p) restart - -- This means that if we hit a blocking query - -- or a return, we pause despite the predicate. - -- - -- This could be fixed if we allowed query I/O - -- here, instead of only in the TTY event loop; - -- let's do it later. - r -> pure r + -- Stepper is waiting for user input from a query + Stepper.Ask (EVM.PleaseChoosePath cont) -> do + -- ensure we aren't stepping past max iterations + vm <- use uiVm + 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 q -> do - -- Tell the TTY to run an I/O action to produce the next stepper. - pure . Blocked $ do - -- First run the fetcher, getting a VM state transition back. - m <- ?fetcher q - -- Join that transition with the stepper script's continuation. - pure (Stepper.evm m >> k ()) + do m <- liftIO (?fetcher q) + interpret mode (Stepper.evm m >>= k) -- Stepper wants to modify the VM. Stepper.EVM m -> do - vm0 <- use uiVm - let (r, vm1) = runState m vm0 - modify (flip updateUiVmState vm1) - interpret mode (k r) - - -- Stepper wants to emit a message. - Stepper.Note s -> do - assign uiVmMessage (Just (unpack s)) - modifying uiVmNotes (unpack s :) - interpret mode (k ()) - - -- Stepper wants to exit because of a failure. - Stepper.Fail e -> - error ("VM error: " ++ show e) + vm <- use uiVm + let (r, vm1) = runState m vm + assign uiVm vm1 + interpret mode (Stepper.exec >> (k r)) isUnitTestContract :: Text -> DappInfo -> Bool isUnitTestContract name dapp = elem name (map fst (view dappUnitTests dapp)) -mkVty :: IO Vty.Vty +mkVty :: IO V.Vty mkVty = do - vty <- Vty.mkVty Vty.defaultConfig - Vty.setMode (Vty.outputIface vty) Vty.BracketedPaste True + vty <- V.mkVty V.defaultConfig + V.setMode (V.outputIface vty) V.BracketedPaste True return vty -runFromVM :: VM -> IO VM -runFromVM vm = do - let - ui0 = UiVmState - { _uiVm = vm - , _uiVmNextStep = - void Stepper.execFully >> Stepper.evm finalize - , _uiVmStackList = undefined - , _uiVmBytecodeList = undefined - , _uiVmTraceList = undefined - , _uiVmSolidityList = undefined - , _uiVmSolc = Nothing - , _uiVmDapp = Nothing - , _uiVmStepCount = 0 - , _uiVmFirstState = undefined - , _uiVmMessage = Just "Executing EVM code" - , _uiVmNotes = [] - , _uiVmShowMemory = False - } - ui1 = updateUiVmState ui0 vm & set uiVmFirstState ui1 +runFromVM :: Maybe Integer -> DappInfo -> (Query -> IO (EVM ())) -> VM -> IO VM +runFromVM maxIter' dappinfo oracle' vm = do - testOpts = UnitTestOptions - { oracle = Fetch.zero - , verbose = False + let + opts = UnitTestOptions + { oracle = oracle' + , verbose = Nothing + , maxIter = maxIter' , match = "" + , fuzzRuns = 1 + , replay = error "irrelevant" , vmModifier = id , testParams = error "irrelevant" + , dapp = dappinfo } + ui0 = initUiVmState vm opts (void Stepper.execFully) - ui2 <- customMain mkVty Nothing (app testOpts) (UiVmScreen ui1) + v <- mkVty + ui2 <- customMain v mkVty Nothing (app opts) (ViewVm ui0) case ui2 of - UiVmScreen ui -> return (view uiVm ui) + ViewVm ui -> return (view uiVm ui) _ -> error "internal error: customMain returned prematurely" + +initUiVmState :: VM -> UnitTestOptions -> Stepper () -> UiVmState +initUiVmState vm0 opts script = + renderVm $ + UiVmState + { _uiVm = vm0 + , _uiStepper = script + , _uiStackList = undefined + , _uiBytecodeList = undefined + , _uiTraceList = undefined + , _uiSolidityList = undefined + , _uiSolc = currentSolc (dapp opts) vm0 + , _uiStep = 0 + , _uiSnapshots = singleton 0 (vm0, script) + , _uiMessage = Just "Creating unit test contract" + , _uiShowMemory = False + , _uiTestOpts = opts + } + + +-- filters out fuzztests, unless they have +-- explicitly been given an argument by `replay` +concreteTests :: UnitTestOptions -> (Text, [(Text, [AbiType])]) -> [(Text, Text)] +concreteTests UnitTestOptions{..} (contractname, tests) = case replay of + Nothing -> [(contractname, fst x) | x <- tests, + null $ snd x] + Just (sig, _) -> [(contractname, fst x) | x <- tests, + null (snd x) || fst x == sig] + main :: UnitTestOptions -> FilePath -> FilePath -> IO () -main opts root jsonFilePath = do +main opts root jsonFilePath = readSolc jsonFilePath >>= \case Nothing -> @@ -288,220 +277,315 @@ Just (contractMap, sourceCache) -> do let dapp = dappInfo root contractMap sourceCache - ui = UiTestPickerScreen $ UiTestPickerState + ui = ViewPicker $ UiTestPickerState { _testPickerList = list TestPickerPane (Vec.fromList (concatMap - (\(a, xs) -> [(a, x) | x <- xs]) + (concreteTests opts) (view dappUnitTests dapp))) 1 , _testPickerDapp = dapp + , _testOpts = opts } - - _ <- customMain mkVty Nothing (app opts) (ui :: UiState) + v <- mkVty + _ <- customMain v mkVty Nothing (app opts) (ui :: UiState) return () --- ^ Specifies whether to do I/O blocking or VM halting while stepping. --- When we step backwards, we don't want to allow those things. -data StepPolicy - = StepNormally -- ^ Allow blocking and returning - | StepTimidly -- ^ Forbid blocking and returning - takeStep - :: (?fetcher :: Fetcher) + :: (?fetcher :: Fetcher + ,?maxIter :: Maybe Integer) => UiVmState - -> StepPolicy -> StepMode -> EventM n (Next UiState) -takeStep ui policy mode = do - let m = interpret mode (view uiVmNextStep ui) +takeStep ui mode = + liftIO nxt >>= \case + (Stopped (), ui') -> + continue (ViewVm ui') + (Continue steps, ui') -> do + continue (ViewVm (ui' & set uiStepper steps)) + where + m = interpret mode (view uiStepper ui) + nxt = runStateT (m <* modify renderVm) ui - case runState (m <* modify renderVm) ui of +appEvent + :: (?fetcher::Fetcher, ?maxIter :: Maybe Integer) => + UiState -> + BrickEvent Name e -> + EventM Name (Next UiState) - (Stepped stepper, ui') -> do - continue (UiVmScreen (ui' & set uiVmNextStep stepper)) +-- Contracts: Down - list down +appEvent (ViewContracts s) (VtyEvent e@(V.EvKey V.KDown [])) = do + s' <- handleEventLensed s + browserContractList + handleListEvent + e + continue (ViewContracts s') - (Blocked blocker, ui') -> - case policy of - StepNormally -> do - stepper <- liftIO blocker - takeStep - (execState (assign uiVmNextStep stepper) ui') - StepNormally StepNone +-- Contracts: Up - list up +appEvent (ViewContracts s) (VtyEvent e@(V.EvKey V.KUp [])) = do + s' <- handleEventLensed s + browserContractList + handleListEvent + e + continue (ViewContracts s') - StepTimidly -> - error "step blocked unexpectedly" +-- Vm Overview: Esc - return to test picker or exit +appEvent st@(ViewVm s) (VtyEvent (V.EvKey V.KEsc [])) = + let opts = view uiTestOpts s + dapp' = dapp (view uiTestOpts s) + tests = concatMap + (concreteTests opts) + (view dappUnitTests dapp') + in case tests of + [] -> halt st + ts -> + continue . ViewPicker $ + UiTestPickerState + { _testPickerList = + list + TestPickerPane + (Vec.fromList + ts) + 1 + , _testPickerDapp = dapp' + , _testOpts = opts + } - (Returned (), ui') -> - case policy of - StepNormally -> - halt (UiVmScreen ui') - StepTimidly -> - error "step halted unexpectedly" +-- Vm Overview: Enter - open contracts view +appEvent (ViewVm s) (VtyEvent (V.EvKey V.KEnter [])) = + continue . ViewContracts $ UiBrowserState + { _browserContractList = + list + BrowserPane + (Vec.fromList (Map.toList (view (uiVm . env . contracts) s))) + 2 + , _browserVm = s + } -app :: UnitTestOptions -> App UiState () Name -app opts = - let ?fetcher = oracle opts - in App - { appDraw = drawUi - , appChooseCursor = neverShowCursor - , appHandleEvent = \ui e -> +-- Vm Overview: m - toggle memory pane +appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'm') [])) = + continue (ViewVm (over uiShowMemory not s)) - case (ui, e) of - (UiVmBrowserScreen s, VtyEvent (Vty.EvKey Vty.KEsc [])) -> - continue (UiVmScreen (view browserVm s)) +-- Vm Overview: h - open help view +appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'h') [])) + = continue . ViewHelp $ s - (UiVmBrowserScreen s, VtyEvent e'@(Vty.EvKey Vty.KDown [])) -> do - s' <- handleEventLensed s - browserContractList - handleListEvent - e' - continue (UiVmBrowserScreen s') +-- Vm Overview: spacebar - read input +appEvent (ViewVm s) (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 () + return (ViewVm s) + in + suspendAndResume $ + Readline.runInputT Readline.defaultSettings loop - (UiVmBrowserScreen s, VtyEvent e'@(Vty.EvKey Vty.KUp [])) -> do - s' <- handleEventLensed s - browserContractList - handleListEvent - e' - continue (UiVmBrowserScreen s') +-- Vm Overview: n - step +appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'n') [])) = + case view (uiVm . result) s of + Just _ -> continue (ViewVm s) + _ -> takeStep s (Step 1) - (_, VtyEvent (Vty.EvKey Vty.KEsc [])) -> - halt ui +-- Vm Overview: N - step +appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'N') [])) = + takeStep s + (StepUntil (isNextSourcePosition s)) - (UiVmScreen s, VtyEvent (Vty.EvKey Vty.KEnter [])) -> - continue . UiVmBrowserScreen $ UiBrowserState - { _browserContractList = - list - BrowserPane - (Vec.fromList (Map.toList (view (uiVm . env . contracts) s))) - 2 - , _browserVm = s - } +-- Vm Overview: C-n - step +appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'n') [V.MCtrl])) = + takeStep s + (StepUntil (isNextSourcePositionWithoutEntering s)) - (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar ' ') [])) -> - let - loop = do - Just hey <- Readline.getInputLine "% " - Readline.outputStrLn hey - Just hey' <- Readline.getInputLine "% " - Readline.outputStrLn hey' - return (UiVmScreen s) - in - suspendAndResume $ - Readline.runInputT Readline.defaultSettings loop +-- Vm Overview: e - step +appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'e') [])) = + takeStep s + (StepUntil (isExecutionHalted s)) +-- Vm Overview: a - step +appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'a') [])) = + -- We keep the current cache so we don't have to redo + -- any blocking queries. + let + (vm, stepper) = fromJust (Map.lookup 0 (view uiSnapshots s)) + s' = s + & set uiVm vm + & set (uiVm . cache) (view (uiVm . cache) s) + & set uiStep 0 + & set uiStepper stepper - (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar 'n') [])) -> - takeStep s StepNormally StepOne + in takeStep s' (Step 0) - (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar 'N') [])) -> - takeStep s - StepNormally - (StepUntil (isNextSourcePosition s)) +-- Vm Overview: p - step +appEvent st@(ViewVm s) (VtyEvent (V.EvKey (V.KChar 'p') [])) = + case view uiStep s of + 0 -> + -- We're already at the first step; ignore command. + continue st + 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 (view uiSnapshots s) + s1 = s + & set uiVm vm + & set (uiVm . cache) (view (uiVm . cache) s) + & set uiStep step + & set uiStepper stepper + stepsToTake = n - step - 1 - (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar 'n') [Vty.MCtrl])) -> - takeStep s - StepNormally - (StepUntil (isNextSourcePositionWithoutEntering s)) + takeStep s1 (Step stepsToTake) - (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar 'p') [])) -> - case view uiVmStepCount s of - 0 -> - -- We're already at the first step; ignore command. - continue ui +-- Vm Overview: 0 - choose no jump +appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar '0') [])) = + case view (uiVm . result) s of + Just (VMFailure (Choose (PleaseChoosePath contin))) -> + takeStep (s & set uiStepper (Stepper.evm (contin True) >> (view uiStepper s))) + (Step 1) + _ -> continue (ViewVm s) - n -> do - -- To step backwards, we revert to the first state - -- and execute n - 1 instructions from there. - -- - -- We keep the current cache so we don't have to redo - -- any blocking queries, and also the memory view. - let - s0 = view uiVmFirstState s - s1 = set (uiVm . cache) (view (uiVm . cache) s) s0 - s2 = set (uiVmShowMemory) (view uiVmShowMemory s) s1 +-- Vm Overview: 1 - choose jump +appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar '1') [])) = + case view (uiVm . result) s of + Just (VMFailure (Choose (PleaseChoosePath contin))) -> + takeStep (s & set uiStepper (Stepper.evm (contin False) >> (view uiStepper s))) + (Step 1) + _ -> continue (ViewVm s) - -- Take n steps; "timidly," because all queries - -- ought to be cached. - takeStep s2 StepTimidly (StepMany (n - 1)) - (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar 'm') [])) -> - continue (UiVmScreen (over uiVmShowMemory not s)) +-- Any: Esc - return to Vm Overview or Exit +appEvent s (VtyEvent (V.EvKey V.KEsc [])) = + case s of + (ViewHelp x) -> overview x + (ViewContracts x) -> overview $ view browserVm x + _ -> halt s + where + overview = continue . ViewVm - (UiTestPickerScreen s', VtyEvent (Vty.EvKey (Vty.KEnter) [])) -> do - case listSelectedElement (view testPickerList s') of - Nothing -> error "nothing selected" - Just (_, x) -> - continue . UiVmScreen $ - initialUiVmStateForTest opts (view testPickerDapp s') x +-- UnitTest Picker: Enter - select from list +appEvent (ViewPicker s) (VtyEvent (V.EvKey V.KEnter [])) = + case listSelectedElement (view testPickerList s) of + Nothing -> error "nothing selected" + Just (_, x) -> + continue . ViewVm $ + initialUiVmStateForTest (view testOpts s) x +-- (view testPickerDapp s) x - (UiTestPickerScreen s', VtyEvent e') -> do - s'' <- handleEventLensed s' - testPickerList - handleListEvent - e' - continue (UiTestPickerScreen s'') +-- UnitTest Picker: (main) - render list +appEvent (ViewPicker s) (VtyEvent e) = do + s' <- handleEventLensed s + testPickerList + handleListEvent + e + continue (ViewPicker s') - _ -> - continue ui +-- Page: Down - scroll +appEvent s (VtyEvent (V.EvKey V.KDown [])) = + vScrollBy (viewportScroll TracePane) 1 >> continue s +-- Page: Up - scroll +appEvent s (VtyEvent (V.EvKey V.KUp [])) = + vScrollBy (viewportScroll TracePane) (-1) >> continue s + +-- Page: C-f - Page down +appEvent s (VtyEvent (V.EvKey (V.KChar 'f') [V.MCtrl])) = + vScrollPage (viewportScroll TracePane) Down >> continue s + +-- Page: C-b - Page up +appEvent s (VtyEvent (V.EvKey (V.KChar 'b') [V.MCtrl])) = + vScrollPage (viewportScroll TracePane) Up >> continue s + +-- Default +appEvent s _ = continue s + +app :: UnitTestOptions -> App UiState () Name +app opts = + let ?fetcher = oracle opts + ?maxIter = maxIter opts + in App + { appDraw = drawUi + , appChooseCursor = neverShowCursor + , appHandleEvent = appEvent , appStartEvent = return - , appAttrMap = const (attrMap Vty.defAttr myTheme) + , appAttrMap = const (attrMap V.defAttr myTheme) } initialUiVmStateForTest :: UnitTestOptions - -> DappInfo -> (Text, Text) -> UiVmState -initialUiVmStateForTest opts@(UnitTestOptions {..}) dapp (theContractName, theTestName) = - ui1 +initialUiVmStateForTest opts@UnitTestOptions{..} (theContractName, theTestName) = + ui where + Just typesig = lookup theTestName (unitTestMethods testContract) + args = case replay of + Nothing -> emptyAbi + Just (sig, callData) -> + if theTestName == sig + then decodeAbiValue (AbiTupleType (Vec.fromList typesig)) callData + else emptyAbi script = do Stepper.evm . pushTrace . EntryTrace $ "test " <> theTestName <> " (" <> theContractName <> ")" initializeUnitTest opts - void (runUnitTest opts theTestName) - ui0 = - UiVmState - { _uiVm = vm0 - , _uiVmNextStep = script - , _uiVmStackList = undefined - , _uiVmBytecodeList = undefined - , _uiVmTraceList = undefined - , _uiVmSolidityList = undefined - , _uiVmSolc = Just testContract - , _uiVmDapp = Just dapp - , _uiVmStepCount = 0 - , _uiVmFirstState = undefined - , _uiVmMessage = Just "Creating unit test contract" - , _uiVmNotes = [] - , _uiVmShowMemory = False - } + void (runUnitTest opts theTestName args) + ui = initUiVmState vm0 opts script Just testContract = view (dappSolcByName . at theContractName) dapp vm0 = - initialUnitTestVm opts testContract (Map.elems (view dappSolcByName dapp)) - ui1 = - updateUiVmState ui0 vm0 & set uiVmFirstState ui1 + initialUnitTestVm opts testContract -myTheme :: [(AttrName, Vty.Attr)] +myTheme :: [(AttrName, V.Attr)] myTheme = - [ (selectedAttr, Vty.defAttr `Vty.withStyle` Vty.standout) - , (dimAttr, Vty.defAttr `Vty.withStyle` Vty.dim) - , (borderAttr, Vty.defAttr `Vty.withStyle` Vty.dim) - , (wordAttr, fg Vty.yellow) - , (boldAttr, Vty.defAttr `Vty.withStyle` Vty.bold) - , (activeAttr, Vty.defAttr `Vty.withStyle` Vty.standout) + [ (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 (UiVmScreen s) = drawVm s -drawUi (UiTestPickerScreen s) = drawTestPicker s -drawUi (UiVmBrowserScreen s) = drawVmBrowser s +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" <> + "m Toggle memory pane\n" <> + "0 Choose the branch which does not jump \n" <> + "1 Choose the branch which does jump \n" <> + "Down Scroll memory pane fwds\n" <> + "Up Scroll memory pane back\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") . @@ -520,21 +604,26 @@ [ borderWithLabel (txt "Contracts") . hLimit 60 $ renderList - (\selected (k, c) -> + (\selected (k, c') -> withHighlight selected . txt . mconcat $ - [ fromMaybe "" . flip preview ui $ - ( browserVm . uiVmDapp . _Just . dappSolcByHash . ix (view codehash c) + [ fromMaybe "" . flip preview dapp' $ + ( dappSolcByHash . ix (view codehash c') . _2 . contractName ) , "\n" , " ", pack (show k) ]) True (view browserContractList ui) - , let - Just (_, (_, c)) = listSelectedElement (view browserContractList ui) - Just dapp = view (browserVm . uiVmDapp) ui - in case flip preview ui (browserVm . uiVmDapp . _Just . dappSolcByHash . ix (view codehash c) . _2) of - Nothing -> txt ("n/a; codehash " <> pack (show (view codehash c))) + , case flip preview dapp' (dappSolcByHash . ix (view codehash c) . _2) of + Nothing -> + hBox + [ borderWithLabel (txt "Contract information") . padBottom Max . padRight Max $ vBox + [ txt ("Codehash: " <> pack (show (view codehash c))) + , txt ("Nonce: " <> showWordExact (view nonce c)) + , txt ("Balance: " <> showWordExact (view balance c)) + , txt ("Storage: " <> storageDisplay (view storage c)) + ] + ] Just solc -> hBox [ borderWithLabel (txt "Contract information") . padBottom Max . padRight (Pad 2) $ vBox @@ -547,12 +636,18 @@ , txt "Public methods:" , vBox . flip map (sort (Map.elems (view abiMap solc))) $ \method -> txt (" " <> view methodSignature method) + , txt ("Storage:" <> storageDisplay (view storage c)) ] - , borderWithLabel (txt "Storage slots") . padBottom Max . padRight Max $ vBox - (map txt (storageLayout dapp solc)) - ] + , borderWithLabel (txt "Storage slots") . padBottom Max . padRight Max $ vBox + (map txt (storageLayout dapp' solc)) + ] ] ] + where storageDisplay (Concrete s) = pack ( show ( Map.toList s)) + storageDisplay (Symbolic _) = pack "" + dapp' = dapp (view (browserVm . uiTestOpts) ui) + Just (_, (_, c)) = listSelectedElement (view browserContractList ui) +-- currentContract = view (dappSolcByHash . ix ) dapp drawVm :: UiVmState -> [UiWidget] drawVm ui = @@ -569,7 +664,7 @@ , vLimit 20 $ drawStackPane ui , drawSolidityPane ui , vLimit 20 $ drawTracePane ui - , vLimit 2 $ drawHelpBar + , vLimit 2 drawHelpBar ] ) ( vBox @@ -577,11 +672,11 @@ [ vLimit 20 $ drawBytecodePane ui , vLimit 20 $ drawStackPane ui ] - , hBox $ + , hBox [ drawSolidityPane ui , drawTracePane ui ] - , vLimit 2 $ drawHelpBar + , vLimit 2 drawHelpBar ] ) ] @@ -596,48 +691,48 @@ [ ("n", "step") , ("p", "step back") - , ("N", "step more") - , ("C-n", "step over") --- , (" Enter", "browse") + , ("a", "step to start") + , ("e", "step to end") , ("m", "toggle memory") - , (" Esc", "exit") + , ("Esc", "exit") + , ("h", "more help") ] -stepOneOpcode :: UiVmState -> UiVmState -stepOneOpcode ui = - let - nextVm = execState exec1 (view uiVm ui) - in - ui & over uiVmStepCount (+ 1) - & set uiVm nextVm +stepOneOpcode :: Stepper a -> StateT UiVmState IO () +stepOneOpcode restart = do + n <- use uiStep + when (n > 0 && n `mod` snapshotInterval == 0) $ do + vm <- use uiVm + modifying uiSnapshots (insert n (vm, void restart)) + modifying uiVm (execState exec1) + modifying uiStep (+ 1) + isNextSourcePosition :: UiVmState -> Pred VM isNextSourcePosition ui vm = - let - Just dapp = view uiVmDapp ui - initialPosition = currentSrcMap dapp (view uiVm ui) - in - currentSrcMap dapp vm /= initialPosition + let dapp' = dapp (view uiTestOpts ui) + initialPosition = currentSrcMap dapp' (view uiVm ui) + in currentSrcMap dapp' vm /= initialPosition isNextSourcePositionWithoutEntering :: UiVmState -> Pred VM isNextSourcePositionWithoutEntering ui vm = let + dapp' = dapp (view uiTestOpts ui) vm0 = view uiVm ui - Just dapp = view uiVmDapp ui - initialPosition = currentSrcMap dapp vm0 + initialPosition = currentSrcMap dapp' vm0 initialHeight = length (view frames vm0) in - case currentSrcMap dapp vm of + case currentSrcMap dapp' vm of Nothing -> - True + False Just here -> let moved = Just here /= initialPosition deeper = length (view frames vm) > initialHeight boring = - case srcMapCode (view dappSources dapp) here of + case srcMapCode (view dappSources dapp') here of Just bs -> BS.isPrefixOf "contract " bs Nothing -> @@ -645,6 +740,9 @@ in moved && not deeper && not boring +isExecutionHalted :: UiVmState -> Pred VM +isExecutionHalted _ vm = isJust (view result vm) + currentSrcMap :: DappInfo -> VM -> Maybe SrcMap currentSrcMap dapp vm = let @@ -674,44 +772,50 @@ updateUiVmState :: UiVmState -> VM -> UiVmState updateUiVmState ui vm = let - move = case vmOpIx vm of - Nothing -> id - Just x -> listMoveTo x - ui' = ui + move = maybe id listMoveTo (vmOpIx vm) + address = view (state . contract) vm + message = + case view result vm of + Just (VMSuccess (ConcreteBuffer msg)) -> + Just ("VMSuccess: " <> (show $ ByteStringS msg)) + Just (VMSuccess (SymbolicBuffer msg)) -> + Just ("VMSuccess: " <> (show msg)) + Just (VMFailure (Revert msg)) -> + Just ("VMFailure: " <> (show . ByteStringS $ msg)) + Just (VMFailure err) -> + Just ("VMFailure: " <> show err) + Nothing -> + Just ("Executing EVM code in " <> show address) + in ui & set uiVm vm - & set uiVmStackList + & set uiStackList (list StackPane (Vec.fromList $ zip [1..] (view (state . stack) vm)) 2) - & set uiVmBytecodeList + & set uiBytecodeList (move $ list BytecodePane (view codeOps (fromJust (currentContract vm))) 1) - in - case view uiVmDapp ui of - Nothing -> - ui' - & set uiVmTraceList (list TracePane mempty 1) - & set uiVmSolidityList (list SolidityPane mempty 1) - Just dapp -> - ui' - & set uiVmTraceList - (list - TracePane - (Vec.fromList - . Text.lines - . showTraceTree dapp - $ vm) - 1) - & set uiVmSolidityList - (list SolidityPane - (case currentSrcMap dapp vm of - Nothing -> mempty - Just x -> - view (dappSources - . sourceLines - . ix (srcMapFile x) - . to (Vec.imap (,))) - dapp) - 1) + & set uiMessage message + & set uiTraceList + (list + TracePane + (Vec.fromList + . Text.lines + . showTraceTree dapp' + $ vm) + 1) + & set uiSolidityList + (list SolidityPane + (case currentSrcMap dapp' vm of + Nothing -> mempty + Just x -> + view (dappSources + . sourceLines + . ix (srcMapFile x) + . to (Vec.imap (,))) + dapp') + 1) + where + dapp' = dapp (view uiTestOpts ui) drawStackPane :: UiVmState -> UiWidget drawStackPane ui = @@ -720,19 +824,20 @@ labelText = txt ("Gas available: " <> gasText <> "; stack:") in hBorderWithLabel labelText <=> renderList - (\_ (i, x@(C _ w)) -> + (\_ (i, x@(S _ w)) -> vBox [ withHighlight True (str ("#" ++ show i ++ " ")) <+> str (show x) - , dim (txt (" " <> showWordExplanation w (view uiVmDapp ui))) + , dim (txt (" " <> case unliteral w of + Nothing -> "" + Just u -> showWordExplanation (fromSizzle u) $ dapp (view uiTestOpts ui))) ]) False - (view uiVmStackList ui) + (view uiStackList ui) -showWordExplanation :: W256 -> Maybe DappInfo -> Text -showWordExplanation w Nothing = showDec Unsigned w +showWordExplanation :: W256 -> DappInfo -> Text showWordExplanation w _ | w > 0xffffffff = showDec Unsigned w -showWordExplanation w (Just dapp) = +showWordExplanation w dapp = let fullAbiMap = mconcat (map (view abiMap) (Map.elems (view dappSolcByName dapp))) @@ -743,13 +848,13 @@ drawBytecodePane :: UiVmState -> UiWidget drawBytecodePane ui = - hBorderWithLabel (case view uiVmMessage ui of { Nothing -> str ""; Just s -> str s }) <=> + hBorderWithLabel (case view uiMessage ui of { Nothing -> str ""; Just s -> str s }) <=> Centered.renderList (\active x -> if not active then withDefAttr dimAttr (opWidget x) else withDefAttr boldAttr (opWidget x)) False - (view uiVmBytecodeList ui) + (view uiBytecodeList ui) dim :: Widget n -> Widget n dim = withDefAttr dimAttr @@ -758,49 +863,57 @@ withHighlight False = withDefAttr dimAttr withHighlight True = withDefAttr boldAttr +prettyIfConcrete :: Buffer -> String +prettyIfConcrete (SymbolicBuffer x) = show x +prettyIfConcrete (ConcreteBuffer x) = prettyHex 40 x + drawTracePane :: UiVmState -> UiWidget -drawTracePane ui = - case view uiVmShowMemory ui of - False -> - hBorderWithLabel (txt "Trace") <=> - renderList - (\_ x -> txt x) - False - (view uiVmTraceList ui) +drawTracePane s = + case view uiShowMemory s of True -> - vBox - [ hBorderWithLabel (txt "Calldata") <=> - str (prettyHex 40 (view (uiVm . state . calldata) ui)) - , hBorderWithLabel (txt "Returndata") <=> - str (prettyHex 40 (view (uiVm . state . returndata) ui)) - , hBorderWithLabel (txt "Memory") <=> - str (prettyHex 40 (view (uiVm . state . memory) ui)) - ] + hBorderWithLabel (txt "Calldata") + <=> str (prettyIfConcrete $ fst (view (uiVm . state . calldata) s)) + <=> hBorderWithLabel (txt "Returndata") + <=> str (prettyIfConcrete (view (uiVm . state . returndata) s)) + <=> hBorderWithLabel (txt "Output") + <=> str (maybe "" show (view (uiVm . result) s)) + <=> hBorderWithLabel (txt "Cache") + <=> str (show (view (uiVm . cache . path) s)) + <=> hBorderWithLabel (txt "Memory") + <=> viewport TracePane Vertical + (str (prettyIfConcrete (view (uiVm . state . memory) s))) + False -> + hBorderWithLabel (txt "Trace") + <=> renderList + (\_ x -> txt x) + False + (view uiTraceList s) drawSolidityPane :: UiVmState -> UiWidget -drawSolidityPane ui@(view uiVmDapp -> Just dapp) = - case currentSrcMap dapp (view uiVm ui) of +drawSolidityPane ui = + let dapp' = dapp (view uiTestOpts ui) + in case currentSrcMap dapp' (view uiVm ui) of Nothing -> padBottom Max (hBorderWithLabel (txt "")) Just sm -> - case view (dappSources . sourceLines . at (srcMapFile sm)) dapp of + case view (dappSources . sourceLines . at (srcMapFile sm)) dapp' of Nothing -> padBottom Max (hBorderWithLabel (txt "")) Just rows -> let - subrange i = lineSubrange rows (srcMapOffset sm, srcMapLength sm) i + subrange = lineSubrange rows (srcMapOffset sm, srcMapLength sm) lineNo = (snd . fromJust $ (srcMapCodePos - (view dappSources dapp) + (view dappSources dapp') sm)) - 1 in vBox [ hBorderWithLabel $ txt (maybe "" contractPathPart - (preview (uiVmSolc . _Just . contractName) ui)) + (preview (uiSolc . _Just . contractName) ui)) <+> str (":" ++ show lineNo) -- Show the AST node type if present <+> txt (" (" <> fromMaybe "?" - ((view dappAstSrcMap dapp) sm + ((view dappAstSrcMap dapp') sm >>= preview (key "name" . _String)) <> ")") , Centered.renderList (\_ (i, line) -> @@ -818,12 +931,8 @@ ]) False (listMoveTo lineNo - (view uiVmSolidityList ui)) + (view uiSolidityList ui)) ] -drawSolidityPane _ = - -- When e.g. debugging raw EVM code without dapp info, - -- don't show a Solidity pane. - vBox [] ifTallEnough :: Int -> Widget n -> Widget n -> Widget n ifTallEnough need w1 w2 = @@ -833,84 +942,8 @@ then render w1 else render w2 -showPc :: (Integral a, Show a) => a -> String -showPc x = - if x < 0x10 - then '0' : showHex x "" - else showHex x "" - opWidget :: (Integral a, Show a) => (a, Op) -> Widget n -opWidget (i, o) = str (showPc i <> " ") <+> case o of - OpStop -> txt "STOP" - OpAdd -> txt "ADD" - OpMul -> txt "MUL" - OpSub -> txt "SUB" - OpDiv -> txt "DIV" - OpSdiv -> txt "SDIV" - OpMod -> txt "MOD" - OpSmod -> txt "SMOD" - OpAddmod -> txt "ADDMOD" - OpMulmod -> txt "MULMOD" - OpExp -> txt "EXP" - OpSignextend -> txt "SIGNEXTEND" - OpLt -> txt "LT" - OpGt -> txt "GT" - OpSlt -> txt "SLT" - OpSgt -> txt "SGT" - OpEq -> txt "EQ" - OpIszero -> txt "ISZERO" - OpAnd -> txt "AND" - OpOr -> txt "OR" - OpXor -> txt "XOR" - OpNot -> txt "NOT" - OpByte -> txt "BYTE" - OpSha3 -> txt "SHA3" - OpAddress -> txt "ADDRESS" - OpBalance -> txt "BALANCE" - OpOrigin -> txt "ORIGIN" - OpCaller -> txt "CALLER" - OpCallvalue -> txt "CALLVALUE" - OpCalldataload -> txt "CALLDATALOAD" - OpCalldatasize -> txt "CALLDATASIZE" - OpCalldatacopy -> txt "CALLDATACOPY" - OpCodesize -> txt "CODESIZE" - OpCodecopy -> txt "CODECOPY" - OpGasprice -> txt "GASPRICE" - OpExtcodesize -> txt "EXTCODESIZE" - OpExtcodecopy -> txt "EXTCODECOPY" - OpReturndatasize -> txt "RETURNDATASIZE" - OpReturndatacopy -> txt "RETURNDATACOPY" - OpBlockhash -> txt "BLOCKHASH" - OpCoinbase -> txt "COINBASE" - OpTimestamp -> txt "TIMESTAMP" - OpNumber -> txt "NUMBER" - OpDifficulty -> txt "DIFFICULTY" - OpGaslimit -> txt "GASLIMIT" - OpPop -> txt "POP" - OpMload -> txt "MLOAD" - OpMstore -> txt "MSTORE" - OpMstore8 -> txt "MSTORE8" - OpSload -> txt "SLOAD" - OpSstore -> txt "SSTORE" - OpJump -> txt "JUMP" - OpJumpi -> txt "JUMPI" - OpPc -> txt "PC" - OpMsize -> txt "MSIZE" - OpGas -> txt "GAS" - OpJumpdest -> txt "JUMPDEST" - OpCreate -> txt "CREATE" - OpCall -> txt "CALL" - OpStaticcall -> txt "STATICCALL" - OpCallcode -> txt "CALLCODE" - OpReturn -> txt "RETURN" - OpDelegatecall -> txt "DELEGATECALL" - OpSelfdestruct -> txt "SELFDESTRUCT" - OpDup x -> txt "DUP" <+> str (show x) - OpSwap x -> txt "SWAP" <+> str (show x) - OpLog x -> txt "LOG" <+> str (show x) - OpPush x -> txt "PUSH " <+> withDefAttr wordAttr (str (show x)) - OpRevert -> txt "REVERT" - OpUnknown x -> txt "UNKNOWN " <+> str (show x) +opWidget = txt . pack . opString selectedAttr :: AttrName; selectedAttr = "selected" dimAttr :: AttrName; dimAttr = "dim" diff --git a/src/EVM/Transaction.hs b/src/EVM/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/EVM/Transaction.hs @@ -0,0 +1,92 @@ +module EVM.Transaction where + +import Prelude hiding (Word) + +import EVM.Concrete +import EVM.FeeSchedule +import EVM.Keccak (keccak) +import EVM.Precompiled (execute) +import EVM.RLP +import EVM.Types + +import Data.Aeson (FromJSON (..)) +import Data.ByteString (ByteString) +import Data.Maybe (isNothing) + +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Types as JSON +import qualified Data.ByteString as BS + +data Transaction = Transaction + { txData :: ByteString, + txGasLimit :: W256, + txGasPrice :: W256, + txNonce :: W256, + txR :: W256, + txS :: W256, + txToAddr :: Maybe Addr, + txV :: W256, + txValue :: W256 + } deriving Show + +ecrec :: W256 -> W256 -> W256 -> W256 -> Maybe Addr +ecrec e v r s = (num . word) <$> EVM.Precompiled.execute 1 input 32 + where input = BS.concat (word256Bytes <$> [e, v, r, s]) + +sender :: Int -> Transaction -> Maybe Addr +sender chainId tx = ecrec hash v' (txR tx) (txS tx) + where hash = keccak $ signingData chainId tx + v = txV tx + v' = if v == 27 || v == 28 then v + else 28 - mod v 2 + +signingData :: Int -> Transaction -> ByteString +signingData chainId tx = + if v == (chainId * 2 + 35) || v == (chainId * 2 + 36) + then eip155Data + else normalData + where v = fromIntegral (txV tx) + to' = case txToAddr tx of + Just a -> BS $ word160Bytes a + Nothing -> BS mempty + normalData = rlpList [rlpWord256 (txNonce tx), + rlpWord256 (txGasPrice tx), + rlpWord256 (txGasLimit tx), + to', + rlpWord256 (txValue tx), + BS (txData tx)] + eip155Data = rlpList [rlpWord256 (txNonce tx), + rlpWord256 (txGasPrice tx), + rlpWord256 (txGasLimit tx), + to', + rlpWord256 (txValue tx), + BS (txData tx), + rlpWord256 (fromIntegral chainId), + rlpWord256 0x0, + rlpWord256 0x0] + +txGasCost :: FeeSchedule Word -> Transaction -> Word +txGasCost fs tx = + let calldata = txData tx + zeroBytes = BS.count 0 calldata + nonZeroBytes = BS.length calldata - zeroBytes + baseCost = g_transaction fs + + if isNothing (txToAddr tx) then g_txcreate fs else 0 + zeroCost = g_txdatazero fs + nonZeroCost = g_txdatanonzero fs + in baseCost + zeroCost * (fromIntegral zeroBytes) + nonZeroCost * (fromIntegral nonZeroBytes) + +instance FromJSON Transaction where + parseJSON (JSON.Object val) = do + tdata <- dataField val "data" + gasLimit <- wordField val "gasLimit" + gasPrice <- wordField val "gasPrice" + nonce <- wordField val "nonce" + r <- wordField val "r" + s <- wordField val "s" + toAddr <- addrFieldMaybe val "to" + v <- wordField val "v" + value <- wordField val "value" + return $ Transaction tdata gasLimit gasPrice nonce r s toAddr v value + parseJSON invalid = + JSON.typeMismatch "Transaction" invalid diff --git a/src/EVM/Types.hs b/src/EVM/Types.hs --- a/src/EVM/Types.hs +++ b/src/EVM/Types.hs @@ -1,21 +1,31 @@ {-# Language CPP #-} {-# Language TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} module EVM.Types where -import Data.Aeson ((.:)) -import Data.Aeson (FromJSON (..)) +import Data.Aeson (FromJSON (..), (.:)) #if MIN_VERSION_aeson(1, 0, 0) import Data.Aeson (FromJSONKey (..), FromJSONKeyFunction (..)) #endif +import Data.SBV +import Data.Kind import Data.Monoid ((<>)) -import Data.Bits +import Data.Bifunctor (first) +import Data.Char import Data.ByteString (ByteString) import Data.ByteString.Base16 as BS16 +import Data.ByteString.Builder (byteStringHex, toLazyByteString) +import Data.ByteString.Lazy (toStrict) +import qualified Data.ByteString.Char8 as Char8 import Data.DoubleWord import Data.DoubleWord.TH +import Data.Maybe (fromMaybe) import Data.Word (Word8) import Numeric (readHex, showHex) import Options.Generic @@ -26,6 +36,7 @@ import qualified Data.Serialize.Get as Cereal import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import qualified Text.Read -- Some stuff for "generic programming", needed to create Word512 import Data.Data @@ -40,12 +51,48 @@ , Bits, FiniteBits, Bounded, Generic ) +-- | convert between (WordN 256) and Word256 +type family ToSizzle (t :: Type) :: Type where + ToSizzle W256 = (WordN 256) + ToSizzle Addr = (WordN 160) + +-- | Conversion from a fixed-sized BV to a sized bit-vector. +class ToSizzleBV a where + -- | Convert a fixed-sized bit-vector to the corresponding sized bit-vector, + toSizzle :: a -> ToSizzle a + + default toSizzle :: (Num (ToSizzle a), Integral a) => (a -> ToSizzle a) + toSizzle = fromIntegral + +-- | Capture the correspondence between sized and fixed-sized BVs +type family FromSizzle (t :: Type) :: Type where + FromSizzle (WordN 256) = W256 + FromSizzle (WordN 160) = Addr + + +-- | Conversion from a sized BV to a fixed-sized bit-vector. +class FromSizzleBV a where + -- | Convert a sized bit-vector to the corresponding fixed-sized bit-vector, + -- for instance 'SWord 16' to 'SWord16'. See also 'toSized'. + fromSizzle :: a -> FromSizzle a + + default fromSizzle :: (Num (FromSizzle a), Integral a) => a -> FromSizzle a + fromSizzle = fromIntegral + +instance (ToSizzleBV W256) +instance (FromSizzleBV (WordN 256)) +instance (ToSizzleBV Addr) +instance (FromSizzleBV (WordN 160)) + newtype Addr = Addr { addressWord160 :: Word160 } deriving (Num, Integral, Real, Ord, Enum, Eq, Bits, Generic) +newtype SAddr = SAddr { saddressWord160 :: SWord 160 } + deriving (Num) + instance Read W256 where readsPrec _ "0x" = [(0, "")] - readsPrec n s = (\(x, r) -> (W256 x, r)) <$> readsPrec n s + readsPrec n s = first W256 <$> readsPrec n s instance Show W256 where showsPrec _ s = ("0x" ++) . showHex s @@ -57,17 +104,29 @@ instance Show Addr where showsPrec _ s a = let h = showHex s a - in replicate (40 - length h) '0' ++ h + in "0x" ++ replicate (40 - length h) '0' ++ h -showAddrWith0x :: Addr -> String -showAddrWith0x addr = "0x" ++ show addr +instance Show SAddr where + show (SAddr a) = case unliteral a of + Nothing -> "" + Just c -> show c -showWordWith0x :: W256 -> String -showWordWith0x addr = show addr +strip0x :: ByteString -> ByteString +strip0x bs = if "0x" `Char8.isPrefixOf` bs then Char8.drop 2 bs else bs -showByteStringWith0x :: ByteString -> String -showByteStringWith0x bs = Text.unpack (Text.decodeUtf8 (BS16.encode bs)) +newtype ByteStringS = ByteStringS ByteString deriving (Eq) +instance Show ByteStringS where + show (ByteStringS x) = ("0x" ++) . Text.unpack . fromBinary $ x + where + fromBinary = + Text.decodeUtf8 . toStrict . toLazyByteString . byteStringHex + +instance Read ByteStringS where + readsPrec _ ('0':'x':x) = [(ByteStringS $ fst bytes, Text.unpack . Text.decodeUtf8 $ snd bytes)] + where bytes = BS16.decode (Text.encodeUtf8 (Text.pack x)) + readsPrec _ _ = [] + instance FromJSON W256 where parseJSON v = do s <- Text.unpack <$> parseJSON v @@ -123,13 +182,19 @@ readN :: Integral a => String -> a readN s = fromIntegral (read s :: Integer) +readNull :: Read a => a -> String -> a +readNull x = fromMaybe x . Text.Read.readMaybe + wordField :: JSON.Object -> Text -> JSON.Parser W256 -wordField x f = (read . Text.unpack) +wordField x f = ((readNull 0) . Text.unpack) <$> (x .: f) addrField :: JSON.Object -> Text -> JSON.Parser Addr addrField x f = (read . Text.unpack) <$> (x .: f) +addrFieldMaybe :: JSON.Object -> Text -> JSON.Parser (Maybe Addr) +addrFieldMaybe x f = (Text.Read.readMaybe . Text.unpack) <$> (x .: f) + dataField :: JSON.Object -> Text -> JSON.Parser ByteString dataField x f = hexText <$> (x .: f) @@ -149,10 +214,15 @@ padRight :: Int -> ByteString -> ByteString padRight n xs = xs <> BS.replicate (n - BS.length xs) 0 -word :: ByteString -> W256 -word xs = case Cereal.runGet m (padLeft 32 xs) of - Left _ -> error "internal error" - Right x -> W256 x +truncpad :: Int -> [SWord 8] -> [SWord 8] +truncpad n xs = if m > n then take n xs + else mappend xs (replicate (n - m) 0) + where m = length xs + +word256 :: ByteString -> Word256 +word256 xs = case Cereal.runGet m (padLeft 32 xs) of + Left _ -> error "internal error" + Right x -> x where m = do a <- Cereal.getWord64be b <- Cereal.getWord64be @@ -160,5 +230,49 @@ d <- Cereal.getWord64be return $ fromHiAndLo (fromHiAndLo a b) (fromHiAndLo c d) +word :: ByteString -> W256 +word = W256 . word256 + byteAt :: (Bits a, Bits b, Integral a, Num b) => a -> Int -> b byteAt x j = num (x `shiftR` (j * 8)) .&. 0xff + +fromBE :: (Integral a) => ByteString -> a +fromBE xs = if xs == mempty then 0 + else 256 * fromBE (BS.init xs) + + (num $ BS.last xs) + +asBE :: (Integral a) => a -> ByteString +asBE 0 = mempty +asBE x = asBE (x `div` 256) + <> BS.pack [num $ x `mod` 256] + +word256Bytes :: W256 -> ByteString +word256Bytes x = BS.pack [byteAt x (31 - i) | i <- [0..31]] + +word160Bytes :: Addr -> ByteString +word160Bytes x = BS.pack [byteAt (addressWord160 x) (19 - i) | i <- [0..19]] + +newtype Nibble = Nibble Word8 + deriving ( Num, Integral, Real, Ord, Enum, Eq + , Bits, FiniteBits, Bounded, Generic) + +instance Show Nibble where + show = (:[]) . intToDigit . num + +--Get first and second Nibble from byte +hi, lo :: Word8 -> Nibble +hi b = Nibble $ b `shiftR` 4 +lo b = Nibble $ b .&. 0x0f + +toByte :: Nibble -> Nibble -> Word8 +toByte (Nibble high) (Nibble low) = high `shift` 4 .|. low + +unpackNibbles :: ByteString -> [Nibble] +unpackNibbles bs = BS.unpack bs >>= unpackByte + where unpackByte b = [hi b, lo b] + +--Well-defined for even length lists only (plz dependent types) +packNibbles :: [Nibble] -> ByteString +packNibbles [] = mempty +packNibbles (n1:n2:ns) = BS.singleton (toByte n1 n2) <> packNibbles ns +packNibbles _ = error "cant pack odd number of nibbles" diff --git a/src/EVM/UnitTest.hs b/src/EVM/UnitTest.hs --- a/src/EVM/UnitTest.hs +++ b/src/EVM/UnitTest.hs @@ -1,41 +1,40 @@ -{-# LANGUAGE ViewPatterns #-} - module EVM.UnitTest where import Prelude hiding (Word) import EVM import EVM.ABI +import EVM.Concrete hiding (readMemoryWord) +import EVM.Symbolic import EVM.Dapp import EVM.Debug (srcMapCodePos) import EVM.Exec import EVM.Format -import EVM.Keccak import EVM.Solidity import EVM.Types -import EVM.Concrete (w256, wordAt) import qualified EVM.FeeSchedule as FeeSchedule -import EVM.Stepper (Stepper) +import EVM.Stepper (Stepper, interpret) import qualified EVM.Stepper as Stepper import qualified Control.Monad.Operational as Operational import Control.Lens hiding (Indexed) +import Control.Monad ((>=>)) import Control.Monad.State.Strict hiding (state) import qualified Control.Monad.State.Strict as State import Control.Monad.Par.Class (spawn_) import Control.Monad.Par.IO (runParIO) +import qualified Data.ByteString.Lazy as BSLazy import Data.ByteString (ByteString) +import Data.SBV import Data.Foldable (toList) import Data.Map (Map) -import Data.Maybe (fromMaybe, catMaybes, fromJust, fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, catMaybes, fromJust, isJust, fromMaybe, mapMaybe) import Data.Monoid ((<>)) -import Data.Text (Text, pack, unpack) -import Data.Text (isPrefixOf, stripSuffix, intercalate) -import Data.Text.Encoding (encodeUtf8) +import Data.Text (isPrefixOf, stripSuffix, intercalate, Text, pack, unpack) import Data.Word (Word32) import System.Environment (lookupEnv) import System.IO (hFlush, stdout) @@ -56,12 +55,17 @@ import Data.Vector (Vector) import qualified Data.Vector as Vector +import Test.QuickCheck hiding (verbose) + data UnitTestOptions = UnitTestOptions - { - oracle :: Query -> IO (EVM ()) - , verbose :: Bool + { oracle :: Query -> IO (EVM ()) + , verbose :: Maybe Int + , maxIter :: Maybe Integer , match :: Text + , fuzzRuns :: Int + , replay :: Maybe (Text, BSLazy.ByteString) , vmModifier :: VM -> VM + , dapp :: DappInfo , testParams :: TestVMParams } @@ -78,7 +82,9 @@ , testTimestamp :: W256 , testGaslimit :: W256 , testGasprice :: W256 + , testMaxCodeSize :: W256 , testDifficulty :: W256 + , testChainId :: W256 } defaultGasForCreating :: W256 @@ -93,6 +99,9 @@ defaultBalanceForCreated :: W256 defaultBalanceForCreated = 0xffffffffffffffffffffffff +defaultMaxCodeSize :: W256 +defaultMaxCodeSize = 0xffffffff + type ABIMethod = Text -- | Assuming a constructor is loaded, this stepper will run the constructor @@ -100,117 +109,79 @@ initializeUnitTest :: UnitTestOptions -> Stepper () initializeUnitTest UnitTestOptions { .. } = do - -- Maybe modify the initial VM, e.g. to load library code - Stepper.evm (modify vmModifier) + let addr = testAddress testParams - -- Make a trace entry for running the constructor - Stepper.evm (pushTrace (EntryTrace "constructor")) + Stepper.evm $ do + -- Maybe modify the initial VM, e.g. to load library code + modify vmModifier + -- Make a trace entry for running the constructor + pushTrace (EntryTrace "constructor") -- Constructor is loaded; run until it returns code - bytes <- Stepper.execFullyOrFail - addr <- Stepper.evm (use (state . contract)) - - -- Mutate the current contract to use the new code - Stepper.evm $ replaceCodeOfSelf bytes - - -- Increase the nonce, in case the constructor created contracts - Just n <- Stepper.evm (preuse (env . contracts . ix ethrunAddress . nonce)) - Stepper.evm $ assign (env . contracts . ix addr . nonce) n + void Stepper.execFully -- Give a balance to the test target - Stepper.evm $ + Stepper.evm $ do env . contracts . ix addr . balance += w256 (testBalanceCreate testParams) - -- Initialize the test contract - Stepper.evm (popTrace >> pushTrace (EntryTrace "initialize test")) - Stepper.evm $ - setupCall addr "setUp()" (testBalanceCall testParams) - - Stepper.note "Running `setUp()'" + -- Initialize the test contract + setupCall testParams "setUp()" emptyAbi + popTrace + pushTrace (EntryTrace "initialize test") -- Let `setUp()' run to completion - void Stepper.execFullyOrFail - Stepper.evm popTrace + res <- Stepper.execFully + Stepper.evm $ case res of + 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 -> Stepper Bool -runUnitTest UnitTestOptions { .. } method = do - -- Fail immediately if there was a failure in the setUp() phase - Stepper.evm (use result) >>= - \case - Just (VMFailure e) -> do - Stepper.evm (pushTrace (ErrorTrace e)) - pure False - - _ -> do - -- Decide whether the test is supposed to fail or succeed - let shouldFail = "testFail" `isPrefixOf` method - - -- The test subject should be loaded and initialized already - addr <- Stepper.evm $ use (state . contract) - - -- Set up the call to the test method - Stepper.evm $ - setupCall addr method (testGasCall testParams) - Stepper.evm (pushTrace (EntryTrace method)) - Stepper.note "Running unit test" - - -- Try running the test method - bailed <- - Stepper.execFully >>= - either (const (pure True)) (const (pure False)) +runUnitTest :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool +runUnitTest a method args = do + x <- execTest a method args + checkFailures a method args x - -- If we failed, put the error in the trace. - -- It's not clear to me right now why this doesn't happen somewhere else. - Just problem <- Stepper.evm $ use result - case problem of - VMFailure e -> - Stepper.evm (pushTrace (ErrorTrace e)) - _ -> - pure () +execTest :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool +execTest UnitTestOptions { .. } method args = do + -- Set up the call to the test method + Stepper.evm $ do + setupCall testParams method args + pushTrace (EntryTrace method) + -- Try running the test method + Stepper.execFully >>= \case + -- If we failed, put the error in the trace. + Left e -> Stepper.evm (pushTrace (ErrorTrace e)) >> pure True + _ -> pure False - -- Ask whether any assertions failed - Stepper.evm $ popTrace - Stepper.evm $ setupCall addr "failed()" 10000 - Stepper.note "Checking whether assertions failed" - AbiBool failed <- Stepper.execFullyOrFail >>= Stepper.decode AbiBoolType +checkFailures :: UnitTestOptions -> ABIMethod -> AbiValue -> Bool -> Stepper Bool +checkFailures UnitTestOptions { .. } method args 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 + setupCall testParams "failed()" args + res <- Stepper.execFully -- >>= \(ConcreteBuffer bs) -> (Stepper.decode AbiBoolType bs) + case res of + Right (ConcreteBuffer r) -> + let AbiBool failed = decodeAbiValue AbiBoolType (BSLazy.fromStrict r) + in pure (shouldFail == failed) + _ -> error "internal error: unexpected failure code" - -- Return true if the test was successful - pure (shouldFail == (bailed || failed)) +-- | Randomly generates the calldata arguments and runs the test +fuzzTest :: UnitTestOptions -> Text -> [AbiType] -> VM -> Property +fuzzTest opts sig types vm = forAllShow (genAbiValue (AbiTupleType $ Vector.fromList types)) (show . ByteStringS . encodeAbiValue) + $ \args -> ioProperty $ + fst <$> runStateT (interpret (oracle opts) (runUnitTest opts sig args)) vm tick :: Text -> IO () tick x = Text.putStr x >> hFlush stdout -interpret - :: UnitTestOptions - -> Stepper a - -> StateT VM IO (Either Stepper.Failure a) -interpret opts = - eval . Operational.view - - where - eval - :: Operational.ProgramView Stepper.Action a - -> StateT VM IO (Either Stepper.Failure a) - - eval (Operational.Return x) = - pure (Right x) - - eval (action Operational.:>>= k) = - case action of - Stepper.Exec -> - exec >>= interpret opts . k - Stepper.Wait q -> - do m <- liftIO (oracle opts q) - State.state (runState m) >> interpret opts (k ()) - Stepper.Note _ -> - interpret opts (k ()) - Stepper.Fail e -> - pure (Left e) - Stepper.EVM m -> - State.state (runState m) >>= interpret opts . k - -- | This is like an unresolved source mapping. data OpLocation = OpLocation { srcCodehash :: !W256 @@ -243,7 +214,11 @@ (fromMaybe (error "internal error: op ix") (vmOpIx vm)) execWithCoverage :: StateT CoverageState IO VMResult -execWithCoverage = do +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 @@ -251,36 +226,36 @@ Nothing -> do vm1 <- zoom _1 (State.state (runState exec1) >> get) zoom _2 (modify (MultiSet.insert (currentOpLocation vm1))) - execWithCoverage - Just r -> - pure r + runWithCoverage + Just _ -> pure vm0 + interpretWithCoverage :: UnitTestOptions -> Stepper a - -> StateT CoverageState IO (Either Stepper.Failure a) + -> StateT CoverageState IO a interpretWithCoverage opts = eval . Operational.view where eval :: Operational.ProgramView Stepper.Action a - -> StateT CoverageState IO (Either Stepper.Failure a) + -> StateT CoverageState IO a eval (Operational.Return x) = - pure (Right x) + pure x eval (action Operational.:>>= k) = case action of Stepper.Exec -> execWithCoverage >>= interpretWithCoverage opts . k + Stepper.Run -> + runWithCoverage >>= interpretWithCoverage opts . k Stepper.Wait q -> do m <- liftIO (oracle opts q) zoom _1 (State.state (runState m)) >> interpretWithCoverage opts (k ()) - Stepper.Note _ -> - interpretWithCoverage opts (k ()) - Stepper.Fail e -> - pure (Left e) + Stepper.Ask _ -> + error "cannot make choice in this interpreter" Stepper.EVM m -> zoom _1 (State.state (runState m)) >>= interpretWithCoverage opts . k @@ -319,7 +294,7 @@ ) f :: Text -> Vector ByteString -> Vector (Int, ByteString) - f name xs = + f name = Vector.imap (\i bs -> let @@ -328,7 +303,6 @@ then MultiSet.occur (name, i + 1) srcMapCov else -1 in (n, bs)) - xs in Map.mapWithKey f linesByName @@ -336,7 +310,7 @@ :: UnitTestOptions -> Map Text SolcContract -> SourceCache - -> (Text, [Text]) + -> (Text, [(Text, [AbiType])]) -> IO (MultiSet SrcMap) coverageForUnitTestContract opts@(UnitTestOptions {..}) contractMap sources (name, testNames) = do @@ -349,7 +323,7 @@ Just theContract -> do -- Construct the initial VM and begin the contract's constructor - let vm0 = initialUnitTestVm opts theContract (Map.elems contractMap) + let vm0 = initialUnitTestVm opts theContract (vm1, cov1) <- execStateT (interpretWithCoverage opts @@ -358,15 +332,12 @@ -- Define the thread spawner for test cases let - runOne testName = spawn_ . liftIO $ do + runOne (testName, _) = spawn_ . liftIO $ do (x, (_, cov)) <- runStateT - (interpretWithCoverage opts (runUnitTest opts testName)) + (interpretWithCoverage opts (runUnitTest opts testName emptyAbi)) (vm1, mempty) - case x of - Right True -> pure cov - _ -> error "test failure during coverage analysis; fix it!" - + pure cov -- Run all the test cases in parallel and gather their coverages covs <- runParIO (mapM runOne testNames >>= mapM Par.get) @@ -374,22 +345,19 @@ -- Sum up all the coverage counts let cov2 = MultiSet.unions (cov1 : covs) - -- Gather the dapp-related metadata - let dapp = dappInfo "." contractMap sources - pure (MultiSet.mapMaybe (srcMapForOpLocation dapp) cov2) runUnitTestContract :: UnitTestOptions -> Map Text SolcContract -> SourceCache - -> (Text, [Text]) + -> (Text, [(Text, [AbiType])]) -> IO Bool runUnitTestContract - opts@(UnitTestOptions {..}) contractMap sources (name, testNames) = do + opts@(UnitTestOptions {..}) contractMap sources (name, testSigs) = do -- Print a header - putStrLn $ "Running " ++ show (length testNames) ++ " tests for " + putStrLn $ "Running " ++ show (length testSigs) ++ " tests for " ++ unpack name -- Look for the wanted contract by name from the Solidity info @@ -400,66 +368,113 @@ Just theContract -> do -- Construct the initial VM and begin the contract's constructor - let vm0 = initialUnitTestVm opts theContract (Map.elems contractMap) + let vm0 = initialUnitTestVm opts theContract vm1 <- execStateT - (interpret opts + (interpret oracle (Stepper.enter name >> initializeUnitTest opts)) vm0 - -- Gather the dapp-related metadata - let dapp = dappInfo "." contractMap sources + case view result vm1 of + Nothing -> error "internal error: setUp() did not end with a result" + Just (VMFailure _) -> do + Text.putStrLn "\x1b[31m[FAIL]\x1b[0m setUp()" + tick "\n" + tick $ failOutput vm1 opts "setUp()" + pure False + Just (VMSuccess _) -> do - -- Define the thread spawner for test cases - let - runOne testName = do - x <- - runStateT - (interpret opts (runUnitTest opts testName)) - vm1 - case x of - (Right True, vm) -> - let - gasSpent = - view burned vm - view burned vm1 - gasText = - pack . show $ - (fromIntegral gasSpent :: Integer) - in - pure - ( "PASS " <> testName <> " (gas: " <> gasText <> ")" - , Right (passOutput vm dapp opts testName) - ) - (Right False, vm) -> - pure ("FAIL " <> testName, Left (failOutput vm dapp opts testName)) - (Left _, _) -> - pure ("OOPS " <> testName, Left ("VM error for " <> testName)) + -- Define the thread spawner for normal test cases + let + runOne testName args = do + let argInfo = pack (if args == emptyAbi then "" else " with arguments: " <> show args) + (bailed, vm2) <- + runStateT + (interpret oracle (execTest opts testName args)) + vm1 + (success, vm) <- runStateT (interpret oracle (checkFailures opts testName args bailed)) vm2 + if success + then + let gasSpent = num (testGasCall testParams) - view (state . gas) vm2 + gasText = pack . show $ (fromIntegral gasSpent :: Integer) + in + pure + ("\x1b[32m[PASS]\x1b[0m " + <> testName <> argInfo <> " (gas: " <> gasText <> ")" + , Right (passOutput vm opts testName) + ) + else + pure + ("\x1b[31m[FAIL]\x1b[0m " + <> testName <> argInfo + , Left (failOutput vm opts testName) + ) - let inform = \(x, y) -> Text.putStrLn x >> pure y + -- Define the thread spawner for property based tests + let fuzzRun (testName, types) = do + let args = Args{ replay = Nothing + , maxSuccess = fuzzRuns + , maxDiscardRatio = 10 + , maxSize = 100 + , chatty = isJust verbose + , maxShrinks = maxBound + } + res <- quickCheckWithResult args (fuzzTest opts testName types vm1) + case res of + Success numTests _ _ _ _ _ -> + pure ("\x1b[32m[PASS]\x1b[0m " + <> testName <> " (runs: " <> (pack $ show numTests) <> ")", + -- vm1 isn't quite the post vm we want... + -- but the vm we want is not accessible here anyway... + Right (passOutput vm1 opts testName)) + 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 + vm2 <- execStateT (interpret oracle (runUnitTest opts testName abiValue)) vm1 + 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 vm2 opts testName)) + _ -> pure ("\x1b[31m[OOPS]\x1b[0m " + <> testName, Left (failOutput vm1 opts testName)) - -- Run all the test cases and print their status updates - details <- - mapM (\x -> runOne x >>= inform) testNames + let runTest (testName, []) = runOne testName emptyAbi + runTest (testName, types) = case replay of + Nothing -> fuzzRun (testName, types) + Just (sig, callData) -> if sig == testName + then runOne testName $ + decodeAbiValue (AbiTupleType (Vector.fromList types)) callData + else fuzzRun (testName, types) - let mails = [x | Right x <- details] - let fails = [x | Left x <- details] + let inform (x, y) = Text.putStrLn x >> pure y - tick "\n" - tick (Text.unlines (filter (not . Text.null) mails)) - tick (Text.unlines (filter (not . Text.null) fails)) + -- Run all the test cases and print their status updates + details <- + mapM (runTest >=> inform) testSigs - pure (null fails) + let running = [x | Right x <- details] + let bailing = [x | Left x <- details] + tick "\n" + tick (Text.unlines (filter (not . Text.null) running)) + tick (Text.unlines (filter (not . Text.null) bailing)) + + pure (null bailing) + indentLines :: Int -> Text -> Text indentLines n s = let p = Text.replicate n " " in Text.unlines (map (p <>) (Text.lines s)) -passOutput :: VM -> DappInfo -> UnitTestOptions -> Text -> Text -passOutput vm dapp UnitTestOptions { .. } testName = +passOutput :: VM -> UnitTestOptions -> Text -> Text +passOutput vm UnitTestOptions { .. } testName = case verbose of - True -> - mconcat $ + Just 2 -> + mconcat [ "Success: " , fromMaybe "" (stripSuffix "()" testName) , "\n" @@ -467,17 +482,19 @@ , indentLines 2 (showTraceTree dapp vm) , "\n" ] - False -> + _ -> "" -failOutput :: VM -> DappInfo -> UnitTestOptions -> Text -> Text -failOutput vm dapp _ testName = mconcat $ +failOutput :: VM -> UnitTestOptions -> Text -> Text +failOutput vm UnitTestOptions { .. } testName = mconcat [ "Failure: " , fromMaybe "" (stripSuffix "()" testName) , "\n" , indentLines 2 (formatTestLogs (view dappEventMap dapp) (view logs vm)) - , indentLines 2 (showTraceTree dapp vm) - , "\n" + , case verbose of + Just _ -> indentLines 2 (showTraceTree dapp vm) + _ -> "" + ] formatTestLogs :: Map W256 Event -> Seq.Seq Log -> Text @@ -488,75 +505,85 @@ formatTestLog :: Map W256 Event -> Log -> Maybe Text formatTestLog _ (Log _ _ []) = Nothing -formatTestLog events (Log _ args (t:_)) = - let - name = getEventName event - event = getEvent t events - - in case name of - - "log_bytes32" -> - Just $ formatBytes args +formatTestLog events (Log _ args (topic:_)) = + case maybeLitWord topic of + Nothing -> Nothing + Just t -> case (Map.lookup (wordValue t) events) of + Nothing -> Nothing + Just (Event name _ _) -> case name of + "log_bytes32" -> + Just $ formatSBytes args - "log_named_bytes32" -> - let key = BS.take 32 args - val = BS.drop 32 args - in Just $ formatString key <> ": " <> formatBytes val + "log_named_bytes32" -> + let key = grab 32 args + val = ditch 32 args + in Just $ formatSString key <> ": " <> formatSBytes val - "log_named_address" -> - let key = BS.take 32 args - val = BS.drop 44 args - in Just $ formatString key <> ": " <> formatBinary val + "log_named_address" -> + let key = grab 32 args + val = ditch 44 args + in Just $ formatSString key <> ": " <> formatSBinary val - -- TODO: event logs (bytes); - -- TODO: event log_named_decimal_int (bytes32 key, int val, uint decimals); - -- TODO: event log_named_decimal_uint (bytes32 key, uint val, uint decimals); + "log_named_int" -> + let key = grab 32 args + val = case maybeLitWord (readMemoryWord 32 args) of + Just c -> showDec Signed (wordValue c) + Nothing -> "" + in Just $ formatSString key <> ": " <> val - "log_named_int" -> - let key = BS.take 32 args - val = wordAt 32 args - in Just $ formatString key <> ": " <> showDec Signed val + "log_named_uint" -> + let key = grab 32 args + val = case maybeLitWord (readMemoryWord 32 args) of + Just c -> showDec Unsigned (wordValue c) + Nothing -> "" + in Just $ formatSString key <> ": " <> val - "log_named_uint" -> - let key = BS.take 32 args - val = wordAt 32 args - in Just $ formatString key <> ": " <> showDec Unsigned val +-- TODO: event logs (bytes); +-- TODO: event log_named_decimal_int (bytes32 key, int val, uint decimals); +-- TODO: event log_named_decimal_uint (bytes32 key, uint val, uint decimals); - _ -> - Nothing + _ -> Nothing word32Bytes :: Word32 -> ByteString word32Bytes x = BS.pack [byteAt x (3 - i) | i <- [0..3]] -setupCall :: Addr -> Text -> W256 -> EVM () -setupCall target abi allowance = do +setupCall :: TestVMParams -> Text -> AbiValue -> EVM () +setupCall TestVMParams{..} sig args = do resetState - loadContract target - assign (state . calldata) (word32Bytes (abiKeccak (encodeUtf8 abi))) - assign (state . gas) (w256 allowance) + use (env . contracts) >>= assign (tx . txReversion) + assign (tx . isCreate) False + loadContract testAddress + assign (state . calldata) $ (ConcreteBuffer $ abiMethod sig args, literal . num . BS.length $ abiMethod sig args) + assign (state . caller) (litAddr testCaller) + assign (state . gas) (w256 testGasCall) -initialUnitTestVm :: UnitTestOptions -> SolcContract -> [SolcContract] -> VM -initialUnitTestVm (UnitTestOptions {..}) theContract _ = +initialUnitTestVm :: UnitTestOptions -> SolcContract -> VM +initialUnitTestVm (UnitTestOptions {..}) theContract = let TestVMParams {..} = testParams vm = makeVm $ VMOpts - { vmoptCode = view creationCode theContract - , vmoptCalldata = "" + { vmoptContract = initialContract (InitCode (view creationCode theContract)) + , vmoptCalldata = (mempty, 0) , vmoptValue = 0 , vmoptAddress = testAddress - , vmoptCaller = testCaller + , vmoptCaller = litAddr testCaller , vmoptOrigin = testOrigin , vmoptGas = testGasCreate + , vmoptGaslimit = testGasCreate , vmoptCoinbase = testCoinbase , vmoptNumber = testNumber , vmoptTimestamp = testTimestamp - , vmoptGaslimit = testGaslimit + , vmoptBlockGaslimit = testGaslimit , vmoptGasprice = testGasprice + , vmoptMaxCodeSize = testMaxCodeSize , vmoptDifficulty = testDifficulty - , vmoptSchedule = FeeSchedule.metropolis + , vmoptSchedule = FeeSchedule.istanbul + , vmoptChainId = testChainId + , vmoptCreate = True + , vmoptStorageModel = ConcreteS } creator = - initialContract mempty + initialContract (RuntimeCode mempty) & set nonce 1 & set balance (w256 testBalanceCreate) in vm @@ -569,7 +596,7 @@ getAddr s def = maybe def read <$> lookupEnv s TestVMParams - <$> getAddr "DAPP_TEST_ADDRESS" (newContractAddress ethrunAddress 1) + <$> getAddr "DAPP_TEST_ADDRESS" (createAddress ethrunAddress 1) <*> getAddr "DAPP_TEST_CALLER" ethrunAddress <*> getAddr "DAPP_TEST_ORIGIN" ethrunAddress <*> getWord "DAPP_TEST_GAS_CREATE" defaultGasForCreating @@ -577,8 +604,10 @@ <*> getWord "DAPP_TEST_BALANCE_CREATE" defaultBalanceForCreator <*> getWord "DAPP_TEST_BALANCE_CALL" defaultBalanceForCreated <*> getAddr "DAPP_TEST_COINBASE" 0 - <*> getWord "DAPP_TEST_NUMBER" 512 + <*> getWord "DAPP_TEST_NUMBER" 0 <*> getWord "DAPP_TEST_TIMESTAMP" 1 <*> getWord "DAPP_TEST_GAS_LIMIT" 0 <*> getWord "DAPP_TEST_GAS_PRICE" 0 + <*> getWord "DAPP_TEST_MAXCODESIZE" defaultMaxCodeSize <*> getWord "DAPP_TEST_DIFFICULTY" 1 + <*> getWord "DAPP_TEST_CHAINID" 99 diff --git a/src/EVM/VMTest.hs b/src/EVM/VMTest.hs --- a/src/EVM/VMTest.hs +++ b/src/EVM/VMTest.hs @@ -5,121 +5,248 @@ ( Case #if MIN_VERSION_aeson(1, 0, 0) , parseSuite + , parseBCSuite #endif , vmForCase , checkExpectation - , interpret ) where import qualified EVM import qualified EVM.Concrete as EVM -import qualified EVM.Exec -import qualified EVM.FeeSchedule as EVM.FeeSchedule -import qualified EVM.Stepper as Stepper -import qualified EVM.Fetch as Fetch - -import Control.Monad.State.Strict (runState, join) -import qualified Control.Monad.Operational as Operational -import qualified Control.Monad.State.Class as State +import qualified EVM.FeeSchedule -import EVM (EVM) -import EVM.Stepper (Stepper) +import EVM.Symbolic +import EVM.Transaction import EVM.Types -import Control.Lens +import Data.SBV -import IPPrint.Colored (cpprint) +import Control.Arrow ((***), (&&&)) +import Control.Lens +import Control.Monad import Data.ByteString (ByteString) -import Data.Aeson ((.:), (.:?)) -import Data.Aeson (FromJSON (..)) +import Data.Aeson ((.:), (.:?), FromJSON (..)) +import Data.Bifunctor (bimap) +import Data.Foldable (fold) import Data.Map (Map) -import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.Witherable (Filterable, catMaybes) import qualified Data.Map as Map import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString as BS +data Which = Pre | Post + +data Block = Block + { blockCoinbase :: Addr + , blockDifficulty :: W256 + , blockGasLimit :: W256 + , blockNumber :: W256 + , blockTimestamp :: W256 + , blockTxs :: [Transaction] + } deriving Show + data Case = Case { testVmOpts :: EVM.VMOpts - , testContracts :: Map Addr Contract + , checkContracts :: Map Addr Contract , testExpectation :: Maybe Expectation } deriving Show +data BlockchainCase = BlockchainCase + { blockchainBlocks :: [Block] + , blockchainPre :: Map Addr Contract + , blockchainPost :: Map Addr Contract + , blockchainNetwork :: String + } deriving Show + data Contract = Contract - { contractBalance :: W256 - , contractCode :: ByteString - , contractNonce :: W256 - , contractStorage :: Map W256 W256 + { _balance :: W256 + , _code :: EVM.ContractCode + , _nonce :: W256 + , _storage :: Map W256 W256 + , _create :: Bool } deriving Show data Expectation = Expectation - { expectedOut :: ByteString + { expectedOut :: Maybe ByteString , expectedContracts :: Map Addr Contract - , expectedGas :: W256 + , expectedGas :: Maybe W256 } deriving Show -checkExpectation :: Case -> EVM.VM -> IO Bool -checkExpectation x vm = +makeLenses ''Contract + +accountAt :: Addr -> Getter (Map Addr Contract) Contract +accountAt a = (at a) . (to $ fromMaybe newAccount) + +touchAccount :: Addr -> Map Addr Contract -> Map Addr Contract +touchAccount a = Map.insertWith (flip const) a newAccount + +newAccount :: Contract +newAccount = Contract + { _balance = 0 + , _code = EVM.RuntimeCode mempty + , _nonce = 0 + , _storage = mempty + , _create = False + } + +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 -> Expectation -> EVM.VM -> (Bool, Bool, Bool, Bool, Bool) -> IO Bool +checkStateFail diff x expectation vm (okState, okMoney, okNonce, okData, okCode) = do + let + printField :: (v -> String) -> Map Addr v -> IO () + printField f d = putStrLn $ Map.foldrWithKey (\k v acc -> + acc ++ show k ++ " : " ++ f v ++ "\n") "" d + + reason = map fst (filter (not . snd) + [ ("bad-state", okMoney || okNonce || okData || okCode || okState) + , ("bad-balance", not okMoney || okNonce || okData || okCode || okState) + , ("bad-nonce", not okNonce || okMoney || okData || okCode || okState) + , ("bad-storage", not okData || okMoney || okNonce || okCode || okState) + , ("bad-code", not okCode || okMoney || okNonce || okData || okState) + ]) + check = checkContracts x + initial = initTx x + expected = expectedContracts expectation + actual = view (EVM.env . EVM.contracts . to (fmap (clearZeroStorage.clearOrigStorage))) vm + printStorage (EVM.Symbolic c) = show c + printStorage (EVM.Concrete c) = show $ Map.toList c + + putStr (unwords reason) + when (diff && (not okState)) $ do + putStrLn "\nCheck balance/state: " + printField (\v -> (show . toInteger $ _nonce v) ++ " " + ++ (show . toInteger $ _balance v) ++ " " + ++ (show . Map.toList $ _storage v)) check + putStrLn "\nInitial balance/state: " + printField (\v -> (show . toInteger $ _nonce v) ++ " " + ++ (show . toInteger $ _balance v) ++ " " + ++ (show . Map.toList $ _storage v)) initial + putStrLn "\nExpected balance/state: " + printField (\v -> (show . toInteger $ _nonce v) ++ " " + ++ (show . toInteger $ _balance v) ++ " " + ++ (show . Map.toList $ _storage v)) expected + putStrLn "\nActual balance/state: " + printField (\v -> (show . toInteger $ EVM._nonce v) ++ " " + ++ (show . toInteger $ EVM._balance v) ++ " " + ++ (printStorage $ EVM._storage v)) actual + return okState + +checkExpectation :: Bool -> Case -> EVM.VM -> IO Bool +checkExpectation diff x vm = case (testExpectation x, view EVM.result vm) of - (Just expectation, Just (EVM.VMSuccess output)) -> do - let - (s1, b1) = ("bad-state", checkExpectedContracts vm (expectedContracts expectation)) - (s2, b2) = ("bad-output", checkExpectedOut output (expectedOut expectation)) - (s3, b3) = ("bad-gas", checkExpectedGas vm (expectedGas expectation)) - ss = map fst (filter (not . snd) [(s1, b1), (s2, b2), (s3, b3)]) - putStr (intercalate " " ss) - return (b1 && b2 && b3) + (Just expectation, _) -> do + let (okState, b2, b3, b4, b5) = + checkExpectedContracts vm (expectedContracts expectation) + _ <- if not okState then + checkStateFail + diff x expectation vm (okState, b2, b3, b4, b5) + else return True + return okState + (Nothing, Just (EVM.VMSuccess _)) -> do putStr "unexpected-success" return False + (Nothing, Just (EVM.VMFailure _)) -> return True - (Just _, Just (EVM.VMFailure _)) -> do - putStr "unexpected-failure" - return False + (_, Nothing) -> do - cpprint (view EVM.result vm) + print (view EVM.result vm) error "internal error" -checkExpectedOut :: ByteString -> ByteString -> Bool -checkExpectedOut output expected = - output == expected +-- quotient account state by nullness +(~=) :: Map Addr EVM.Contract -> Map Addr EVM.Contract -> Bool +(~=) cs cs' = + let nullAccount = EVM.initialContract (EVM.RuntimeCode mempty) + padNewAccounts cs'' ks = (fold [Map.insertWith (\_ x -> x) k nullAccount | k <- ks]) cs'' + padded_cs' = padNewAccounts cs' (Map.keys cs) + padded_cs = padNewAccounts cs (Map.keys cs') + in padded_cs == padded_cs' -checkExpectedContracts :: EVM.VM -> Map Addr Contract -> Bool +checkExpectedContracts :: EVM.VM -> Map Addr Contract -> (Bool, Bool, Bool, Bool, Bool) checkExpectedContracts vm expected = - realizeContracts expected == vm ^. EVM.env . EVM.contracts . to (fmap clearZeroStorage) + let cs = vm ^. EVM.env . EVM.contracts . to (fmap (clearZeroStorage.clearOrigStorage)) + expectedCs = clearOrigStorage <$> realizeContracts expected + in ( (expectedCs ~= cs) + , (clearBalance <$> expectedCs) ~= (clearBalance <$> cs) + , (clearNonce <$> expectedCs) ~= (clearNonce <$> cs) + , (clearStorage <$> expectedCs) ~= (clearStorage <$> cs) + , (clearCode <$> expectedCs) ~= (clearCode <$> cs) + ) +clearOrigStorage :: EVM.Contract -> EVM.Contract +clearOrigStorage = set EVM.origStorage mempty + clearZeroStorage :: EVM.Contract -> EVM.Contract -clearZeroStorage = - over EVM.storage (Map.filterWithKey (\_ x -> x /= 0)) +clearZeroStorage c = case EVM._storage c of + EVM.Symbolic _ -> c + EVM.Concrete m -> let store = Map.filter (\x -> forceLit x /= 0) m + in set EVM.storage (EVM.Concrete store) c -checkExpectedGas :: EVM.VM -> W256 -> Bool -checkExpectedGas vm expected = - case vm ^. EVM.state . EVM.gas of - EVM.C _ x | x == expected -> True - _ -> False +clearStorage :: EVM.Contract -> EVM.Contract +clearStorage = set EVM.storage (EVM.Concrete mempty) +clearBalance :: EVM.Contract -> EVM.Contract +clearBalance = set EVM.balance 0 + +clearNonce :: EVM.Contract -> EVM.Contract +clearNonce = set EVM.nonce 0 + +clearCode :: EVM.Contract -> EVM.Contract +clearCode = set EVM.contractcode (EVM.RuntimeCode mempty) + #if MIN_VERSION_aeson(1, 0, 0) instance FromJSON Contract where parseJSON (JSON.Object v) = Contract <$> v .: "balance" - <*> (hexText <$> v .: "code") + <*> (EVM.RuntimeCode <$> (hexText <$> v .: "code")) <*> v .: "nonce" <*> v .: "storage" + <*> pure False parseJSON invalid = JSON.typeMismatch "VM test case contract" invalid instance FromJSON Case where parseJSON (JSON.Object v) = Case <$> parseVmOpts v - <*> parseContracts v + <*> parseContracts Pre v <*> parseExpectation v parseJSON invalid = - JSON.typeMismatch "VM test case" invalid + JSON.typeMismatch "VM test case" invalid +instance FromJSON BlockchainCase where + parseJSON (JSON.Object v) = BlockchainCase + <$> v .: "blocks" + <*> parseContracts Pre v + <*> parseContracts Post v + <*> v .: "network" + parseJSON invalid = + JSON.typeMismatch "GeneralState test case" invalid + +instance FromJSON Block where + parseJSON (JSON.Object v) = do + v' <- v .: "blockHeader" + txs <- v .: "transactions" + coinbase <- addrField v' "coinbase" + difficulty <- wordField v' "difficulty" + gasLimit <- wordField v' "gasLimit" + number <- wordField v' "number" + timestamp <- wordField v' "timestamp" + return $ Block coinbase difficulty gasLimit number timestamp txs + parseJSON invalid = + JSON.typeMismatch "Block" invalid + parseVmOpts :: JSON.Object -> JSON.Parser EVM.VMOpts parseVmOpts v = do envV <- v .: "env" @@ -127,27 +254,35 @@ case (envV, execV) of (JSON.Object env, JSON.Object exec) -> EVM.VMOpts - <$> dataField exec "code" - <*> dataField exec "data" - <*> wordField exec "value" + <$> (dataField exec "code" >>= pure . EVM.initialContract . EVM.RuntimeCode) + <*> (dataField exec "data" >>= \a -> pure ( (ConcreteBuffer a), literal . num $ BS.length a)) + <*> (w256lit <$> wordField exec "value") <*> addrField exec "address" - <*> addrField exec "caller" + <*> (litAddr <$> addrField exec "caller") <*> addrField exec "origin" <*> wordField exec "gas" -- XXX: correct? + <*> wordField exec "gas" -- XXX: correct? <*> wordField env "currentNumber" <*> wordField env "currentTimestamp" <*> addrField env "currentCoinbase" <*> wordField env "currentDifficulty" + <*> pure 0xffffffff <*> wordField env "currentGasLimit" <*> wordField exec "gasPrice" - <*> pure (EVM.FeeSchedule.homestead) + <*> pure (EVM.FeeSchedule.istanbul) + <*> pure 1 + <*> pure False + <*> pure EVM.ConcreteS _ -> JSON.typeMismatch "VM test case" (JSON.Object v) parseContracts :: - JSON.Object -> JSON.Parser (Map Addr Contract) -parseContracts v = - v .: "pre" >>= parseJSON + Which -> JSON.Object -> JSON.Parser (Map Addr Contract) +parseContracts w v = + v .: which >>= parseJSON + where which = case w of + Pre -> "pre" + Post -> "postState" parseExpectation :: JSON.Object -> JSON.Parser (Maybe Expectation) parseExpectation v = @@ -156,7 +291,7 @@ gas <- v .:? "gas" case (out, contracts, gas) of (Just x, Just y, Just z) -> - return (Just (Expectation x y z)) + return (Just (Expectation (Just x) y (Just z))) _ -> return Nothing @@ -164,6 +299,20 @@ Lazy.ByteString -> Either String (Map String Case) parseSuite = JSON.eitherDecode' +parseBCSuite :: + Lazy.ByteString -> Either String (Map String Case) +parseBCSuite x = case (JSON.eitherDecode' x) :: Either String (Map String BlockchainCase) of + Left e -> Left e + Right bcCases -> let allCases = (fromBlockchainCase <$> bcCases) + keepError (Left e) = errorFatal e + keepError _ = True + filteredCases = Map.filter keepError allCases + (erroredCases, parsedCases) = splitEithers filteredCases + in if Map.size erroredCases > 0 + then Left ("errored case: " ++ (show $ (Map.elems erroredCases) !! 0)) + else if Map.size parsedCases == 0 + then Left "No cases to check." + else Right parsedCases #endif realizeContracts :: Map Addr Contract -> Map Addr EVM.Contract @@ -173,43 +322,205 @@ realizeContract :: Contract -> EVM.Contract realizeContract x = - EVM.initialContract (contractCode x) - & EVM.balance .~ EVM.w256 (contractBalance x) - & EVM.nonce .~ EVM.w256 (contractNonce x) - & EVM.storage .~ ( + EVM.initialContract (x ^. code) + & EVM.balance .~ EVM.w256 (x ^. balance) + & EVM.nonce .~ EVM.w256 (x ^. nonce) + & EVM.storage .~ EVM.Concrete ( Map.fromList . - map (\(k, v) -> (EVM.w256 k, EVM.w256 v)) . - Map.toList $ contractStorage x + map (bimap EVM.w256 (litWord . EVM.w256)) . + Map.toList $ x ^. storage ) + & EVM.origStorage .~ ( + Map.fromList . + map (bimap EVM.w256 EVM.w256) . + Map.toList $ x ^. storage + ) -vmForCase :: Case -> EVM.VM -vmForCase x = - EVM.makeVm (testVmOpts x) - & EVM.env . EVM.contracts .~ realizeContracts (testContracts x) - & EVM.execMode .~ EVM.ExecuteAsVMTest +data BlockchainError + = TooManyBlocks + | TooManyTxs + | NoTxs + | TargetMissing + | SignatureUnverified + | InvalidTx + | OldNetwork + | FailedCreate + deriving Show -interpret :: Stepper a -> EVM a -interpret = - eval . Operational.view +errorFatal :: BlockchainError -> Bool +errorFatal TooManyBlocks = True +errorFatal TooManyTxs = True +errorFatal TargetMissing = True +errorFatal SignatureUnverified = True +errorFatal InvalidTx = True +errorFatal _ = False - where - eval - :: Operational.ProgramView Stepper.Action a - -> EVM a +fromBlockchainCase :: BlockchainCase -> Either BlockchainError Case +fromBlockchainCase (BlockchainCase blocks preState postState network) = + case (blocks, network) of + ([block], "Istanbul") -> case blockTxs block of + [tx] -> case txToAddr tx of + Nothing -> fromCreateBlockchainCase block tx preState postState + Just _ -> fromNormalBlockchainCase block tx preState postState + [] -> Left NoTxs + _ -> Left TooManyTxs + ([_], _) -> Left OldNetwork + (_, _) -> Left TooManyBlocks - eval (Operational.Return x) = - pure x +fromCreateBlockchainCase :: Block -> Transaction + -> Map Addr Contract -> Map Addr Contract + -> Either BlockchainError Case +fromCreateBlockchainCase block tx preState postState = + case (sender 1 tx, + checkCreateTx tx block preState) of + (Nothing, _) -> Left SignatureUnverified + (_, Nothing) -> Left FailedCreate + (Just origin, Just (checkState, createdAddr)) -> let + feeSchedule = EVM.FeeSchedule.istanbul + in Right $ Case + (EVM.VMOpts + { vmoptContract = EVM.initialContract (EVM.InitCode (txData tx)) + , vmoptCalldata = (mempty, 0) + , vmoptValue = w256lit $ txValue tx + , vmoptAddress = createdAddr + , vmoptCaller = (litAddr origin) + , vmoptOrigin = origin + , vmoptGas = txGasLimit tx - fromIntegral (txGasCost feeSchedule tx) + , vmoptGaslimit = txGasLimit tx + , vmoptNumber = blockNumber block + , vmoptTimestamp = blockTimestamp block + , vmoptCoinbase = blockCoinbase block + , vmoptDifficulty = blockDifficulty block + , vmoptMaxCodeSize = 24576 + , vmoptBlockGaslimit = blockGasLimit block + , vmoptGasprice = txGasPrice tx + , vmoptSchedule = feeSchedule + , vmoptChainId = 1 + , vmoptCreate = True + , vmoptStorageModel = EVM.ConcreteS + }) + checkState + (Just $ Expectation Nothing postState Nothing) - eval (action Operational.:>>= k) = - case action of - Stepper.Exec -> - EVM.Exec.exec >>= interpret . k - Stepper.Wait q -> - do join (Fetch.zero q) - interpret (k ()) - Stepper.Note _ -> - interpret (k ()) - Stepper.Fail _ -> - error "VMTest stepper not supposed to fail" - Stepper.EVM m -> - State.state (runState m) >>= interpret . k + +fromNormalBlockchainCase :: Block -> Transaction + -> Map Addr Contract -> Map Addr Contract + -> Either BlockchainError Case +fromNormalBlockchainCase block tx preState postState = + let Just toAddr = txToAddr tx + feeSchedule = EVM.FeeSchedule.istanbul + toCode = Map.lookup toAddr preState + theCode = case toCode of + Nothing -> EVM.RuntimeCode mempty + Just c -> view code c + in case (toAddr , toCode , sender 1 tx , checkNormalTx tx block preState) of + (_, _, Nothing, _) -> Left SignatureUnverified + (_, _, _, Nothing) -> Left InvalidTx + (_, _, Just origin, Just checkState) -> Right $ Case + (EVM.VMOpts + { vmoptContract = EVM.initialContract theCode + , vmoptCalldata = (ConcreteBuffer $ txData tx, literal . num . BS.length $ txData tx) + , vmoptValue = litWord (EVM.w256 $ txValue tx) + , vmoptAddress = toAddr + , vmoptCaller = (litAddr origin) + , vmoptOrigin = origin + , vmoptGas = txGasLimit tx - fromIntegral (txGasCost feeSchedule tx) + , vmoptGaslimit = txGasLimit tx + , vmoptNumber = blockNumber block + , vmoptTimestamp = blockTimestamp block + , vmoptCoinbase = blockCoinbase block + , vmoptDifficulty = blockDifficulty block + , vmoptMaxCodeSize = 24576 + , vmoptBlockGaslimit = blockGasLimit block + , vmoptGasprice = txGasPrice tx + , vmoptSchedule = feeSchedule + , vmoptChainId = 1 + , vmoptCreate = False + , vmoptStorageModel = EVM.ConcreteS + }) + checkState + (Just $ Expectation Nothing postState Nothing) + + +validateTx :: Transaction -> Map Addr Contract -> Maybe Bool +validateTx tx cs = do + origin <- sender 1 tx + originBalance <- (view balance) <$> view (at origin) cs + originNonce <- (view nonce) <$> view (at origin) cs + let gasDeposit = fromIntegral (txGasPrice tx) * (txGasLimit tx) + return $ gasDeposit + (txValue tx) <= originBalance + && (txNonce tx) == originNonce + +checkNormalTx :: Transaction -> Block -> Map Addr Contract -> Maybe (Map Addr Contract) +checkNormalTx tx block prestate = do + toAddr <- txToAddr tx + origin <- sender 1 tx + valid <- validateTx tx prestate + let gasDeposit = fromIntegral (txGasPrice tx) * (txGasLimit tx) + coinbase = blockCoinbase block + if not valid then mzero else + return $ + (Map.adjust ((over nonce (+ 1)) + . (over balance (subtract gasDeposit))) origin) + . touchAccount origin + . touchAccount toAddr + . touchAccount coinbase $ prestate + +checkCreateTx :: Transaction -> Block -> Map Addr Contract -> Maybe ((Map Addr Contract), Addr) +checkCreateTx tx block prestate = do + origin <- sender 1 tx + valid <- validateTx tx prestate + let gasDeposit = fromIntegral (txGasPrice tx) * (txGasLimit tx) + coinbase = blockCoinbase block + senderNonce = view (accountAt origin . nonce) prestate + createdAddr = EVM.createAddress origin senderNonce + prevCode = view (accountAt createdAddr . code) prestate + prevNonce = view (accountAt createdAddr . nonce) prestate + if (prevCode /= EVM.RuntimeCode mempty) || (prevNonce /= 0) || (not valid) + then mzero + else + return + ((Map.adjust ((over nonce (+ 1)) + . (over balance (subtract gasDeposit))) origin) + . touchAccount origin + . touchAccount createdAddr + . touchAccount coinbase $ prestate, createdAddr) + +initTx :: Case -> Map Addr Contract +initTx x = + let + checkState = checkContracts x + opts = testVmOpts x + toAddr = EVM.vmoptAddress opts + origin = EVM.vmoptOrigin opts + value = EVM.vmoptValue opts + initcode = EVM._contractcode (EVM.vmoptContract opts) + creation = EVM.vmoptCreate opts + in + (Map.adjust (over balance (subtract (EVM.wordValue $ forceLit value))) origin) + . (Map.adjust (over balance (+ (EVM.wordValue $ forceLit value))) toAddr) + . (if creation + then (Map.adjust (set code initcode) toAddr) + . (Map.adjust (set nonce 1) toAddr) + . (Map.adjust (set storage mempty) toAddr) + . (Map.adjust (set create True) toAddr) + else id) + $ checkState + +vmForCase :: Case -> EVM.VM +vmForCase x = + let + checkState = checkContracts x + initState = initTx x + opts = testVmOpts x + creation = EVM.vmoptCreate opts + touchedAccounts = + if creation then + [EVM.vmoptOrigin opts] + else + [EVM.vmoptOrigin opts, EVM.vmoptAddress opts] + in + EVM.makeVm (testVmOpts x) + & EVM.env . EVM.contracts .~ realizeContracts initState + & EVM.tx . EVM.txReversion .~ realizeContracts checkState + & EVM.tx . EVM.substate . EVM.touchedAccounts .~ touchedAccounts diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,33 +1,51 @@ {-# Language OverloadedStrings #-} {-# Language QuasiQuotes #-} - +{-# Language TypeSynonymInstances #-} +{-# Language FlexibleInstances #-} +{-# Language GeneralizedNewtypeDeriving #-} +{-# Language DataKinds #-} +{-# Language StandaloneDeriving #-} import Data.Text (Text) import Data.ByteString (ByteString) +import Prelude hiding (fail) + import qualified Data.Text as Text import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS (fromStrict) import qualified Data.ByteString.Base16 as Hex - import Test.Tasty -import Test.Tasty.QuickCheck (testProperty, Arbitrary (..), NonNegative (..)) +import Test.Tasty.QuickCheck-- hiding (forAll) import Test.Tasty.HUnit import Control.Monad.State.Strict (execState, runState) -import Control.Lens +import Control.Lens hiding (List, pre) import qualified Data.Vector as Vector import Data.String.Here +import Control.Monad.Fail + import Data.Binary.Put (runPut) +import Data.SBV hiding ((===), forAll) +import Data.SBV.Control +import qualified Data.Map as Map import Data.Binary.Get (runGetOrFail) -import EVM +import EVM hiding (Query) +import EVM.SymExec +import EVM.Symbolic import EVM.ABI import EVM.Exec +import EVM.Patricia as Patricia +import EVM.Precompiled +import EVM.RLP import EVM.Solidity import EVM.Types -import EVM.Precompiled +instance MonadFail Query where + fail = io . fail + main :: IO () main = defaultMain $ testGroup "hevm" [ testGroup "ABI" @@ -36,9 +54,8 @@ Right ("", _, x') -> x' == x _ -> False ] - , testGroup "Solidity expressions" - [ testCase "Trivial" $ do + [ testCase "Trivial" $ SolidityCall "x = 3;" [] ===> AbiUInt 256 3 @@ -48,32 +65,12 @@ SolidityCall "x = a - 1;" [AbiUInt 8 0] ===> AbiUInt 8 255 - , testCase "keccak256()" $ do + , testCase "keccak256()" $ SolidityCall "x = uint(keccak256(abi.encodePacked(a)));" [AbiString ""] ===> AbiUInt 256 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470 ] - , testGroup "ecrecover" - [ testCase "Example 1" $ - let - h = "0x0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef" - r = "0xc84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4732" - s = "0x1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" - in SolidityCall - (Text.unlines - [ "bytes32 h = keccak256(abi.encodePacked(\"\\x19Ethereum Signed Message:\\n32\", d));" - , "x = ecrecover(h, a, b, c);" - ]) - [ AbiUInt 8 28 - , AbiBytes 32 (hexText r) - , AbiBytes 32 (hexText s) - , AbiBytes 32 (hexText h) - ] - ===> - AbiAddress 0x2d5e56d45c63150d937f2182538a0f18510cb11f - ] - - , testGroup "Precompiled contracts" $ + , testGroup "Precompiled contracts" [ testGroup "Example (reverse)" [ testCase "success" $ assertEqual "example contract reverses" @@ -105,7 +102,6 @@ (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) @@ -120,11 +116,417 @@ y = BS.replicate n 0 in x == y ] - ] + , 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 $ Literal Patricia.Empty) + ] + + , testGroup "Symbolic execution" + [ + -- 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 asWord :: [SWord 8] -> SWord 256 + asWord = fromBytes + pre preVM = let SymbolicBuffer bs = ditch 4 (fst $ view (state . calldata) preVM) + (x, y) = splitAt 32 bs + in asWord x .<= asWord x + asWord y + .&& view (state . callvalue) preVM .== 0 + post = Just $ \(prestate, poststate) -> + let SymbolicBuffer input = fst $ view (state.calldata) prestate + (x, y) = splitAt 32 (drop 4 input) + in case view result poststate of + Just (VMSuccess (SymbolicBuffer out)) -> (asWord out) .== (asWord x) + (asWord y) + _ -> sFalse + Left (_, res) <- runSMT $ query $ verifyContract (RuntimeCode safeAdd) Nothing (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre post + putStrLn $ "successfully explored: " <> show (length 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 asWord :: [SWord 8] -> SWord 256 + asWord = fromBytes + pre preVM = let SymbolicBuffer bs = ditch 4 (fst $ view (state . calldata) preVM) + (x, y) = splitAt 32 bs + in (asWord x .<= asWord x + asWord y) + .&& (x .== y) + .&& view (state . callvalue) preVM .== 0 + post = Just $ \(prestate, poststate) + -> let SymbolicBuffer input = fst $ view (state.calldata) prestate + (_, y) = splitAt 32 (drop 4 input) + in case view result poststate of + Just (VMSuccess (SymbolicBuffer out)) -> asWord out .== 2 * asWord y + _ -> sFalse + Left (_, res) <- runSMTWith z3 $ query $ + verifyContract (RuntimeCode safeAdd) Nothing (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre post + putStrLn $ "successfully explored: " <> show (length res) <> " paths" + , + testCase "factorize 973013" $ do + Just factor <- solcRuntime "PrimalityCheck" + [i| + contract PrimalityCheck { + function factor(uint x, uint y) public pure { + require(1 < x && x < 973013 && 1 < y && y < 973013); + assert(x*y != 973013); + } + } + |] + bs <- runSMTWith cvc4 $ query $ do + Right vm <- checkAssert (RuntimeCode factor) Nothing (Just ("factor(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] + case view (state . calldata . _1) vm of + SymbolicBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs + ConcreteBuffer _ -> error "unexpected" + + let AbiTuple xy = decodeAbiValue (AbiTupleType $ Vector.fromList [AbiUIntType 256, AbiUIntType 256]) (BS.fromStrict (BS.drop 4 bs)) + [AbiUInt 256 x, AbiUInt 256 y] = Vector.toList xy + assertEqual "" True (x == 953 && y == 1021 || x == 1021 && y == 953) + , + testCase "summary storage writes" $ do + Just c <- solcRuntime "A" + [i| + contract A { + uint x; + function f(uint256 y) public { + x += y; + x += y; + } + } + |] + let pre vm = 0 .== view (state . callvalue) vm + post = Just $ \(prestate, poststate) -> + let SymbolicBuffer y = ditch 4 $ fst (view (state.calldata) prestate) + this = view (state . codeContract) prestate + Just preC = view (env.contracts . at this) prestate + Just postC = view (env.contracts . at this) poststate + Symbolic prestore = _storage preC + Symbolic poststore = _storage postC + prex = readArray prestore 0 + postx = readArray poststore 0 + in case view result poststate of + Just (VMSuccess _) -> prex + 2 * (fromBytes y) .== postx + _ -> sFalse + Left (_, res) <- runSMT $ query $ verifyContract (RuntimeCode c) Nothing (Just ("f(uint256)", [AbiUIntType 256])) [] SymbolicS pre post + putStrLn $ "successfully explored: " <> show (length res) <> " paths" + , + -- Inspired by these `msg.sender == to` token bugs + -- which break linearity of totalSupply. + testCase "catch storage collisions" $ 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 = 0 .== view (state . callvalue) vm + post = Just $ \(prestate, poststate) -> + let SymbolicBuffer bs = fst (view (state.calldata) prestate) + (x,y) = over both (fromBytes) (splitAt 32 $ drop 4 bs) + this = view (state . codeContract) prestate + (Just preC, Just postC) = both' (view (env.contracts . at this)) (prestate, poststate) + --Just postC = view (env.contracts . at this) poststate + (Symbolic prestore, Symbolic poststore) = both' (view storage) (preC, postC) + (prex, prey) = both' (readArray prestore) (x, y) + (postx, posty) = both' (readArray poststore) (x, y) + in case view result poststate of + Just (VMSuccess _) -> prex + prey .== postx + (posty :: SWord 256) + _ -> sFalse + bs <- runSMT $ query $ do + Right vm <- verifyContract (RuntimeCode c) Nothing (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre post + case view (state . calldata . _1) vm of + SymbolicBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs + ConcreteBuffer bs -> error "unexpected" + + let AbiTuple xyz = decodeAbiValue (AbiTupleType $ Vector.fromList [AbiUIntType 256, AbiUIntType 256]) (BS.fromStrict (BS.drop 4 bs)) + [AbiUInt 256 x, AbiUInt 256 y] = Vector.toList xyz + assertEqual "Catch storage collisions" x y + , + 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); + } + } + |] + Left (_, res) <- runSMTWith z3 $ query $ checkAssert (RuntimeCode c) Nothing (Just ("deposit(uint256)", [AbiUIntType 256])) [] + putStrLn $ "successfully explored: " <> show (length res) <> " paths" + , + testCase "Deposit contract loop (cvc4)" $ 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); + } + } + |] + Left (_, res) <- runSMTWith cvc4 $ query $ checkAssert (RuntimeCode c) Nothing (Just ("deposit(uint256)", [AbiUIntType 256])) [] + putStrLn $ "successfully explored: " <> show (length 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); + } + } + |] + bs <- runSMT $ query $ do + Right vm <- checkAssert (RuntimeCode c) Nothing (Just ("deposit(uint8)", [AbiUIntType 8])) [] + case view (state . calldata . _1) vm of + SymbolicBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs + ConcreteBuffer _ -> error "unexpected" + + let deposit = decodeAbiValue (AbiUIntType 8) (BS.fromStrict (BS.drop 4 bs)) + assertEqual "overflowing uint8" deposit (AbiUInt 8 255) + , + -- This test uses cvc4 instead of z3 + testCase "explore function dispatch" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x) public pure returns (uint) { + return x; + } + } + |] + Left (_, res) <- runSMTWith cvc4 $ query $ checkAssert (RuntimeCode c) Nothing Nothing [] + putStrLn $ "successfully explored: " <> show (length res) <> " paths" + , + + 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); + } + } + |] + Left (_, res) <- runSMTWith cvc4 $ query $ checkAssert (RuntimeCode c) Nothing Nothing [] + putStrLn $ "successfully explored: " <> show (length res) <> " paths" + , + 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); + } + } + |] + Left (_, res) <- runSMTWith cvc4 $ query $ checkAssert (RuntimeCode c) Nothing Nothing [] + putStrLn $ "successfully explored: " <> show (length 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))); + } + } + |] + bs <- runSMTWith z3 $ query $ do + Right vm <- checkAssert (RuntimeCode c) Nothing (Just ("f(uint256,uint256,uint256,uint256)", replicate 4 (AbiUIntType 256))) [] + case view (state . calldata . _1) vm of + SymbolicBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs + ConcreteBuffer _ -> error "unexpected" + + let AbiTuple xywz = decodeAbiValue (AbiTupleType $ Vector.fromList + [AbiUIntType 256, AbiUIntType 256, + AbiUIntType 256, AbiUIntType 256]) (BS.fromStrict (BS.drop 4 bs)) + [AbiUInt 256 x, AbiUInt 256 y, AbiUInt 256 w, AbiUInt 256 z] = Vector.toList xywz + assertEqual "x == w" x w + assertEqual "y == z" y z + , + + testCase "calldata beyond calldatasize is 0 (z3)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f() public pure { + uint y; + assembly { + let x := calldatasize() + y := calldataload(x) + } + assert(y == 0); + } + } + |] + Left (_, res) <- runSMTWith z3 $ query $ checkAssert (RuntimeCode c) Nothing Nothing [] + putStrLn $ "successfully explored: " <> show (length res) <> " paths" + + , + + testCase "keccak soundness" $ do + Just c <- solcRuntime "C" + [i| + contract C { + mapping (uint => mapping (uint => uint)) maps; + + function f(uint x, uint y) public view { + assert(maps[y][0] == maps[x][0]); + } + } + |] + -- should find a counterexample + Right counterexample <- runSMTWith cvc4 $ query $ checkAssert (RuntimeCode c) Nothing Nothing [] + putStrLn $ "found counterexample:" + + + , + 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 + Right cex <- runSMT $ query $ do + vm0 <- abstractVM (Just ("call_A()", [])) [] c SymbolicS + store <- freshArray (show aAddr) Nothing + let vm = vm0 + & set (state . callvalue) 0 + & over (env . contracts) + (Map.insert aAddr (initialContract (RuntimeCode a) & + set EVM.storage (Symbolic store))) + verify vm Nothing Nothing (Just checkAssertions) + putStrLn $ "found counterexample:" + + ] + , testGroup "Equivalence checking" + [ + testCase "yul optimized" $ do + -- These yul programs are not equivalent: (try --calldata $(seth --to-uint256 2) for example) + -- A: B: + -- { { + -- calldatacopy(0, 0, 32) calldatacopy(0, 0, 32) + -- switch mload(0) switch mload(0) + -- case 0 { } case 0 { } + -- case 1 { } case 2 { } + -- default { invalid() } default { invalid() } + -- } } + let aPrgm = hex "602060006000376000805160008114601d5760018114602457fe6029565b8191506029565b600191505b50600160015250" + bPrgm = hex "6020600060003760005160008114601c5760028114602057fe6021565b6021565b5b506001600152" + runSMTWith z3 $ query $ do + Right counterexample <- equivalenceCheck aPrgm bPrgm Nothing Nothing + return () + + ] + ] where (===>) = assertSolidityComputation +runSimpleVM :: ByteString -> ByteString -> Maybe ByteString +runSimpleVM x ins = case loadVM x of + Nothing -> Nothing + Just vm -> let calldata' = (ConcreteBuffer ins, literal . num $ BS.length ins) + in case runState (assign (state.calldata) calldata' >> exec) vm of + (VMSuccess (ConcreteBuffer bs), _) -> Just bs + _ -> Nothing + +loadVM :: ByteString -> Maybe VM +loadVM x = + case runState exec (vmForEthrunCreation x) of + (VMSuccess (ConcreteBuffer targetCode), vm1) -> do + let target = view (state . contract) vm1 + vm2 = execState (replaceCodeOfSelf (RuntimeCode targetCode)) vm1 + return $ snd $ flip runState vm2 + (do resetState + assign (state . gas) 0xffffffffffffffff -- kludge + loadContract target) + _ -> Nothing + hex :: ByteString -> ByteString hex s = case Hex.decode s of @@ -148,6 +550,11 @@ then "memory" else "" +runFunction :: Text -> ByteString -> IO (Maybe ByteString) +runFunction c input = do + Just x <- singleContract "X" c + return $ runSimpleVM x input + runStatements :: Text -> [AbiValue] -> AbiType -> IO (Maybe ByteString) @@ -158,34 +565,15 @@ <> " " <> defaultDataLocation (abiValueType x) <> " " <> Text.pack [c]) (zip args "abcdefg")) - sig = + s = "foo(" <> Text.intercalate "," (map (abiTypeSolidity . abiValueType) args) <> ")" - Just x <- singleContract "X" [i| + runFunction [i| function foo(${params}) public pure returns (${abiTypeSolidity t} x) { ${stmts} } - |] - - case runState exec (vmForEthrunCreation x) of - (VMSuccess targetCode, vm1) -> do - let target = view (state . contract) vm1 - vm2 = execState (replaceCodeOfSelf targetCode) vm1 - case flip runState vm2 - (do resetState - assign (state . gas) 0xffffffffffffffff -- kludge - loadContract target - assign (state . calldata) - (abiCalldata sig (Vector.fromList args)) - exec) of - (VMSuccess out, _) -> - return (Just out) - (VMFailure problem, _) -> do - print problem - return Nothing - _ -> - return Nothing + |] (abiCalldata s (Vector.fromList args)) newtype Bytes = Bytes ByteString deriving Eq @@ -195,6 +583,21 @@ 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]) + ] data Invocation = SolidityCall Text [AbiValue]