hevm (empty) → 0.16
raw patch · 34 files changed
+9035/−0 lines, 34 filesdep +HUnitdep +QuickCheckdep +abstract-parsetup-changed
Dependencies added: HUnit, QuickCheck, abstract-par, aeson, ansi-wl-pprint, async, base, base16-bytestring, base64-bytestring, binary, brick, bytestring, cereal, containers, cryptonite, data-dword, deepseq, directory, fgl, filepath, ghci-pretty, haskeline, here, hevm, lens, lens-aeson, megaparsec, memory, monad-par, mtl, multiset, operational, optparse-generic, process, quickcheck-text, readline, regex-tdfa, restless-git, rosezipper, s-cargot, scientific, tasty, tasty-hunit, tasty-quickcheck, temporary, text, text-format, time, transformers, tree-view, unordered-containers, vector, vty, wreq
Files
- CHANGELOG.md +188/−0
- COPYING +661/−0
- Setup.hs +2/−0
- ethjet/ethjet.c +110/−0
- ethjet/tinykeccak.c +152/−0
- hevm-cli/hevm-cli.hs +372/−0
- hevm.cabal +204/−0
- run-consensus-tests +82/−0
- src/EVM.hs +1679/−0
- src/EVM/ABI.hs +413/−0
- src/EVM/Concrete.hs +252/−0
- src/EVM/Dapp.hs +113/−0
- src/EVM/Debug.hs +145/−0
- src/EVM/Dev.hs +82/−0
- src/EVM/Emacs.hs +485/−0
- src/EVM/Exec.hs +76/−0
- src/EVM/Facts.hs +197/−0
- src/EVM/Facts/Git.hs +51/−0
- src/EVM/FeeSchedule.hs +103/−0
- src/EVM/Fetch.hs +144/−0
- src/EVM/Flatten.hs +212/−0
- src/EVM/Format.hs +280/−0
- src/EVM/Keccak.hs +102/−0
- src/EVM/Op.hs +76/−0
- src/EVM/Precompiled.hs +65/−0
- src/EVM/Solidity.hs +372/−0
- src/EVM/Stepper.hs +122/−0
- src/EVM/StorageLayout.hs +185/−0
- src/EVM/TTY.hs +894/−0
- src/EVM/TTYCenteredList.hs +71/−0
- src/EVM/Types.hs +164/−0
- src/EVM/UnitTest.hs +569/−0
- src/EVM/VMTest.hs +215/−0
- test/test.hs +197/−0
+ CHANGELOG.md view
@@ -0,0 +1,188 @@+# hevm changelog++## 0.16 - 2018-09-19+ - Move ethjet into hevm++## [0.15] - 2018-05-09+ - Fix SDIV/SMOD definitions for extreme case++## [0.14.1] - 2018-04-17+ - Improve PC display in TTY++## [0.14] - 2018-03-08+ - Implement STATICCALL++## [0.13] - 2018-02-28+ - Require specific block number for RPC debugging+ - Implement RETURNDATACOPY and RETURNDATASIZE+ - Fix bug where created contracts didn't get their balance++## [0.12.3] - 2017-12-19+ - More useful RPC debugging because we strip the entire BZZR metadata++## [0.12.2] - 2017-12-17+ - Experimental new ecrecover implementation via libethjet+ - Correct error checking for setUp() invocations++## [0.12.1] - 2017-11-28+ - Test name regex matching via --match+ - Fixed source map parsing bug when used with solc --optimize+ - TTY: fix a padding-related display glitch++## [0.12] - 2017-11-14+ - Use 13 different environment variables to control block parameters+ for unit testing, e.g. block number, timestamp, initial balance, etc.++ Full list:++ - `DAPP_TEST_ADDRESS`+ - `DAPP_TEST_CALLER`+ - `DAPP_TEST_ORIGIN`+ - `DAPP_TEST_GAS_CREATE`+ - `DAPP_TEST_GAS_CALL`+ - `DAPP_TEST_BALANCE_CREATE`+ - `DAPP_TEST_BALANCE_CALL`+ - `DAPP_TEST_COINBASE`+ - `DAPP_TEST_NUMBER`+ - `DAPP_TEST_TIMESTAMP`+ - `DAPP_TEST_GAS_LIMIT`+ - `DAPP_TEST_GAS_PRICE`+ - `DAPP_TEST_DIFFICULTY`++## [0.11.5] - 2017-11-14+ - Use --state with --exec --debug++## [0.11.4] - 2017-11-12+ - Fix bug when unit test contract has creations in constructor++## [0.11.3] - 2017-11-08+ - Fix array support in ABI module++## [0.11.2] - 2017-11-04+ - TTY: show a help bar with key bindings at the bottom++## [0.11.1] - 2017-11-02+ - TTY: fix a display glitch+ - TTY: improve display of ABI hashes on the stack++## [0.11] - 2017-10-31+ - Add "hevm flatten" for Etherscan-ish source code concatenation+ - Simplify code by removing concrete/symbolic machine abstraction++## [0.10.9] - 2017-10-23+ - Fix bugs in ABI formatting++## [0.10.7] - 2017-10-19+ - Fix library linking bug+ - Fix gas consumption of DELEGATECALL+ - Better error tracing+ - Experimental "contract browser" (stupid list of addresses)++## [0.10.6] - 2017-10-19+ - Enable library linking for unit tests and debugger+ - Use the same default gas/balance values as `ethrun`++## [0.10.5] - 2017-10-17+ - Better trace output including arguments and return values+ - Proof of concept coverage analysis via `dapp-test --coverage`++## [0.10] - 2017-10-10+ - Enable new trace output by default for failing tests+ - Exit with failure code from test runner when tests fail+ - More fixes to improve Ethereum test suite compliance++## [0.9.5] - 2017-10-06+ - Prototype of new trace output with `hevm dapp-test --verbose`+ - Nicer trace tree in the TTY debugger+ - Many fixes to improve Ethereum test suite compliance++## [0.9] - 2017-09-29+ - Integrates with live chains via RPC (read-only)+ - Exposes a special contract address with test-related functionality (time warp)++## [0.8.5] - 2017-09-22+ - Renames `hevm` from its maiden name `hsevm` :sparkles:++## [0.8] - 2017-09-21+ - Implements gas metering (Metropolis rules by default)+ - Shows gas counter in the terminal interface+ - Enables debugger for consensus test executions+ - Consensus test runner script with HTML reporting+ - Passes 564 of the `VMTests`; fails 115 (see [0.8 test report])+ - Command line options for specifying initial gas amounts and balances+ - Improved TTY UI layout++## [0.7] - 2017-09-07+ - Can save and load contract states to disk using a Git-backed store (only `--exec`)+ - Can debug raw EVM bytecode using `exec --debug`+ - Fixes `exec --value`+ - Has smarter defaults for command line when running tests or debugging+ - Fixes bug with `MSIZE` in `CALL` context++## [0.6.5] - 2017-09-01+ - Fixes `exec` with regards to exit codes and error messages++## [0.6.1] - 2017-08-03+ - TTY: Adds command `C-n` in TTY for "stepping over"++## [0.6] - 2017-08-03+ - TTY: Adds second line to stack entries with humanized formatting+ - TTY: Gets rid of the separate log pane in favor of a unified trace pane++## [0.5] - 2017-08-02+ - TTY: Adds `p` command for stepping backwards+ - Adds ability to track origins of stack and heap words+ - Tracks Keccak preimage for words that come from the `SHA3` instruction++## [0.4] - 2017-07-31+ - Parallelizes unit test runner+ - Improves speed by changing representation of memory+ - Internal refactoring for future support of symbolic execution+ - Adds logs to the trace pane++## [0.3.2] - 2017-06-17+ - Adds `REVERT` opcode+ - Sets `TIMESTAMP` value to `1` in unit tests++## [0.3.0] - 2017-06-14+ - Reverts contract state after `CALL` fails+ - Improves test runner console output++## [0.2.0] - 2017-06-13+ - Fixes bug in `CALL`++## [0.1.0.1] - 2017-03-31+ - Highlights Solidity exactly on character level+ - Adds `N` command for stepping by Solidity source position instead of by opcode++## 0.1.0.0 - 2017-03-29+ - First release++[0.8 test report]: https://hydra.dapp.tools/build/135/download/1/index.html++[0.12]: https://github.com/dapphub/hevm/compare/0.11.5...0.12+[0.11.5]: https://github.com/dapphub/hevm/compare/0.11.4...0.11.5+[0.11.4]: https://github.com/dapphub/hevm/compare/0.11.3...0.11.4+[0.11.3]: https://github.com/dapphub/hevm/compare/0.11.2...0.11.3+[0.11.2]: https://github.com/dapphub/hevm/compare/0.11.1...0.11.2+[0.11.1]: https://github.com/dapphub/hevm/compare/0.11...0.11.1+[0.11]: https://github.com/dapphub/hevm/compare/0.10.9...0.11+[0.10.9]: https://github.com/dapphub/hevm/compare/0.10.7...0.10.9+[0.10.7]: https://github.com/dapphub/hevm/compare/0.10.6...0.10.7+[0.10.6]: https://github.com/dapphub/hevm/compare/0.10.5...0.10.6+[0.10.5]: https://github.com/dapphub/hevm/compare/0.10...0.10.5+[0.10]: https://github.com/dapphub/hevm/compare/0.9.5...0.10+[0.9.5]: https://github.com/dapphub/hevm/compare/0.9...0.9.5+[0.9]: https://github.com/dapphub/hevm/compare/v0.8.5...v0.9+[0.8.5]: https://github.com/dapphub/hevm/compare/v0.8...v0.8.5+[0.8]: https://github.com/dapphub/hevm/compare/v0.7...v0.8+[0.7]: https://github.com/dapphub/hevm/compare/v0.6.5...v0.7+[0.6.5]: https://github.com/dapphub/hevm/compare/v0.6.1...v0.6.5+[0.6.1]: https://github.com/dapphub/hevm/compare/v0.6...v0.6.1+[0.6]: https://github.com/dapphub/hevm/compare/v0.5...v0.6+[0.5]: https://github.com/dapphub/hevm/compare/v0.4...v0.5+[0.4]: https://github.com/dapphub/hevm/compare/v0.3.2...v0.4+[0.3.2]: https://github.com/dapphub/hevm/compare/v0.3.0...v0.3.2+[0.3.0]: https://github.com/dapphub/hevm/compare/v0.2.0...v0.3.0+[0.2.0]: https://github.com/dapphub/hevm/compare/v0.1.0.1...v0.2.0+[0.1.0.1]: https://github.com/dapphub/hevm/compare/v0.1.0.0...v0.1.0.1
+ COPYING view
@@ -0,0 +1,661 @@+ GNU AFFERO GENERAL PUBLIC LICENSE+ Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU Affero General Public License is a free, copyleft license for+software and other kinds of works, specifically designed to ensure+cooperation with the community in the case of network server software.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+our General Public Licenses are intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ Developers that use our General Public Licenses protect your rights+with two steps: (1) assert copyright on the software, and (2) offer+you this License which gives you legal permission to copy, distribute+and/or modify the software.++ A secondary benefit of defending all users' freedom is that+improvements made in alternate versions of the program, if they+receive widespread use, become available for other developers to+incorporate. Many developers of free software are heartened and+encouraged by the resulting cooperation. However, in the case of+software used on network servers, this result may fail to come about.+The GNU General Public License permits making a modified version and+letting the public access it on a server without ever releasing its+source code to the public.++ The GNU Affero General Public License is designed specifically to+ensure that, in such cases, the modified source code becomes available+to the community. It requires the operator of a network server to+provide the source code of the modified version running there to the+users of that server. Therefore, public use of a modified version, on+a publicly accessible server, gives the public access to the source+code of the modified version.++ An older license, called the Affero General Public License and+published by Affero, was designed to accomplish similar goals. This is+a different license, not a version of the Affero GPL, but Affero has+released a new version of the Affero GPL which permits relicensing under+this license.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU Affero General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Remote Network Interaction; Use with the GNU General Public License.++ Notwithstanding any other provision of this License, if you modify the+Program, your modified version must prominently offer all users+interacting with it remotely through a computer network (if your version+supports such interaction) an opportunity to receive the Corresponding+Source of your version by providing access to the Corresponding Source+from a network server at no charge, through some standard or customary+means of facilitating copying of software. This Corresponding Source+shall include the Corresponding Source for any work covered by version 3+of the GNU General Public License that is incorporated pursuant to the+following paragraph.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the work with which it is combined will remain governed by version+3 of the GNU General Public License.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU Affero General Public License from time to time. Such new versions+will be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU Affero General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU Affero General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU Affero General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU Affero General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU Affero General Public License for more details.++ You should have received a copy of the GNU Affero General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If your software can interact with users remotely through a computer+network, you should also make sure that it provides a way for users to+get its source. For example, if your program is a web application, its+interface could display a "Source" link that leads users to an archive+of the code. There are many ways you could offer source, and different+solutions will be better for different programs; see section 13 for the+specific requirements.++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU AGPL, see+<http://www.gnu.org/licenses/>.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ethjet/ethjet.c view
@@ -0,0 +1,110 @@+#include "ethjet.h"+#include "tinykeccak.h"++#include <secp256k1_recovery.h>++#include <stdlib.h>+#include <stdint.h>+#include <string.h>++struct ethjet_context *+ethjet_init ()+{+ struct ethjet_context *ctx;+ ctx = malloc (sizeof *ctx);+ if (!ctx) return NULL;++ ctx->ec = secp256k1_context_create (SECP256K1_CONTEXT_VERIFY);++ return ctx;+}++void+ethjet_free (struct ethjet_context *ctx)+{+ secp256k1_context_destroy (ctx->ec);+ free (ctx);+}++/* + * The example contract at 0xdeadbeef just reverses its input.+ */+int+ethjet_example (struct ethjet_context *ctx,+ uint8_t *in, size_t in_size,+ uint8_t *out, size_t out_size)+{+ if (out_size != in_size)+ return 0;++ for (int i = 0; i < in_size; i++)+ out[i] = in[in_size - i - 1];++ return 1;+}++int+ethjet_ecrecover (secp256k1_context *ctx,+ uint8_t *in, size_t in_size,+ uint8_t *out, size_t out_size)+{+ /* Input: H V R S, all 32 bytes. */++ secp256k1_pubkey pubkey;+ secp256k1_ecdsa_recoverable_signature rsig;++ uint8_t *input64;+ uint8_t pubkey_hex[65];+ size_t hexlen = 65;++ int recid;++ if (in_size != 128)+ return 0;++ if (out_size != 32)+ return 0;++ input64 = in + 64;+ recid = in[63] - 27;++ if (recid < 0 || recid > 3)+ return 0;++ if (!secp256k1_ecdsa_recoverable_signature_parse_compact+ (ctx, &rsig, input64, recid))+ return 0;++ if (!secp256k1_ecdsa_recover (ctx, &pubkey, &rsig, in))+ return 0;++ if (!secp256k1_ec_pubkey_serialize+ (ctx, pubkey_hex, &hexlen, &pubkey, SECP256K1_EC_UNCOMPRESSED))+ return 0;++ if (sha3_256 (out, 32, pubkey_hex + 1, 64))+ return 0;++ memset (out, 0, 12);++ return 1;+}++int+ethjet (struct ethjet_context *ctx,+ enum ethjet_operation op,+ uint8_t *in, size_t in_size,+ uint8_t *out, size_t out_size)+{+ switch (op) {+ case ETHJET_ECRECOVER:+ return ethjet_ecrecover (ctx->ec, in, in_size, out, out_size);+ break;++ case ETHJET_EXAMPLE:+ return ethjet_example (ctx, in, in_size, out, out_size);++ default:+ return 0;+ }+}
+ ethjet/tinykeccak.c view
@@ -0,0 +1,152 @@+/** libkeccak-tiny+*+* A single-file implementation of SHA-3 and SHAKE.+*+* Implementor: David Leon Gil+* License: CC0, attribution kindly requested. Blame taken too,+* but not liability.+*/++#include "tinykeccak.h"++#include <stdint.h>+#include <stdio.h>+#include <stdlib.h>+#include <string.h>++/******** The Keccak-f[1600] permutation ********/++/*** Constants. ***/+static const uint8_t rho[24] = \+ { 1, 3, 6, 10, 15, 21,+ 28, 36, 45, 55, 2, 14,+ 27, 41, 56, 8, 25, 43,+ 62, 18, 39, 61, 20, 44};+static const uint8_t pi[24] = \+ {10, 7, 11, 17, 18, 3,+ 5, 16, 8, 21, 24, 4,+ 15, 23, 19, 13, 12, 2,+ 20, 14, 22, 9, 6, 1};+static const uint64_t RC[24] = \+ {1ULL, 0x8082ULL, 0x800000000000808aULL, 0x8000000080008000ULL,+ 0x808bULL, 0x80000001ULL, 0x8000000080008081ULL, 0x8000000000008009ULL,+ 0x8aULL, 0x88ULL, 0x80008009ULL, 0x8000000aULL,+ 0x8000808bULL, 0x800000000000008bULL, 0x8000000000008089ULL, 0x8000000000008003ULL,+ 0x8000000000008002ULL, 0x8000000000000080ULL, 0x800aULL, 0x800000008000000aULL,+ 0x8000000080008081ULL, 0x8000000000008080ULL, 0x80000001ULL, 0x8000000080008008ULL};++/*** Helper macros to unroll the permutation. ***/+#define rol(x, s) (((x) << s) | ((x) >> (64 - s)))+#define REPEAT6(e) e e e e e e+#define REPEAT24(e) REPEAT6(e e e e)+#define REPEAT5(e) e e e e e+#define FOR5(v, s, e) \+ v = 0; \+ REPEAT5(e; v += s;)++/*** Keccak-f[1600] ***/+static inline void keccakf(void* state) {+ uint64_t* a = (uint64_t*)state;+ uint64_t b[5] = {0};+ uint64_t t = 0;+ uint8_t x, y;++ for (int i = 0; i < 24; i++) {+ // Theta+ FOR5(x, 1,+ b[x] = 0;+ FOR5(y, 5,+ b[x] ^= a[x + y]; ))+ FOR5(x, 1,+ FOR5(y, 5,+ a[y + x] ^= b[(x + 4) % 5] ^ rol(b[(x + 1) % 5], 1); ))+ // Rho and pi+ t = a[1];+ x = 0;+ REPEAT24(b[0] = a[pi[x]];+ a[pi[x]] = rol(t, rho[x]);+ t = b[0];+ x++; )+ // Chi+ FOR5(y,+ 5,+ FOR5(x, 1,+ b[x] = a[y + x];)+ FOR5(x, 1,+ a[y + x] = b[x] ^ ((~b[(x + 1) % 5]) & b[(x + 2) % 5]); ))+ // Iota+ a[0] ^= RC[i];+ }+}++/******** The FIPS202-defined functions. ********/++/*** Some helper macros. ***/++#define _(S) do { S } while (0)+#define FOR(i, ST, L, S) \+ _(for (size_t i = 0; i < L; i += ST) { S; })+#define mkapply_ds(NAME, S) \+ static inline void NAME(uint8_t* dst, \+ const uint8_t* src, \+ size_t len) { \+ FOR(i, 1, len, S); \+ }+#define mkapply_sd(NAME, S) \+ static inline void NAME(const uint8_t* src, \+ uint8_t* dst, \+ size_t len) { \+ FOR(i, 1, len, S); \+ }++mkapply_ds(xorin, dst[i] ^= src[i]) // xorin+mkapply_sd(setout, dst[i] = src[i]) // setout++#define P keccakf+#define Plen 200++// Fold P*F over the full blocks of an input.+#define foldP(I, L, F) \+ while (L >= rate) { \+ F(a, I, rate); \+ P(a); \+ I += rate; \+ L -= rate; \+ }++/** The sponge-based hash construction. **/+static inline int hash(uint8_t* out, size_t outlen,+ const uint8_t* in, size_t inlen,+ size_t rate, uint8_t delim) {+ if ((out == NULL) || ((in == NULL) && inlen != 0) || (rate >= Plen)) {+ return -1;+ }+ uint8_t a[Plen] = {0};+ // Absorb input.+ foldP(in, inlen, xorin);+ // Xor in the DS and pad frame.+ a[inlen] ^= delim;+ a[rate - 1] ^= 0x80;+ // Xor in the last block.+ xorin(a, in, inlen);+ // Apply P+ P(a);+ // Squeeze output.+ foldP(out, outlen, setout);+ setout(a, out, outlen);+ memset(a, 0, 200);+ return 0;+}++#define defsha3(bits) \+ int sha3_##bits(uint8_t* out, size_t outlen, \+ const uint8_t* in, size_t inlen) { \+ if (outlen > (bits/8)) { \+ return -1; \+ } \+ return hash(out, outlen, in, inlen, 200 - (bits / 4), 0x01); \+ }++/*** FIPS202 SHA3 FOFs ***/+defsha3(256)+defsha3(512)
+ hevm-cli/hevm-cli.hs view
@@ -0,0 +1,372 @@+-- Main file of the hevm CLI program++{-# Language BangPatterns #-}+{-# Language CPP #-}+{-# Language DeriveGeneric #-}+{-# Language GeneralizedNewtypeDeriving #-}+{-# Language LambdaCase #-}+{-# Language NumDecimals #-}+{-# Language OverloadedStrings #-}+{-# Language TemplateHaskell #-}++import EVM.Concrete (w256)++import qualified EVM as EVM+import qualified EVM.Concrete as EVM+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++#if MIN_VERSION_aeson(1, 0, 0)+import qualified EVM.VMTest as VMTest+#endif++import EVM.Debug+import EVM.Exec+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 qualified Paths_hevm as Paths++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 Data.ByteString (ByteString)+import Data.List (intercalate, isSuffixOf)+import Data.Text (Text, unpack, pack)+import Data.Maybe (fromMaybe)+import System.Directory (withCurrentDirectory, listDirectory)+import System.Exit (die, exitFailure)+import System.IO (hFlush, stdout)+import System.Process (callProcess)+import System.Timeout (timeout)++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 Text.Regex.TDFA as Regex+import qualified Data.Sequence as Seq++-- 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+ }+ | DappTest+ { jsonFile :: Maybe String+ , dappRoot :: Maybe String+ , debug :: Bool+ , rpc :: Maybe URL+ , verbose :: Bool+ , coverage :: Bool+ , state :: Maybe String+ , match :: Maybe String+ }+ | Interactive+ { jsonFile :: Maybe String+ , dappRoot :: Maybe String+ , rpc :: Maybe URL+ , state :: Maybe String+ }+ | VmTest+ { file :: String+ , test :: [String]+ , debug :: Bool+ }+ | VmTestReport+ { tests :: String+ }+ | Flatten+ { sourceFile :: String+ , jsonFile :: Maybe String+ , dappRoot :: Maybe String+ }+ | Emacs+ deriving (Show, Options.Generic, Eq)++type URL = Text++instance Options.ParseRecord Command where+ parseRecord =+ Options.parseRecordWithModifiers Options.lispCaseModifiers++optsMode :: Command -> Mode+optsMode x = if debug x then Debug else Run++unitTestOptions :: Command -> IO UnitTestOptions+unitTestOptions cmd = do+ vmModifier <-+ case state cmd of+ Nothing ->+ pure id+ Just repoPath -> do+ facts <- Git.loadFacts (Git.RepoAt repoPath)+ pure (flip Facts.apply facts)++ params <- getParametersFromEnvironmentVariables++ pure EVM.UnitTest.UnitTestOptions+ { EVM.UnitTest.oracle =+ case rpc cmd of+ Just url -> EVM.Fetch.http (EVM.Fetch.BlockNumber (testNumber params)) url+ Nothing -> EVM.Fetch.zero+ , EVM.UnitTest.verbose = verbose cmd+ , EVM.UnitTest.match = pack $ fromMaybe "^test" (match cmd)+ , EVM.UnitTest.vmModifier = vmModifier+ , EVM.UnitTest.testParams = params+ }++main :: IO ()+main = do+ cmd <- Options.getRecord "hevm -- Ethereum evaluator"+ let+ root = fromMaybe "." (dappRoot cmd)+ case cmd of+ Exec {} ->+ launchExec cmd+ VmTest {} ->+ launchVMTest cmd+ DappTest {} ->+ withCurrentDirectory root $ do+ testFile <- findJsonFile (jsonFile cmd)+ testOpts <- unitTestOptions cmd+ case coverage cmd of+ False ->+ dappTest testOpts (optsMode cmd) testFile+ True ->+ dappCoverage testOpts (optsMode cmd) testFile+ Interactive {} ->+ withCurrentDirectory root $ do+ testFile <- findJsonFile (jsonFile cmd)+ testOpts <- unitTestOptions cmd+ EVM.TTY.main testOpts root testFile+ VmTestReport {} ->+ withCurrentDirectory (tests cmd) $ do+ dataDir <- Paths.getDataDir+ callProcess "bash" [dataDir ++ "/run-consensus-tests", "."]+ Flatten {} ->+ withCurrentDirectory root $ do+ theJson <- findJsonFile (jsonFile cmd)+ readSolc theJson >>=+ \case+ Just (contractMap, cache) -> do+ let dapp = dappInfo "." contractMap cache+ EVM.Flatten.flatten dapp (pack (sourceFile cmd))+ Nothing ->+ error ("Failed to read Solidity JSON for `" ++ theJson ++ "'")+ Emacs ->+ EVM.Emacs.main++findJsonFile :: Maybe String -> IO String+findJsonFile (Just s) = pure s+findJsonFile Nothing = do+ outFiles <- listDirectory "out"+ case filter (isSuffixOf ".sol.json") outFiles of+ [x] -> pure ("out/" ++ x)+ [] ->+ error $ concat+ [ "No `*.sol.json' file found in `./out'.\n"+ , "Maybe you need to run `dapp build'.\n"+ , "You can specify a file with `--json-file'."+ ]+ xs ->+ error $ concat+ [ "Multiple `*.sol.json' files found in `./out'.\n"+ , "Specify one using `--json-file'.\n"+ , "Files found: "+ , intercalate ", " xs+ ]++dappTest :: UnitTestOptions -> Mode -> String -> IO ()+dappTest opts _ solcFile = do+ readSolc solcFile >>=+ \case+ Just (contractMap, cache) -> do+ let matcher = regexMatches (EVM.UnitTest.match opts)+ let unitTests = (findUnitTests matcher) (Map.elems contractMap)+ results <- mapM (runUnitTestContract opts contractMap cache) unitTests+ when (any (== False) results) exitFailure+ Nothing ->+ error ("Failed to read Solidity JSON for `" ++ solcFile ++ "'")++regexMatches :: Text -> Text -> Bool+regexMatches regexSource =+ let+ compOpts =+ Regex.defaultCompOpt { Regex.lastStarGreedy = True }+ execOpts =+ Regex.defaultExecOpt { Regex.captureGroups = False }+ regex = Regex.makeRegexOpts compOpts execOpts (unpack regexSource)+ in+ Regex.matchTest regex . Seq.fromList . unpack++dappCoverage :: UnitTestOptions -> Mode -> String -> IO ()+dappCoverage opts _ solcFile = do+ readSolc solcFile >>=+ \case+ Just (contractMap, cache) -> do+ let matcher = regexMatches (EVM.UnitTest.match opts)+ let unitTests = (findUnitTests matcher) (Map.elems contractMap)+ covs <- mconcat <$> mapM (coverageForUnitTestContract opts contractMap cache) unitTests++ let+ dapp = dappInfo "." contractMap cache+ f (k, vs) = do+ putStr "***** hevm coverage for "+ putStrLn (unpack k)+ putStrLn ""+ forM_ vs $ \(n, bs) -> do+ case ByteString.find (\x -> x /= 0x9 && x /= 0x20 && x /= 0x7d) bs of+ Nothing -> putStr "..... "+ Just _ ->+ case n of+ -1 -> putStr ";;;;; "+ 0 -> putStr "##### "+ _ -> putStr " "+ Char8.putStrLn bs+ putStrLn ""++ mapM_ f (Map.toList (coverageReport dapp covs))+ Nothing ->+ error ("Failed to read Solidity JSON for `" ++ solcFile ++ "'")++launchExec :: Command -> IO ()+launchExec cmd = do+ let vm = vmFromCommand cmd+ vm1 <- case state cmd of+ Nothing -> pure vm+ Just path ->+ -- Note: this will load the code, so if you've specified a state+ -- repository, then you effectively can't change `--code' after+ -- the first run.+ 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+ Nothing ->+ error "internal error; no EVM result"+ Just (EVM.VMFailure e) -> do+ die (show e)+ Just (EVM.VMSuccess (EVM.B x)) -> do+ let hex = BS16.encode x+ if ByteString.null hex then pure ()+ else do+ ByteString.putStr hex+ putStrLn ""+ case state cmd of+ Nothing -> pure ()+ Just path ->+ Git.saveFacts (Git.RepoAt path) (Facts.vmFacts vm')+ Debug ->+ void (EVM.TTY.runFromVM vm1)++vmFromCommand :: Command -> EVM.VM+vmFromCommand cmd =+ vm1 & EVM.env . EVM.contracts . ix address' . EVM.balance +~ (w256 value')+ 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+ }+ word f def = maybe def id (f cmd)+ addr f def = maybe def id (f cmd)++launchVMTest :: Command -> IO ()+launchVMTest cmd =+#if MIN_VERSION_aeson(1, 0, 0)+ VMTest.parseSuite <$> LazyByteString.readFile (file cmd) >>=+ \case+ Left err -> print err+ Right allTests ->+ let testFilter =+ if null (test cmd)+ then id+ else filter (\(x, _) -> elem x (test cmd))+ in+ mapM_ (runVMTest (optsMode 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++ putStr (name ++ " ")+ hFlush stdout+ result <- do+ action <- async $+ case mode of+ Run ->+ timeout (1e6) . evaluate $ do+ execState (VMTest.interpret m) vm0+ Debug ->+ Just <$> EVM.TTY.runFromVM vm0+ waitCatch action+ case result of+ Right (Just vm1) -> do+ ok <- VMTest.checkExpectation x vm1+ putStrLn (if ok then "ok" else "")+ return ok+ Right Nothing -> do+ putStrLn "timeout"+ return False+ Left _ -> do+ putStrLn "error"+ return False++#endif
+ hevm.cabal view
@@ -0,0 +1,204 @@+name:+ hevm+version:+ 0.16+synopsis:+ Ethereum virtual machine evaluator+description:+ Hevm implements the Ethereum virtual machine semantics.+ .+ It can be used as a library, and it also comes with an executable+ that can run unit test suites, optionally with a visual TTY debugger.+homepage:+ https://github.com/dapphub/dapptools+license:+ AGPL-3+license-file:+ COPYING+author:+ Mikael Brockman+maintainer:+ mikael@brockman.se+category:+ Ethereum+build-type:+ Simple+cabal-version:+ >=1.10+data-files:+ run-consensus-tests+extra-source-files:+ CHANGELOG.md++library+ exposed-modules:+ EVM,+ EVM.ABI,+ EVM.Concrete,+ EVM.Dapp,+ EVM.Dev,+ EVM.Debug,+ EVM.Emacs,+ EVM.Exec,+ EVM.Facts,+ EVM.Facts.Git,+ EVM.Flatten,+ EVM.Format,+ EVM.Fetch,+ EVM.FeeSchedule,+ EVM.Op,+ EVM.Precompiled,+ EVM.Keccak,+ EVM.Solidity,+ EVM.Stepper,+ EVM.StorageLayout,+ EVM.TTY,+ EVM.TTYCenteredList,+ EVM.Types,+ EVM.UnitTest,+ EVM.VMTest,+ Paths_hevm+ ghc-options:+ -Wall -Wno-deprecations+ extra-libraries:+ secp256k1+ c-sources:+ ethjet/ethjet.c, ethjet/tinykeccak.c+ 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.6,+ rosezipper >= 0.2,+ scientific >= 0.3,+ s-cargot >= 0.1,+ temporary >= 1.2,+ text >= 1.2,+ text-format >= 0.3,+ tree-view == 0.5,+ unordered-containers >= 0.2,+ vector >= 0.11,+ vty >= 5.15,+ wreq >= 0.5+ hs-source-dirs:+ src+ default-language:+ Haskell2010+ default-extensions:+ BangPatterns,+ DeriveDataTypeable,+ DeriveGeneric,+ FlexibleContexts,+ GeneralizedNewtypeDeriving,+ LambdaCase,+ OverloadedStrings,+ Rank2Types,+ RecordWildCards,+ TypeFamilies,+ ViewPatterns++executable hevm+ default-language:+ Haskell2010+ hs-source-dirs:+ hevm-cli+ main-is:+ hevm-cli.hs+ ghc-options:+ -Wall -threaded -with-rtsopts=-N+ 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,+ 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++test-suite test+ default-language:+ Haskell2010+ ghc-options:+ -Wall+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ test+ main-is:+ test.hs+ extra-libraries:+ secp256k1+ build-depends:+ HUnit >= 1.6,+ QuickCheck >= 2.9,+ base >= 4.9 && < 5,+ base16-bytestring >= 0.1,+ ghci-pretty >= 0.0.2,+ hevm,+ 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
+ run-consensus-tests view
@@ -0,0 +1,82 @@+#!/usr/bin/env bash+set -e++if [[ $# != 1 ]]; then+ echo >&2 "usage: $(basename "$0") <tests-dir>"+ 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="<tr><td class=testcase>$testcase<td>$outcome<td class=category>$category"+ row+=$'\n'+ case $outcome in+ ok) passed+=$row ;;+ *) failed+=$row ;;+ esac+ done+ + cat <<.+<!doctype html>+<title>hevm test results</title>+<style>+* {+ font-family:+ "latin modern mono", "fantasque sans mono",+ inconsolata, menlo, monospace;+ font-size: 22px;+ line-height: 26px;+}++body { margin: 2rem; }+header { text-align: center; margin: 4rem 0; }+table { border-collapse: collapse; width: 100%; }+tr:nth-child(even) { background: rgba(0, 0, 0, 0.05); }+td:not(:first-child):not(:last-child) { padding: 0 1rem; }+.category { opacity: 0.6; text-align: right }+a { color: darkblue; text-decoration: none; }+h1, h2 { text-align: center; margin-top: 2rem }+.testcase { font-weight: bold }+#failed .testcase { color: rgb(200, 0, 0) }+#passed .testcase { color: rgb(0, 150, 0) }+</style>+<header>+<h1>hevm consensus test report</h1>+<p>+$(date +%Y-%m-%d)+<p>+.++ wc -l <<<"$passed"+ echo "passed, "+ wc -l <<<"$failed"+ echo "failed"+ + cat <<.+<p>+(Test suite: <span class=VMTests</span>VMTests</span> for Homestead)+</header>+<h2>Failed tests</h2>+<table id=failed>+<tbody>+.+ echo "$failed"+ cat <<.+</table>+<h2>Passed tests</h2>+<table id=passed>+<tbody>+.+ echo "$passed"+ cat <<.+</table>+.+}
+ src/EVM.hs view
@@ -0,0 +1,1679 @@+{-# 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.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+ | 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 Blob -- ^ 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 Blob 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 _ ->+ (("<EVM.Query: fetch contract " ++ show addr ++ ">") ++)+ PleaseFetchSlot addr slot _ ->+ (("<EVM.Query: fetch slot "+ ++ show slot ++ " for "+ ++ show addr ++ ">") ++)++-- | 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 Blob [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 :: Blob+ , 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 :: Memory+ , _memorySize :: Int+ , _calldata :: Blob+ , _callvalue :: Word+ , _caller :: Addr+ , _gas :: Word+ , _returndata :: Blob+ , _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 Blob+ , _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 Monoid Cache where+ mempty = Cache { _fetched = mempty }+ mappend a b = Cache+ { _fetched = mappend (view fetched a) (view fetched b)+ }++-- * 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 = B $ 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 =+ case vm ^. frames of+ [] ->+ assign result (Just (VMSuccess ""))+ (nextFrame : remainingFrames) -> do+ popTrace+ assign frames remainingFrames+ assign state (view frameState nextFrame)+ case view frameContext nextFrame of+ CreationContext _ -> do+ -- Move back the gas to the parent context+ assign (state . gas) (the state gas)++ CallContext _ _ _ _ _ _ -> do+ -- Take back the remaining gas allowance+ modifying (state . gas) (+ the state gas)+ modifying burned (subtract (the state gas))+ push 1++ if the state pc >= num (BS.length (the state code))+ then+ case view frames vm of+ (nextFrame : remainingFrames) -> do+ assign frames remainingFrames+ assign state (view frameState nextFrame)+ push 1+ [] ->+ assign result (Just (VMSuccess (blob "")))++ 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 (blob (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 (blob (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 (forceConcreteWord (view nonce this))+ case view execMode vm of+ ExecuteAsVMTest -> do+ assign (state . stack) (num newAddr : xs)+ next++ ExecuteNormally -> do+ let+ newCode =+ forceConcreteBlob $ 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+ _ ->+ 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+ case vm ^. frames of+ [] ->+ assign result (Just (VMSuccess (readMemory (num xOffset) (num xSize) vm)))++ (nextFrame : remainingFrames) -> do+ assign frames remainingFrames++ case view frameContext nextFrame of+ CreationContext _ -> do+ replaceCodeOfSelf (forceConcreteBlob (readMemory (num xOffset) (num xSize) vm))+ assign state (view frameState nextFrame)++ -- Move back the gas to the parent context+ assign (state . gas) (the state gas)++ push (num (the state contract))+ popTrace++ ctx@(CallContext yOffset ySize _ _ _ _) -> do+ let output = readMemory (num xOffset) (num xSize) vm+ assign state (view frameState nextFrame)++ -- Take back the remaining gas allowance+ modifying (state . gas) (+ the state gas)+ modifying burned (subtract (the state gas))++ assign (state . returndata) output+ copyBytesToMemory+ output+ (num ySize)+ 0+ (num yOffset)+ push 1++ insertTrace (ReturnTrace output ctx)+ popTrace++ _ -> 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 ->+ vmError Revert++ xxx ->+ vmError (UnrecognizedOpcode xxx)++precompiledContract :: (?op :: Word8) => EVM ()+precompiledContract = do+ vm <- get+ fees <- use (block . schedule)++ use (state . stack) >>= \case+ (_:(num -> op):_:inOffset:inSize:outOffset:outSize:xs) ->+ let+ input = forceConcreteBlob (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 (blob output) outSize 0 outOffset)+ next+ _ ->+ underrun++-- * 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 current contract's code, like when CREATE returns+-- from the constructor code.+replaceCodeOfSelf :: ByteString -> EVM ()+replaceCodeOfSelf createdCode = do+ self <- use (state . contract)+ zoom (env . contracts . at self) $ do+ if BS.null createdCode+ then put Nothing+ else do+ Just now <- get+ put . Just $+ initialContract createdCode+ & set storage (view storage now)+ & set balance (view balance now)++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.+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 (forceConcreteWord (readMemoryWord32 inOffset mem))+ input =+ forceConcreteBlob (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 (blob 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 = forceConcreteWord+ (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++vmError :: Error -> EVM ()+vmError e = do+ vm <- get+ case view frames vm of+ [] -> assign result (Just (VMFailure e))++ (nextFrame : remainingFrames) -> do++ insertTrace (ErrorTrace e)+ popTrace++ case view frameContext nextFrame of+ CreationContext _ -> do+ assign frames remainingFrames+ assign state (view frameState nextFrame)+ assign (state . gas) 0+ push 0+ let self = vm ^. state . contract+ assign (env . contracts . at self) Nothing++ CallContext _ _ _ _ _ reversion -> do+ assign frames remainingFrames+ assign state (view frameState nextFrame)+ assign (env . contracts) reversion+ push 0+++-- * 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+ :: Blob -> 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 -> Blob+readMemory offset size vm = sliceMemory offset size (view (state . memory) vm)++word256At+ :: Functor f+ => Word -> (Word -> f Word)+ -> Memory -> f Memory+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+ 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++-- * Arithmetic++ceilDiv :: (Num a, Integral a) => a -> a -> a+ceilDiv m n = div (m + n - 1) n++allButOne64th :: (Num a, Integral a) => a -> a+allButOne64th n = n - div n 64++log2 :: FiniteBits b => b -> Int+log2 x = finiteBitSize x - 1 - countLeadingZeros x+++-- * Emacs setup++-- Local Variables:+-- outline-regexp: "-- \\*+\\|data \\|newtype \\|type \\| +-- op: "+-- outline-heading-alist:+-- (("-- *" . 1) ("data " . 2) ("newtype " . 2) ("type " . 2))+-- compile-command: "make"+-- End:
+ src/EVM/ABI.hs view
@@ -0,0 +1,413 @@+{-++ The ABI encoding is mostly straightforward.++ Definition: an int-like value is an uint, int, boolean, or address.++ Basic encoding:++ * Int-likes and length prefixes are big-endian.+ * All values are right-0-padded to multiples of 256 bits.+ - Bytestrings are padded as a whole; e.g., bytes[33] takes 64 bytes.+ * Dynamic-length sequences are prefixed with their length.++ Sequences are encoded as a head followed by a tail, thus:++ * the tail is the concatenation of encodings of non-int-like items.+ * the head has 256 bits per sequence item, thus:+ - int-likes are stored directly;+ - non-int-likes are stored as byte offsets into the tail,+ starting from the beginning of the head.++ Nested sequences are encoded recursively with no special treatment.++ Calldata args are encoded as heterogenous sequences sans length prefix.++-}++{-# Language DeriveAnyClass #-}+{-# Language StrictData #-}+{-# Language TemplateHaskell #-}++module EVM.ABI+ ( AbiValue (..)+ , AbiType (..)+ , Event (..)+ , Anonymity (..)+ , Indexed (..)+ , putAbi+ , getAbi+ , getAbiSeq+ , abiValueType+ , abiTypeSolidity+ , abiCalldata+ , encodeAbiValue+ , parseTypeName+ ) where++import EVM.Keccak (abiKeccak)+import EVM.Types ()++import Control.Monad (replicateM, replicateM_, forM_, void)+import Data.Binary.Get (Get, 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.Monoid ((<>))+import Data.Text (Text, pack)+import Data.Text.Encoding (encodeUtf8)+import Data.Vector (Vector)+import Data.Word (Word32, Word8)+import GHC.Generics++import Test.QuickCheck hiding ((.&.), label)++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 Text.Megaparsec as P+import qualified Text.Megaparsec.Char as P++data AbiValue+ = AbiUInt Int Word256+ | AbiInt Int Int256+ | AbiAddress Word160+ | 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)++data AbiType+ = AbiUIntType Int+ | AbiIntType Int+ | AbiAddressType+ | AbiBoolType+ | AbiBytesType Int+ | AbiBytesDynamicType+ | AbiStringType+ | AbiArrayDynamicType AbiType+ | AbiArrayType Int AbiType+ deriving (Show, Read, Eq, Ord, Generic)++data AbiKind = Dynamic | Static+ deriving (Show, Read, Eq, Ord, Generic)++data Anonymity = Anonymous | NotAnonymous+ deriving (Show, Ord, Eq, Generic)+data Indexed = Indexed | NotIndexed+ deriving (Show, Ord, Eq, Generic)+data Event = Event Text Anonymity [(AbiType, Indexed)]+ deriving (Show, Ord, Eq, Generic)++abiKind :: AbiType -> AbiKind+abiKind = \case+ AbiBytesDynamicType -> Dynamic+ AbiStringType -> Dynamic+ AbiArrayDynamicType _ -> Dynamic+ AbiArrayType _ t -> abiKind t+ _ -> Static++abiValueType :: AbiValue -> AbiType+abiValueType = \case+ AbiUInt n _ -> AbiUIntType n+ AbiInt n _ -> AbiIntType n+ AbiAddress _ -> AbiAddressType+ AbiBool _ -> AbiBoolType+ AbiBytes n _ -> AbiBytesType n+ AbiBytesDynamic _ -> AbiBytesDynamicType+ AbiString _ -> AbiStringType+ AbiArrayDynamic t _ -> AbiArrayDynamicType t+ AbiArray n t _ -> AbiArrayType n t++abiTypeSolidity :: AbiType -> Text+abiTypeSolidity = \case+ AbiUIntType n -> "uint" <> pack (show n)+ AbiIntType n -> "int" <> pack (show n)+ AbiAddressType -> "address"+ AbiBoolType -> "bool"+ AbiBytesType n -> "bytes" <> pack (show n)+ AbiBytesDynamicType -> "bytes"+ AbiStringType -> "string"+ AbiArrayDynamicType t -> abiTypeSolidity t <> "[]"+ AbiArrayType n t -> abiTypeSolidity t <> "[" <> pack (show n) <> "]"++getAbi :: AbiType -> Get AbiValue+getAbi t = label (Text.unpack (abiTypeSolidity t)) $+ case t of+ AbiUIntType n -> do+ let word32Count = 8 * div (n + 255) 256+ xs <- replicateM word32Count getWord32be+ pure (AbiUInt n (pack32 word32Count xs))++ AbiIntType n -> asUInt n (AbiInt n)+ AbiAddressType -> asUInt 256 AbiAddress+ AbiBoolType -> asUInt 256 (AbiBool . (== (1 :: Int)))++ AbiBytesType n ->+ AbiBytes n <$> getBytesWith256BitPadding n++ AbiBytesDynamicType ->+ AbiBytesDynamic <$>+ (label "bytes length prefix" getWord256+ >>= label "bytes data" . getBytesWith256BitPadding)++ AbiStringType -> do+ AbiBytesDynamic x <- getAbi AbiBytesDynamicType+ pure (AbiString x)++ AbiArrayType n t' ->+ AbiArray n t' <$> getAbiSeq n (repeat t')++ AbiArrayDynamicType t' -> do+ AbiUInt _ n <- label "array length" (getAbi (AbiUIntType 256))+ AbiArrayDynamic t' <$>+ label "array body" (getAbiSeq (fromIntegral n) (repeat t'))++putAbi :: AbiValue -> Put+putAbi = \case+ AbiUInt n x -> do+ let word32Count = div (roundTo256Bits n) 4+ forM_ (reverse [0 .. word32Count - 1]) $ \i ->+ putWord32be (fromIntegral (shiftR x (i * 32) .&. 0xffffffff))++ AbiInt n x -> putAbi (AbiUInt n (fromIntegral x))+ AbiAddress x -> putAbi (AbiUInt 160 (fromIntegral x))+ AbiBool x -> putAbi (AbiUInt 8 (if x then 1 else 0))++ AbiBytes n xs -> do+ forM_ [0 .. n-1] (putWord8 . BS.index xs)+ replicateM_ (roundTo256Bits n - n) (putWord8 0)++ AbiBytesDynamic xs -> do+ let n = BS.length xs+ putAbi (AbiUInt 256 (fromIntegral n))+ putAbi (AbiBytes n xs)++ AbiString s ->+ putAbi (AbiBytesDynamic s)++ AbiArray _ _ xs ->+ putAbiSeq xs++ AbiArrayDynamic _ xs -> do+ putAbi (AbiUInt 256 (fromIntegral (Vector.length xs)))+ putAbiSeq xs++getAbiSeq :: Int -> [AbiType] -> Get (Vector AbiValue)+getAbiSeq n ts = label "sequence" $ do+ hs <- label "sequence head" (getAbiHead n ts)+ Vector.fromList <$>+ label "sequence tail" (mapM (either getAbi pure) hs)++getAbiHead :: Int -> [AbiType]+ -> Get [Either AbiType AbiValue]+getAbiHead 0 _ = pure []+getAbiHead _ [] = fail "ran out of types"+getAbiHead n (t:ts) = do+ case abiKind t of+ Dynamic ->+ (Left t :) <$> (skip 32 *> getAbiHead (n - 1) ts)+ Static ->+ do x <- getAbi t+ xs <- getAbiHead (n - 1) ts+ pure (Right x : xs)++putAbiTail :: AbiValue -> Put+putAbiTail x =+ case abiKind (abiValueType x) of+ Static -> pure ()+ Dynamic -> putAbi x++abiValueSize :: AbiValue -> Int+abiValueSize x =+ case x of+ AbiUInt n _ -> roundTo256Bits n+ AbiInt n _ -> roundTo256Bits n+ AbiBytes n _ -> roundTo256Bits 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)+ AbiArrayDynamic _ xs -> 32 + Vector.sum (Vector.map abiHeadSize xs) ++ Vector.sum (Vector.map abiTailSize xs)+ AbiString s -> 32 + roundTo256Bits (BS.length s)++abiTailSize :: AbiValue -> Int+abiTailSize x =+ case abiKind (abiValueType x) of+ Static -> 0+ Dynamic ->+ case x of+ AbiString s -> 32 + roundTo256Bits (BS.length s)+ AbiBytesDynamic s -> 32 + roundTo256Bits (BS.length s)+ AbiArrayDynamic _ xs -> 32 + Vector.sum (Vector.map abiValueSize xs)+ AbiArray _ _ xs -> Vector.sum (Vector.map abiValueSize xs)+ _ -> error "impossible"++abiHeadSize :: AbiValue -> Int+abiHeadSize x =+ case abiKind (abiValueType x) of+ Dynamic -> 32+ Static ->+ case x of+ AbiUInt n _ -> roundTo256Bits n+ AbiInt n _ -> roundTo256Bits n+ AbiBytes n _ -> roundTo256Bits n+ AbiAddress _ -> 32+ AbiBool _ -> 32+ AbiArray _ _ xs -> Vector.sum (Vector.map abiHeadSize xs) ++ Vector.sum (Vector.map abiTailSize xs)+ AbiBytesDynamic _ -> 32+ AbiArrayDynamic _ _ -> 32+ AbiString _ -> 32++putAbiSeq :: Vector AbiValue -> Put+putAbiSeq xs =+ do snd $ Vector.foldl' f (headSize, pure ()) (Vector.zip xs tailSizes)+ Vector.sequence_ (Vector.map putAbiTail xs)+ where+ headSize = Vector.sum $ Vector.map abiHeadSize xs+ tailSizes = Vector.map abiTailSize xs+ f (i, m) (x, j) =+ case abiKind (abiValueType x) of+ Static -> (i, m >> putAbi x)+ Dynamic -> (i + j, m >> putAbi (AbiUInt 256 (fromIntegral i)))++encodeAbiValue :: AbiValue -> BS.ByteString+encodeAbiValue = BSLazy.toStrict . runPut . putAbi++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++typeWithArraySuffix :: P.Parsec () Text AbiType+typeWithArraySuffix = do+ base <- basicType+ sizes <-+ P.many $+ P.between+ (P.char '[') (P.char ']')+ (P.many P.digitChar)++ let+ parseSize :: AbiType -> [Char] -> AbiType+ parseSize t "" = AbiArrayDynamicType t+ parseSize t s = AbiArrayType (read s) t++ pure (foldl parseSize base sizes)++basicType :: P.Parsec () Text AbiType+basicType =+ P.choice+ [ P.string "address" *> pure AbiAddressType+ , P.string "bool" *> pure AbiBoolType+ , P.string "string" *> pure AbiStringType++ , sizedType "uint" AbiUIntType+ , sizedType "int" AbiIntType+ , sizedType "bytes" AbiBytesType++ , P.string "bytes" *> pure AbiBytesDynamicType+ ]++ where+ sizedType :: Text -> (Int -> AbiType) -> P.Parsec () Text AbiType+ sizedType s f = P.try $ do+ void (P.string s)+ fmap (f . read) (P.some P.digitChar)++pack32 :: Int -> [Word32] -> Word256+pack32 n xs =+ 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++getBytesWith256BitPadding :: Integral a => a -> Get ByteString+getBytesWith256BitPadding i =+ (BS.pack <$> replicateM n getWord8)+ <* skip ((roundTo256Bits n) - n)+ where n = fromIntegral i++-- QuickCheck instances++genAbiValue :: AbiType -> Gen AbiValue+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)+ AbiAddressType ->+ (\(AbiUInt _ x) -> AbiAddress (fromIntegral x)) <$> genUInt 20+ AbiBoolType ->+ elements [AbiBool False, AbiBool True]+ AbiBytesType n ->+ do xs <- replicateM n arbitrary+ pure (AbiBytes n (BS.pack xs))+ AbiBytesDynamicType ->+ AbiBytesDynamic . BS.pack <$> listOf arbitrary+ AbiStringType ->+ AbiString . BS.pack <$> listOf arbitrary+ AbiArrayDynamicType t ->+ do xs <- listOf1 (scale (`div` 2) (genAbiValue t))+ pure (AbiArrayDynamic t (Vector.fromList xs))+ AbiArrayType n t ->+ AbiArray n t . Vector.fromList <$>+ replicateM n (scale (`div` 2) (genAbiValue t))+ 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)++instance Arbitrary AbiType where+ arbitrary = oneof+ [ (AbiUIntType . (* 8)) <$> choose (1, 32)+ , (AbiIntType . (* 8)) <$> choose (1, 32)+ , pure AbiAddressType+ , pure AbiBoolType+ , AbiBytesType . getPositive <$> arbitrary+ , pure AbiBytesDynamicType+ , pure AbiStringType+ , AbiArrayDynamicType <$> scale (`div` 2) arbitrary+ , AbiArrayType+ <$> (getPositive <$> arbitrary)+ <*> scale (`div` 2) arbitrary+ ]++instance Arbitrary AbiValue where+ arbitrary = arbitrary >>= genAbiValue+ shrink = \case+ AbiArrayDynamic t v ->+ Vector.toList v +++ map (AbiArrayDynamic t . Vector.fromList)+ (shrinkList shrink (Vector.toList v))+ AbiArray _ t v ->+ Vector.toList v +++ map (\x -> AbiArray (length x) t (Vector.fromList x))+ (shrinkList shrink (Vector.toList v))+ _ -> []
+ src/EVM/Concrete.hs view
@@ -0,0 +1,252 @@+{-# Language FlexibleInstances #-}+{-# Language StandaloneDeriving #-}+{-# Language StrictData #-}++module EVM.Concrete where++import Prelude hiding (Word, (^))++import EVM.Types (W256 (..), num, toWord512, fromWord512)+import EVM.Types (word, padRight, byteAt)+import EVM.Keccak (keccak)++import Control.Lens ((^?), ix)+import Data.Bits (Bits (..), FiniteBits (..))+import Data.ByteString (ByteString)+import Data.DoubleWord (signedWord, unsignedWord)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.String (IsString)+import Data.Word (Word8)++import qualified Data.ByteString as BS++wordAt :: Int -> ByteString -> W256+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)++byteStringSliceWithDefaultZeroes :: Int -> Int -> ByteString -> ByteString+byteStringSliceWithDefaultZeroes offset size bs =+ if size == 0+ then ""+ else+ let bs' = BS.take size (BS.drop offset bs)+ in bs' <> BS.replicate (size - BS.length bs') 0++data Whiff = Dull | FromKeccak ByteString+ deriving Show++w256 :: W256 -> Word+w256 = C Dull++blob :: ByteString -> Blob+blob = B++data Word = C Whiff W256+newtype Blob = B ByteString+newtype Byte = ConcreteByte Word8+newtype Memory = ConcreteMemory ByteString++wordToByte :: Word -> Byte+wordToByte (C _ x) = ConcreteByte (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++forceConcreteBlob :: Blob -> ByteString+forceConcreteBlob (B x) = x++forceConcreteWord :: Word -> W256+forceConcreteWord (C _ x) = x++sliceMemory :: (Integral a, Integral b) => a -> b -> Memory -> Blob+sliceMemory o s (ConcreteMemory m) =+ B $ byteStringSliceWithDefaultZeroes (num o) (num s) m++writeMemory :: Blob -> Word -> Word -> Word -> Memory -> Memory+writeMemory (B bs1) (C _ n) (C _ src) (C _ dst) (ConcreteMemory 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+ ConcreteMemory $+ 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+ ConcreteMemory $+ a <> BS.replicate (num dst - BS.length a) 0 <> c <> b'++readMemoryWord :: Word -> Memory -> Word+readMemoryWord (C _ i) (ConcreteMemory m) =+ let+ go !a (-1) = a+ go !a !n = go (a + shiftL (num $ readByteOrZero (num i + n) m)+ (8 * (31 - n))) (n - 1)+ in {-# SCC readMemoryWord #-}+ w256 $ go (0 :: W256) (31 :: Int)++readMemoryWord32 :: Word -> Memory -> Word+readMemoryWord32 (C _ i) (ConcreteMemory m) =+ let+ go !a (-1) = a+ go !a !n = go (a + shiftL (num $ readByteOrZero (num i + n) m)+ (8 * (3 - n))) (n - 1)+ in {-# SCC readMemoryWord32 #-}+ w256 $ go (0 :: W256) (3 :: Int)++setMemoryWord :: Word -> Word -> Memory -> Memory+setMemoryWord (C _ i) (C _ x) m =+ writeMemory (B (word256Bytes x)) 32 0 (num i) m++setMemoryByte :: Word -> Byte -> Memory -> Memory+setMemoryByte (C _ i) (ConcreteByte x) m =+ writeMemory (B (BS.singleton x)) 1 0 (num i) m++readBlobWord :: Word -> Blob -> Word+readBlobWord (C _ i) (B x) =+ if i > num (BS.length x)+ then 0+ else w256 (wordAt (num i) x)++blobSize :: Blob -> Word+blobSize (B x) = w256 (num (BS.length x))++keccakBlob :: Blob -> Word+keccakBlob (B x) = C (FromKeccak x) (keccak x)++deriving instance Bits Byte+deriving instance FiniteBits Byte+deriving instance Enum Byte+deriving instance Eq Byte+deriving instance Integral Byte+deriving instance IsString Blob+deriving instance Monoid Blob+deriving instance Monoid Memory+deriving instance Num Byte+deriving instance Ord Byte+deriving instance Real Byte+deriving instance Show Blob++instance Show Word where+ show (C Dull x) = show x+ show (C whiff x) = show whiff ++ ": " ++ show x++instance Read Word where+ readsPrec n s =+ case readsPrec n s of+ [(x, r)] -> [(C Dull x, r)]+ _ -> []++instance Bits Word where+ (C _ x) .&. (C _ y) = w256 (x .&. y)+ (C _ x) .|. (C _ y) = w256 (x .|. y)+ (C _ x) `xor` (C _ y) = w256 (x `xor` y)+ complement (C _ x) = w256 (complement x)+ shift (C _ x) i = w256 (shift x i)+ rotate (C _ x) i = w256 (rotate x i)+ bitSize (C _ x) = bitSize x+ bitSizeMaybe (C _ x) = bitSizeMaybe x+ isSigned (C _ x) = isSigned x+ testBit (C _ x) i = testBit x i+ bit i = w256 (bit i)+ popCount (C _ x) = popCount x++instance FiniteBits Word where+ finiteBitSize (C _ x) = finiteBitSize x+ countLeadingZeros (C _ x) = countLeadingZeros x+ countTrailingZeros (C _ x) = countTrailingZeros x++instance Bounded Word where+ minBound = w256 minBound+ maxBound = w256 maxBound++instance Eq Word where+ (C _ x) == (C _ y) = x == y++instance Enum Word where+ toEnum i = w256 (toEnum i)+ fromEnum (C _ x) = fromEnum x++instance Integral Word where+ quotRem (C _ x) (C _ y) =+ let (a, b) = quotRem x y+ in (w256 a, w256 b)+ toInteger (C _ x) = toInteger x++instance Num Word where+ (C _ x) + (C _ y) = w256 (x + y)+ (C _ x) * (C _ y) = w256 (x * y)+ abs (C _ x) = w256 (abs x)+ signum (C _ x) = w256 (signum x)+ fromInteger x = w256 (fromInteger x)+ negate (C _ x) = w256 (negate x)++instance Real Word where+ toRational (C _ x) = toRational x++instance Ord Word where+ compare (C _ x) (C _ y) = compare x y++-- Copied from the standard library just to get specialization.+-- We also use bit operations instead of modulo and multiply.+-- (This operation was significantly slow.)+(^) :: W256 -> W256 -> W256+x0 ^ y0 | y0 < 0 = errorWithoutStackTrace "Negative exponent"+ | y0 == 0 = 1+ | otherwise = f x0 y0+ where+ f x y | not (testBit y 0) = f (x * x) (y `shiftR` 1)+ | y == 1 = x+ | otherwise = g (x * x) ((y - 1) `shiftR` 1) x+ g x y z | not (testBit y 0) = g (x * x) (y `shiftR` 1) z+ | y == 1 = x * z+ | otherwise = g (x * x) ((y - 1) `shiftR` 1) (x * z)
+ src/EVM/Dapp.hs view
@@ -0,0 +1,113 @@+{-# Language TemplateHaskell #-}++module EVM.Dapp where++import EVM (Trace, traceCodehash, traceOpIx)+import EVM.ABI (Event)+import EVM.Debug (srcMapCodePos)+import EVM.Keccak (abiKeccak)+import EVM.Solidity (SolcContract, CodeType (..), SourceCache, SrcMap)+import EVM.Solidity (contractName)+import EVM.Solidity (runtimeCodehash, creationCodehash, abiMap)+import EVM.Solidity (runtimeSrcmap, creationSrcmap, eventMap)+import EVM.Solidity (methodSignature, contractAst, astIdMap, astSrcMap)+import EVM.Types (W256)++import Data.Aeson (Value)+import Data.Text (Text, isPrefixOf, pack)+import Data.Text.Encoding (encodeUtf8)+import Data.Map (Map)+import Data.Monoid ((<>))+import Data.Word (Word32)+import Data.List (sort)++import Control.Arrow ((>>>))+import Control.Lens++import qualified Data.Map as Map++data DappInfo = DappInfo+ { _dappRoot :: FilePath+ , _dappSolcByName :: Map Text SolcContract+ , _dappSolcByHash :: Map W256 (CodeType, SolcContract)+ , _dappSources :: SourceCache+ , _dappUnitTests :: [(Text, [Text])]+ , _dappEventMap :: Map W256 Event+ , _dappAstIdMap :: Map Int Value+ , _dappAstSrcMap :: (SrcMap -> Maybe Value)+ }++makeLenses ''DappInfo++dappInfo+ :: FilePath -> Map Text SolcContract -> SourceCache -> DappInfo+dappInfo root solcByName sources =+ let+ solcs = Map.elems solcByName+ astIds = astIdMap (map (view contractAst) solcs)++ in DappInfo+ { _dappRoot = root+ , _dappUnitTests = findUnitTests ("test" `isPrefixOf`) solcs+ , _dappSources = sources+ , _dappSolcByName = solcByName+ , _dappSolcByHash =+ let+ f g k = Map.fromList [(view g x, (k, x)) | x <- solcs]+ in+ mappend+ (f runtimeCodehash Runtime)+ (f creationCodehash Creation)++ , _dappEventMap =+ -- Sum up the event ABI maps from all the contracts.+ mconcat (map (view eventMap) solcs)++ , _dappAstIdMap = astIds+ , _dappAstSrcMap = astSrcMap astIds+ }++unitTestMarkerAbi :: Word32+unitTestMarkerAbi = abiKeccak (encodeUtf8 "IS_TEST()")++findUnitTests :: (Text -> Bool) -> ([SolcContract] -> [(Text, [Text])])+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)]++unitTestMethods :: (Text -> Bool) -> (SolcContract -> [Text])+unitTestMethods matcher =+ view abiMap+ >>> Map.elems+ >>> map (view methodSignature)+ >>> filter matcher+ >>> sort++traceSrcMap :: DappInfo -> Trace -> Maybe SrcMap+traceSrcMap dapp trace =+ let+ h = view traceCodehash trace+ i = view traceOpIx trace+ in case preview (dappSolcByHash . ix h) dapp of+ Nothing ->+ Nothing+ Just (Creation, solc) ->+ preview (creationSrcmap . ix i) solc+ Just (Runtime, solc) ->+ preview (runtimeSrcmap . ix i) solc++showTraceLocation :: DappInfo -> Trace -> Either Text Text+showTraceLocation dapp trace =+ case traceSrcMap dapp trace of+ Nothing -> Left "<no source map>"+ Just sm ->+ case srcMapCodePos (view dappSources dapp) sm of+ Nothing -> Left "<source not found>"+ Just (fileName, lineIx) ->+ Right (fileName <> ":" <> pack (show lineIx))
+ src/EVM/Debug.hs view
@@ -0,0 +1,145 @@+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.Types (Addr)++import Control.Arrow (second)+import Control.Lens+import Data.ByteString (ByteString)+import Data.Map (Map)+import Data.Text (Text)++import qualified Data.ByteString as ByteString+import qualified Data.Map as Map++import Text.PrettyPrint.ANSI.Leijen++data Mode = Debug | Run deriving (Eq, Show)++object :: [(Doc, Doc)] -> Doc+object xs =+ group $ lbrace+ <> line+ <> indent 2 (sep (punctuate (char ';') [k <+> equals <+> v | (k, v) <- xs]))+ <> line+ <> rbrace++prettyContract :: Contract -> Doc+prettyContract c =+ object $+ [ (text "codesize", int (ByteString.length (c ^. bytecode)))+ , (text "codehash", text (show (c ^. codehash)))+ , (text "balance", int (fromIntegral (c ^. balance)))+ , (text "nonce", int (fromIntegral (c ^. nonce)))+ , (text "code", text (show (ByteString.take 16 (c ^. bytecode))))+ , (text "storage", text (show (c ^. storage)))+ ]++prettyContracts :: Map Addr Contract -> Doc+prettyContracts x =+ object $+ (map (\(a, b) -> (text (show a), prettyContract b))+ (Map.toList x))++-- debugger :: Maybe SourceCache -> VM -> IO VM+-- debugger maybeCache vm = do+-- -- cpprint (view state vm)+-- cpprint ("pc" :: Text, view (state . pc) vm)+-- cpprint (view (state . stack) vm)+-- -- cpprint (view logs vm)+-- cpprint (vmOp vm)+-- cpprint (opParams vm)+-- cpprint (length (view frames vm))++-- -- putDoc (prettyContracts (view (env . contracts) vm))++-- case maybeCache of+-- Nothing ->+-- return ()+-- Just cache ->+-- case currentSrcMap vm of+-- Nothing -> cpprint ("no srcmap" :: Text)+-- Just sm -> cpprint (srcMapCode cache sm)++-- if vm ^. result /= Nothing+-- then do+-- print (vm ^. result)+-- return vm+-- else+-- -- readline "(evm) " >>=+-- return (Just "") >>=+-- \case+-- Nothing ->+-- return vm+-- Just cmdline ->+-- case words cmdline of+-- [] ->+-- debugger maybeCache (execState exec1 vm)++-- ["block"] ->+-- do cpprint (view block vm)+-- debugger maybeCache vm++-- ["storage"] ->+-- do cpprint (view (env . contracts) vm)+-- debugger maybeCache vm++-- ["contracts"] ->+-- do putDoc (prettyContracts (view (env . contracts) vm))+-- debugger maybeCache vm++-- -- ["disassemble"] ->+-- -- do cpprint (mkCodeOps (view (state . code) vm))+-- -- debugger maybeCache vm++-- _ -> debugger maybeCache vm++-- lookupSolc :: VM -> W256 -> Maybe SolcContract+-- lookupSolc vm hash =+-- case vm ^? env . solcByRuntimeHash . ix hash of+-- Just x -> Just x+-- Nothing ->+-- vm ^? env . solcByCreationHash . ix hash++-- currentSolc :: VM -> Maybe SolcContract+-- currentSolc vm =+-- let+-- c = vm ^?! env . contracts . ix (vm ^. state . contract)+-- theCodehash = view codehash c+-- in+-- case vm ^? env . solcByRuntimeHash . ix theCodehash of+-- Just x ->+-- Just x+-- Nothing ->+-- vm ^? env . solcByCreationHash . ix theCodehash++-- currentSrcMap :: VM -> Maybe SrcMap+-- currentSrcMap vm =+-- let+-- c = vm ^?! env . contracts . ix (vm ^. state . contract)+-- theOpIx = (c ^. opIxMap) Vector.! (vm ^. state . pc)+-- theCodehash = view codehash c+-- (isRuntime, solc) =+-- case vm ^? env . solcByRuntimeHash . ix theCodehash of+-- Just x ->+-- (True, Just x)+-- Nothing ->+-- (False, vm ^? env . solcByCreationHash . ix theCodehash)+-- srcmapLens = if isRuntime then runtimeSrcmap else creationSrcmap+-- in+-- join (fmap (preview (srcmapLens . ix theOpIx)) solc)++srcMapCodePos :: SourceCache -> SrcMap -> Maybe (Text, Int)+srcMapCodePos cache sm =+ fmap (second f) $ cache ^? sourceFiles . ix (srcMapFile sm)+ where+ f v = ByteString.count 0xa (ByteString.take (srcMapOffset sm - 1) v) + 1++srcMapCode :: SourceCache -> SrcMap -> Maybe ByteString+srcMapCode cache sm =+ fmap f $ cache ^? sourceFiles . ix (srcMapFile sm)+ where+ f (_, v) = ByteString.take (min 80 (srcMapLength sm)) (ByteString.drop (srcMapOffset sm) v)
+ src/EVM/Dev.hs view
@@ -0,0 +1,82 @@+module EVM.Dev where++import System.Directory++import EVM.Dapp+import EVM.Solidity+import EVM.UnitTest++import qualified EVM.Fetch+import qualified EVM.TTY+import qualified EVM.Emacs+import qualified EVM.Facts as Facts+import qualified EVM.Facts.Git as Git++import Data.Text (isPrefixOf)++import qualified Data.Map as Map++loadDappInfo :: String -> String -> IO DappInfo+loadDappInfo path file =+ withCurrentDirectory path $+ readSolc file >>=+ \case+ Just (contractMap, cache) -> do+ pure (dappInfo "." contractMap cache)+ _ ->+ error "nope, sorry"++ghciTest :: String -> String -> Maybe String -> IO [Bool]+ghciTest root path state =+ withCurrentDirectory root $ do+ loadFacts <-+ case state of+ Nothing ->+ pure id+ Just repoPath -> do+ facts <- Git.loadFacts (Git.RepoAt repoPath)+ pure (flip Facts.apply facts)+ params <- getParametersFromEnvironmentVariables+ let+ opts = UnitTestOptions+ { oracle = EVM.Fetch.zero+ , verbose = False+ , match = ""+ , vmModifier = loadFacts+ , testParams = params+ }+ readSolc path >>=+ \case+ Just (contractMap, cache) -> do+ let unitTests = findUnitTests ("test" `isPrefixOf`) (Map.elems contractMap)+ mapM (runUnitTestContract opts contractMap cache) unitTests+ Nothing ->+ error ("Failed to read Solidity JSON for `" ++ path ++ "'")++ghciTty :: String -> String -> Maybe String -> IO ()+ghciTty root path state =+ withCurrentDirectory root $ do+ loadFacts <-+ case state of+ Nothing ->+ pure id+ Just repoPath -> do+ facts <- Git.loadFacts (Git.RepoAt repoPath)+ pure (flip Facts.apply facts)+ params <- getParametersFromEnvironmentVariables+ let+ testOpts = UnitTestOptions+ { oracle = EVM.Fetch.zero+ , verbose = False+ , match = ""+ , vmModifier = loadFacts+ , testParams = params+ }+ EVM.TTY.main testOpts root path++ghciEmacs :: IO ()+ghciEmacs =+ EVM.Emacs.main++foo :: IO ()+foo = ghciEmacs
+ src/EVM/Emacs.hs view
@@ -0,0 +1,485 @@+{-# Language ImplicitParams #-}+{-# Language TemplateHaskell #-}+{-# Language FlexibleInstances #-}++module EVM.Emacs where++import Control.Lens+import Control.Monad.IO.Class+import Control.Monad.State.Strict hiding (state)+import Data.ByteString (ByteString)+import Data.Map (Map)+import Data.Maybe+import Data.Monoid+import Data.SCargot+import Data.SCargot.Language.HaskLike+import Data.SCargot.Repr+import Data.SCargot.Repr.Basic+import Data.Text (Text, pack, unpack)+import EVM+import EVM.Concrete+import EVM.Dapp+import EVM.Fetch (Fetcher)+import EVM.Solidity+import EVM.Stepper (Stepper)+import EVM.TTY (currentSrcMap)+import EVM.Types+import EVM.UnitTest hiding (interpret)+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.Map as Map+import qualified EVM.Fetch as Fetch+import qualified EVM.Stepper as Stepper++data UiVmState = UiVmState+ { _uiVm :: VM+ , _uiVmNextStep :: Stepper ()+ , _uiVmSolc :: Maybe SolcContract+ , _uiVmDapp :: Maybe DappInfo+ , _uiVmStepCount :: Int+ , _uiVmFirstState :: UiVmState+ , _uiVmFetcher :: Fetcher+ , _uiVmMessage :: Maybe Text+ }++makeLenses ''UiVmState++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++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++interpret+ :: StepMode+ -> Stepper a+ -> State UiVmState (StepOutcome a)+interpret mode =+ eval . Operational.view+ where+ eval+ :: Operational.ProgramView Stepper.Action a+ -> State UiVmState (StepOutcome a)++ eval (Operational.Return x) =+ pure (Returned x)++ eval (action Operational.:>>= k) =+ case action of++ -- 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++ StepMany i -> do+ -- Run one instruction.+ interpret StepOne restart >>=+ \case+ Stepped stepper ->+ interpret (StepMany (i - 1)) stepper++ -- This shouldn't happen, because re-stepping needs+ -- to avoid blocking and halting.+ r -> pure r++ 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++ -- 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 wants to make a query and wait for the results?+ Stepper.Wait q -> do+ fetcher <- use uiVmFetcher+ -- 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 ())++ -- 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 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+ nextVm = execState exec1 (view uiVm ui)+ in+ ui & over uiVmStepCount (+ 1)+ & set uiVm nextVm++updateUiVmState :: UiVmState -> VM -> UiVmState+updateUiVmState ui vm =+ ui & set uiVm vm++type Sexp = WellFormedSExpr HaskLikeAtom++prompt :: Console (Maybe Sexp)+prompt = do+ line <- liftIO (putStr "> " >> hFlush stdout >> getLine)+ case decodeOne (asWellFormed haskLikeParser) (pack line) of+ Left e -> do+ output (L [A "error", A (txt e)])+ pure Nothing+ Right s ->+ pure (Just s)++class SDisplay a where+ sexp :: a -> SExpr Text++display :: SDisplay a => a -> Text+display = encodeOne (basicPrint id) . sexp++txt :: Show a => a -> Text+txt = pack . show++data UiState+ = UiStarted+ | UiDappLoaded DappInfo+ | UiVm UiVmState++type Console a = StateT UiState IO a++output :: SDisplay a => a -> Console ()+output = liftIO . putStrLn . unpack . display++main :: IO ()+main = do+ putStrLn ";; Welcome to Hevm's Emacs integration."+ _ <- execStateT loop UiStarted+ pure ()++loop :: Console ()+loop =+ prompt >>=+ \case+ Nothing -> pure ()+ Just command -> do+ handle command+ loop++handle :: Sexp -> Console ()+handle (WFSList (WFSAtom (HSIdent cmd) : args)) =+ do s <- get+ handleCmd s (cmd, args)+handle _ =+ output (L [A ("unrecognized-command" :: Text)])++handleCmd :: UiState -> (Text, [Sexp]) -> Console ()+handleCmd UiStarted = \case+ ("load-dapp",+ [WFSAtom (HSString (unpack -> root)),+ WFSAtom (HSString (unpack -> jsonPath))]) ->+ do liftIO (setCurrentDirectory root)+ liftIO (readSolc jsonPath) >>=+ \case+ Nothing ->+ output (L [A ("error" :: Text)])+ Just (contractMap, sourceCache) ->+ let+ dapp = dappInfo root contractMap sourceCache+ in do+ output dapp+ put (UiDappLoaded dapp)++ _ ->+ output (L [A ("unrecognized-command" :: Text)])++handleCmd (UiDappLoaded dapp) = \case+ ("run-test", [WFSAtom (HSString contractPath),+ WFSAtom (HSString testName)]) -> do+ opts <- defaultUnitTestOptions+ put (UiVm (initialStateForTest opts dapp (contractPath, testName)))+ outputVm+ _ ->+ output (L [A ("unrecognized-command" :: Text)])++handleCmd (UiVm s) = \case+ ("step", [WFSAtom (HSString modeName)]) -> do+ case parseStepMode s modeName of+ Just mode -> do+ takeStep s StepNormally mode+ outputVm+ Nothing ->+ output (L [A ("unrecognized-command" :: Text)])+ _ ->+ output (L [A ("unrecognized-command" :: Text)])++outputVm :: Console ()+outputVm = do+ UiVm s <- get+ let+ noMap =+ output $+ L [ A "step"+ , L [A ("pc" :: Text), A (txt (view (uiVm . state . pc) s))]]++ fromMaybe noMap $ do+ dapp <- view uiVmDapp s+ sm <- currentSrcMap dapp (view uiVm s)+ (fileName, _) <- view (dappSources . sourceFiles . at (srcMapFile sm)) dapp+ pure . output $+ L [ A "step"+ , L [A ("vm" :: Text), sexp (view uiVm s)]+ , L [A ("file" :: Text), A (txt fileName)]+ , L [ A ("srcmap" :: Text)+ , A (txt (srcMapOffset sm))+ , A (txt (srcMapLength sm))+ , A (txt (srcMapJump sm))+ ]+ ]+++isNextSourcePosition+ :: UiVmState -> Pred VM+isNextSourcePosition ui vm =+ let+ Just dapp = view uiVmDapp ui+ initialPosition = currentSrcMap dapp (view uiVm ui)+ in+ currentSrcMap dapp vm /= initialPosition++parseStepMode :: UiVmState -> Text -> Maybe StepMode+parseStepMode s =+ \case+ "once" -> Just StepOne+ "source-location" -> Just (StepUntil (isNextSourcePosition s))+ _ -> Nothing++-- ^ 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+ :: UiVmState+ -> StepPolicy+ -> StepMode+ -> Console ()+takeStep ui policy mode = do+ let m = interpret mode (view uiVmNextStep ui)++ case runState m ui of++ (Stepped stepper, ui') -> do+ put (UiVm (ui' & set uiVmNextStep stepper))++ (Blocked blocker, ui') ->+ case policy of+ StepNormally -> do+ stepper <- liftIO blocker+ takeStep+ (execState (assign uiVmNextStep stepper) ui')+ StepNormally StepNone++ StepTimidly ->+ error "step blocked unexpectedly"++ (Returned (), ui') ->+ case policy of+ StepNormally ->+ put (UiVm ui')+ StepTimidly ->+ error "step halted unexpectedly"++ -- readSolc jsonPath >>=+ -- \case+ -- Nothing -> error "Failed to read Solidity JSON"+ -- Just (contractMap, sourceCache) -> do+ -- let+ -- dapp = dappInfo root contractMap sourceCache+ -- putStrLn (unpack (display dapp))++instance SDisplay DappInfo where+ sexp x =+ L [ A "dapp-info"+ , L [A "root", A (txt $ view dappRoot x)]+ , L (A "unit-tests" :+ [ L [A (txt a), L (map (A . txt) b)]+ | (a, b) <- view dappUnitTests x])+ ]++instance SDisplay (SExpr Text) where+ sexp = id++instance SDisplay VM where+ sexp x =+ L [ L [A "result", sexp (view result x)]+ , L [A "state", sexp (view state x)]+ , L [A "frames", sexp (view frames x)]+ , L [A "contracts", sexp (view (env . contracts) x)]+ ]++quoted :: Text -> Text+quoted x = "\"" <> x <> "\""++instance SDisplay Addr where+ sexp = A . quoted . pack . showAddrWith0x++instance SDisplay Contract where+ sexp x =+ L [ L [A "storage", sexp (view storage x)]+ , L [A "balance", sexp (view balance x)]+ , L [A "nonce", sexp (view nonce x)]+ , L [A "codehash", sexp (view codehash x)]+ ]++instance SDisplay W256 where+ sexp x = A (txt (txt x))++instance (SDisplay k, SDisplay v) => SDisplay (Map k v) where+ sexp x = L [L [sexp k, sexp v] | (k, v) <- Map.toList x]++instance SDisplay a => SDisplay (Maybe a) where+ sexp Nothing = A "nil"+ sexp (Just x) = sexp x++instance SDisplay VMResult where+ sexp = \case+ VMFailure e -> L [A "vm-failure", A (txt (txt e))]+ VMSuccess b -> L [A "vm-success", sexp b]++instance SDisplay Frame where+ sexp x =+ L [A "frame", sexp (view frameContext x), sexp (view frameState x)]++instance SDisplay Blob where+ sexp (B x) = sexp x++instance SDisplay FrameContext where+ sexp _x = A "some-context"++instance SDisplay FrameState where+ sexp x =+ L [ L [A "contract", sexp (view contract x)]+ , L [A "code-contract", sexp (view codeContract x)]+ , L [A "pc", A (txt (view pc x))]+ , L [A "stack", sexp (view stack x)]+ , L [A "memory", sexp (view memory x)]+ ]++instance SDisplay a => SDisplay [a] where+ sexp = L . map sexp++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]++instance SDisplay ByteString where+ sexp = A . txt . pack . showByteStringWith0x++instance SDisplay Memory where+ sexp (ConcreteMemory bs) =+ if BS.length bs > 1024+ then L [A "large-memory", A (txt (BS.length bs))]+ else sexp bs++defaultUnitTestOptions :: MonadIO m => m UnitTestOptions+defaultUnitTestOptions = do+ params <- liftIO getParametersFromEnvironmentVariables+ pure UnitTestOptions+ { oracle = Fetch.zero+ , verbose = False+ , match = ""+ , vmModifier = id+ , testParams = params+ }++initialStateForTest+ :: UnitTestOptions+ -> DappInfo+ -> (Text, Text)+ -> UiVmState+initialStateForTest opts@(UnitTestOptions {..}) dapp (contractPath, testName) =+ ui1+ where+ script = do+ Stepper.evm . pushTrace . EntryTrace $+ "test " <> testName <> " (" <> contractPath <> ")"+ initializeUnitTest opts+ void (runUnitTest opts testName)+ ui0 =+ UiVmState+ { _uiVm = vm0+ , _uiVmNextStep = script+ , _uiVmSolc = Just testContract+ , _uiVmDapp = Just dapp+ , _uiVmStepCount = 0+ , _uiVmFirstState = undefined+ , _uiVmFetcher = oracle+ , _uiVmMessage = Nothing+ }+ Just testContract =+ view (dappSolcByName . at contractPath) dapp+ vm0 =+ initialUnitTestVm opts testContract (Map.elems (view dappSolcByName dapp))+ ui1 =+ updateUiVmState ui0 vm0 & set uiVmFirstState ui1
+ src/EVM/Exec.hs view
@@ -0,0 +1,76 @@+module EVM.Exec where++import EVM+import EVM.Keccak (newContractAddress)+import EVM.Types++import qualified EVM.FeeSchedule as FeeSchedule++import Control.Lens+import Control.Monad.State.Class (MonadState)+import Control.Monad.State.Strict (runState)+import Data.ByteString (ByteString)+import Data.Maybe (isNothing)++import qualified Control.Monad.State.Class as State++ethrunAddress :: Addr+ethrunAddress = Addr 0x00a329c0648769a73afac7f9381e08fb43dbea72++vmForEthrunCreation :: ByteString -> VM+vmForEthrunCreation creationCode =+ (makeVm $ VMOpts+ { vmoptCode = creationCode+ , vmoptCalldata = ""+ , vmoptValue = 0+ , vmoptAddress = newContractAddress ethrunAddress 1+ , vmoptCaller = ethrunAddress+ , vmoptOrigin = ethrunAddress+ , vmoptCoinbase = 0+ , vmoptNumber = 0+ , vmoptTimestamp = 0+ , vmoptGaslimit = 0+ , vmoptGasprice = 0+ , vmoptDifficulty = 0+ , vmoptGas = 0xffffffffffffffff+ , vmoptSchedule = FeeSchedule.metropolis+ }) & set (env . contracts . at ethrunAddress)+ (Just (initialContract mempty))++exec :: MonadState VM m => m VMResult+exec =+ use EVM.result >>= \case+ Nothing -> State.state (runState exec1) >> exec+ Just x -> return x++execWhile :: MonadState VM m => (VM -> Bool) -> m Int+execWhile p = go 0+ where+ go i = do+ x <- State.get+ if p x && isNothing (view result x)+ then do+ State.state (runState exec1)+ go $! (i + 1)+ else+ return i++-- locateBreakpoint :: UIState -> Text -> Int -> Maybe [(Word256, Vector Bool)]+-- locateBreakpoint ui fileName lineNo = do+-- (i, (t, s)) <-+-- flip find (Map.toList (ui ^. uiSourceCache . sourceFiles))+-- (\(_, (t, _)) -> t == fileName)+-- let ls = BS.split 0x0a s+-- l = ls !! (lineNo - 1)+-- offset = 1 + sum (map ((+ 1) . BS.length) (take (lineNo - 1) ls))+-- horizon = offset + BS.length l+-- return $ Map.elems (ui ^. uiVm . _Just . env . solc)+-- & map (\c -> (+-- c ^. solcCodehash,+-- Vector.create $ new (Seq.length (c ^. solcSrcmap)) >>= \v -> do+-- fst $ foldl' (\(!m, !j) (sm@SM { srcMapOffset = o }) ->+-- if srcMapFile sm == i && o >= offset && o < horizon+-- then (m >> write v j True, j + 1)+-- else (m >> write v j False, j + 1)) (return (), 0) (c ^. solcSrcmap)+-- return v+-- ))
+ src/EVM/Facts.hs view
@@ -0,0 +1,197 @@+{-# Language PartialTypeSignatures #-}+{-# Language FlexibleInstances #-}+{-# Language ExtendedDefaultRules #-}+{-# Language NamedFieldPuns #-}+{-# Language PatternSynonyms #-}+{-# Language RecordWildCards #-}+{-# Language ScopedTypeVariables #-}+{-# Language ViewPatterns #-}++-- Converts between Ethereum contract states and simple trees of+-- texts. Dumps and loads such trees as Git repositories (the state+-- gets serialized as commits with folders and files).+--+-- Example state file hierarchy:+--+-- /0123...abc/balance says "0x500"+-- /0123...abc/code says "60023429..."+-- /0123...abc/nonce says "0x3"+-- /0123...abc/storage/0x1 says "0x1"+-- /0123...abc/storage/0x2 says "0x0"+--+-- This format could easily be serialized into any nested record+-- syntax, e.g. JSON.++module EVM.Facts+ ( File (..)+ , Fact (..)+ , Data (..)+ , Path (..)+ , apply+ , contractFacts+ , vmFacts+ , factToFile+ , fileToFact+ ) where++import EVM (VM, Contract)+import EVM.Concrete (Word)+import EVM (balance, nonce, storage, bytecode, env, contracts)+import EVM.Types (Addr)++import qualified EVM as EVM++import Prelude hiding (Word)++import Control.Lens (view, set, at, ix, (&))+import Data.ByteString (ByteString)+import Data.Monoid ((<>))+import Data.Ord (comparing)+import Data.Set (Set)+import Text.Read (readMaybe)++import qualified Data.ByteString.Base16 as BS16+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as Char8+import qualified Data.Map as Map+import qualified Data.Set as Set++-- We treat everything as ASCII byte strings because+-- we only use hex digits (and the letter 'x').+type ASCII = ByteString++-- When using string literals, default to infer the ASCII type.+default (ASCII)++-- We use the word "fact" to mean one piece of serializable+-- information about the state.+--+-- Note that Haskell allows this kind of union of records.+-- It's convenient here, but typically avoided.+data Fact+ = BalanceFact { addr :: Addr, what :: Word }+ | NonceFact { addr :: Addr, what :: Word }+ | StorageFact { addr :: Addr, what :: Word, which :: Word }+ | CodeFact { addr :: Addr, blob :: ByteString }+ deriving (Eq, Show)++-- A fact path means something like "/0123...abc/storage/0x1",+-- or alternatively "contracts['0123...abc'].storage['0x1']".+data Path = Path [ASCII] ASCII+ deriving (Eq, Ord, Show)++-- A fact data is the content of a file. We encapsulate it+-- with a newtype to make it easier to change the representation+-- (to use bytestrings, some sum type, or whatever).+newtype Data = Data { dataASCII :: ASCII }+ deriving (Eq, Ord, Show)++-- We use the word "file" to denote a serialized value at a path.+data File = File { filePath :: Path, fileData :: Data }+ deriving (Eq, Ord, Show)++class AsASCII a where+ dump :: a -> ASCII+ load :: ASCII -> Maybe a++instance AsASCII Addr where+ dump = Char8.pack . show+ load = readMaybe . Char8.unpack++instance AsASCII Word where+ dump = Char8.pack . show+ load = readMaybe . Char8.unpack++instance AsASCII ByteString where+ dump x = BS16.encode x <> "\n"+ load x =+ case BS16.decode . mconcat . BS.split 10 $ x of+ (y, "") -> Just y+ _ -> Nothing++contractFacts :: Addr -> Contract -> [Fact]+contractFacts a x = storageFacts a x +++ [ BalanceFact a (view balance x)+ , NonceFact a (view nonce x)+ , CodeFact a (view bytecode x)+ ]++storageFacts :: Addr -> Contract -> [Fact]+storageFacts a x = map f (Map.toList (view storage x))+ where+ f :: (Word, Word) -> Fact+ f (k, v) = StorageFact+ { addr = a+ , what = fromIntegral v+ , which = fromIntegral k+ }++vmFacts :: VM -> Set Fact+vmFacts vm = Set.fromList $ do+ (k, v) <- Map.toList (view (env . contracts) vm)+ contractFacts k v++-- Somewhat stupidly, this function demands that for each contract,+-- the code fact for that contract comes before the other facts for+-- that contract. This is an incidental thing because right now we+-- always initialize contracts starting with the code (to calculate+-- the code hash and so on).+--+-- Therefore, we need to make sure to sort the fact set in such a way.+apply1 :: VM -> Fact -> VM+apply1 vm fact =+ case fact of+ CodeFact {..} ->+ vm & set (env . contracts . at addr) (Just (EVM.initialContract blob))+ StorageFact {..} ->+ vm & set (env . contracts . ix addr . storage . at which) (Just what)+ BalanceFact {..} ->+ vm & set (env . contracts . ix addr . balance) what+ NonceFact {..} ->+ vm & set (env . contracts . ix addr . nonce) what++-- Sort facts in the right order for `apply1` to work.+instance Ord Fact where+ compare = comparing f+ where+ f :: Fact -> (Int, Addr, Word)+ f (CodeFact a _) = (0, a, 0)+ f (BalanceFact a _) = (1, a, 0)+ f (NonceFact a _) = (2, a, 0)+ f (StorageFact a _ x) = (3, a, x)++-- Applies a set of facts to a VM.+apply :: VM -> Set Fact -> VM+apply vm =+ -- The set's ordering is relevant; see `apply1`.+ foldl apply1 vm++factToFile :: Fact -> File+factToFile fact = case fact of+ StorageFact {..} -> mk ["storage"] (dump which) what+ BalanceFact {..} -> mk [] "balance" what+ NonceFact {..} -> mk [] "nonce" what+ CodeFact {..} -> mk [] "code" blob+ where+ mk :: AsASCII a => [ASCII] -> ASCII -> a -> File+ mk prefix base a =+ File (Path (dump (addr fact) : prefix) base)+ (Data $ dump a)++-- This lets us easier pattern match on serialized things.+-- Uses language extensions: `PatternSynonyms` and `ViewPatterns`.+pattern Load :: AsASCII a => a -> ASCII+pattern Load x <- (load -> Just x)++fileToFact :: File -> Maybe Fact+fileToFact = \case+ File (Path [Load a] "code") (Data (Load x))+ -> Just (CodeFact a x)+ File (Path [Load a] "balance") (Data (Load x))+ -> Just (BalanceFact a x)+ File (Path [Load a] "nonce") (Data (Load x))+ -> Just (NonceFact a x)+ File (Path [Load a, "storage"] (Load x)) (Data (Load y))+ -> Just (StorageFact a y x)+ _+ -> Nothing
+ src/EVM/Facts/Git.hs view
@@ -0,0 +1,51 @@+{-# Language ViewPatterns #-}++-- This is a backend for the fact representation that uses a Git+-- repository as the store.++module EVM.Facts.Git+ ( saveFacts+ , loadFacts+ , RepoAt (..)+ ) where++import EVM.Facts (Fact (..), File (..), Path (..), Data (..))+import EVM.Facts (fileToFact, factToFile)++import Control.Lens+import Data.Set (Set)+import Data.Maybe (catMaybes)++import qualified Data.Set as Set+import qualified Restless.Git as Git++newtype RepoAt = RepoAt String+ deriving (Eq, Ord, Show)++-- For modularity reasons, we have our own file data type that is+-- isomorphic with the one in the `restless-git` library. We declare+-- the isomorphism so we can go between them easily.+fileRepr :: Iso' File Git.File+fileRepr = iso f g+ where+ f :: File -> Git.File+ f (File (Path ps p) (Data x)) =+ (Git.File (Git.Path ps p) x)++ g :: Git.File -> File+ g (Git.File (Git.Path ps p) x) =+ (File (Path ps p) (Data x))++saveFacts :: RepoAt -> Set Fact -> IO ()+saveFacts (RepoAt repo) facts =+ Git.save repo "hevm execution"+ (Set.map (view fileRepr . factToFile) facts)++prune :: Ord a => Set (Maybe a) -> Set a+prune = Set.fromList . catMaybes . Set.toList++loadFacts :: RepoAt -> IO (Set Fact)+loadFacts (RepoAt src) =+ fmap+ (prune . Set.map (fileToFact . view (from fileRepr)))+ (Git.load src)
+ src/EVM/FeeSchedule.hs view
@@ -0,0 +1,103 @@+module EVM.FeeSchedule where++data Num n => FeeSchedule n = FeeSchedule+ { g_zero :: n+ , g_base :: n+ , g_verylow :: n+ , g_low :: n+ , g_mid :: n+ , g_high :: n+ , g_extcode :: n+ , g_balance :: n+ , g_sload :: n+ , g_jumpdest :: n+ , g_sset :: n+ , g_sreset :: n+ , r_sclear :: n+ , r_selfdestruct :: n+ , r_selfdestruct_newaccount :: n+ , g_create :: n+ , g_codedeposit :: n+ , g_call :: n+ , g_callvalue :: n+ , g_callstipend :: n+ , g_newaccount :: n+ , g_exp :: n+ , g_expbyte :: n+ , g_memory :: n+ , g_txcreate :: n+ , g_txdatazero :: n+ , g_txdatanonzero :: n+ , g_transaction :: n+ , g_log :: n+ , g_logdata :: n+ , g_logtopic :: n+ , g_sha3 :: n+ , g_sha3word :: n+ , g_copy :: n+ , g_blockhash :: n+ } deriving Show++-- For the purposes of this module, we define an EIP as just a fee+-- schedule modification.+type EIP n = Num n => FeeSchedule n -> FeeSchedule n++-- EIP150: Gas cost changes for IO-heavy operations+-- <https://github.com/ethereum/EIPs/blob/master/EIPS/eip-150.md>+eip150 :: EIP n+eip150 fees = fees+ { g_extcode = 700+ , g_balance = 400+ , g_sload = 200+ , g_call = 700+ , r_selfdestruct = 5000+ , r_selfdestruct_newaccount = 25000+ }++-- EIP160: EXP cost increase+-- <https://github.com/ethereum/EIPs/blob/master/EIPS/eip-160.md>+eip160 :: EIP n+eip160 fees = fees+ { g_expbyte = 50 }++homestead :: Num n => FeeSchedule n+homestead = FeeSchedule+ { g_zero = 0+ , g_base = 2+ , g_verylow = 3+ , g_low = 5+ , g_mid = 8+ , g_high = 10+ , g_extcode = 20+ , g_balance = 20+ , g_sload = 50+ , g_jumpdest = 1+ , g_sset = 20000+ , g_sreset = 5000+ , r_sclear = 15000+ , r_selfdestruct = 0+ , r_selfdestruct_newaccount = 0+ , g_create = 32000+ , g_codedeposit = 200+ , g_call = 40+ , g_callvalue = 9000+ , g_callstipend = 2300+ , g_newaccount = 25000+ , g_exp = 10+ , g_expbyte = 10+ , g_memory = 3+ , g_txcreate = 32000+ , g_txdatazero = 4+ , g_txdatanonzero = 68+ , g_transaction = 21000+ , g_log = 375+ , g_logdata = 8+ , g_logtopic = 375+ , g_sha3 = 30+ , g_sha3word = 6+ , g_copy = 3+ , g_blockhash = 20+ }++metropolis :: Num n => FeeSchedule n+metropolis = eip160 . eip150 $ homestead
+ src/EVM/Fetch.hs view
@@ -0,0 +1,144 @@+{-# Language GADTs #-}+{-# Language StandaloneDeriving #-}++module EVM.Fetch where++import Prelude hiding (Word)++import EVM.Types (Addr, W256, showAddrWith0x, showWordWith0x, hexText)+import EVM.Concrete (Word, w256)+import EVM (EVM, Contract, initialContract, nonce, balance, external)++import qualified EVM as EVM++import Control.Lens hiding ((.=))+import Control.Monad.Trans.Maybe+import Data.Aeson+import Data.Aeson.Lens+import Data.ByteString (ByteString)+import Data.Text (Text, unpack)+import Network.Wreq+import Network.Wreq.Session (Session)++import qualified Network.Wreq.Session as Session++-- | Abstract representation of an RPC fetch request+data RpcQuery a where+ QueryCode :: Addr -> RpcQuery ByteString+ QueryBalance :: Addr -> RpcQuery W256+ QueryNonce :: Addr -> RpcQuery W256+ QuerySlot :: Addr -> W256 -> 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)+ , "id" .= Number 1+ , "method" .= method+ , "params" .= args+ ]++class ToRPC a where+ toRPC :: a -> String++instance ToRPC Addr where+ toRPC = showAddrWith0x++instance ToRPC W256 where+ toRPC = showWordWith0x++instance ToRPC BlockNumber where+ toRPC Latest = "latest"+ toRPC (BlockNumber n) = showWordWith0x n++readText :: Read a => Text -> a+readText = read . unpack++fetchQuery+ :: Show a+ => BlockNumber+ -> (Value -> IO (Maybe Text))+ -> RpcQuery a+ -> IO (Maybe a)+fetchQuery n f q = do+ x <- case q of+ QueryCode addr -> do+ fmap hexText <$>+ f (rpc "eth_getCode" [toRPC addr, toRPC n])+ QueryNonce addr ->+ fmap readText <$>+ f (rpc "eth_getTransactionCount" [toRPC addr, toRPC n])+ QueryBalance addr ->+ fmap readText <$>+ f (rpc "eth_getBalance" [toRPC addr, toRPC n])+ QuerySlot addr slot ->+ fmap readText <$>+ f (rpc "eth_getStorageAt" [toRPC addr, toRPC slot, toRPC n])+ return x++fetchWithSession :: Text -> Session -> Value -> IO (Maybe Text)+fetchWithSession url sess x = do+ r <- asValue =<< Session.post sess (unpack url) x+ return (r ^? responseBody . key "result" . _String)++fetchContractWithSession+ :: BlockNumber -> Text -> Session -> Addr -> IO (Maybe Contract)+fetchContractWithSession n url sess addr = runMaybeT $ do+ let+ fetch :: Show a => RpcQuery a -> IO (Maybe a)+ fetch = fetchQuery n (fetchWithSession url sess)++ theCode <- MaybeT $ fetch (QueryCode addr)+ theNonce <- MaybeT $ fetch (QueryNonce addr)+ theBalance <- MaybeT $ fetch (QueryBalance addr)++ return $+ initialContract 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+ 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)++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+ case q of+ EVM.PleaseFetchContract addr continue ->+ fetchContractFrom n url addr >>= \case+ Just x -> do+ 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)++zero :: Monad m => EVM.Query -> m (EVM ())+zero q = do+ case q of+ EVM.PleaseFetchContract _ continue ->+ return (continue (initialContract ""))+ EVM.PleaseFetchSlot _ _ continue ->+ return (continue 0)++type Fetcher = EVM.Query -> IO (EVM ())
+ src/EVM/Flatten.hs view
@@ -0,0 +1,212 @@+module EVM.Flatten (flatten) where++-- This module concatenates all the imported dependencies+-- of a given source file, so that you can paste the result+-- into Remix or the Etherscan contract verification page.+--+-- The concatenated files are stripped of import directives+-- and compiler version pragmas are merged into just one.+--+-- This module is mostly independent from the rest of Hevm,+-- using only the source code metadata support modules.++import EVM.Dapp (DappInfo, dappSources)+import EVM.Solidity (sourceAsts)++-- 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.+import Control.Lens (preview, view, universe)+import Data.Aeson (Value (String))+import Data.Aeson.Lens (key, _String, _Array)++-- We use the FGL graph library for the topological sort.+-- (We use four FGL functions and they're all in different modules!)+import qualified Data.Graph.Inductive.Graph as Fgl+import qualified Data.Graph.Inductive.PatriciaTree as Fgl+import qualified Data.Graph.Inductive.Query.BFS as Fgl+import qualified Data.Graph.Inductive.Query.DFS as Fgl++import Control.Monad (forM)+import Data.ByteString (ByteString)+import Data.Foldable (foldl', toList)+import Data.List (sort)+import Data.Map (Map, (!))+import Data.Maybe (mapMaybe, isJust, fromMaybe)+import Data.Monoid ((<>))+import Data.Text (Text, unpack, pack, intercalate)+import Data.Text.Encoding (encodeUtf8)+import Text.Read (readMaybe)++import qualified Data.Map as Map+import qualified Data.Text as Text+import qualified Data.ByteString as BS++-- Define an alias for FGL graphs with text nodes and unlabeled edges.+type FileGraph = Fgl.Gr Text ()++-- Given the AST of a source file, resolve all its imported paths.+importsFrom :: Value -> [Text]+importsFrom ast =+ let+ -- We use the astonishing `universe` function from Lens+ -- to get a lazy list of every node in the AST structure.+ allNodes :: [Value]+ allNodes = universe ast++ -- Given some subvalue in the AST, we check if it's an import,+ -- and if so, return its resolved import path.+ resolveImport :: Value -> Maybe Text+ resolveImport node =+ case preview (key "name") node of+ Just (String "ImportDirective") ->+ preview (key "attributes" . key "absolutePath" . _String) node+ _ ->+ Nothing++ -- Now we just try to resolve import paths at all subnodes.+ in mapMaybe resolveImport allNodes++flatten :: DappInfo -> Text -> IO ()+flatten dapp target = do+ let+ -- The nodes and edges are defined below.+ graph :: FileGraph+ graph = Fgl.mkGraph nodes edges++ -- The graph nodes are ints with source paths as labels.+ nodes :: [(Int, Text)]+ nodes = zip [1..] (Map.keys asts)++ -- The graph edges are defined by module imports.+ edges =+ [ (indices ! s, indices ! t, ()) -- Edge from S to T+ | (s, v) <- Map.toList asts -- for every file S+ , t <- importsFrom v ] -- and every T imported by S.++ -- We can look up the node index for a source file path.+ indices :: Map Text Int+ indices = Map.fromList [(v, k) | (k, v) <- nodes]++ -- The JSON ASTs are indexed by source file path.+ asts :: Map Text Value+ asts = view (dappSources . sourceAsts) dapp++ -- We use the target source file to make a relevant subgraph+ -- with only files transitively depended on from the target.+ case Map.lookup target indices of+ Nothing ->+ error "didn't find contract AST"+ Just root -> do+ let+ -- Restrict the graph to only the needed nodes,+ -- discovered via breadth-first search from the target.+ subgraph :: Fgl.Gr Text ()+ subgraph = Fgl.subgraph (Fgl.bfs root graph) graph++ -- Now put the source file paths in the right order+ -- by sorting topologically.+ ordered :: [Text]+ ordered = reverse (Fgl.topsort' subgraph)++ -- Take the highest Solidity version from all pragmas.+ pragma :: Text+ pragma = maximalPragma (Map.elems asts)++ -- Read the source files in order and strip unwanted directives.+ -- Also add an informative comment with the original source file path.+ sources <-+ forM ordered $ \path -> do+ src <- BS.readFile (unpack path)+ pure $ mconcat+ [ "////// ", encodeUtf8 path, "\n"+ , stripImportsAndPragmas src (asts ! path), "\n"+ ]++ -- Finally print the whole concatenation.+ putStrLn $ "// hevm: flattened sources of " <> unpack target+ putStrLn (unpack pragma)+ BS.putStr (mconcat sources)++-- Construct a new Solidity version pragma for the highest mentioned version+-- given a list of source file ASTs.+maximalPragma :: [Value] -> Text+maximalPragma asts =+ case mapMaybe versions asts of+ [] -> error "no Solidity version pragmas in any source files"+ xs ->+ "pragma solidity ^"+ <> intercalate "." (map (pack . show) (maximum xs))+ <> ";\n"++ where+ -- Get the version components from a source file's pragma,+ -- or nothing if no pragma present.+ versions :: Value -> Maybe [Int]+ versions ast = fmap grok components+ where+ pragma :: Maybe Value+ pragma =+ case filter (nodeIs "PragmaDirective") (universe ast) of+ [x] -> Just x+ [] -> Nothing+ _ -> error "multiple version pragmas"++ components :: Maybe [Value]+ components = fmap toList+ (pragma >>= preview (key "attributes" . key "literals" . _Array))++ grok :: [Value] -> [Int]+ 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))+ x ->+ error ("unrecognized pragma: " ++ show x)++nodeIs :: Text -> Value -> Bool+nodeIs t x = isSourceNode && hasRightName+ where+ isSourceNode =+ isJust (preview (key "src") x)+ hasRightName =+ Just t == preview (key "name" . _String) x++stripImportsAndPragmas :: ByteString -> Value -> ByteString+stripImportsAndPragmas bs ast = stripAstNodes bs ast p+ where+ p x = nodeIs "ImportDirective" x || nodeIs "PragmaDirective" x++stripAstNodes :: ByteString -> Value -> (Value -> Bool) -> ByteString+stripAstNodes bs ast p =+ cutRanges [sourceRange node | node <- universe ast, p node]++ where+ -- Parses the `src` field of an AST node into a pair of byte indices.+ sourceRange :: Value -> (Int, Int)+ sourceRange v =+ case preview (key "src" . _String) v of+ Just (Text.splitOn ":" -> [readAs -> Just i, readAs -> Just n, _]) ->+ (i, i + n)+ _ ->+ error "internal error: no source position for AST node"++ -- Removes a set of non-overlapping ranges from a bytestring+ -- by commenting them out.+ cutRanges :: [(Int, Int)] -> ByteString+ cutRanges (sort -> rs) = fst (foldl' f (bs, 0) rs)+ where+ f (bs', n) (i, j) =+ ( cut bs' (i + n) (j + n)+ , n + length ("/* */" :: String))++ -- Comments out the bytes between two indices from a bytestring.+ cut :: ByteString -> Int -> Int -> ByteString+ cut x i j =+ let (a, b) = BS.splitAt i x+ in a <> "/* " <> BS.take (j - i) b <> " */" <> BS.drop (j - i) b++readAs :: Read a => Text -> Maybe a+readAs = readMaybe . Text.unpack
+ src/EVM/Format.hs view
@@ -0,0 +1,280 @@+module EVM.Format where++import Prelude hiding (Word)++import EVM (VM, cheatCode, traceForest, traceData)+import EVM (Trace, TraceData (..), Log (..), Query (..), FrameContext (..))+import EVM.Dapp (DappInfo, dappSolcByHash, showTraceLocation, dappEventMap)+import EVM.Concrete (Word (..), Blob (..))+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.Solidity (SolcContract, contractName, abiMap)+import EVM.Solidity (methodOutput, methodSignature)+import EVM.Concrete (forceConcreteBlob, forceConcreteWord)++import Control.Arrow ((>>>))+import Control.Lens (view, preview, ix, _2, to, _Just)+import Data.Binary.Get (runGetOrFail)+import Data.ByteString (ByteString)+import Data.ByteString.Builder (byteStringHex, toLazyByteString)+import Data.ByteString.Lazy (toStrict, fromStrict)+import Data.DoubleWord (signedWord)+import Data.Foldable (toList)+import Data.Map (Map)+import Data.Maybe (catMaybes)+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 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++showDec :: Signedness -> W256 -> Text+showDec signed (W256 w) =+ let+ i = case signed of+ Signed -> num (signedWord w)+ Unsigned -> num w++ in+ if i == num cheatCode+ then "<hevm cheat address>"+ else+ if abs i > 1000000000000+ then+ "~" <> pack (Scientific.formatScientific+ Scientific.Generic+ (Just 8)+ (fromIntegral i))+ else+ showDecExact i++showDecExact :: Integer -> Text+showDecExact = humanizeInteger++showWordExact :: Word -> Text+showWordExact (C _ (W256 w)) = humanizeInteger w++humanizeInteger :: (Num a, Integral a, Show a) => a -> Text+humanizeInteger =+ ( Text.intercalate ","+ . reverse+ . map Text.reverse+ . Text.chunksOf 3+ . Text.reverse+ . Text.pack+ . show+ )++-- TODO: make polymorphic+showAbiValues :: Vector AbiValue -> Text+showAbiValues vs =+ "(" <> intercalate ", " (toList (fmap showAbiValue vs)) <> ")"++showAbiArray :: Vector AbiValue -> Text+showAbiArray vs =+ "[" <> intercalate ", " (toList (fmap showAbiValue vs)) <> "]"++showAbiValue :: AbiValue -> Text+showAbiValue (AbiUInt _ w) =+ pack $ show w+showAbiValue (AbiInt _ w) =+ pack $ show w+showAbiValue (AbiBool b) =+ pack $ show b+showAbiValue (AbiAddress w160) =+ pack $ "0x" ++ (showHex w160 "")+showAbiValue (AbiBytes _ bs) =+ formatBytes bs+showAbiValue (AbiBytesDynamic bs) =+ formatBinary bs+showAbiValue (AbiString bs) =+ formatQString bs+showAbiValue (AbiArray _ _ xs) =+ showAbiArray xs+showAbiValue (AbiArrayDynamic _ xs) =+ showAbiArray xs++isPrintable :: ByteString -> Bool+isPrintable =+ decodeUtf8' >>>+ either (const False)+ (Text.all (not . Char.isControl))++formatBytes :: ByteString -> Text+formatBytes b =+ let (s, _) = BS.spanEnd (== 0) b+ in+ if isPrintable s+ then formatQString s+ else formatBinary b++formatQString :: ByteString -> Text+formatQString = pack . show++formatString :: ByteString -> Text+formatString bs = decodeUtf8 (fst (BS.spanEnd (== 0) bs))++formatBinary :: ByteString -> Text+formatBinary =+ (<>) "0x" . decodeUtf8 . toStrict . toLazyByteString . byteStringHex++showTraceTree :: DappInfo -> VM -> Text+showTraceTree dapp =+ traceForest+ >>> fmap (fmap (unpack . showTrace dapp))+ >>> concatMap showTree+ >>> pack++showTrace :: DappInfo -> Trace -> Text+showTrace dapp trace =+ let+ pos =+ case showTraceLocation dapp trace of+ Left x -> " \x1b[90m" <> x <> "\x1b[0m"+ Right x -> " \x1b[90m(" <> x <> ")\x1b[0m"+ in case view traceData trace of+ EventTrace (Log _ bytes topics) ->+ case topics of+ (t:_) ->+ formatLog+ (getEvent t (view dappEventMap dapp))+ (forceConcreteBlob bytes) <> pos+ _ ->+ "log" <> pos+ 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+ ErrorTrace e ->+ "\x1b[91merror\x1b[0m " <> pack (show e) <> pos++ ReturnTrace output (CallContext _ _ hash (Just abi) _ _) ->+ case getAbiMethodOutput dapp hash abi of+ Nothing ->+ "← " <> formatBinary (forceConcreteBlob output)+ Just (_, t) ->+ "← " <> abiTypeSolidity t <> " " <> showValue t (forceConcreteBlob output)+ ReturnTrace output (CallContext {}) ->+ "← " <> formatBinary (forceConcreteBlob output)+ ReturnTrace _ (CreationContext {}) ->+ error "internal error: shouldn't show returns for creates"++ EntryTrace t ->+ t+ FrameTrace (CreationContext hash) ->+ "create " <> maybeContractName (preview (dappSolcByHash . ix hash . _2) dapp) <> pos+ FrameTrace (CallContext _ _ hash abi calldata _) ->+ case preview (dappSolcByHash . ix hash . _2) dapp of+ Nothing ->+ "call [unknown]" <> pos+ Just solc ->+ "call "+ <> "\x1b[1m"+ <> view (contractName . to contractNamePart) solc+ <> "::"+ <> maybe ("[fallback function]")+ (\x -> maybe "[unknown method]" id (maybeAbiName solc x))+ abi+ <> maybe ("(" <> formatBinary (forceConcreteBlob calldata) <> ")")+ -- todo: if unknown method, then just show raw calldata+ (\x -> showCall (catMaybes x) (forceConcreteBlob calldata))+ (abi >>= fmap getAbiTypes . maybeAbiName solc)+ <> "\x1b[0m"+ <> pos++getAbiMethodOutput+ :: DappInfo -> W256 -> Word -> Maybe (Text, AbiType)+getAbiMethodOutput dapp hash abi =+ -- Some typical ugly lens code. :'(+ preview+ ( dappSolcByHash . ix hash . _2 . abiMap+ . ix (fromIntegral abi) . methodOutput . _Just+ )+ dapp++getAbiTypes :: Text -> [Maybe AbiType]+getAbiTypes abi = map parseTypeName 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+ Right (_, _, xs) -> showAbiValues xs+ Left (_, _, _) -> formatBinary bs++showValue :: AbiType -> ByteString -> Text+showValue t bs =+ case runGetOrFail (getAbi t) (fromStrict bs) of+ Right (_, _, x) -> showAbiValue x+ Left (_, _, _) -> formatBinary bs++maybeContractName :: Maybe SolcContract -> Text+maybeContractName =+ maybe "<unknown contract>" (view (contractName . to contractNamePart))++maybeAbiName :: SolcContract -> Word -> Maybe Text+maybeAbiName solc abi = preview (abiMap . ix (fromIntegral abi) . methodSignature) solc++contractNamePart :: Text -> Text+contractNamePart x = Text.split (== ':') x !! 1++contractPathPart :: Text -> Text+contractPathPart x = Text.split (== ':') x !! 0++-- TODO: this should take Log+formatLog :: Maybe Event -> ByteString -> Text+formatLog event args =+ let types = getEventUnindexedTypes event+ name = getEventName event+ in+ case runGetOrFail (getAbiSeq (length types) types)+ (fromStrict args) of+ Right (_, _, abivals) ->+ mconcat+ [ "\x1b[36m"+ , name+ , showAbiValues abivals+ , "\x1b[0m"+ ]+ Left (_,_,_) ->+ error "lol"++getEvent :: Word -> Map W256 Event -> Maybe Event+getEvent w events = Map.lookup (forceConcreteWord w) events++getEventName :: Maybe Event -> Text+getEventName (Just (Event name _ _)) = name+getEventName Nothing = "<unknown-event>"++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]++getEventArgs :: Blob -> Text+getEventArgs b = formatBlob b++formatBlob :: Blob -> Text+formatBlob b = decodeUtf8 $ forceConcreteBlob b
+ src/EVM/Keccak.hs view
@@ -0,0 +1,102 @@+{-# Language CPP #-}++#ifdef __GHCJS__+{-# Language JavaScriptFFI #-}+#endif++module EVM.Keccak (keccak, abiKeccak, newContractAddress) where++import EVM.Types++import Control.Arrow ((>>>))++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 =+ (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+ >>> BS.take 32+ >>> word++abiKeccak :: ByteString -> Word32+abiKeccak =+ keccakBytes+ >>> 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])
+ src/EVM/Op.hs view
@@ -0,0 +1,76 @@+module EVM.Op (Op (..)) where++import EVM.Types (W256)+import Data.Word (Word8)++data Op+ = OpStop+ | OpAdd+ | OpMul+ | OpSub+ | OpDiv+ | OpSdiv+ | OpMod+ | OpSmod+ | OpAddmod+ | OpMulmod+ | OpExp+ | OpSignextend+ | OpLt+ | OpGt+ | OpSlt+ | OpSgt+ | OpEq+ | OpIszero+ | OpAnd+ | OpOr+ | OpXor+ | OpNot+ | OpByte+ | OpSha3+ | OpAddress+ | OpBalance+ | OpOrigin+ | OpCaller+ | OpCallvalue+ | OpCalldataload+ | OpCalldatasize+ | OpCalldatacopy+ | OpCodesize+ | OpCodecopy+ | OpGasprice+ | OpExtcodesize+ | OpExtcodecopy+ | OpReturndatasize+ | OpReturndatacopy+ | OpBlockhash+ | OpCoinbase+ | OpTimestamp+ | OpNumber+ | OpDifficulty+ | OpGaslimit+ | OpPop+ | OpMload+ | OpMstore+ | OpMstore8+ | OpSload+ | OpSstore+ | OpJump+ | OpJumpi+ | OpPc+ | OpMsize+ | OpGas+ | OpJumpdest+ | OpCreate+ | OpCall+ | OpCallcode+ | OpReturn+ | OpDelegatecall+ | OpRevert+ | OpSelfdestruct+ | OpDup !Word8+ | OpSwap !Word8+ | OpLog !Word8+ | OpPush !W256+ | OpUnknown Word8+ deriving (Show, Eq)
+ src/EVM/Precompiled.hs view
@@ -0,0 +1,65 @@+{-# Language ForeignFunctionInterface #-}++module EVM.Precompiled (execute) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS++import Foreign.C+import Foreign.Ptr+import Foreign.ForeignPtr++import System.IO.Unsafe++-- | Opaque representation of the C library's context struct.+data EthjetContext++foreign import ccall "ethjet_init"+ ethjet_init :: IO (Ptr EthjetContext)+foreign import ccall "ðjet_free"+ ethjet_free :: FunPtr (Ptr EthjetContext -> IO ())+foreign import ccall "ethjet"+ ethjet+ :: Ptr EthjetContext -- initialized context+ -> CInt -- operation+ -> Ptr CChar -> CInt -- input+ -> Ptr CChar -> CInt -- output+ -> IO CInt -- 1 if good++-- Lazy evaluation ensures this context is only initialized once,+-- and `unsafePerformIO` in such situations is a common pattern.+--+-- We use a "foreign pointer" annotated with a finalizer.+globalContext :: ForeignPtr EthjetContext+{-# NOINLINE globalContext #-}+globalContext =+ unsafePerformIO $+ ethjet_init >>= newForeignPtr ethjet_free++-- | Run a given precompiled contract using the C library.+execute+ :: Int -- ^ The number of the precompiled contract+ -> ByteString -- ^ The input buffer+ -> Int -- ^ The desired output size+ -> Maybe ByteString -- ^ Hopefully, the output buffer+execute contract input outputSize =++ -- This code looks messy because of the pointer handling,+ -- but it's actually simple.+ --+ -- We use `unsafePerformIO` because the contracts are pure.++ unsafePerformIO . BS.useAsCStringLen input $+ \(inputPtr, inputSize) -> do+ outputForeignPtr <- mallocForeignPtrBytes outputSize+ withForeignPtr outputForeignPtr $ \outputPtr -> do+ status <-+ withForeignPtr globalContext $ \contextPtr ->+ -- Finally, we can invoke the C library.+ ethjet contextPtr (fromIntegral contract)+ inputPtr (fromIntegral inputSize)+ outputPtr (fromIntegral outputSize)++ case status of+ 1 -> Just <$> BS.packCStringLen (outputPtr, outputSize)+ _ -> pure Nothing
+ src/EVM/Solidity.hs view
@@ -0,0 +1,372 @@+{-# Language DeriveAnyClass #-}+{-# Language StrictData #-}+{-# Language TemplateHaskell #-}++module EVM.Solidity+ ( solidity+ , JumpType (..)+ , SolcContract (..)+ , SourceCache (..)+ , SrcMap (..)+ , CodeType (..)+ , Method (..)+ , methodName+ , methodSignature+ , methodInputs+ , methodOutput+ , abiMap+ , eventMap+ , contractName+ , creationCode+ , makeSrcMaps+ , readSolc+ , runtimeCode+ , snippetCache+ , runtimeCodehash+ , creationCodehash+ , runtimeSrcmap+ , creationSrcmap+ , contractAst+ , sourceFiles+ , sourceLines+ , sourceAsts+ , stripBytecodeMetadata+ , lineSubrange+ , astIdMap+ , astSrcMap+) where++import EVM.ABI+import EVM.Keccak+import EVM.Types++import Control.Applicative+import Control.Lens hiding (Indexed)+import Data.Aeson (Value (..))+import Data.Aeson.Lens+import Data.ByteString (ByteString)+import Data.Char (isDigit, digitToInt)+import Data.Foldable+import Data.Map.Strict (Map)+import Data.Maybe+import Data.Monoid+import Data.Sequence (Seq)+import Data.Text (Text, pack, intercalate)+import Data.Text.Encoding (encodeUtf8)+import Data.Text.IO (readFile, writeFile)+import Data.Vector (Vector)+import Data.Word+import GHC.Generics (Generic)+import Prelude hiding (readFile, writeFile)+import System.IO hiding (readFile, writeFile)+import System.IO.Temp+import System.Process+import Text.Read (readMaybe)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as BS16+import qualified Data.HashMap.Strict as HMap+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Data.Vector as Vector++data SolcContract = SolcContract+ { _runtimeCodehash :: W256+ , _creationCodehash :: W256+ , _runtimeCode :: ByteString+ , _creationCode :: ByteString+ , _contractName :: Text+ , _abiMap :: Map Word32 Method+ , _eventMap :: Map W256 Event+ , _runtimeSrcmap :: Seq SrcMap+ , _creationSrcmap :: Seq SrcMap+ , _contractAst :: Value+ } deriving (Show, Eq, Generic)++data Method = Method+ { _methodOutput :: Maybe (Text, AbiType)+ , _methodInputs :: [(Text, AbiType)]+ , _methodName :: Text+ , _methodSignature :: Text+ } deriving (Show, Eq, Ord, Generic)++data SourceCache = SourceCache+ { _snippetCache :: Map (Int, Int) ByteString+ , _sourceFiles :: Map Int (Text, ByteString)+ , _sourceLines :: Map Int (Vector ByteString)+ , _sourceAsts :: Map Text Value+ } deriving (Show, Eq, Generic)++instance Monoid SourceCache where+ mempty = SourceCache mempty mempty mempty mempty+ mappend (SourceCache _ _ _ _) (SourceCache _ _ _ _) = error "lol"++data JumpType = JumpInto | JumpFrom | JumpRegular+ deriving (Show, Eq, Ord, Generic)++data SrcMap = SM {+ srcMapOffset :: {-# UNPACK #-} Int,+ srcMapLength :: {-# UNPACK #-} Int,+ srcMapFile :: {-# UNPACK #-} Int,+ srcMapJump :: JumpType+} 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+ | Fe+ deriving Show++data CodeType = Creation | Runtime+ deriving (Show, Eq, Ord)++makeLenses ''SolcContract+makeLenses ''SourceCache+makeLenses ''Method++-- Obscure but efficient parser for the Solidity sourcemap format.+makeSrcMaps :: Text -> Maybe (Seq SrcMap)+makeSrcMaps = (\case (_, Fe, _) -> Nothing; x -> Just (done x))+ . Text.foldl' (\x y -> go y x) (mempty, F1 [] 1, SM 0 0 0 JumpRegular)+ 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'++ 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 '-' (xs, F1 [] _, p) = (xs, F1 [] (-1), p)+ go d (xs, F1 ds k, p) | isDigit d = (xs, F1 (digitToInt 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, 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+ (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 '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 c (xs, _, p) = (xs, error ("srcmap: y u " ++ show c ++ "?!?"), p)++makeSourceCache :: [Text] -> Map Text Value -> IO SourceCache+makeSourceCache paths asts = do+ xs <- mapM (BS.readFile . Text.unpack) paths+ return $! SourceCache+ { _snippetCache = mempty+ , _sourceFiles =+ Map.fromList (zip [0..] (zip paths xs))+ , _sourceLines =+ Map.fromList (zip [0 .. length paths - 1]+ (map (Vector.fromList . BS.split 0xa) xs))+ , _sourceAsts =+ asts+ }++lineSubrange ::+ Vector ByteString -> (Int, Int) -> Int -> Maybe (Int, Int)+lineSubrange xs (s1, n1) i =+ let+ ks = Vector.map (\x -> 1 + BS.length x) xs+ s2 = Vector.sum (Vector.take i ks)+ n2 = ks Vector.! i+ in+ if s1 + n1 < s2 || s1 > s2 + n2+ then Nothing+ else Just (s1 - s2, min (s2 + n2 - s1) n1)++readSolc :: FilePath -> IO (Maybe (Map Text SolcContract, SourceCache))+readSolc fp =+ (readJSON <$> readFile fp) >>=+ \case+ Nothing -> return Nothing+ Just (contracts, asts, sources) -> do+ sourceCache <- makeSourceCache sources asts+ return $! Just (contracts, sourceCache)++solidity :: Text -> Text -> IO (Maybe ByteString)+solidity contract src = do+ (json, path) <- solidity' src+ let Just (solc, _, _) = readJSON json+ return (solc ^? ix (path <> ":" <> contract) . creationCode)++force :: String -> Maybe a -> a+force s = fromMaybe (error s)++readJSON :: Text -> Maybe (Map Text SolcContract, Map Text Value, [Text])+readJSON json = do+ contracts <-+ f <$> (json ^? key "contracts" . _Object)+ <*> (fmap (fmap (^. _String)) $ json ^? key "sourceList" . _Array)+ sources <- toList . fmap (view _String) <$> json ^? key "sourceList" . _Array+ return (contracts, Map.fromList (HMap.toList asts), sources)+ where+ asts = fromMaybe (error "JSON lacks abstract syntax trees.") (json ^? key "sources" . _Object)+ f x y = Map.fromList . map (g y) . HMap.toList $ x+ g _ (s, x) =+ let+ theRuntimeCode = toCode (x ^?! key "bin-runtime" . _String)+ theCreationCode = toCode (x ^?! key "bin" . _String)+ in (s, SolcContract {+ _runtimeCode = theRuntimeCode,+ _creationCode = theCreationCode,+ _runtimeCodehash = keccak (stripBytecodeMetadata theRuntimeCode),+ _creationCodehash = keccak (stripBytecodeMetadata theCreationCode),+ _runtimeSrcmap = force "internal error: srcmap-runtime" (makeSrcMaps (x ^?! key "srcmap-runtime" . _String)),+ _creationSrcmap = force "internal error: srcmap" (makeSrcMaps (x ^?! key "srcmap" . _String)),+ _contractName = s,+ _contractAst =+ fromMaybe+ (error "JSON lacks abstract syntax trees.")+ (preview (ix (Text.split (== ':') s !! 0) . key "AST") asts),+ _abiMap = Map.fromList $+ let+ abis =+ toList ((x ^?! key "abi" . _String) ^?! _Array)+ relevant =+ filter (\y -> "function" == y ^?! key "type" . _String) abis+ in flip map relevant $+ \abi -> (+ abiKeccak (encodeUtf8 (signature abi)),+ Method+ { _methodName = abi ^?! key "name" . _String+ , _methodSignature = signature abi+ , _methodInputs =+ map parseMethodInput+ (toList (abi ^?! key "inputs" . _Array))+ , _methodOutput =+ fmap parseMethodInput+ (abi ^? key "outputs" . _Array . ix 0)+ }+ ),+ _eventMap = Map.fromList $+ flip map (filter (\y -> "event" == y ^?! key "type" . _String)+ . toList $ (x ^?! key "abi" . _String) ^?! _Array) $+ \abi ->+ ( keccak (encodeUtf8 (signature abi))+ , Event+ (abi ^?! key "name" . _String)+ (case abi ^?! key "anonymous" . _Bool of+ True -> Anonymous+ False -> NotAnonymous)+ (map (\y -> ( force "internal error: type" (parseTypeName (y ^?! key "type" . _String))+ , if y ^?! key "indexed" . _Bool+ then Indexed+ else NotIndexed ))+ (toList $ abi ^?! key "inputs" . _Array))+ )+ })++signature :: AsValue s => s -> Text+signature abi =+ case abi ^?! key "type" of+ "fallback" -> "<fallback>"+ _ ->+ fold [+ fromMaybe "<constructor>" (abi ^? key "name" . _String), "(",+ intercalate ","+ (map (\x -> x ^?! key "type" . _String)+ (toList $ abi ^?! key "inputs" . _Array)),+ ")"+ ]++-- This actually can also parse a method output! :O+parseMethodInput :: (Show s, AsValue s) => s -> (Text, AbiType)+parseMethodInput x =+ ( x ^?! key "name" . _String+ , force "internal error: method type" (parseTypeName (x ^?! key "type" . _String))+ )++toCode :: Text -> ByteString+toCode = fst . BS16.decode . encodeUtf8++solidity' :: Text -> IO (Text, Text)+solidity' src = withSystemTempFile "hevm.sol" $ \path handle -> do+ hClose handle+ writeFile path ("pragma solidity ^0.4.8;\n" <> src)+ x <- pack <$>+ readProcess+ "solc"+ ["--combined-json=bin-runtime,bin,srcmap,srcmap-runtime,abi,ast", path]+ ""+ return (x, pack path)++-- When doing CREATE and passing constructor arguments, Solidity loads+-- the argument data via the creation bytecode, since there is no "calldata"+-- for CREATE.+--+-- This interferes with our ability to look up the current contract by+-- codehash, so we must somehow strip away this extra suffix. Luckily+-- we can detect the end of the actual bytecode by looking for the+-- "metadata hash". (Not 100% correct, but works in practice.)+--+-- Actually, we strip away the entire BZZR suffix too, because as long+-- 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]++-- | Every node in the AST has an ID, and other nodes reference those+-- IDs. This function recurses through the tree looking for objects+-- with the "id" key and makes a big map from ID to value.+astIdMap :: Foldable f => f Value -> Map Int Value+astIdMap = foldMap f+ where+ f :: Value -> Map Int Value+ f (Array x) = foldMap f x+ f v@(Object x) =+ let t = foldMap f (HMap.elems x)+ in case HMap.lookup "id" x of+ Nothing -> t+ Just (Number i) -> t <> Map.singleton (round i) v+ Just _ -> t+ f _ = mempty++astSrcMap :: Map Int Value -> (SrcMap -> Maybe Value)+astSrcMap astIds =+ \(SM i n f _) -> Map.lookup (i, n, f) tmp+ where+ tmp :: Map (Int, Int, Int) Value+ tmp =+ ( Map.fromList+ . catMaybes+ . map (\v ->+ case preview (key "src" . _String) v of+ Just src ->+ case map (readMaybe . Text.unpack) (Text.split (== ':') src) of+ [Just i, Just n, Just f] ->+ Just ((i, n, f), v)+ _ ->+ error "strange formatting of src field"+ _ ->+ Nothing)+ . Map.elems+ $ astIds+ )
+ src/EVM/Stepper.hs view
@@ -0,0 +1,122 @@+{-# Language GADTs #-}+{-# Language NamedFieldPuns #-}++module EVM.Stepper+ ( Action (..)+ , Failure (..)+ , Stepper+ , exec+ , execFully+ , execFullyOrFail+ , decode+ , fail+ , wait+ , evm+ , note+ , entering+ , enter+ )+where++-- This module is an abstract definition of EVM steppers.+-- Steppers can be run as TTY debuggers or as CLI test runners.+--+-- The implementation uses the operational monad pattern+-- as the framework for monadic interpretation.+--+-- Note: this is a sketch of a work in progress!++import Prelude hiding (fail)++import Control.Monad.Operational (Program, singleton)+import Data.Binary.Get (runGetOrFail)+import Data.Text (Text)++import EVM (EVM, VMResult (VMFailure, VMSuccess), Error (Query), Query)+import qualified EVM++import EVM.ABI (AbiType, AbiValue, getAbi)+import EVM.Concrete (Blob (B))++import qualified Data.ByteString.Lazy as LazyByteString++-- | The instruction type of the operational monad+data Action a where++ -- | Keep executing until an intermediate result is reached+ Exec :: Action VMResult+ + -- | Short-circuit with a failure+ Fail :: Failure -> Action a+ + -- | Wait for a query to be resolved+ Wait :: Query -> 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++-- Singleton actions++exec :: Stepper VMResult+exec = singleton Exec++fail :: Failure -> Stepper a+fail = singleton . Fail++wait :: Query -> Stepper ()+wait = singleton . Wait++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 Blob)+execFully =+ exec >>= \case+ VMFailure (Query q) ->+ wait q >> execFully+ VMFailure x ->+ pure (Left x)+ VMSuccess x ->+ pure (Right x)++execFullyOrFail :: Stepper Blob+execFullyOrFail = execFully >>= either (fail . VMFailed) pure++-- | Decode a blob as an ABI value, failing if ABI encoding wrong+decode :: AbiType -> Blob -> Stepper AbiValue+decode abiType (B bytes) =+ case runGetOrFail (getAbi abiType) (LazyByteString.fromStrict bytes) of+ Right ("", _, x) ->+ pure x+ Right _ ->+ fail DecodingError+ Left _ ->+ fail DecodingError++entering :: Text -> Stepper a -> Stepper a+entering t stepper = do+ evm (EVM.pushTrace (EVM.EntryTrace t))+ x <- stepper+ evm EVM.popTrace+ pure x++enter :: Text -> Stepper ()+enter t = do+ evm (EVM.pushTrace (EVM.EntryTrace t))
+ src/EVM/StorageLayout.hs view
@@ -0,0 +1,185 @@+module EVM.StorageLayout where++-- 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 Data.Aeson (Value (Number))+import Data.Aeson.Lens++import Control.Lens++import Data.Text (Text, unpack, 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++import Prelude hiding (words)++-- A contract has all the slots of its inherited contracts.+--+-- The slot order is determined by the inheritance linearization order,+-- so we first have to calculate that.+--+-- This information is available in the abstract syntax tree.++findContractDefinition :: DappInfo -> SolcContract -> Maybe Value+findContractDefinition dapp solc =+ -- The first source mapping in the contract's creation code+ -- corresponds to the source field of the contract definition.+ case Seq.viewl (view creationSrcmap solc) of+ firstSrcMap Seq.:< _ ->+ (view dappAstSrcMap dapp) firstSrcMap+ _ ->+ Nothing++storageLayout :: DappInfo -> SolcContract -> [Text]+storageLayout dapp solc =+ let+ root :: Value+ root =+ fromMaybe (error "no contract definition AST")+ (findContractDefinition dapp solc)+ in+ case preview ( key "attributes"+ . key "linearizedBaseContracts"+ . _Array+ ) root of+ Nothing ->+ []+ Just ((reverse . toList) -> linearizedBaseContracts) ->+ flip concatMap linearizedBaseContracts+ (\case+ Number i -> fromMaybe (error "malformed AST JSON") $+ storageVariablesForContract =<<+ preview (dappAstIdMap . ix (floor i)) dapp+ _ ->+ error "malformed AST JSON")++storageVariablesForContract :: Value -> Maybe [Text]+storageVariablesForContract node = do+ name <- preview (ix "attributes" . key "name" . _String) node+ vars <-+ fmap+ (filter isStorageVariableDeclaration . toList)+ (preview (ix "children" . _Array) node)++ pure . flip map vars $+ \x ->+ case preview (key "attributes" . key "name" . _String) x of+ Just variableName ->+ mconcat+ [ variableName+ , " (", name, ")"+ , "\n", " Type: "+ , slotTypeSolidity (slotTypeForDeclaration x)+ ]+ Nothing ->+ error "malformed variable declaration"++nodeIs :: Text -> Value -> Bool+nodeIs t x = isSourceNode && hasRightName+ where+ isSourceNode =+ isJust (preview (key "src") x)+ hasRightName =+ Just t == preview (key "name" . _String) x++isStorageVariableDeclaration :: Value -> Bool+isStorageVariableDeclaration x =+ nodeIs "VariableDeclaration" x+ && preview (key "attributes" . key "constant" . _Bool) x /= Just True++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+ Just (x:_) ->+ grokDeclarationType x+ _ ->+ error "malformed AST"++grokDeclarationType :: Value -> SlotType+grokDeclarationType x =+ case preview (key "name" . _String) x of+ Just "Mapping" ->+ case preview (key "children" . _Array) x of+ Just (toList -> xs) ->+ grokMappingType xs+ _ ->+ error "malformed AST"+ Just _ ->+ StorageValue (grokValueType x)+ _ ->+ error ("malformed AST " ++ show x)++grokMappingType :: [Value] -> SlotType+grokMappingType [s, t] =+ case (grokDeclarationType s, grokDeclarationType t) of+ (StorageValue s', StorageMapping t' x) ->+ StorageMapping (NonEmpty.cons s' t') x+ (StorageValue s', StorageValue t') ->+ StorageMapping (pure s') t'+ (StorageMapping _ _, _) ->+ error "unexpected mapping as mapping key"+grokMappingType _ =+ error "unexpected AST child count for mapping"++grokValueType :: Value -> AbiType+grokValueType x =+ case ( preview (key "name" . _String) x+ , preview (key "children" . _Array) x+ , preview (key "attributes" . key "type" . _String) x+ ) of+ (Just "ElementaryTypeName", _, Just typeName) ->+ case parseTypeName (head (words typeName)) of+ Just t -> t+ Nothing ->+ error ("ungrokked value type: " ++ show typeName)+ (Just "UserDefinedTypeName", _, _) ->+ AbiAddressType+ (Just "ArrayTypeName", fmap toList -> Just [t], _)->+ AbiArrayDynamicType (grokValueType t)+ (Just "ArrayTypeName", fmap toList -> Just [t, n], _)->+ case ( preview (key "name" . _String) n+ , preview (key "attributes" . key "value" . _String) n+ ) of+ (Just "Literal", Just ((read . unpack) -> i)) ->+ AbiArrayType i (grokValueType t)+ _ ->+ error "malformed AST"+ _ ->+ error ("unknown value type " ++ show x)
+ src/EVM/TTY.hs view
@@ -0,0 +1,894 @@+{-# Language TemplateHaskell #-}+{-# Language ImplicitParams #-}++module EVM.TTY where++import Prelude hiding (Word)++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center+import Brick.Widgets.List++import EVM+import EVM.Concrete (Word (C))+import EVM.Dapp (DappInfo, dappInfo)+import EVM.Dapp (dappUnitTests, 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.Op+import EVM.Solidity+import EVM.Types hiding (padRight)+import EVM.UnitTest (UnitTestOptions (..))+import EVM.UnitTest (initialUnitTestVm)+import EVM.UnitTest (initializeUnitTest, runUnitTest)+import EVM.StorageLayout++import EVM.Stepper (Stepper)+import qualified EVM.Stepper as Stepper+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.Monoid ((<>))+import Data.Text (Text, unpack, pack)+import Data.Text.Encoding (decodeUtf8)+import Data.List (sort)+import Numeric (showHex)++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 System.Console.Haskeline as Readline++import qualified EVM.TTYCenteredList as Centered++data Name+ = AbiPane+ | StackPane+ | BytecodePane+ | TracePane+ | SolidityPane+ | SolidityViewport+ | TestPickerPane+ | BrowserPane+ 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]+ }++data UiTestPickerState = UiTestPickerState+ { _testPickerList :: List Name (Text, Text)+ , _testPickerDapp :: DappInfo+ }++data UiBrowserState = UiBrowserState+ { _browserContractList :: List Name (Addr, Contract)+ , _browserVm :: UiVmState+ }++data UiState+ = UiVmScreen UiVmState+ | UiVmBrowserScreen UiBrowserState+ | UiTestPickerScreen UiTestPickerState++makeLenses ''UiVmState+makeLenses ''UiTestPickerState+makeLenses ''UiBrowserState+makePrisms ''UiState++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++-- | 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++-- | This turns a @Stepper@ into a state action usable+-- from within the TTY loop, yielding a @StepOutcome@ depending on the @StepMode@.+interpret+ :: (?fetcher :: Fetcher)+ => StepMode+ -> Stepper a+ -> State UiVmState (StepOutcome a)+interpret mode =++ -- Like the similar interpreters in @EVM.UnitTest@ and @EVM.VMTest@,+ -- this one is implemented as an "operational monad interpreter".++ eval . Operational.view+ where+ eval+ :: Operational.ProgramView Stepper.Action a+ -> State UiVmState (StepOutcome a)++ eval (Operational.Return x) =+ pure (Returned x)++ eval (action Operational.:>>= k) =+ case action of++ -- 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++ StepMany i -> do+ -- Run one instruction.+ interpret StepOne restart >>=+ \case+ Stepped stepper ->+ interpret (StepMany (i - 1)) stepper++ -- This shouldn't happen, because re-stepping needs+ -- to avoid blocking and halting.+ r -> pure r++ 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++ -- 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 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 ())++ -- 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)++isUnitTestContract :: Text -> DappInfo -> Bool+isUnitTestContract name dapp =+ elem name (map fst (view dappUnitTests dapp))++mkVty :: IO Vty.Vty+mkVty = do+ vty <- Vty.mkVty Vty.defaultConfig+ Vty.setMode (Vty.outputIface vty) Vty.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 = []+ }+ ui1 = updateUiVmState ui0 vm & set uiVmFirstState ui1++ testOpts = UnitTestOptions+ { oracle = Fetch.zero+ , verbose = False+ , match = ""+ , vmModifier = id+ , testParams = error "irrelevant"+ }++ ui2 <- customMain mkVty Nothing (app testOpts) (UiVmScreen ui1)+ case ui2 of+ UiVmScreen ui -> return (view uiVm ui)+ _ -> error "internal error: customMain returned prematurely"++main :: UnitTestOptions -> FilePath -> FilePath -> IO ()+main opts root jsonFilePath = do+ readSolc jsonFilePath >>=+ \case+ Nothing ->+ error "Failed to read Solidity JSON"+ Just (contractMap, sourceCache) -> do+ let+ dapp = dappInfo root contractMap sourceCache+ ui = UiTestPickerScreen $ UiTestPickerState+ { _testPickerList =+ list+ TestPickerPane+ (Vec.fromList+ (concatMap+ (\(a, xs) -> [(a, x) | x <- xs])+ (view dappUnitTests dapp)))+ 1+ , _testPickerDapp = dapp+ }++ _ <- customMain 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)+ => UiVmState+ -> StepPolicy+ -> StepMode+ -> EventM n (Next UiState)+takeStep ui policy mode = do+ let m = interpret mode (view uiVmNextStep ui)++ case runState (m <* modify renderVm) ui of++ (Stepped stepper, ui') -> do+ continue (UiVmScreen (ui' & set uiVmNextStep stepper))++ (Blocked blocker, ui') ->+ case policy of+ StepNormally -> do+ stepper <- liftIO blocker+ takeStep+ (execState (assign uiVmNextStep stepper) ui')+ StepNormally StepNone++ StepTimidly ->+ error "step blocked unexpectedly"++ (Returned (), ui') ->+ case policy of+ StepNormally ->+ halt (UiVmScreen ui')+ StepTimidly ->+ error "step halted unexpectedly"++app :: UnitTestOptions -> App UiState () Name+app opts =+ let ?fetcher = oracle opts+ in App+ { appDraw = drawUi+ , appChooseCursor = neverShowCursor+ , appHandleEvent = \ui e ->++ case (ui, e) of+ (UiVmBrowserScreen s, VtyEvent (Vty.EvKey Vty.KEsc [])) ->+ continue (UiVmScreen (view browserVm s))++ (UiVmBrowserScreen s, VtyEvent e'@(Vty.EvKey Vty.KDown [])) -> do+ s' <- handleEventLensed s+ browserContractList+ handleListEvent+ e'+ continue (UiVmBrowserScreen s')++ (UiVmBrowserScreen s, VtyEvent e'@(Vty.EvKey Vty.KUp [])) -> do+ s' <- handleEventLensed s+ browserContractList+ handleListEvent+ e'+ continue (UiVmBrowserScreen s')++ (_, VtyEvent (Vty.EvKey Vty.KEsc [])) ->+ halt ui++ (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+ }++ (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+++ (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar 'n') [])) ->+ takeStep s StepNormally StepOne++ (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar 'N') [])) ->+ takeStep s+ StepNormally+ (StepUntil (isNextSourcePosition s))++ (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar 'n') [Vty.MCtrl])) ->+ takeStep s+ StepNormally+ (StepUntil (isNextSourcePositionWithoutEntering s))++ (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++ 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.+ let+ s0 = view uiVmFirstState s+ s1 = set (uiVm . cache) (view (uiVm . cache) s) s0++ -- Take n steps; "timidly," because all queries+ -- ought to be cached.+ takeStep s1 StepTimidly (StepMany (n - 1))++ (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++ (UiTestPickerScreen s', VtyEvent e') -> do+ s'' <- handleEventLensed s'+ testPickerList+ handleListEvent+ e'+ continue (UiTestPickerScreen s'')++ _ ->+ continue ui++ , appStartEvent = return+ , appAttrMap = const (attrMap Vty.defAttr myTheme)+ }++initialUiVmStateForTest+ :: UnitTestOptions+ -> DappInfo+ -> (Text, Text)+ -> UiVmState+initialUiVmStateForTest opts@(UnitTestOptions {..}) dapp (theContractName, theTestName) =+ ui1+ where+ 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 = []+ }+ Just testContract =+ view (dappSolcByName . at theContractName) dapp+ vm0 =+ initialUnitTestVm opts testContract (Map.elems (view dappSolcByName dapp))+ ui1 =+ updateUiVmState ui0 vm0 & set uiVmFirstState ui1++myTheme :: [(AttrName, Vty.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)+ ]++drawUi :: UiState -> [UiWidget]+drawUi (UiVmScreen s) = drawVm s+drawUi (UiTestPickerScreen s) = drawTestPicker s+drawUi (UiVmBrowserScreen s) = drawVmBrowser s++drawTestPicker :: UiTestPickerState -> [UiWidget]+drawTestPicker ui =+ [ center . borderWithLabel (txt "Unit tests") .+ hLimit 80 $+ renderList+ (\selected (x, y) ->+ withHighlight selected $+ txt " Debug " <+> txt (contractNamePart x) <+> txt "::" <+> txt y)+ True+ (view testPickerList ui)+ ]++drawVmBrowser :: UiBrowserState -> [UiWidget]+drawVmBrowser ui =+ [ hBox+ [ borderWithLabel (txt "Contracts") .+ hLimit 60 $+ renderList+ (\selected (k, c) ->+ withHighlight selected . txt . mconcat $+ [ fromMaybe "<unknown contract>" . flip preview ui $+ ( browserVm . uiVmDapp . _Just . 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)))+ Just solc ->+ hBox+ [ borderWithLabel (txt "Contract information") . padBottom Max . padRight (Pad 2) $ vBox+ [ txt "Name: " <+> txt (contractNamePart (view contractName solc))+ , txt "File: " <+> txt (contractPathPart (view contractName solc))+ , txt " "+ , txt "Public methods:"+ , vBox . flip map (sort (Map.elems (view abiMap solc))) $+ \method -> txt (" " <> view methodSignature method)+ ]+ , borderWithLabel (txt "Storage slots") . padBottom Max . padRight Max $ vBox+ (map txt (storageLayout dapp solc))+ ]+ ]+ ]++drawVm :: UiVmState -> [UiWidget]+drawVm ui =+ -- EVM debugging needs a lot of space because of the 256-bit words+ -- in both the bytecode and the stack .+ --+ -- If on a very tall display, prefer a vertical layout.+ --+ -- Actually the horizontal layout would be preferrable if the display+ -- is both very tall and very wide, but this is okay for now.+ [ ifTallEnough (20 * 4)+ ( vBox+ [ vLimit 20 $ drawBytecodePane ui+ , vLimit 20 $ drawStackPane ui+ , drawSolidityPane ui+ , vLimit 20 $ drawTracePane ui+ , vLimit 2 $ drawHelpBar+ ]+ )+ ( vBox+ [ hBox+ [ vLimit 20 $ drawBytecodePane ui+ , vLimit 20 $ drawStackPane ui+ ]+ , hBox $+ [ drawSolidityPane ui+ , drawTracePane ui+ ]+ , vLimit 2 $ drawHelpBar+ ]+ )+ ]++drawHelpBar :: UiWidget+drawHelpBar = hBorder <=> hCenter help+ where+ help =+ hBox (map (\(k, v) -> txt k <+> dim (txt (" (" <> v <> ") "))) helps)++ helps =+ [+ ("n", "step")+ , ("p", "step back")+ , ("N", "step more")+ , ("C-n", "step over")+-- , (" Enter", "browse")+ , (" Esc", "exit")+ ]++stepOneOpcode :: UiVmState -> UiVmState+stepOneOpcode ui =+ let+ nextVm = execState exec1 (view uiVm ui)+ in+ ui & over uiVmStepCount (+ 1)+ & set uiVm nextVm++isNextSourcePosition+ :: UiVmState -> Pred VM+isNextSourcePosition ui vm =+ let+ Just dapp = view uiVmDapp ui+ initialPosition = currentSrcMap dapp (view uiVm ui)+ in+ currentSrcMap dapp vm /= initialPosition++isNextSourcePositionWithoutEntering+ :: UiVmState -> Pred VM+isNextSourcePositionWithoutEntering ui vm =+ let+ vm0 = view uiVm ui+ Just dapp = view uiVmDapp ui+ initialPosition = currentSrcMap dapp vm0+ initialHeight = length (view frames vm0)+ in+ case currentSrcMap dapp vm of+ Nothing ->+ True+ Just here ->+ let+ moved = Just here /= initialPosition+ deeper = length (view frames vm) > initialHeight+ boring =+ case srcMapCode (view dappSources dapp) here of+ Just bs ->+ BS.isPrefixOf "contract " bs+ Nothing ->+ True+ in+ moved && not deeper && not boring++currentSrcMap :: DappInfo -> VM -> Maybe SrcMap+currentSrcMap dapp vm =+ let+ this = vm ^?! env . contracts . ix (view (state . codeContract) vm)+ i = (view opIxMap this) SVec.! (view (state . pc) vm)+ h = view codehash this+ in+ case preview (dappSolcByHash . ix h) dapp of+ Nothing ->+ Nothing+ Just (Creation, solc) ->+ preview (creationSrcmap . ix i) solc+ Just (Runtime, solc) ->+ preview (runtimeSrcmap . ix i) solc++currentSolc :: DappInfo -> VM -> Maybe SolcContract+currentSolc dapp vm =+ let+ this = vm ^?! env . contracts . ix (view (state . contract) vm)+ h = view codehash this+ in+ preview (dappSolcByHash . ix h . _2) dapp++renderVm :: UiVmState -> UiVmState+renderVm ui = updateUiVmState ui (view uiVm ui)++updateUiVmState :: UiVmState -> VM -> UiVmState+updateUiVmState ui vm =+ let+ move = case vmOpIx vm of+ Nothing -> id+ Just x -> listMoveTo x+ ui' = ui+ & set uiVm vm+ & set uiVmStackList+ (list StackPane (Vec.fromList $ zip [1..] (view (state . stack) vm)) 2)+ & set uiVmBytecodeList+ (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)++drawStackPane :: UiVmState -> UiWidget+drawStackPane ui =+ let+ gasText = showWordExact (view (uiVm . state . gas) ui)+ labelText = txt ("Gas available: " <> gasText <> "; stack:")+ in hBorderWithLabel labelText <=>+ renderList+ (\_ (i, x@(C _ w)) ->+ vBox+ [ withHighlight True (str ("#" ++ show i ++ " "))+ <+> str (show x)+ , dim (txt (" " <> showWordExplanation w (view uiVmDapp ui)))+ ])+ False+ (view uiVmStackList ui)++showWordExplanation :: W256 -> Maybe DappInfo -> Text+showWordExplanation w Nothing = showDec Unsigned w+showWordExplanation w _ | w > 0xffffffff = showDec Unsigned w+showWordExplanation w (Just dapp) =+ let+ fullAbiMap =+ mconcat (map (view abiMap) (Map.elems (view dappSolcByName dapp)))+ in+ case Map.lookup (fromIntegral w) fullAbiMap of+ Nothing -> showDec Unsigned w+ Just x -> "keccak(\"" <> view methodSignature x <> "\")"++drawBytecodePane :: UiVmState -> UiWidget+drawBytecodePane ui =+ hBorderWithLabel (case view uiVmMessage 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)++dim :: Widget n -> Widget n+dim = withDefAttr dimAttr++withHighlight :: Bool -> Widget n -> Widget n+withHighlight False = withDefAttr dimAttr+withHighlight True = withDefAttr boldAttr++drawTracePane :: UiVmState -> UiWidget+drawTracePane ui =+ hBorderWithLabel (txt "Trace") <=>+ renderList+ (\_ x -> txt x)+ False+ (view uiVmTraceList ui)++drawSolidityPane :: UiVmState -> UiWidget+drawSolidityPane ui@(view uiVmDapp -> Just dapp) =+ case currentSrcMap dapp (view uiVm ui) of+ Nothing -> padBottom Max (hBorderWithLabel (txt "<no source map>"))+ Just sm ->+ case view (dappSources . sourceLines . at (srcMapFile sm)) dapp of+ Nothing -> padBottom Max (hBorderWithLabel (txt "<source not found>"))+ Just rows ->+ let+ subrange i = lineSubrange rows (srcMapOffset sm, srcMapLength sm) i+ lineNo =+ (snd . fromJust $+ (srcMapCodePos+ (view dappSources dapp)+ sm)) - 1+ in vBox+ [ hBorderWithLabel $+ txt (maybe "<unknown>" contractPathPart+ (preview (uiVmSolc . _Just . contractName) ui))+ <+> str (":" ++ show lineNo)++ -- Show the AST node type if present+ <+> txt (" (" <> fromMaybe "?"+ ((view dappAstSrcMap dapp) sm+ >>= preview (key "name" . _String)) <> ")")+ , Centered.renderList+ (\_ (i, line) ->+ let s = case decodeUtf8 line of "" -> " "; y -> y+ in case subrange i of+ Nothing -> withHighlight False (txt s)+ Just (a, b) ->+ let (x, y, z) = ( Text.take a s+ , Text.take b (Text.drop a s)+ , Text.drop (a + b) s+ )+ in hBox [ withHighlight False (txt x)+ , withHighlight True (txt y)+ , withHighlight False (txt z)+ ])+ False+ (listMoveTo lineNo+ (view uiVmSolidityList 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 =+ Widget Greedy Greedy $ do+ c <- getContext+ if view availHeightL c > need+ 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"+ 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)++selectedAttr :: AttrName; selectedAttr = "selected"+dimAttr :: AttrName; dimAttr = "dim"+wordAttr :: AttrName; wordAttr = "word"+boldAttr :: AttrName; boldAttr = "bold"+activeAttr :: AttrName; activeAttr = "active"
+ src/EVM/TTYCenteredList.hs view
@@ -0,0 +1,71 @@+module EVM.TTYCenteredList where++-- Hard fork of brick's List that centers the currently highlighted line.++import Control.Lens+import Data.Maybe (fromMaybe)++import Brick.Types+import Brick.Widgets.Core+import Brick.Widgets.List++import qualified Data.Vector as V++-- | Turn a list state value into a widget given an item drawing+-- function.+renderList :: (Ord n, Show n)+ => (Bool -> e -> Widget n)+ -- ^ Rendering function, True for the selected element+ -> Bool+ -- ^ Whether the list has focus+ -> List n e+ -- ^ The List to be rendered+ -> Widget n+ -- ^ rendered widget+renderList drawElem foc l =+ withDefAttr listAttr $+ drawListElements foc l drawElem++drawListElements :: (Ord n, Show n) => Bool -> List n e -> (Bool -> e -> Widget n) -> Widget n+drawListElements foc l drawElem =+ Widget Greedy Greedy $ do+ c <- getContext++ let es = V.slice start num (l^.listElementsL)+ idx = fromMaybe 0 (l^.listSelectedL)++ start = max 0 $ idx - (initialNumPerHeight `div` 2)+ num = min (numPerHeight * 2) (V.length (l^.listElementsL) - start)++ -- The number of items to show is the available height divided by+ -- the item height...+ initialNumPerHeight = (c^.availHeightL) `div` (l^.listItemHeightL)+ -- ... but if the available height leaves a remainder of+ -- an item height then we need to ensure that we render an+ -- extra item to show a partial item at the top or bottom to+ -- give the expected result when an item is more than one+ -- row high. (Example: 5 rows available with item height+ -- of 3 yields two items: one fully rendered, the other+ -- rendered with only its top 2 or bottom 2 rows visible,+ -- depending on how the viewport state changes.)+ numPerHeight = initialNumPerHeight ++ if initialNumPerHeight * (l^.listItemHeightL) == c^.availHeightL+ then 0+ else 1++ -- off = start * (l^.listItemHeightL)++ drawnElements = flip V.imap es $ \i e ->+ let isSelected = i == (if start == 0 then idx else div initialNumPerHeight 2)+ elemWidget = drawElem isSelected e+ selItemAttr = if foc+ then withDefAttr listSelectedFocusedAttr+ else withDefAttr listSelectedAttr+ makeVisible = if isSelected+ then visible . selItemAttr+ else id+ in makeVisible elemWidget++ render $ viewport (l^.listNameL) Vertical $+ -- translateBy (Location (0, off)) $+ vBox $ V.toList drawnElements
+ src/EVM/Types.hs view
@@ -0,0 +1,164 @@+{-# Language CPP #-}+{-# Language TemplateHaskell #-}++module EVM.Types where++import Data.Aeson ((.:))+import Data.Aeson (FromJSON (..))++#if MIN_VERSION_aeson(1, 0, 0)+import Data.Aeson (FromJSONKey (..), FromJSONKeyFunction (..))+#endif++import Data.Monoid ((<>))+import Data.Bits+import Data.ByteString (ByteString)+import Data.ByteString.Base16 as BS16+import Data.DoubleWord+import Data.DoubleWord.TH+import Data.Word (Word8)+import Numeric (readHex, showHex)+import Options.Generic++import qualified Data.Aeson as JSON+import qualified Data.Aeson.Types as JSON+import qualified Data.ByteString as BS+import qualified Data.Serialize.Get as Cereal+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++-- Some stuff for "generic programming", needed to create Word512+import Data.Data++-- We need a 512-bit word for doing ADDMOD and MULMOD with full precision.+mkUnpackedDoubleWord "Word512" ''Word256 "Int512" ''Int256 ''Word256+ [''Typeable, ''Data, ''Generic]++newtype W256 = W256 Word256+ deriving+ ( Num, Integral, Real, Ord, Enum, Eq+ , Bits, FiniteBits, Bounded, Generic+ )++newtype Addr = Addr { addressWord160 :: Word160 }+ deriving (Num, Integral, Real, Ord, Enum, Eq, Bits, Generic)++instance Read W256 where+ readsPrec _ "0x" = [(0, "")]+ readsPrec n s = (\(x, r) -> (W256 x, r)) <$> readsPrec n s++instance Show W256 where+ showsPrec _ s = ("0x" ++) . showHex s++instance Read Addr where+ readsPrec _ ('0':'x':s) = readHex s+ readsPrec _ s = readHex s++instance Show Addr where+ showsPrec _ s a =+ let h = showHex s a+ in replicate (40 - length h) '0' ++ h++showAddrWith0x :: Addr -> String+showAddrWith0x addr = "0x" ++ show addr++showWordWith0x :: W256 -> String+showWordWith0x addr = show addr++showByteStringWith0x :: ByteString -> String+showByteStringWith0x bs = Text.unpack (Text.decodeUtf8 (BS16.encode bs))++instance FromJSON W256 where+ parseJSON v = do+ s <- Text.unpack <$> parseJSON v+ case reads s of+ [(x, "")] -> return x+ _ -> fail $ "invalid hex word (" ++ s ++ ")"++instance FromJSON Addr where+ parseJSON v = do+ s <- Text.unpack <$> parseJSON v+ case reads s of+ [(x, "")] -> return x+ _ -> fail $ "invalid address (" ++ s ++ ")"++#if MIN_VERSION_aeson(1, 0, 0)++instance FromJSONKey W256 where+ fromJSONKey = FromJSONKeyTextParser $ \s ->+ case reads (Text.unpack s) of+ [(x, "")] -> return x+ _ -> fail $ "invalid word (" ++ Text.unpack s ++ ")"++instance FromJSONKey Addr where+ fromJSONKey = FromJSONKeyTextParser $ \s ->+ case reads (Text.unpack s) of+ [(x, "")] -> return x+ _ -> fail $ "invalid word (" ++ Text.unpack s ++ ")"++#endif++instance ParseField W256+instance ParseFields W256+instance ParseRecord W256 where+ parseRecord = fmap getOnly parseRecord++instance ParseField Addr+instance ParseFields Addr+instance ParseRecord Addr where+ parseRecord = fmap getOnly parseRecord++hexByteString :: String -> ByteString -> ByteString+hexByteString msg bs =+ case BS16.decode bs of+ (x, "") -> x+ _ -> error ("invalid hex bytestring for " ++ msg)++hexText :: Text -> ByteString+hexText t =+ case BS16.decode (Text.encodeUtf8 (Text.drop 2 t)) of+ (x, "") -> x+ _ -> error ("invalid hex bytestring " ++ show t)++readN :: Integral a => String -> a+readN s = fromIntegral (read s :: Integer)++wordField :: JSON.Object -> Text -> JSON.Parser W256+wordField x f = (read . Text.unpack)+ <$> (x .: f)++addrField :: JSON.Object -> Text -> JSON.Parser Addr+addrField x f = (read . Text.unpack) <$> (x .: f)++dataField :: JSON.Object -> Text -> JSON.Parser ByteString+dataField x f = hexText <$> (x .: f)++toWord512 :: W256 -> Word512+toWord512 (W256 x) = fromHiAndLo 0 x++fromWord512 :: Word512 -> W256+fromWord512 x = W256 (loWord x)++{-# SPECIALIZE num :: Word8 -> W256 #-}+num :: (Integral a, Num b) => a -> b+num = fromIntegral++padLeft :: Int -> ByteString -> ByteString+padLeft n xs = BS.replicate (n - BS.length xs) 0 <> xs++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+ where+ m = do a <- Cereal.getWord64be+ b <- Cereal.getWord64be+ c <- Cereal.getWord64be+ d <- Cereal.getWord64be+ return $ fromHiAndLo (fromHiAndLo a b) (fromHiAndLo c d)++byteAt :: (Bits a, Bits b, Integral a, Num b) => a -> Int -> b+byteAt x j = num (x `shiftR` (j * 8)) .&. 0xff
+ src/EVM/UnitTest.hs view
@@ -0,0 +1,569 @@+{-# LANGUAGE ViewPatterns #-}++module EVM.UnitTest where++import Prelude hiding (Word)++import EVM+import EVM.ABI+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 (blob, w256, forceConcreteBlob, Blob (B), wordAt)++import qualified EVM.FeeSchedule as FeeSchedule++import EVM.Stepper (Stepper)+import qualified EVM.Stepper as Stepper+import qualified Control.Monad.Operational as Operational++import Control.Lens hiding (Indexed)+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 Data.ByteString (ByteString)+import Data.Foldable (toList)+import Data.Map (Map)+import Data.Maybe (fromMaybe, catMaybes, fromJust, fromMaybe, mapMaybe)+import Data.Monoid ((<>))+import Data.Text (Text, pack, unpack)+import Data.Text (isPrefixOf, stripSuffix, intercalate)+import Data.Text.Encoding (encodeUtf8)+import Data.Word (Word32)+import System.Environment (lookupEnv)+import System.IO (hFlush, stdout)++import qualified Control.Monad.Par.Class as Par+import qualified Data.ByteString as BS+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Text as Text+import qualified Data.Text.IO as Text++import Data.MultiSet (MultiSet)+import qualified Data.MultiSet as MultiSet++import Data.Set (Set)+import qualified Data.Set as Set++import Data.Vector (Vector)+import qualified Data.Vector as Vector++data UnitTestOptions = UnitTestOptions+ {+ oracle :: Query -> IO (EVM ())+ , verbose :: Bool+ , match :: Text+ , vmModifier :: VM -> VM+ , testParams :: TestVMParams+ }++data TestVMParams = TestVMParams+ { testAddress :: Addr+ , testCaller :: Addr+ , testOrigin :: Addr+ , testGasCreate :: W256+ , testGasCall :: W256+ , testBalanceCreate :: W256+ , testBalanceCall :: W256+ , testCoinbase :: Addr+ , testNumber :: W256+ , testTimestamp :: W256+ , testGaslimit :: W256+ , testGasprice :: W256+ , testDifficulty :: W256+ }++defaultGasForCreating :: W256+defaultGasForCreating = 0xffffffffffff++defaultGasForInvoking :: W256+defaultGasForInvoking = 0xffffffffffff++defaultBalanceForCreator :: W256+defaultBalanceForCreator = 0xffffffffffffffffffffffff++defaultBalanceForCreated :: W256+defaultBalanceForCreated = 0xffffffffffffffffffffffff++type ABIMethod = Text++-- | Assuming a constructor is loaded, this stepper will run the constructor+-- to create the test contract, give it an initial balance, and run `setUp()'.+initializeUnitTest :: UnitTestOptions -> Stepper ()+initializeUnitTest UnitTestOptions { .. } = do++ -- Maybe modify the initial VM, e.g. to load library code+ Stepper.evm (modify vmModifier)++ -- Make a trace entry for running the constructor+ Stepper.evm (pushTrace (EntryTrace "constructor"))++ -- Constructor is loaded; run until it returns code+ B 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++ -- Give a balance to the test target+ Stepper.evm $+ 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()'"++ -- Let `setUp()' run to completion+ void Stepper.execFullyOrFail+ Stepper.evm 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))++ -- 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 ()++ -- 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++ -- Return true if the test was successful+ pure (shouldFail == (bailed || failed))++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+ , srcOpIx :: !Int+ } deriving (Eq, Ord, Show)++srcMapForOpLocation :: DappInfo -> OpLocation -> Maybe SrcMap+srcMapForOpLocation dapp (OpLocation hash opIx) =+ case preview (dappSolcByHash . ix hash) dapp of+ Nothing -> Nothing+ Just (codeType, solc) ->+ let+ vec =+ case codeType of+ Runtime -> view runtimeSrcmap solc+ Creation -> view creationSrcmap solc+ in+ preview (ix opIx) vec++type CoverageState = (VM, MultiSet OpLocation)++currentOpLocation :: VM -> OpLocation+currentOpLocation vm =+ case currentContract vm of+ Nothing ->+ error "internal error: why no contract?"+ Just c ->+ OpLocation+ (view codehash c)+ (fromMaybe (error "internal error: op ix") (vmOpIx vm))++execWithCoverage :: StateT CoverageState IO VMResult+execWithCoverage = do+ -- This is just like `exec` except for every instruction evaluated,+ -- we also increment a counter indexed by the current code location.+ vm0 <- use _1+ case view result vm0 of+ Nothing -> do+ vm1 <- zoom _1 (State.state (runState exec1) >> get)+ zoom _2 (modify (MultiSet.insert (currentOpLocation vm1)))+ execWithCoverage+ Just r ->+ pure r++interpretWithCoverage+ :: UnitTestOptions+ -> Stepper a+ -> StateT CoverageState IO (Either Stepper.Failure a)+interpretWithCoverage opts =+ eval . Operational.view++ where+ eval+ :: Operational.ProgramView Stepper.Action a+ -> StateT CoverageState IO (Either Stepper.Failure a)++ eval (Operational.Return x) =+ pure (Right x)++ eval (action Operational.:>>= k) =+ case action of+ Stepper.Exec ->+ execWithCoverage >>= 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.EVM m ->+ zoom _1 (State.state (runState m)) >>= interpretWithCoverage opts . k++coverageReport+ :: DappInfo+ -> MultiSet SrcMap+ -> Map Text (Vector (Int, ByteString))+coverageReport dapp cov =+ let+ sources :: SourceCache+ sources = view dappSources dapp++ allPositions :: Set (Text, Int)+ allPositions =+ ( Set.fromList+ . mapMaybe (srcMapCodePos sources)+ . toList+ $ mconcat+ ( view dappSolcByName dapp+ & Map.elems+ & map (\x -> view runtimeSrcmap x <> view creationSrcmap x)+ )+ )++ srcMapCov :: MultiSet (Text, Int)+ srcMapCov = MultiSet.mapMaybe (srcMapCodePos sources) cov++ -- linesByName :: Map Text (Vector ByteString)+ linesByName =+ ( Map.fromList+ . map+ (\(k, v) ->+ (fst (fromJust (Map.lookup k (view sourceFiles sources))), v))+ . Map.toList+ $ view sourceLines sources+ )++ f :: Text -> Vector ByteString -> Vector (Int, ByteString)+ f name xs =+ Vector.imap+ (\i bs ->+ let+ n =+ if Set.member (name, i + 1) allPositions+ then MultiSet.occur (name, i + 1) srcMapCov+ else -1+ in (n, bs))+ xs+ in+ Map.mapWithKey f linesByName++coverageForUnitTestContract+ :: UnitTestOptions+ -> Map Text SolcContract+ -> SourceCache+ -> (Text, [Text])+ -> IO (MultiSet SrcMap)+coverageForUnitTestContract+ opts@(UnitTestOptions {..}) contractMap sources (name, testNames) = do++ -- Look for the wanted contract by name from the Solidity info+ case preview (ix name) contractMap of+ Nothing ->+ -- Fail if there's no such contract+ error $ "Contract " ++ unpack name ++ " not found"++ Just theContract -> do+ -- Construct the initial VM and begin the contract's constructor+ let vm0 = initialUnitTestVm opts theContract (Map.elems contractMap)+ (vm1, cov1) <-+ execStateT+ (interpretWithCoverage opts+ (Stepper.enter name >> initializeUnitTest opts))+ (vm0, mempty)++ -- Define the thread spawner for test cases+ let+ runOne testName = spawn_ . liftIO $ do+ (x, (_, cov)) <-+ runStateT+ (interpretWithCoverage opts (runUnitTest opts testName))+ (vm1, mempty)+ case x of+ Right True -> pure cov+ _ -> error "test failure during coverage analysis; fix it!"++ -- Run all the test cases in parallel and gather their coverages+ covs <-+ runParIO (mapM runOne testNames >>= mapM Par.get)++ -- Sum up all the coverage counts+ let cov2 = MultiSet.unions (cov1 : covs)++ -- Gather the dapp-related metadata+ let dapp = dappInfo "." contractMap sources++ pure (MultiSet.mapMaybe (srcMapForOpLocation dapp) cov2)++runUnitTestContract+ :: UnitTestOptions+ -> Map Text SolcContract+ -> SourceCache+ -> (Text, [Text])+ -> IO Bool+runUnitTestContract+ opts@(UnitTestOptions {..}) contractMap sources (name, testNames) = do++ -- Print a header+ putStrLn $ "Running " ++ show (length testNames) ++ " tests for "+ ++ unpack name++ -- Look for the wanted contract by name from the Solidity info+ case preview (ix name) contractMap of+ Nothing ->+ -- Fail if there's no such contract+ error $ "Contract " ++ unpack name ++ " not found"++ Just theContract -> do+ -- Construct the initial VM and begin the contract's constructor+ let vm0 = initialUnitTestVm opts theContract (Map.elems contractMap)+ vm1 <-+ execStateT+ (interpret opts+ (Stepper.enter name >> initializeUnitTest opts))+ vm0++ -- Gather the dapp-related metadata+ let dapp = dappInfo "." contractMap sources++ -- 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 testName)+ )+ (Right False, vm) ->+ pure ("FAIL " <> testName, Left (failOutput vm dapp testName))+ (Left _, _) ->+ pure ("OOPS " <> testName, Left ("VM error for " <> testName))+ inform = \(x, y) -> Text.putStrLn x >> pure y++ -- Run all the test cases and print their status updates+ details <-+ mapM (\x -> runOne x >>= inform) testNames++ let fails = [x | Left x <- details]++ tick "\n"+ tick (Text.unlines fails)++ pure (null fails)++indentLines :: Int -> Text -> Text+indentLines n s =+ let p = Text.replicate n " "+ in Text.unlines (map (p <>) (Text.lines s))++passOutput :: VM -> Text -> Text+passOutput _ testName = "PASS " <> testName++failOutput :: VM -> DappInfo -> Text -> Text+failOutput vm dapp testName = mconcat $+ [ "Failure: "+ , fromMaybe "" (stripSuffix "()" testName)+ , "\n"+ , indentLines 2 (formatTestLogs (view dappEventMap dapp) (view logs vm))+ , indentLines 2 (showTraceTree dapp vm)+ , "\n"+ ]++formatTestLogs :: Map W256 Event -> Seq.Seq Log -> Text+formatTestLogs events xs =+ case catMaybes (toList (fmap (formatTestLog events) xs)) of+ [] -> "\n"+ ys -> "\n" <> intercalate "\n" ys <> "\n\n"++formatTestLog :: Map W256 Event -> Log -> Maybe Text+formatTestLog _ (Log _ _ []) = Nothing+formatTestLog events (Log _ b (t:_)) =+ let+ name = getEventName event+ args = forceConcreteBlob b+ event = getEvent t events++ in case name of++ "log_bytes32" ->+ Just $ formatBytes args++ "log_named_bytes32" ->+ let key = BS.take 32 args+ val = BS.drop 32 args+ in Just $ formatString key <> ": " <> formatBytes val++ "log_named_address" ->+ let key = BS.take 32 args+ val = BS.drop 44 args+ in Just $ formatString key <> ": " <> formatBinary val++ -- 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 = BS.take 32 args+ val = wordAt 32 args+ in Just $ formatString key <> ": " <> showDec Signed val++ "log_named_uint" ->+ let key = BS.take 32 args+ val = wordAt 32 args+ in Just $ formatString key <> ": " <> showDec Unsigned val++ _ ->+ 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+ resetState+ loadContract target+ assign (state . calldata) (blob (word32Bytes (abiKeccak (encodeUtf8 abi))))+ assign (state . gas) (w256 allowance)++initialUnitTestVm :: UnitTestOptions -> SolcContract -> [SolcContract] -> VM+initialUnitTestVm (UnitTestOptions {..}) theContract _ =+ let+ TestVMParams {..} = testParams+ vm = makeVm $ VMOpts+ { vmoptCode = view creationCode theContract+ , vmoptCalldata = ""+ , vmoptValue = 0+ , vmoptAddress = testAddress+ , vmoptCaller = testCaller+ , vmoptOrigin = testOrigin+ , vmoptGas = testGasCreate+ , vmoptCoinbase = testCoinbase+ , vmoptNumber = testNumber+ , vmoptTimestamp = testTimestamp+ , vmoptGaslimit = testGaslimit+ , vmoptGasprice = testGasprice+ , vmoptDifficulty = testDifficulty+ , vmoptSchedule = FeeSchedule.metropolis+ }+ creator =+ initialContract mempty+ & set nonce 1+ & set balance (w256 testBalanceCreate)+ in vm+ & set (env . contracts . at ethrunAddress) (Just creator)++getParametersFromEnvironmentVariables :: IO TestVMParams+getParametersFromEnvironmentVariables = do+ let+ getWord s def = maybe def read <$> lookupEnv s+ getAddr s def = maybe def read <$> lookupEnv s++ TestVMParams+ <$> getAddr "DAPP_TEST_ADDRESS" (newContractAddress ethrunAddress 1)+ <*> getAddr "DAPP_TEST_CALLER" ethrunAddress+ <*> getAddr "DAPP_TEST_ORIGIN" ethrunAddress+ <*> getWord "DAPP_TEST_GAS_CREATE" defaultGasForCreating+ <*> getWord "DAPP_TEST_GAS_CALL" defaultGasForInvoking+ <*> getWord "DAPP_TEST_BALANCE_CREATE" defaultBalanceForCreator+ <*> getWord "DAPP_TEST_BALANCE_CALL" defaultBalanceForCreated+ <*> getAddr "DAPP_TEST_COINBASE" 0+ <*> getWord "DAPP_TEST_NUMBER" 512+ <*> getWord "DAPP_TEST_TIMESTAMP" 1+ <*> getWord "DAPP_TEST_GAS_LIMIT" 0+ <*> getWord "DAPP_TEST_GAS_PRICE" 0+ <*> getWord "DAPP_TEST_DIFFICULTY" 1
+ src/EVM/VMTest.hs view
@@ -0,0 +1,215 @@+{-# Language CPP #-}+{-# Language TemplateHaskell #-}++module EVM.VMTest+ ( Case+#if MIN_VERSION_aeson(1, 0, 0)+ , parseSuite+#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 EVM (EVM)+import EVM.Stepper (Stepper)+import EVM.Types++import Control.Lens++import IPPrint.Colored (cpprint)++import Data.ByteString (ByteString)+import Data.Aeson ((.:), (.:?))+import Data.Aeson (FromJSON (..))+import Data.Map (Map)+import Data.List (intercalate)++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++data Case = Case+ { testVmOpts :: EVM.VMOpts+ , testContracts :: Map Addr Contract+ , testExpectation :: Maybe Expectation+ } deriving Show++data Contract = Contract+ { contractBalance :: W256+ , contractCode :: ByteString+ , contractNonce :: W256+ , contractStorage :: Map W256 W256+ } deriving Show++data Expectation = Expectation+ { expectedOut :: ByteString+ , expectedContracts :: Map Addr Contract+ , expectedGas :: W256+ } deriving Show++checkExpectation :: Case -> EVM.VM -> IO Bool+checkExpectation x vm =+ case (testExpectation x, view EVM.result vm) of+ (Just expectation, Just (EVM.VMSuccess (EVM.B 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)+ (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)+ error "internal error"++checkExpectedOut :: ByteString -> ByteString -> Bool+checkExpectedOut output expected =+ output == expected++checkExpectedContracts :: EVM.VM -> Map Addr Contract -> Bool+checkExpectedContracts vm expected =+ realizeContracts expected == vm ^. EVM.env . EVM.contracts . to (fmap clearZeroStorage)++clearZeroStorage :: EVM.Contract -> EVM.Contract+clearZeroStorage =+ over EVM.storage (Map.filterWithKey (\_ x -> x /= 0))++checkExpectedGas :: EVM.VM -> W256 -> Bool+checkExpectedGas vm expected =+ case vm ^. EVM.state . EVM.gas of+ EVM.C _ x | x == expected -> True+ _ -> False++#if MIN_VERSION_aeson(1, 0, 0)++instance FromJSON Contract where+ parseJSON (JSON.Object v) = Contract+ <$> v .: "balance"+ <*> (hexText <$> v .: "code")+ <*> v .: "nonce"+ <*> v .: "storage"+ parseJSON invalid =+ JSON.typeMismatch "VM test case contract" invalid++instance FromJSON Case where+ parseJSON (JSON.Object v) = Case+ <$> parseVmOpts v+ <*> parseContracts v+ <*> parseExpectation v+ parseJSON invalid =+ JSON.typeMismatch "VM test case" invalid++parseVmOpts :: JSON.Object -> JSON.Parser EVM.VMOpts+parseVmOpts v =+ do envV <- v .: "env"+ execV <- v .: "exec"+ case (envV, execV) of+ (JSON.Object env, JSON.Object exec) ->+ EVM.VMOpts+ <$> dataField exec "code"+ <*> dataField exec "data"+ <*> wordField exec "value"+ <*> addrField exec "address"+ <*> addrField exec "caller"+ <*> addrField exec "origin"+ <*> wordField exec "gas" -- XXX: correct?+ <*> wordField env "currentNumber"+ <*> wordField env "currentTimestamp"+ <*> addrField env "currentCoinbase"+ <*> wordField env "currentDifficulty"+ <*> wordField env "currentGasLimit"+ <*> wordField exec "gasPrice"+ <*> pure (EVM.FeeSchedule.homestead)+ _ ->+ JSON.typeMismatch "VM test case" (JSON.Object v)++parseContracts ::+ JSON.Object -> JSON.Parser (Map Addr Contract)+parseContracts v =+ v .: "pre" >>= parseJSON++parseExpectation :: JSON.Object -> JSON.Parser (Maybe Expectation)+parseExpectation v =+ do out <- fmap hexText <$> v .:? "out"+ contracts <- v .:? "post"+ gas <- v .:? "gas"+ case (out, contracts, gas) of+ (Just x, Just y, Just z) ->+ return (Just (Expectation x y z))+ _ ->+ return Nothing++parseSuite ::+ Lazy.ByteString -> Either String (Map String Case)+parseSuite = JSON.eitherDecode'++#endif++realizeContracts :: Map Addr Contract -> Map Addr EVM.Contract+realizeContracts = Map.fromList . map f . Map.toList+ where+ f (a, x) = (a, realizeContract x)++realizeContract :: Contract -> EVM.Contract+realizeContract x =+ EVM.initialContract (contractCode x)+ & EVM.balance .~ EVM.w256 (contractBalance x)+ & EVM.nonce .~ EVM.w256 (contractNonce x)+ & EVM.storage .~ (+ Map.fromList .+ map (\(k, v) -> (EVM.w256 k, EVM.w256 v)) .+ Map.toList $ contractStorage x+ )++vmForCase :: Case -> EVM.VM+vmForCase x =+ EVM.makeVm (testVmOpts x)+ & EVM.env . EVM.contracts .~ realizeContracts (testContracts x)+ & EVM.execMode .~ EVM.ExecuteAsVMTest++interpret :: Stepper a -> EVM a+interpret =+ eval . Operational.view++ where+ eval+ :: Operational.ProgramView Stepper.Action a+ -> EVM a++ eval (Operational.Return x) =+ pure x++ 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
+ test/test.hs view
@@ -0,0 +1,197 @@+{-# Language OverloadedStrings #-}+{-# Language QuasiQuotes #-}++import Data.Text (Text)+import Data.ByteString (ByteString)++import qualified Data.Text as Text+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as Hex++import Test.Tasty+import Test.Tasty.QuickCheck (testProperty, Arbitrary (..), NonNegative (..))+import Test.Tasty.HUnit++import Control.Monad.State.Strict (execState, runState)+import Control.Lens++import Data.Monoid+import qualified Data.Vector as Vector+import Data.String.Here++import Data.Binary.Put (runPut)+import Data.Binary.Get (runGetOrFail)++import EVM+import EVM.ABI+import EVM.Concrete+import EVM.Exec+import EVM.Solidity+import EVM.Types+import EVM.Precompiled++main :: IO ()+main = defaultMain $ testGroup "hevm"+ [ testGroup "ABI"+ [ testProperty "Put/get inverse" $ \x ->+ case runGetOrFail (getAbi (abiValueType x)) (runPut (putAbi x)) of+ Right ("", _, x') -> x' == x+ _ -> False+ ]++ , testGroup "Solidity expressions"+ [ testCase "Trivial" $ do+ SolidityCall "x = 3;" []+ ===> AbiUInt 256 3++ , testCase "Arithmetic" $ do+ SolidityCall "x = a + 1;"+ [AbiUInt 256 1] ===> AbiUInt 256 2+ SolidityCall "x = a - 1;"+ [AbiUInt 8 0] ===> AbiUInt 8 255++ , testCase "keccak256()" $ do+ SolidityCall "x = uint(keccak256(a));"+ [AbiString ""] ===> AbiUInt 256 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470+ ]++ , testGroup "ecrecover"+ [ testCase "Example 1" $+ let+ h = "0x0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef"+ r = "0xc84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4732"+ s = "0x1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d"+ in SolidityCall+ (Text.unlines+ [ "bytes32 h = keccak256(\"\\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 "Example (reverse)"+ [ testCase "success" $+ assertEqual "example contract reverses"+ (execute 0xdeadbeef "foobar" 6) (Just "raboof")+ , testCase "failure" $+ assertEqual "example contract fails on length mismatch"+ (execute 0xdeadbeef "foobar" 5) Nothing+ ]++ , testGroup "ECRECOVER"+ [ testCase "success" $ do+ let+ r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4732"+ s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d"+ v = hex "000000000000000000000000000000000000000000000000000000000000001c"+ h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31"+ a = hex "0000000000000000000000002d5e56d45c63150d937f2182538a0f18510cb11f"+ assertEqual "successful recovery"+ (Just a)+ (execute 1 (h <> v <> r <> s) 32)+ , testCase "fail on made up values" $ do+ let+ r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4731"+ s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d"+ v = hex "000000000000000000000000000000000000000000000000000000000000001c"+ h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31"+ assertEqual "fail because bit flip"+ Nothing+ (execute 1 (h <> v <> r <> s) 32)+ ]+ ]++ , testGroup "Byte/word manipulations"+ [ testProperty "padLeft length" $ \n (Bytes bs) ->+ BS.length (padLeft n bs) == max n (BS.length bs)+ , testProperty "padLeft identity" $ \(Bytes bs) ->+ padLeft (BS.length bs) bs == bs+ , testProperty "padRight length" $ \n (Bytes bs) ->+ BS.length (padLeft n bs) == max n (BS.length bs)+ , testProperty "padRight identity" $ \(Bytes bs) ->+ padLeft (BS.length bs) bs == bs+ , testProperty "padLeft zeroing" $ \(NonNegative n) (Bytes bs) ->+ let x = BS.take n (padLeft (BS.length bs + n) bs)+ y = BS.replicate n 0+ in x == y+ ]+ ]++ where+ (===>) = assertSolidityComputation++hex :: ByteString -> ByteString+hex s =+ case Hex.decode s of+ (x, "") -> x+ _ -> error "internal error"++singleContract :: Text -> Text -> IO (Maybe ByteString)+singleContract x s =+ solidity x [i|+ contract ${x} { ${s} }+ |]++runStatements+ :: Text -> [AbiValue] -> AbiType+ -> IO (Maybe ByteString)+runStatements stmts args t = do+ let params =+ Text.intercalate ", "+ (map (\(x, c) -> abiTypeSolidity (abiValueType x)+ <> " " <> Text.pack [c])+ (zip args "abcdefg"))+ sig =+ "foo(" <> Text.intercalate ","+ (map (abiTypeSolidity . abiValueType) args) <> ")"++ Just x <- singleContract "X" [i|+ function foo(${params}) public pure returns (${abiTypeSolidity t} x) {+ ${stmts}+ }+ |]++ case runState exec (vmForEthrunCreation x) of+ (VMSuccess (B 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)+ (B (abiCalldata sig (Vector.fromList args)))+ exec) of+ (VMSuccess (B out), _) ->+ return (Just out)+ (VMFailure problem, _) -> do+ print problem+ return Nothing+ _ ->+ return Nothing++newtype Bytes = Bytes ByteString+ deriving Eq++instance Show Bytes where+ showsPrec _ (Bytes x) _ = show (BS.unpack x)++instance Arbitrary Bytes where+ arbitrary = fmap (Bytes . BS.pack) arbitrary++data Invocation+ = SolidityCall Text [AbiValue]+ deriving Show++assertSolidityComputation :: Invocation -> AbiValue -> IO ()+assertSolidityComputation (SolidityCall s args) x =+ do y <- runStatements s args (abiValueType x)+ assertEqual (Text.unpack s)+ (fmap Bytes (Just (encodeAbiValue x)))+ (fmap Bytes y)