diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,11 +5,28 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.50.0] - 2022-12-19 + +### Changed + +The symbolic execution engine has been rewritten. We have removed our dependency on sbv, and now +symbolic execution decompiles bytecode into a custom IR, and smt queries are constructed based on +the structure of the term in this IR. + +This gives us much deeper control over the encoding, and makes the addition of custom static +analysis and simplification passes much easier to implement. + +The symbolic execution engine is now parallel by default, and will distribute granular SMT queries +across a pool of solvers, allowing analysis to be scaled out horizontally across many CPUs. + +more details can be found in the [architecuture](../../architecture.md) docs. + ## [0.49.0] - 2021-11-12 ### Added - Support for solc 0.8.10 +- Support for solc 0.8.11 ### Changed diff --git a/COPYING b/COPYING deleted file mode 100644 --- a/COPYING +++ /dev/null @@ -1,661 +0,0 @@ - GNU AFFERO GENERAL PUBLIC LICENSE - Version 3, 19 November 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - 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. - - - Copyright (C) - - 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 . - -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 -. diff --git a/hevm-cli/hevm-cli.hs b/hevm-cli/hevm-cli.hs --- a/hevm-cli/hevm-cli.hs +++ b/hevm-cli/hevm-cli.hs @@ -2,45 +2,35 @@ {-# Language CPP #-} {-# Language DataKinds #-} -{-# Language StandaloneDeriving #-} {-# Language DeriveAnyClass #-} -{-# Language FlexibleInstances #-} -{-# Language DeriveGeneric #-} {-# Language GADTs #-} -{-# Language LambdaCase #-} -{-# Language OverloadedStrings #-} -{-# Language TypeOperators #-} -{-# Language RecordWildCards #-} module Main where import EVM (StorageModel(..)) import qualified EVM -import EVM.Concrete (createAddress, wordValue) -import EVM.Symbolic (litWord, forceLitBytes, litAddr, len, forceLit) +import EVM.Concrete (createAddress) import qualified EVM.FeeSchedule as FeeSchedule import qualified EVM.Fetch -import qualified EVM.Flatten import qualified EVM.Stepper -import qualified EVM.TTY -import qualified EVM.Emacs -import EVM.Dev (interpretWithTrace) -#if MIN_VERSION_aeson(1, 0, 0) + import qualified EVM.VMTest as VMTest -#endif + import EVM.SymExec import EVM.Debug import EVM.ABI +import qualified EVM.Expr as Expr +import EVM.SMT +import qualified EVM.TTY as TTY import EVM.Solidity +import EVM.Expr (litAddr) import EVM.Types hiding (word) -import EVM.UnitTest (UnitTestOptions, coverageReport, coverageForUnitTestContract) -import EVM.UnitTest (runUnitTestContract) -import EVM.UnitTest (getParametersFromEnvironmentVariables, testNumber) +import EVM.UnitTest (UnitTestOptions, coverageReport, coverageForUnitTestContract, getParametersFromEnvironmentVariables, testNumber, dappTest) import EVM.Dapp (findUnitTests, dappInfo, DappInfo, emptyDapp) -import EVM.Format (showTraceTree, showTree', renderTree, showBranchInfoWithAbi, showLeafInfo) -import EVM.RLP (rlpdecode) +import GHC.Natural +import EVM.Format (showTraceTree, formatExpr) import qualified EVM.Patricia as Patricia import Data.Map (Map) @@ -48,27 +38,22 @@ import qualified EVM.Facts.Git as Git import qualified EVM.UnitTest -import GHC.IO.Encoding import GHC.Stack +import GHC.Conc import Control.Concurrent.Async (async, waitCatch) import Control.Lens hiding (pre, passing) import Control.Monad (void, when, forM_, unless) import Control.Monad.State.Strict (execStateT, liftIO) import Data.ByteString (ByteString) import Data.List (intercalate, isSuffixOf) -import Data.Tree import Data.Text (unpack, pack) import Data.Text.Encoding (encodeUtf8) -import Data.Text.IO (hPutStr) -import Data.Maybe (fromMaybe, fromJust) +import Data.Maybe (fromMaybe, fromJust, mapMaybe) import Data.Version (showVersion) import Data.DoubleWord (Word256) -import Data.SBV hiding (Word, solver, verbose, name) -import Data.SBV.Control hiding (Version, timeout, create) import System.IO (hFlush, stdout, stderr) import System.Directory (withCurrentDirectory, listDirectory) import System.Exit (exitFailure, exitWith, ExitCode(..)) -import System.Environment (setEnv) import System.Process (callProcess) import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON @@ -77,12 +62,12 @@ import qualified Data.Vector as V import qualified Data.ByteString.Lazy as Lazy -import qualified Data.SBV as SBV import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Map as Map -import qualified Data.Text as Text +import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified System.Timeout as Timeout import qualified Paths_hevm as Paths @@ -111,7 +96,7 @@ , gasprice :: w ::: Maybe W256 "Tx: gas price" , create :: w ::: Bool "Tx: creation" , maxcodesize :: w ::: Maybe W256 "Block: max code size" - , difficulty :: w ::: Maybe W256 "Block: difficulty" + , prevRandao :: w ::: Maybe W256 "Block: prevRandao" , chainid :: w ::: Maybe W256 "Env: chainId" -- remote state opts , rpc :: w ::: Maybe URL "Fetch state from a remote node" @@ -128,20 +113,22 @@ , debug :: w ::: Bool "Run interactively" , getModels :: w ::: Bool "Print example testcase for each execution path" , showTree :: w ::: Bool "Print branches explored in tree view" - , smttimeout :: w ::: Maybe Integer "Timeout given to SMT solver in milliseconds (default: 60000)" + , showReachableTree :: w ::: Bool "Print only reachable branches explored in tree view" + , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in milliseconds (default: 60000)" , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" - , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc4" + , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc5" , smtdebug :: w ::: Bool "Print smt queries sent to the solver" , assertions :: w ::: Maybe [Word256] "Comma seperated list of solc panic codes to check for (default: everything except arithmetic overflow)" , askSmtIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 5)" + , numSolvers :: w ::: Maybe Natural "Number of solver instances to use (default: number of cpu cores)" } | Equivalence -- prove equivalence between two programs { codeA :: w ::: ByteString "Bytecode of the first program" , codeB :: w ::: ByteString "Bytecode of the second program" , sig :: w ::: Maybe Text "Signature of types to decode / encode" - , smttimeout :: w ::: Maybe Integer "Timeout given to SMT solver in milliseconds (default: 60000)" + , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in milliseconds (default: 60000)" , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" - , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc4" + , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc5" , smtoutput :: w ::: Bool "Print verbose smt output" , smtdebug :: w ::: Bool "Print smt queries sent to the solver" , askSmtIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 5)" @@ -164,7 +151,7 @@ , gasprice :: w ::: Maybe W256 "Tx: gas price" , create :: w ::: Bool "Tx: creation" , maxcodesize :: w ::: Maybe W256 "Block: max code size" - , difficulty :: w ::: Maybe W256 "Block: difficulty" + , prevRandao :: w ::: Maybe W256 "Block: prevRandao" , chainid :: w ::: Maybe W256 "Env: chainId" , debug :: w ::: Bool "Run interactively" , jsontrace :: w ::: Bool "Print json trace output at every step" @@ -191,14 +178,14 @@ , cache :: w ::: Maybe String "Path to rpc cache repository" , match :: w ::: Maybe String "Test case filter - only run methods matching regex" , covMatch :: w ::: Maybe String "Coverage filter - only print coverage for files matching regex" - , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc4" + , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc5" , smtdebug :: w ::: Bool "Print smt queries sent to the solver" , ffi :: w ::: Bool "Allow the usage of the hevm.ffi() cheatcode (WARNING: this allows test authors to execute arbitrary code on your machine)" - , smttimeout :: w ::: Maybe Integer "Timeout given to SMT solver in milliseconds (default: 60000)" + , smttimeout :: w ::: Maybe Natural "Timeout given to SMT solver in milliseconds (default: 60000)" , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" , askSmtIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point before we consult the smt solver to check reachability (default: 5)" } - | BcTest -- Run an Ethereum Blockhain/GeneralState test + | BcTest -- Run an Ethereum Blockchain/GeneralState test { file :: w ::: String "Path to .json test file" , test :: w ::: [String] "Test case filter - only run specified test method(s)" , debug :: w ::: Bool "Run interactively" @@ -206,7 +193,7 @@ , diff :: w ::: Bool "Print expected vs. actual state on failure" , timeout :: w ::: Maybe Int "Execution timeout (default: 10 sec.)" } - | Compliance -- Run Ethereum Blockhain compliance report + | Compliance -- Run Ethereum Blockchain compliance report { tests :: w ::: String "Path to Ethereum Tests directory" , group :: w ::: Maybe String "Report group to run: VM or Blockchain (default: Blockchain)" , match :: w ::: Maybe String "Test case filter - only run methods matching regex" @@ -214,26 +201,10 @@ , html :: w ::: Bool "Output html report" , timeout :: w ::: Maybe Int "Execution timeout (default: 10 sec.)" } - | Flatten -- Concat all dependencies for a given source file - { sourceFile :: w ::: String "Path to solidity source file e.g. src/contract.sol" - , jsonFile :: w ::: Maybe String "Filename or path to dapp build output (default: out/*.solc.json)" - , dappRoot :: w ::: Maybe String "Path to dapp project root directory (default: . )" - } - | Emacs - | Version - | Rlp -- RLP decode a string and print the result - { decode :: w ::: ByteString "RLP encoded hexstring" - } - | Abiencode - { abi :: w ::: Maybe String "Signature of types to decode / encode" - , arg :: w ::: [String] "Values to encode" - } | MerkleTest -- Insert a set of key values and check against the given root - { file :: w ::: String "Path to .json test file" - } - | StripMetadata -- Remove metadata from contract bytecode - { code :: w ::: Maybe ByteString "Program bytecode" - } + { file :: w ::: String "Path to .json test file" + } + | Version deriving (Options.Generic) @@ -252,7 +223,10 @@ Options.parseRecordWithModifiers Options.lispCaseModifiers optsMode :: Command Options.Unwrapped -> Mode -optsMode x = if debug x then Debug else if jsontrace x then JsonTrace else Run +optsMode x + | Main.debug x = Debug + | jsontrace x = JsonTrace + | otherwise = Run applyCache :: (Maybe String, Maybe String) -> IO (EVM.VM -> EVM.VM) applyCache (state, cache) = @@ -272,18 +246,17 @@ stateFacts <- Git.loadFacts (Git.RepoAt statePath) pure $ (applyState stateFacts) . (applyCache' cacheFacts) -unitTestOptions :: Command Options.Unwrapped -> String -> Query UnitTestOptions -unitTestOptions cmd testFile = do +unitTestOptions :: Command Options.Unwrapped -> SolverGroup -> String -> IO UnitTestOptions +unitTestOptions cmd solvers testFile = do let root = fromMaybe "." (dappRoot cmd) - srcInfo <- liftIO $ readSolc testFile >>= \case + srcInfo <- readSolc testFile >>= \case Nothing -> error "Could not read .sol.json file" Just (contractMap, sourceCache) -> pure $ dappInfo root contractMap sourceCache - vmModifier <- liftIO $ applyCache (state cmd, cache cmd) + vmModifier <- applyCache (state cmd, cache cmd) - params <- liftIO $ getParametersFromEnvironmentVariables (rpc cmd) - state <- queryState + params <- getParametersFromEnvironmentVariables (rpc cmd) let testn = testNumber params @@ -292,16 +265,16 @@ else EVM.Fetch.BlockNumber testn pure EVM.UnitTest.UnitTestOptions - { EVM.UnitTest.oracle = - case rpc cmd of - Just url -> EVM.Fetch.oracle (Just state) (Just (block', url)) True - Nothing -> EVM.Fetch.oracle (Just state) Nothing True + { EVM.UnitTest.solvers = solvers + , EVM.UnitTest.rpcInfo = case rpc cmd of + Just url -> Just (block', url) + Nothing -> Nothing , EVM.UnitTest.maxIter = maxIterations cmd , EVM.UnitTest.askSmtIters = askSmtIterations cmd + , EVM.UnitTest.smtDebug = smtdebug cmd , EVM.UnitTest.smtTimeout = smttimeout cmd , EVM.UnitTest.solver = solver cmd , EVM.UnitTest.covMatch = pack <$> covMatch cmd - , EVM.UnitTest.smtState = Just state , EVM.UnitTest.verbose = verbose cmd , EVM.UnitTest.match = pack $ fromMaybe ".*" (match cmd) , EVM.UnitTest.maxDepth = depth cmd @@ -326,18 +299,19 @@ Equivalence {} -> equivalence cmd Exec {} -> launchExec cmd - Abiencode {} -> - print . ByteStringS $ abiencode (abi cmd) (arg cmd) BcTest {} -> launchTest cmd DappTest {} -> withCurrentDirectory root $ do - testFile <- findJsonFile (jsonFile cmd) - runSMTWithTimeOut (solver cmd) (smttimeout cmd) (smtdebug cmd) $ query $ do - testOpts <- unitTestOptions cmd testFile + cores <- num <$> getNumProcessors + withSolvers Z3 cores (smttimeout cmd) $ \solvers -> do + testFile <- findJsonFile (jsonFile cmd) + testOpts <- unitTestOptions cmd solvers testFile case (coverage cmd, optsMode cmd) of - (False, Run) -> dappTest testOpts testFile (cache cmd) - (False, Debug) -> liftIO $ EVM.TTY.main testOpts root testFile + (False, Run) -> do + res <- dappTest testOpts testFile (cache cmd) + unless res exitFailure + (False, Debug) -> liftIO $ TTY.main testOpts root testFile (False, JsonTrace) -> error "json traces not implemented for dappTest" (True, _) -> liftIO $ dappCoverage testOpts (optsMode cmd) testFile Compliance {} -> @@ -345,25 +319,7 @@ Just "Blockchain" -> launchScript "/run-blockchain-tests" cmd Just "VM" -> launchScript "/run-consensus-tests" cmd _ -> launchScript "/run-blockchain-tests" cmd - Flatten {} -> - withCurrentDirectory root $ do - theJson <- findJsonFile (jsonFile cmd) - 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 - Rlp {} -> - case rlpdecode $ hexByteString "--decode" $ strip0x $ decode cmd of - Nothing -> error "Malformed RLP string" - Just c -> print c MerkleTest {} -> merkleTest cmd - StripMetadata {} -> print . - ByteStringS . stripBytecodeMetadata . hexByteString "bytecode" . strip0x $ fromJust $ code cmd launchScript :: String -> Command Options.Unwrapped -> IO () launchScript script cmd = @@ -398,78 +354,38 @@ , intercalate ", " xs ] -dappTest :: UnitTestOptions -> String -> Maybe String -> Query () -dappTest opts solcFile cache = do - out <- liftIO $ readSolc solcFile - case out of - Just (contractMap, _) -> do - let unitTests = findUnitTests (EVM.UnitTest.match opts) $ Map.elems contractMap - results <- concatMapM (runUnitTestContract opts contractMap) unitTests - let (passing, vms) = unzip results - case cache of - Nothing -> - pure () - Just path -> - -- merge all of the post-vm caches and save into the state - let - cache' = mconcat [view EVM.cache vm | vm <- vms] - in - liftIO $ Git.saveFacts (Git.RepoAt path) (Facts.cacheFacts cache') - - liftIO $ unless (and passing) exitFailure - Nothing -> - error ("Failed to read Solidity JSON for `" ++ solcFile ++ "'") - equivalence :: Command Options.Unwrapped -> IO () -equivalence cmd = - do let bytecodeA = hexByteString "--code" . strip0x $ codeA cmd - bytecodeB = hexByteString "--code" . strip0x $ codeB cmd - maybeSignature <- case sig cmd of - Nothing -> return Nothing - Just sig' -> do method' <- functionAbi sig' - return $ Just (view methodSignature method', snd <$> view methodInputs method') - - void . runSMTWithTimeOut (solver cmd) (smttimeout cmd) (smtdebug cmd) . query $ - equivalenceCheck bytecodeA bytecodeB (maxIterations cmd) (askSmtIterations cmd) maybeSignature >>= \case - Cex vm -> do - io $ putStrLn "Not equal!" - io $ putStrLn "Counterexample:" - showCounterexample vm maybeSignature - io exitFailure - Qed (postAs, postBs) -> io $ do - putStrLn $ "Explored: " <> show (length postAs) - <> " execution paths of A and: " - <> show (length postBs) <> " paths of B." - putStrLn "No discrepancies found." - Timeout () -> io $ do - hPutStr stderr "Solver timeout!" - exitFailure - --- cvc4 sets timeout via a commandline option instead of smtlib `(set-option)` -runSMTWithTimeOut :: Maybe Text -> Maybe Integer -> Bool -> Symbolic a -> IO a -runSMTWithTimeOut solver maybeTimeout smtdebug symb - | solver == Just "cvc4" = runwithcvc4 - | solver == Just "z3" = runwithz3 - | solver == Nothing = runwithz3 - | otherwise = error "Unknown solver. Currently supported solvers; z3, cvc4" - where timeout = fromMaybe 60000 maybeTimeout - runwithz3 = runSMTWith z3{SBV.verbose=smtdebug} $ (setTimeOut timeout) >> symb - runwithcvc4 = do - setEnv "SBV_CVC4_OPTIONS" ("--lang=smt --incremental --interactive --no-interactive-prompt --model-witness-value --tlimit-per=" <> show timeout) - a <- runSMTWith cvc4{SBV.verbose=smtdebug} symb - setEnv "SBV_CVC4_OPTIONS" "" - return a - +equivalence cmd = do + let bytecodeA = hexByteString "--code" . strip0x $ codeA cmd + bytecodeB = hexByteString "--code" . strip0x $ codeB cmd + veriOpts = VeriOpts { simp = True + , debug = False + , maxIter = maxIterations cmd + , askSmtIters = askSmtIterations cmd + , rpcInfo = Nothing + } + withSolvers Z3 3 Nothing $ \s -> do + res <- equivalenceCheck s bytecodeA bytecodeB veriOpts Nothing + case containsA (Cex()) res of + False -> do + putStrLn "No discrepancies found" + when (containsA (EVM.SymExec.Timeout()) res) $ do + putStrLn "But timeout(s) occurred" + exitFailure + True -> do + putStrLn $ "Not equivalent. Counterexample(s):" <> show res + exitFailure checkForVMErrors :: [EVM.VM] -> [String] checkForVMErrors [] = [] checkForVMErrors (vm:vms) = case view EVM.result vm of - Just (EVM.VMFailure EVM.UnexpectedSymbolicArg) -> + Just (EVM.VMFailure (EVM.UnexpectedSymbolicArg pc msg _)) -> ("Unexpected symbolic argument at opcode: " - <> maybe "??" show (EVM.vmOp vm) - <> ". Not supported (yet!)" + <> show pc + <> ". " + <> msg ) : checkForVMErrors vms _ -> checkForVMErrors vms @@ -488,104 +404,95 @@ -- Although it is tempting to fully abstract calldata and give any hints about -- the nature of the signature doing so results in significant time spent in --- consulting z3 about rather trivial matters. But with cvc4 it is quite +-- consulting z3 about rather trivial matters. But with cvc5 it is quite -- pleasant! -- If function signatures are known, they should always be given for best results. assert :: Command Options.Unwrapped -> IO () assert cmd = do - srcInfo <- getSrcInfo cmd let block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) rpcinfo = (,) block' <$> rpc cmd - treeShowing :: Tree BranchInfo -> Query () - treeShowing tree = - when (showTree cmd) $ do - consistentTree tree >>= \case - Nothing -> io $ putStrLn "No consistent paths" -- unlikely - Just tree' -> let - showBranch = showBranchInfoWithAbi srcInfo - renderTree' = renderTree showBranch (showLeafInfo srcInfo) - in io $ setLocaleEncoding utf8 >> putStrLn (showTree' (renderTree' tree')) + decipher = hexByteString "bytes" . strip0x + calldata' <- case (Main.calldata cmd, sig cmd) of + -- fully abstract calldata + (Nothing, Nothing) -> pure + ( AbstractBuf "txdata" + -- assert that the length of the calldata is never more than 2^64 + -- this is way larger than would ever be allowed by the gas limit + -- and avoids spurious counterexamples during abi decoding + -- TODO: can we encode calldata as an array with a smaller length? + , [Expr.bufLength (AbstractBuf "txtdata") .< (Lit (2 ^ (64 :: Integer)))] + ) - maybesig <- case sig cmd of - Nothing -> - return Nothing - Just sig' -> do + -- fully concrete calldata + (Just c, Nothing) -> pure (ConcreteBuf (decipher c), []) + -- calldata according to given abi with possible specializations from the `arg` list + (Nothing, Just sig') -> do method' <- functionAbi sig' - let typ = snd <$> view methodInputs method' - name = view methodSignature method' - return $ Just (name,typ) - if debug cmd then - runSMTWithTimeOut (solver cmd) (smttimeout cmd) (smtdebug cmd) $ query $ do - preState <- symvmFromCommand cmd - smtState <- queryState - io $ void $ EVM.TTY.runFromVM + let typs = snd <$> view methodInputs method' + pure $ symCalldata (view methodSignature method') typs (arg cmd) mempty + _ -> error "incompatible options: calldata and abi" + + preState <- symvmFromCommand cmd calldata' + let errCodes = fromMaybe defaultPanicCodes (assertions cmd) + cores <- num <$> getNumProcessors + let solverCount = fromMaybe cores (numSolvers cmd) + withSolvers EVM.SMT.Z3 solverCount (smttimeout cmd) $ \solvers -> do + if Main.debug cmd then do + srcInfo <- getSrcInfo cmd + void $ TTY.runFromVM + solvers + rpcinfo (maxIterations cmd) srcInfo - (EVM.Fetch.oracle (Just smtState) rpcinfo True) preState + else do + let opts = VeriOpts { simp = True, debug = smtdebug cmd, maxIter = maxIterations cmd, askSmtIters = askSmtIterations cmd, rpcInfo = rpcinfo} + (expr, res) <- verify solvers opts preState (Just $ checkAssertions errCodes) + case res of + [Qed _] -> putStrLn "\nQED: No reachable property violations discovered\n" + cexs -> do + let counterexamples + | null (getCexs cexs) = [] + | otherwise = + [ "" + , "Discovered the following counterexamples:" + , "" + ] <> fmap (formatCex (fst calldata')) (getCexs cexs) + unknowns + | null (getTimeouts cexs) = [] + | otherwise = + [ "" + , "Could not determine reachability of the following end states:" + , "" + ] <> fmap (formatExpr) (getTimeouts cexs) + T.putStrLn $ T.unlines (counterexamples <> unknowns) + when (showTree cmd) $ do + putStrLn "=== Expression ===\n" + T.putStrLn $ formatExpr expr + putStrLn "" + when (showReachableTree cmd) $ do + reached <- reachable solvers expr + putStrLn "=== Reachable Expression ===\n" + T.putStrLn (formatExpr . snd $ reached) + putStrLn "" + when (getModels cmd) $ do + putStrLn $ "=== Models for " <> show (Expr.numBranches expr) <> " branches ===\n" + ms <- produceModels solvers expr + forM_ ms (showModel (fst calldata')) - else - runSMTWithTimeOut (solver cmd) (smttimeout cmd) (smtdebug cmd) $ query $ do - preState <- symvmFromCommand cmd - let errCodes = fromMaybe defaultPanicCodes (assertions cmd) - verify preState (maxIterations cmd) (askSmtIterations cmd) rpcinfo (Just $ checkAssertions errCodes) >>= \case - Cex tree -> do - io $ putStrLn "Assertion violation found." - showCounterexample preState maybesig - treeShowing tree - io $ exitWith (ExitFailure 1) - Timeout tree -> do - treeShowing tree - io $ exitWith (ExitFailure 1) - Qed tree -> do - io $ putStrLn $ "Explored: " <> show (length tree) - <> " branches without assertion violations" - treeShowing tree - let vmErrs = checkForVMErrors $ leaves tree - unless (null vmErrs) $ io $ do - putStrLn $ - "However, " - <> show (length vmErrs) - <> " branch(es) errored while exploring:" - print vmErrs - -- When `--get-models` is passed, we print example vm info for each path - when (getModels cmd) $ - forM_ (zip [(1:: Integer)..] (leaves tree)) $ \(i, postVM) -> do - resetAssertions - constrain (sAnd (fst <$> view EVM.constraints postVM)) - io $ putStrLn $ - "-- Branch (" <> show i <> "/" <> show (length tree) <> ") --" - checkSat >>= \case - DSat _ -> error "assert: unexpected SMT result" - Unk -> io $ do putStrLn "Timed out" - print $ view EVM.result postVM - Unsat -> io $ do putStrLn "Inconsistent path conditions: dead path" - print $ view EVM.result postVM - Sat -> do - showCounterexample preState maybesig - io $ putStrLn "-- Pathconditions --" - io $ print $ snd <$> view EVM.constraints postVM - case view EVM.result postVM of - Nothing -> - error "internal error; no EVM result" - Just (EVM.VMFailure (EVM.Revert "")) -> io . putStrLn $ - "Reverted" - Just (EVM.VMFailure (EVM.Revert msg)) -> io . putStrLn $ - "Reverted: " <> show (ByteStringS msg) - Just (EVM.VMFailure err) -> io . putStrLn $ - "Failed: " <> show err - Just (EVM.VMSuccess (ConcreteBuffer msg)) -> - if ByteString.null msg - then io $ putStrLn - "Stopped" - else io $ putStrLn $ - "Returned: " <> show (ByteStringS msg) - Just (EVM.VMSuccess (SymbolicBuffer msg)) -> do - out <- mapM (getValue.fromSized) msg - io . putStrLn $ - "Returned: " <> show (ByteStringS (ByteString.pack out)) +getCexs :: [VerifyResult] -> [SMTCex] +getCexs = mapMaybe go + where + go (Cex cex) = Just $ snd cex + go _ = Nothing +getTimeouts :: [VerifyResult] -> [Expr End] +getTimeouts = mapMaybe go + where + go (Timeout leaf) = Just leaf + go _ = Nothing + dappCoverage :: UnitTestOptions -> Mode -> String -> IO () dappCoverage opts _ solcFile = readSolc solcFile >>= @@ -620,46 +527,52 @@ shouldPrintCoverage Nothing file = not (isTestOrLib file) isTestOrLib :: Text -> Bool -isTestOrLib file = Text.isSuffixOf ".t.sol" file || areAnyPrefixOf ["src/test/", "src/tests/", "lib/"] file +isTestOrLib file = T.isSuffixOf ".t.sol" file || areAnyPrefixOf ["src/test/", "src/tests/", "lib/"] file areAnyPrefixOf :: [Text] -> Text -> Bool -areAnyPrefixOf prefixes t = any (flip Text.isPrefixOf t) prefixes +areAnyPrefixOf prefixes t = any (flip T.isPrefixOf t) prefixes launchExec :: Command Options.Unwrapped -> IO () launchExec cmd = do dapp <- getSrcInfo cmd vm <- vmFromCommand cmd - case optsMode cmd of - Run -> do - vm' <- execStateT (EVM.Stepper.interpret fetcher . void $ EVM.Stepper.execFully) vm - when (trace cmd) $ hPutStr stderr (showTraceTree dapp vm') - case view EVM.result vm' of - Nothing -> - error "internal error; no EVM result" - Just (EVM.VMFailure (EVM.Revert msg)) -> do - print $ ByteStringS msg - exitWith (ExitFailure 2) - Just (EVM.VMFailure err) -> do - print err - exitWith (ExitFailure 2) - Just (EVM.VMSuccess buf) -> do - let msg = case buf of - SymbolicBuffer msg' -> forceLitBytes msg' - ConcreteBuffer msg' -> msg' - print $ ByteStringS msg - case state cmd of - Nothing -> pure () - Just path -> - Git.saveFacts (Git.RepoAt path) (Facts.vmFacts vm') - case cache cmd of - Nothing -> pure () - Just path -> - Git.saveFacts (Git.RepoAt path) (Facts.cacheFacts (view EVM.cache vm')) + smtjobs <- fromIntegral <$> getNumProcessors + withSolvers Z3 smtjobs (smttimeout cmd) $ \solvers -> do + case optsMode cmd of + Run -> do + vm' <- execStateT (EVM.Stepper.interpret (EVM.Fetch.oracle solvers rpcinfo) . void $ EVM.Stepper.execFully) vm + when (trace cmd) $ T.hPutStr stderr (showTraceTree dapp vm') + case view EVM.result vm' of + Nothing -> + error "internal error; no EVM result" + Just (EVM.VMFailure (EVM.Revert msg)) -> do + let res = case msg of + ConcreteBuf bs -> bs + _ -> "" + print $ ByteStringS res + exitWith (ExitFailure 2) + Just (EVM.VMFailure err) -> do + print err + exitWith (ExitFailure 2) + Just (EVM.VMSuccess buf) -> do + let msg = case buf of + ConcreteBuf msg' -> msg' + _ -> "" + print $ ByteStringS msg + case state cmd of + Nothing -> pure () + Just path -> + Git.saveFacts (Git.RepoAt path) (Facts.vmFacts vm') + case cache cmd of + Nothing -> pure () + Just path -> + Git.saveFacts (Git.RepoAt path) (Facts.cacheFacts (view EVM.cache vm')) - Debug -> void $ EVM.TTY.runFromVM Nothing dapp fetcher vm - JsonTrace -> void $ execStateT (interpretWithTrace fetcher EVM.Stepper.runFully) vm - where fetcher = maybe EVM.Fetch.zero (EVM.Fetch.http block') (rpc cmd) - block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) + Debug -> void $ TTY.runFromVM solvers rpcinfo Nothing dapp vm + --JsonTrace -> void $ execStateT (interpretWithTrace fetcher EVM.Stepper.runFully) vm + _ -> error "TODO" + where block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) + rpcinfo = (,) block' <$> rpc cmd data Testcase = Testcase { _entries :: [(Text, Maybe Text)], @@ -725,15 +638,15 @@ vmFromCommand cmd = do withCache <- applyCache (state cmd, cache cmd) - (miner,ts,baseFee,blockNum,diff) <- case rpc cmd of - Nothing -> return (0,0,0,0,0) + (miner,ts,baseFee,blockNum,prevRan) <- case rpc cmd of + Nothing -> return (0,Lit 0,0,0,0) Just url -> EVM.Fetch.fetchBlockFrom block' url >>= \case Nothing -> error "Could not fetch block" Just EVM.Block{..} -> return (_coinbase - , wordValue $ forceLit _timestamp - , wordValue _baseFee - , wordValue _number - , wordValue _difficulty + , _timestamp + , _baseFee + , _number + , _prevRandao ) contract <- case (rpc cmd, address cmd, code cmd) of @@ -745,8 +658,7 @@ -- if both code and url is given, -- fetch the contract and overwrite the code return $ - EVM.initialContract (codeType $ hexByteString "--code" $ strip0x c) - & set EVM.storage (view EVM.storage contract') + EVM.initialContract (mkCode $ hexByteString "--code" $ strip0x c) & set EVM.balance (view EVM.balance contract') & set EVM.nonce (view EVM.nonce contract') & set EVM.external (view EVM.external contract') @@ -759,46 +671,52 @@ (_, _, Just c) -> return $ - EVM.initialContract (codeType $ hexByteString "--code" $ strip0x c) + EVM.initialContract (mkCode $ hexByteString "--code" $ strip0x c) (_, _, Nothing) -> error "must provide at least (rpc + address) or code" - return $ VMTest.initTx $ withCache (vm0 baseFee miner ts blockNum diff contract) + let ts' = case unlit ts of + Just t -> t + Nothing -> error "unexpected symbolic timestamp when executing vm test" + + return $ VMTest.initTx $ withCache (vm0 baseFee miner ts' blockNum prevRan contract) where - decipher = hexByteString "bytes" . strip0x block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) value' = word value 0 caller' = addr caller 0 origin' = addr origin 0 - calldata' = ConcreteBuffer $ bytes calldata "" - codeType = (if create cmd then EVM.InitCode else EVM.RuntimeCode) . ConcreteBuffer + calldata' = ConcreteBuf $ bytes Main.calldata "" + decipher = hexByteString "bytes" . strip0x + mkCode bs = if create cmd + then EVM.InitCode bs mempty + else EVM.RuntimeCode (fromJust $ Expr.toList (ConcreteBuf bs)) address' = if create cmd then addr address (createAddress origin' (word nonce 0)) else addr address 0xacab - vm0 baseFee miner ts blockNum diff c = EVM.makeVm $ EVM.VMOpts + vm0 baseFee miner ts blockNum prevRan c = EVM.makeVm $ EVM.VMOpts { EVM.vmoptContract = c - , EVM.vmoptCalldata = (calldata', litWord (num $ len calldata')) - , EVM.vmoptValue = w256lit value' + , EVM.vmoptCalldata = (calldata', []) + , EVM.vmoptValue = Lit value' , EVM.vmoptAddress = address' , EVM.vmoptCaller = litAddr caller' , EVM.vmoptOrigin = origin' - , EVM.vmoptGas = word gas 0 + , EVM.vmoptGas = 0 , EVM.vmoptBaseFee = baseFee - , EVM.vmoptPriorityFee = word priorityFee 0 - , EVM.vmoptGaslimit = word gas 0 + , EVM.vmoptPriorityFee = 0 + , EVM.vmoptGaslimit = 0 , EVM.vmoptCoinbase = addr coinbase miner , EVM.vmoptNumber = word number blockNum - , EVM.vmoptTimestamp = w256lit $ word timestamp ts - , EVM.vmoptBlockGaslimit = word gaslimit 0 - , EVM.vmoptGasprice = word gasprice 0 + , EVM.vmoptTimestamp = Lit $ word timestamp ts + , EVM.vmoptBlockGaslimit = 0 + , EVM.vmoptGasprice = 0 , EVM.vmoptMaxCodeSize = word maxcodesize 0xffffffff - , EVM.vmoptDifficulty = word difficulty diff + , EVM.vmoptPrevRandao = word prevRandao prevRan , EVM.vmoptSchedule = FeeSchedule.berlin , EVM.vmoptChainId = word chainid 1 , EVM.vmoptCreate = create cmd - , EVM.vmoptStorageModel = ConcreteS + , EVM.vmoptStorageBase = EVM.Concrete , EVM.vmoptTxAccessList = mempty -- TODO: support me soon , EVM.vmoptAllowFFI = False } @@ -806,56 +724,38 @@ addr f def = fromMaybe def (f cmd) bytes f def = maybe def decipher (f cmd) -symvmFromCommand :: Command Options.Unwrapped -> Query EVM.VM -symvmFromCommand cmd = do - - (miner,blockNum,baseFee,diff) <- case rpc cmd of +symvmFromCommand :: Command Options.Unwrapped -> (Expr Buf, [Prop]) -> IO (EVM.VM) +symvmFromCommand cmd calldata' = do + (miner,blockNum,baseFee,prevRan) <- case rpc cmd of Nothing -> return (0,0,0,0) - Just url -> io $ EVM.Fetch.fetchBlockFrom block' url >>= \case + Just url -> EVM.Fetch.fetchBlockFrom block' url >>= \case Nothing -> error "Could not fetch block" Just EVM.Block{..} -> return (_coinbase - , wordValue _number - , wordValue _baseFee - , wordValue _difficulty + , _number + , _baseFee + , _prevRandao ) - caller' <- maybe (SAddr <$> freshVar_) (return . litAddr) (caller cmd) - ts <- maybe (var "Timestamp" <$> freshVar_) (return . w256lit) (timestamp cmd) - callvalue' <- maybe (var "CallValue" <$> freshVar_) (return . w256lit) (value cmd) - (calldata', cdlen, pathCond) <- case (calldata cmd, sig cmd) of - -- fully abstract calldata (up to 256 bytes) - (Nothing, Nothing) -> do - cd <- sbytes256 - len' <- freshVar_ - return (SymbolicBuffer cd, var "CALLDATALENGTH" len', (len' .<= 256, Todo "len < 256" [])) - -- fully concrete calldata - (Just c, Nothing) -> - let cd = ConcreteBuffer $ decipher c - in return (cd, litWord (num $ len cd), (sTrue, Todo "" [])) - -- calldata according to given abi with possible specializations from the `arg` list - (Nothing, Just sig') -> do - method' <- io $ functionAbi sig' - let typs = snd <$> view methodInputs method' - (cd, cdlen) <- symCalldata (view methodSignature method') typs (arg cmd) - return (SymbolicBuffer cd, litWord (num cdlen), (sTrue, Todo "" [])) - - _ -> error "incompatible options: calldata and abi" - - store <- case storageModel cmd of - -- InitialS and SymbolicS can read and write to symbolic locations - -- ConcreteS cannot (instead values can be fetched from rpc!) - -- Initial defaults to 0 for uninitialized storage slots, - -- whereas the values of SymbolicS are unconstrained. - Just InitialS -> EVM.Symbolic [] <$> freshArray_ (Just 0) - Just ConcreteS -> return (EVM.Concrete mempty) - Just SymbolicS -> EVM.Symbolic [] <$> freshArray_ Nothing - Nothing -> EVM.Symbolic [] <$> freshArray_ (if create cmd then (Just 0) else Nothing) + let + caller' = Caller 0 + ts = maybe Timestamp Lit (timestamp cmd) + callvalue' = maybe (CallValue 0) Lit (value cmd) + -- TODO: rework this, ConcreteS not needed anymore + let store = case storageModel cmd of + -- InitialS and SymbolicS can read and write to symbolic locations + -- ConcreteS cannot (instead values can be fetched from rpc!) + -- Initial defaults to 0 for uninitialized storage slots, + -- whereas the values of SymbolicS are unconstrained. + Just InitialS -> EmptyStore + Just ConcreteS -> ConcreteStore mempty + Just SymbolicS -> AbstractStore + Nothing -> if create cmd then EmptyStore else AbstractStore - withCache <- io $ applyCache (state cmd, cache cmd) + withCache <- applyCache (state cmd, cache cmd) contract' <- case (rpc cmd, address cmd, code cmd) of (Just url, Just addr', _) -> - io (EVM.Fetch.fetchContractFrom block' url addr') >>= \case + EVM.Fetch.fetchContractFrom block' url addr' >>= \case Nothing -> error "contract not found." Just contract' -> return contract'' @@ -864,51 +764,53 @@ Nothing -> contract' -- if both code and url is given, -- fetch the contract and overwrite the code - Just c -> EVM.initialContract (codeType $ decipher c) - & set EVM.origStorage (view EVM.origStorage contract') + Just c -> EVM.initialContract (mkCode $ decipher c) + -- TODO: fix this + -- & set EVM.origStorage (view EVM.origStorage contract') & set EVM.balance (view EVM.balance contract') & set EVM.nonce (view EVM.nonce contract') & set EVM.external (view EVM.external contract') (_, _, Just c) -> - return (EVM.initialContract . codeType $ decipher c) + return (EVM.initialContract . mkCode $ decipher c) (_, _, Nothing) -> error "must provide at least (rpc + address) or code" - return $ (VMTest.initTx $ withCache $ vm0 baseFee miner ts blockNum diff cdlen calldata' callvalue' caller' contract') - & over EVM.constraints (<> [pathCond]) - & set (EVM.env . EVM.contracts . (ix address') . EVM.storage) store + return $ (VMTest.initTx $ withCache $ vm0 baseFee miner ts blockNum prevRan calldata' callvalue' caller' contract') + & set (EVM.env . EVM.storage) store where decipher = hexByteString "bytes" . strip0x block' = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber (block cmd) origin' = addr origin 0 - codeType = (if create cmd then EVM.InitCode else EVM.RuntimeCode) . ConcreteBuffer + mkCode bs = if create cmd + then EVM.InitCode bs mempty + else EVM.RuntimeCode (fromJust . Expr.toList $ ConcreteBuf bs) address' = if create cmd then addr address (createAddress origin' (word nonce 0)) else addr address 0xacab - vm0 baseFee miner ts blockNum diff cdlen calldata' callvalue' caller' c = EVM.makeVm $ EVM.VMOpts + vm0 baseFee miner ts blockNum prevRan cd' callvalue' caller' c = EVM.makeVm $ EVM.VMOpts { EVM.vmoptContract = c - , EVM.vmoptCalldata = (calldata', cdlen) + , EVM.vmoptCalldata = cd' , EVM.vmoptValue = callvalue' , EVM.vmoptAddress = address' , EVM.vmoptCaller = caller' , EVM.vmoptOrigin = origin' - , EVM.vmoptGas = word gas 0xffffffffffffffff - , EVM.vmoptGaslimit = word gas 0xffffffffffffffff + , EVM.vmoptGas = 0xffffffffffffffff + , EVM.vmoptGaslimit = 0xffffffffffffffff , EVM.vmoptBaseFee = baseFee , EVM.vmoptPriorityFee = word priorityFee 0 , EVM.vmoptCoinbase = addr coinbase miner , EVM.vmoptNumber = word number blockNum , EVM.vmoptTimestamp = ts - , EVM.vmoptBlockGaslimit = word gaslimit 0 - , EVM.vmoptGasprice = word gasprice 0 + , EVM.vmoptBlockGaslimit = 0 + , EVM.vmoptGasprice = 0 , EVM.vmoptMaxCodeSize = word maxcodesize 0xffffffff - , EVM.vmoptDifficulty = word difficulty diff + , EVM.vmoptPrevRandao = word prevRandao prevRan , EVM.vmoptSchedule = FeeSchedule.berlin , EVM.vmoptChainId = word chainid 1 , EVM.vmoptCreate = create cmd - , EVM.vmoptStorageModel = fromMaybe SymbolicS (storageModel cmd) + , EVM.vmoptStorageBase = EVM.Symbolic , EVM.vmoptTxAccessList = mempty , EVM.vmoptAllowFFI = False } @@ -917,7 +819,6 @@ launchTest :: HasCallStack => Command Options.Unwrapped -> IO () launchTest cmd = do -#if MIN_VERSION_aeson(1, 0, 0) parsed <- VMTest.parseBCSuite <$> LazyByteString.readFile (file cmd) case parsed of Left "No cases to check." -> putStrLn "no-cases ok" @@ -930,11 +831,7 @@ in mapM_ (runVMTest (diff cmd) (optsMode cmd) (timeout cmd)) $ testFilter (Map.toList allTests) -#else - putStrLn "Not supported" -#endif -#if MIN_VERSION_aeson(1, 0, 0) runVMTest :: HasCallStack => Bool -> Mode -> Maybe Int -> (String, VMTest.Case) -> IO Bool runVMTest diffmode mode timelimit (name, x) = do @@ -946,11 +843,12 @@ case mode of Run -> Timeout.timeout (1000000 * (fromMaybe 10 timelimit)) $ - execStateT (EVM.Stepper.interpret EVM.Fetch.zero . void $ EVM.Stepper.execFully) vm0 + execStateT (EVM.Stepper.interpret (EVM.Fetch.zero 0 (Just 0)) . void $ EVM.Stepper.execFully) vm0 Debug -> - Just <$> EVM.TTY.runFromVM Nothing emptyDapp EVM.Fetch.zero vm0 + withSolvers Z3 0 Nothing $ \solvers -> Just <$> TTY.runFromVM solvers Nothing Nothing emptyDapp vm0 JsonTrace -> - Just <$> execStateT (interpretWithTrace EVM.Fetch.zero EVM.Stepper.runFully) vm0 + error "JsonTrace: implement me" + -- Just <$> execStateT (EVM.UnitTest.interpretWithCoverage EVM.Fetch.zero EVM.Stepper.runFully) vm0 waitCatch action case result of Right (Just vm1) -> do @@ -965,8 +863,6 @@ then show e else (head . lines . show) e return False - -#endif parseAbi :: (AsValue s) => s -> (Text, [AbiType]) parseAbi abijson = diff --git a/hevm.cabal b/hevm.cabal --- a/hevm.cabal +++ b/hevm.cabal @@ -1,8 +1,8 @@ -cabal-version: 2.2 +cabal-version: 3.0 name: hevm version: - 0.49.0 + 0.50.0 synopsis: Ethereum virtual machine evaluator description: @@ -14,12 +14,10 @@ https://github.com/dapphub/dapptools license: AGPL-3.0-only -license-file: - COPYING author: - Mikael Brockman, Martin Lundfall + Mikael Brockman, Martin Lundfall, dxo maintainer: - mikael@brockman.se, martin.lundfall@gmail.com + mikael@brockman.se, martin.lundfall@gmail.com, git@d-xo.org category: Ethereum build-type: @@ -29,17 +27,61 @@ run-consensus-tests extra-source-files: CHANGELOG.md + test/contracts/lib/test.sol + test/contracts/lib/erc20.sol + test/contracts/pass/trivial.sol + test/contracts/pass/abstract.sol + test/contracts/pass/cheatCodes.sol + test/contracts/pass/constantinople.sol + test/contracts/pass/dsProvePass.sol + test/contracts/pass/invariants.sol + test/contracts/pass/libraries.sol + test/contracts/pass/loops.sol + test/contracts/pass/rpc.sol + test/contracts/fail/trivial.sol + test/contracts/fail/cheatCodes.sol + test/contracts/fail/dsProveFail.sol + test/contracts/fail/invariantFail.sol +common shared + default-language: + Haskell2010 + default-extensions: + LambdaCase + OverloadedStrings + RecordWildCards + TypeFamilies + ViewPatterns + -- GHC2021 default extensions, remove me when GHC is updated to 9.2 + BangPatterns + ConstraintKinds + DeriveDataTypeable + DeriveFunctor + DeriveGeneric + DoAndIfThenElse + EmptyDataDecls + FlexibleContexts + FlexibleInstances + ForeignFunctionInterface + GeneralizedNewtypeDeriving + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeOperators + library + import: shared exposed-modules: EVM, EVM.ABI, EVM.Concrete, EVM.Dapp, - EVM.Dev, EVM.Debug, EVM.Demand, - EVM.Emacs, + EVM.Dev, + EVM.Expr, + EVM.SMT, EVM.Exec, EVM.Facts, EVM.Facts.Git, @@ -55,8 +97,10 @@ EVM.Solidity, EVM.Stepper, EVM.StorageLayout, - EVM.Symbolic, - EVM.SymExec + EVM.SymExec, + EVM.Traversals, + EVM.CSE, + EVM.Keccak, EVM.Transaction, EVM.TTY, EVM.TTYCenteredList, @@ -68,9 +112,11 @@ autogen-modules: Paths_hevm ghc-options: - -Wall -Wno-deprecations + -Wall -Wno-deprecations -Wno-unticked-promoted-constructors -Wno-orphans extra-libraries: secp256k1, ff + if os(linux) + extra-libraries: stdc++ c-sources: ethjet/tinykeccak.c, ethjet/ethjet.c cxx-sources: @@ -88,7 +134,7 @@ transformers >= 0.5.6 && < 0.6, tree-view >= 0.5 && < 0.6, abstract-par >= 0.3.3 && < 0.4, - aeson >= 1.5.6 && < 1.6, + aeson >= 2.0.0 && < 2.1, bytestring >= 0.10.8 && < 0.11, scientific >= 0.3.6 && < 0.4, binary >= 0.8.6 && < 0.9, @@ -97,7 +143,7 @@ vector >= 0.12.1 && < 0.13, ansi-wl-pprint >= 0.6.9 && < 0.7, base16-bytestring >= 1.0.0 && < 2.0, - brick >= 0.58 && < 0.63, + brick >= 0.68 && < 0.69, megaparsec >= 9.0.0 && < 10.0, mtl >= 2.2.2 && < 2.3, directory >= 1.3.3 && < 1.4, @@ -105,15 +151,16 @@ vty >= 5.25.1 && < 5.34, cereal >= 0.5.8 && < 0.6, cryptonite >= 0.27 && <= 0.29, - memory >= 0.14.18 && < 0.16, + memory >= 0.16.0 && < 0.20, data-dword >= 0.3.1 && < 0.4, fgl >= 5.7.0 && < 5.8, free >= 5.1.3 && < 5.2, haskeline >= 0.8.0 && < 0.9, process >= 1.6.5 && < 1.7, - lens >= 4.17.1 && < 4.20, + lens >= 5.0.0 && < 5.1, lens-aeson >= 1.0.2 && < 1.2, monad-par >= 0.3.5 && < 0.4, + async >= 2.2.4 && < 2.3, multiset >= 0.3.4 && < 0.4, operational >= 0.2.3 && < 0.3, optparse-generic >= 1.3.1 && < 1.5, @@ -121,45 +168,36 @@ restless-git >= 0.7 && < 0.8, rosezipper >= 0.2 && < 0.3, s-cargot >= 0.1.4 && < 0.2, - sbv >= 8.9, semver-range >= 0.2.7 && < 0.3, temporary >= 1.3 && < 1.4, - text-format >= 0.3.2 && < 0.4, witherable >= 0.3.5 && < 0.5, wreq >= 0.5.3 && < 0.6, regex-tdfa >= 1.2.3 && < 1.4, base >= 4.9 && < 5, here >= 1.2.13 && < 1.3, + tuple >= 0.3.0.2 && < 0.4, + smt2-parser >= 0.1.0.1, + word-wrap >= 0.5 && < 0.6, + spool >= 0.1 && < 0.2, + parsec >= 3.1.14.0 && < 3.1.15 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 + import: shared hs-source-dirs: hevm-cli main-is: hevm-cli.hs ghc-options: - -Wall -threaded -with-rtsopts=-N + -Wall -threaded -with-rtsopts=-N -Wno-unticked-promoted-constructors -Wno-orphans other-modules: Paths_hevm if os(darwin) + extra-libraries: c++ ld-options: -Wl,-keep_dwarf_unwind + else + extra-libraries: stdc++ build-depends: QuickCheck, aeson, @@ -187,43 +225,85 @@ process, quickcheck-text, regex-tdfa, - sbv, temporary, text, - text-format, unordered-containers, vector, vty -test-suite test - default-language: - Haskell2010 +common test-base + import: shared ghc-options: - -Wall - type: - exitcode-stdio-1.0 + -Wall -Wno-unticked-promoted-constructors -Wno-orphans hs-source-dirs: test - main-is: - test.hs extra-libraries: secp256k1 + other-modules: + Paths_hevm + autogen-modules: + Paths_hevm build-depends: HUnit >= 1.6, QuickCheck, + quickcheck-instances, base, base16-bytestring, binary, containers, + directory, bytestring, - free, here, hevm, lens, mtl, + data-dword, + process, tasty >= 1.0, tasty-hunit >= 0.10, tasty-quickcheck >= 0.9, + tasty-expected-failure >= 0.12, + temporary, text, + regex-tdfa, + regex, + time, + array, vector, - sbv + smt2-parser >= 0.1.0.1 + +library test-utils + import: + test-base + exposed-modules: + EVM.TestUtils + +common test-common + import: + test-base + build-depends: + test-utils + if os(darwin) + extra-libraries: c++ + else + extra-libraries: stdc++ + +--- Test Suites --- + +test-suite test + import: + test-common + type: + exitcode-stdio-1.0 + main-is: + test.hs + +-- these tests require network access so we split them into a seperate test +-- suite to make it easy to skip them when running nix-build +test-suite rpc-tests + import: + test-common + type: + exitcode-stdio-1.0 + main-is: + rpc.hs diff --git a/src/EVM.hs b/src/EVM.hs --- a/src/EVM.hs +++ b/src/EVM.hs @@ -1,2864 +1,2925 @@ {-# Language ImplicitParams #-} -{-# Language ConstraintKinds #-} -{-# Language FlexibleInstances #-} -{-# Language DataKinds #-} -{-# Language GADTs #-} -{-# Language RecordWildCards #-} -{-# Language ScopedTypeVariables #-} -{-# Language StandaloneDeriving #-} -{-# Language StrictData #-} -{-# Language TemplateHaskell #-} -{-# Language TypeOperators #-} -{-# Language ViewPatterns #-} - -module EVM where - -import Prelude hiding (log, Word, exponent, GT, LT) - -import Data.SBV hiding (Word, output, Unknown) -import Data.Proxy (Proxy(..)) -import Data.Text (unpack) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import qualified Data.Vector as V -import EVM.ABI -import EVM.Types -import EVM.Solidity -import EVM.Concrete (createAddress, wordValue, keccakBlob, create2Address, readMemoryWord) -import EVM.Symbolic -import EVM.Op -import EVM.FeeSchedule (FeeSchedule (..)) -import Options.Generic as Options -import qualified EVM.Precompiled - -import Control.Lens hiding (op, (:<), (|>), (.>)) -import Control.Monad.State.Strict hiding (state) - -import Data.ByteString (ByteString) -import Data.ByteString.Lazy (fromStrict) -import Data.Map.Strict (Map) -import Data.Set (Set, insert, member, fromList) -import Data.Maybe (fromMaybe) -import Data.Sequence (Seq) -import Data.Vector.Storable (Vector) -import Data.Foldable (toList) - -import Data.Tree -import Data.List (find) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LS -import qualified Data.ByteString.Char8 as Char8 -import qualified Data.ByteArray as BA -import qualified Data.Map.Strict as Map -import qualified Data.Sequence as Seq -import qualified Data.Tree.Zipper as Zipper -import qualified Data.Vector as V -import qualified Data.Vector.Storable as Vector -import qualified Data.Vector.Storable.Mutable as Vector - -import qualified Data.Vector as RegularVector - -import Crypto.Number.ModArithmetic (expFast) -import qualified Crypto.Hash as Crypto -import Crypto.Hash (Digest, SHA256, RIPEMD160, digestFromByteString) -import Crypto.PubKey.ECC.ECDSA (signDigestWith, PrivateKey(..), Signature(..)) -import Crypto.PubKey.ECC.Types (getCurveByName, CurveName(..), Point(..)) -import Crypto.PubKey.ECC.Generate (generateQ) - --- * Data types - --- | EVM failure modes -data Error - = BalanceTooLow Word Word - | UnrecognizedOpcode Word8 - | SelfDestruction - | StackUnderrun - | BadJumpDestination - | Revert ByteString - | OutOfGas Word Word - | BadCheatCode (Maybe Word32) - | StackLimitExceeded - | IllegalOverflow - | Query Query - | Choose Choose - | StateChangeWhileStatic - | InvalidMemoryAccess - | CallDepthLimitReached - | MaxCodeSizeExceeded Word Word - | InvalidFormat - | PrecompileFailure - | UnexpectedSymbolicArg - | DeadPath - | NotUnique Whiff - | SMTTimeout - | FFI AbiVals -deriving instance Show Error - --- | The possible result states of a VM -data VMResult - = VMFailure Error -- ^ An operation failed - | VMSuccess Buffer -- ^ Reached STOP, RETURN, or end-of-code - -deriving instance Show VMResult - --- | The state of a stepwise EVM execution -data VM = VM - { _result :: Maybe VMResult - , _state :: FrameState - , _frames :: [Frame] - , _env :: Env - , _block :: Block - , _tx :: TxState - , _logs :: Seq Log - , _traces :: Zipper.TreePos Zipper.Empty Trace - , _cache :: Cache - , _burned :: Word - , _constraints :: [(SBool, Whiff)] - , _iterations :: Map CodeLocation Int - , _allowFFI :: Bool - } - deriving (Show) - -data Trace = Trace - { _traceOpIx :: Int - , _traceContract :: Contract - , _traceData :: TraceData - } - deriving (Show) - -data TraceData - = EventTrace Log - | FrameTrace FrameContext - | QueryTrace Query - | ErrorTrace Error - | EntryTrace Text - | ReturnTrace Buffer FrameContext - deriving (Show) - --- | Queries halt execution until resolved through RPC calls or SMT queries -data Query where - PleaseFetchContract :: Addr -> StorageModel -> (Contract -> EVM ()) -> Query - PleaseMakeUnique :: SymVal a => SBV a -> [SBool] -> (IsUnique a -> EVM ()) -> Query - PleaseFetchSlot :: Addr -> Word -> (Word -> EVM ()) -> Query - PleaseAskSMT :: SBool -> [SBool] -> (BranchCondition -> EVM ()) -> Query - PleaseDoFFI :: [String] -> (ByteString -> EVM ()) -> Query - -data Choose where - PleaseChoosePath :: Whiff -> (Bool -> EVM ()) -> Choose - -instance Show Query where - showsPrec _ = \case - PleaseFetchContract addr _ _ -> - (("") ++) - PleaseFetchSlot addr slot _ -> - (("") ++) - PleaseAskSMT condition constraints _ -> - (("") ++) - PleaseMakeUnique val constraints _ -> - (("") ++) - PleaseDoFFI cmd _ -> - ((" - ((" b = Cache - { _fetched = Map.unionWith unifyCachedContract (view fetched a) (view fetched b) - , _path = mappend (view path a) (view path b) - } - --- only intended for use in Cache merges, where we expect --- everything to be Concrete -unifyCachedContract :: Contract -> Contract -> Contract -unifyCachedContract a b = a & set storage merged - where merged = case (view storage a, view storage b) of - (Concrete sa, Concrete sb) -> - Concrete (mappend sa sb) - _ -> - view storage a - -instance Monoid Cache where - mempty = Cache { _fetched = mempty, - _path = mempty - } - --- * Data accessors - -currentContract :: VM -> Maybe Contract -currentContract vm = - view (env . contracts . at (view (state . codeContract) vm)) vm - --- * Data constructors - -makeVm :: VMOpts -> VM -makeVm o = - let txaccessList = vmoptTxAccessList o - txorigin = vmoptOrigin o - txtoAddr = vmoptAddress o - initialAccessedAddrs = fromList $ [txorigin, txtoAddr] ++ [1..9] ++ (Map.keys txaccessList) - initialAccessedStorageKeys = fromList $ foldMap (uncurry (map . (,))) (Map.toList txaccessList) - touched = if vmoptCreate o then [txorigin] else [txorigin, txtoAddr] - in - VM - { _result = Nothing - , _frames = mempty - , _tx = TxState - { _gasprice = w256 $ vmoptGasprice o - , _txgaslimit = w256 $ vmoptGaslimit o - , _txPriorityFee = w256 $ vmoptPriorityFee o - , _origin = txorigin - , _toAddr = txtoAddr - , _value = vmoptValue o - , _substate = SubState mempty touched initialAccessedAddrs initialAccessedStorageKeys mempty - --, _accessList = txaccessList - , _isCreate = vmoptCreate o - , _txReversion = Map.fromList - [(vmoptAddress o, vmoptContract o)] - } - , _logs = mempty - , _traces = Zipper.fromForest [] - , _block = Block - { _coinbase = vmoptCoinbase o - , _timestamp = vmoptTimestamp o - , _number = w256 $ vmoptNumber o - , _difficulty = w256 $ vmoptDifficulty o - , _maxCodeSize = w256 $ vmoptMaxCodeSize o - , _gaslimit = w256 $ vmoptBlockGaslimit o - , _baseFee = w256 $ vmoptBaseFee o - , _schedule = vmoptSchedule o - } - , _state = FrameState - { _pc = 0 - , _stack = mempty - , _memory = mempty - , _memorySize = 0 - , _code = theCode - , _contract = vmoptAddress o - , _codeContract = vmoptAddress o - , _calldata = vmoptCalldata o - , _callvalue = vmoptValue o - , _caller = vmoptCaller o - , _gas = w256 $ vmoptGas o - , _returndata = mempty - , _static = False - } - , _env = Env - { _sha3Crack = mempty - , _chainId = w256 $ vmoptChainId o - , _contracts = Map.fromList - [(vmoptAddress o, vmoptContract o)] - , _keccakUsed = mempty - , _storageModel = vmoptStorageModel o - } - , _cache = Cache mempty mempty - , _burned = 0 - , _constraints = [] - , _iterations = mempty - , _allowFFI = vmoptAllowFFI o - } where theCode = case _contractcode (vmoptContract o) of - InitCode b -> b - RuntimeCode b -> b - --- | Initialize empty contract with given code -initialContract :: ContractCode -> Contract -initialContract theContractCode = Contract - { _contractcode = theContractCode - , _codehash = - case theCode of - ConcreteBuffer b -> keccak (stripBytecodeMetadata b) - SymbolicBuffer _ -> 0 - - , _storage = Concrete mempty - , _balance = 0 - , _nonce = if creation then 1 else 0 - , _opIxMap = mkOpIxMap theCode - , _codeOps = mkCodeOps theCode - , _external = False - , _origStorage = mempty - } where - (creation, theCode) = case theContractCode of - InitCode b -> (True, b) - RuntimeCode b -> (False, b) - -contractWithStore :: ContractCode -> Storage -> Contract -contractWithStore theContractCode store = - initialContract theContractCode & set storage store - --- * Opcode dispatch (exec1) - --- | Update program counter -next :: (?op :: Word8) => EVM () -next = modifying (state . pc) (+ (opSize ?op)) - --- | Executes the EVM one step -exec1 :: EVM () -exec1 = do - vm <- get - - let - -- Convenience function to access parts of the current VM state. - -- Arcane type signature needed to avoid monomorphism restriction. - the :: (b -> VM -> Const a VM) -> ((a -> Const a a) -> b) -> a - the f g = view (f . g) vm - - -- Convenient aliases - mem = the state memory - stk = the state stack - self = the state contract - this = fromMaybe (error "internal error: state contract") (preview (ix self) (the env contracts)) - - fees@FeeSchedule {..} = the block schedule - - doStop = finishFrame (FrameReturned mempty) - - if self > 0x0 && self <= 0x9 then do - -- call to precompile - let ?op = 0x00 -- dummy value - let - calldatasize = snd (the state calldata) - case maybeLitWord calldatasize of - Nothing -> vmError UnexpectedSymbolicArg - Just calldatasize' -> do - copyBytesToMemory (fst $ the state calldata) (num calldatasize') 0 0 - executePrecompile self (num $ the state gas) 0 (num calldatasize') 0 0 [] - vmx <- get - case view (state.stack) vmx of - (x:_) -> case maybeLitWord x of - Just 0 -> do - fetchAccount self $ \_ -> do - touchAccount self - vmError PrecompileFailure - Just _ -> - fetchAccount self $ \_ -> do - touchAccount self - out <- use (state . returndata) - finishFrame (FrameReturned out) - Nothing -> vmError UnexpectedSymbolicArg - _ -> - underrun - - else if the state pc >= len (the state code) - then doStop - - else do - let ?op = fromMaybe (error "could not analyze symbolic code") $ unliteral $ EVM.Symbolic.index (the state pc) (the state code) - - case ?op of - - -- op: PUSH - x | x >= 0x60 && x <= 0x7f -> do - let !n = num x - 0x60 + 1 - !xs = case the state code of - ConcreteBuffer b -> w256lit $ word $ padRight n $ BS.take n (BS.drop (1 + the state pc) b) - SymbolicBuffer b -> readSWord' 0 $ padLeft' 32 $ take n $ drop (1 + the state pc) b - limitStack 1 $ - burn g_verylow $ do - next - pushSym xs - - -- op: DUP - x | x >= 0x80 && x <= 0x8f -> do - let !i = x - 0x80 + 1 - case preview (ix (num i - 1)) stk of - Nothing -> underrun - Just y -> - limitStack 1 $ - burn g_verylow $ do - next - pushSym y - - -- op: SWAP - x | x >= 0x90 && x <= 0x9f -> do - let i = num (x - 0x90 + 1) - if length stk < i + 1 - then underrun - else - burn g_verylow $ do - next - zoom (state . stack) $ do - assign (ix 0) (stk ^?! ix i) - assign (ix i) (stk ^?! ix 0) - - -- op: LOG - x | x >= 0xa0 && x <= 0xa4 -> - notStatic $ - let n = (num x - 0xa0) in - case stk of - (xOffset':xSize':xs) -> - if length xs < n - then underrun - else - forceConcrete2 (xOffset', xSize') $ \(xOffset, xSize) -> do - let (topics, xs') = splitAt n xs - bytes = readMemory (num xOffset) (num xSize) vm - log = Log self bytes topics - - burn (g_log + g_logdata * (num xSize) + num n * g_logtopic) $ - accessMemoryRange fees xOffset xSize $ do - traceLog log - next - assign (state . stack) xs' - pushToSequence logs log - _ -> - underrun - - -- op: STOP - 0x00 -> doStop - - -- op: ADD - 0x01 -> stackOp2 (const g_verylow) (uncurry (+)) - -- op: MUL - 0x02 -> stackOp2 (const g_low) (uncurry (*)) - -- op: SUB - 0x03 -> stackOp2 (const g_verylow) (uncurry (-)) - - -- op: DIV - 0x04 -> stackOp2 (const g_low) (uncurry (sDiv)) - - -- op: SDIV - 0x05 -> - stackOp2 (const g_low) (uncurry sdiv) - - -- op: MOD - 0x06 -> stackOp2 (const g_low) $ \(S a x, S b y) -> S (ITE (IsZero b) (Literal 0) (Mod a b)) (ite (y .== 0) 0 (x `sMod` y)) - - -- op: SMOD - 0x07 -> stackOp2 (const g_low) $ uncurry smod - -- op: ADDMOD - 0x08 -> stackOp3 (const g_mid) (\(x, y, z) -> addmod x y z) - -- op: MULMOD - 0x09 -> stackOp3 (const g_mid) (\(x, y, z) -> mulmod x y z) - - -- op: LT - 0x10 -> stackOp2 (const g_verylow) $ \(S a x, S b y) -> iteWhiff (LT a b) (x .< y) 1 0 - -- op: GT - 0x11 -> stackOp2 (const g_verylow) $ \(S a x, S b y) -> iteWhiff (GT a b) (x .> y) 1 0 - -- op: SLT - 0x12 -> stackOp2 (const g_verylow) $ uncurry slt - -- op: SGT - 0x13 -> stackOp2 (const g_verylow) $ uncurry sgt - - -- op: EQ - 0x14 -> stackOp2 (const g_verylow) $ \(S a x, S b y) -> iteWhiff (Eq a b) (x .== y) 1 0 - -- op: ISZERO - 0x15 -> stackOp1 (const g_verylow) $ \(S a x) -> iteWhiff (IsZero a) (x .== 0) 1 0 - - -- op: AND - 0x16 -> stackOp2 (const g_verylow) $ uncurry (.&.) - -- op: OR - 0x17 -> stackOp2 (const g_verylow) $ uncurry (.|.) - -- op: XOR - 0x18 -> stackOp2 (const g_verylow) $ uncurry xor - -- op: NOT - 0x19 -> stackOp1 (const g_verylow) complement - - -- op: BYTE - 0x1a -> stackOp2 (const g_verylow) $ \case - (n, _) | (forceLit n) >= 32 -> 0 - (n, x) | otherwise -> 0xff .&. shiftR x (8 * (31 - num (forceLit n))) - - -- op: SHL - 0x1b -> stackOp2 (const g_verylow) $ \((S a n), (S b x)) -> S (SHL b a) $ sShiftLeft x n - -- op: SHR - 0x1c -> stackOp2 (const g_verylow) $ \((S a n), (S b x)) -> S (SHR b a) $ sShiftRight x n - -- op: SAR - 0x1d -> stackOp2 (const g_verylow) $ \((S a n), (S b x)) -> S (SAR b a) $ sSignedShiftArithRight x n - - -- op: SHA3 - -- more accurately refered to as KECCAK - 0x20 -> - case stk of - (xOffset' : xSize' : xs) -> - forceConcrete xOffset' $ - \xOffset -> forceConcrete xSize' $ \xSize -> - burn (g_sha3 + g_sha3word * ceilDiv (num xSize) 32) $ - accessMemoryRange fees xOffset xSize $ do - (hash@(S _ hash'), invMap, bytes) <- case readMemory xOffset xSize vm of - ConcreteBuffer bs -> do - pure (litWord $ keccakBlob bs, Map.singleton (keccakBlob bs) bs, litBytes bs) - SymbolicBuffer bs -> do - let hash' = symkeccak' bs - return (S (FromKeccak $ SymbolicBuffer bs) hash', mempty, bs) - - -- Although we would like to simply assert that the uninterpreted function symkeccak' - -- is injective, this proves to cause a lot of concern for our smt solvers, probably - -- due to the introduction of universal quantifiers into the queries. - - -- Instead, we keep track of all of the particular invocations of symkeccak' we see - -- (similarly to sha3Crack), and simply assert that injectivity holds for these - -- particular invocations. - -- - -- We additionally make the probabalisitc assumption that the output of symkeccak' - -- is greater than 100. This lets us avoid having to reason about storage collisions - -- between mappings and "normal" slots - - let previousUsed = view (env . keccakUsed) vm - env . keccakUsed <>= [(bytes, hash')] - constraints <>= (hash' .> 100, Todo "probabilistic keccak assumption" []): - (fmap (\(preimage, image) -> - -- keccak is a function - ((preimage .== bytes .=> image .== hash') .&& - -- which is injective - (image .== hash' .=> preimage .== bytes), Todo "injective keccak assumption" [])) - previousUsed) - - next - assign (state . stack) (hash : xs) - (env . sha3Crack) <>= invMap - _ -> underrun - - -- op: ADDRESS - 0x30 -> - limitStack 1 $ - burn g_base (next >> push (num self)) - - -- op: BALANCE - 0x31 -> - case stk of - (x':xs) -> forceConcrete x' $ \x -> - accessAndBurn (num x) $ - fetchAccount (num x) $ \c -> do - next - assign (state . stack) xs - push (view balance c) - [] -> - underrun - - -- op: ORIGIN - 0x32 -> - limitStack 1 . burn g_base $ - next >> push (num (the tx origin)) - - -- op: CALLER - 0x33 -> - limitStack 1 . burn g_base $ - let toSymWord :: SAddr -> SymWord - toSymWord (SAddr x) = case unliteral x of - Just s -> litWord $ num s - Nothing -> var "CALLER" $ sFromIntegral x - in next >> pushSym (toSymWord (the state caller)) - - -- op: CALLVALUE - 0x34 -> - limitStack 1 . burn g_base $ - next >> pushSym (the state callvalue) - - -- op: CALLDATALOAD - 0x35 -> stackOp1 (const g_verylow) $ - \ind -> uncurry (readSWordWithBound ind) (the state calldata) - - -- op: CALLDATASIZE - 0x36 -> - limitStack 1 . burn g_base $ - next >> pushSym (snd (the state calldata)) - - -- op: CALLDATACOPY - 0x37 -> - case stk of - (xTo' : xFrom' : xSize' : xs) -> forceConcrete3 (xTo',xFrom',xSize') $ \(xTo,xFrom,xSize) -> - burn (g_verylow + g_copy * ceilDiv (num xSize) 32) $ - accessUnboundedMemoryRange fees xTo xSize $ do - next - assign (state . stack) xs - case the state calldata of - (SymbolicBuffer cd, (S _ cdlen)) -> copyBytesToMemory (SymbolicBuffer [ite (i .<= cdlen) x 0 | (x, i) <- zip cd [1..]]) xSize xFrom xTo - -- when calldata is concrete, - -- the bound should always be equal to the bytestring length - (cd, _) -> copyBytesToMemory cd xSize xFrom xTo - _ -> underrun - - -- op: CODESIZE - 0x38 -> - limitStack 1 . burn g_base $ - next >> push (num (len (the state code))) - - -- op: CODECOPY - 0x39 -> - case stk of - (memOffset' : codeOffset' : n' : xs) -> forceConcrete3 (memOffset',codeOffset',n') $ \(memOffset,codeOffset,n) -> do - burn (g_verylow + g_copy * ceilDiv (num n) 32) $ - accessUnboundedMemoryRange fees memOffset n $ do - next - assign (state . stack) xs - copyBytesToMemory (the state code) - n codeOffset memOffset - _ -> underrun - - -- op: GASPRICE - 0x3a -> - limitStack 1 . burn g_base $ - next >> push (the tx gasprice) - - -- op: EXTCODESIZE - 0x3b -> - case stk of - (x':xs) -> makeUnique x' $ \x -> - if x == num cheatCode - then do - next - assign (state . stack) xs - push (w256 1) - else - accessAndBurn (num x) $ - fetchAccount (num x) $ \c -> do - next - assign (state . stack) xs - push (num (len (view bytecode c))) - [] -> - underrun - - -- op: EXTCODECOPY - 0x3c -> - case stk of - ( extAccount' - : memOffset' - : codeOffset' - : codeSize' - : xs ) -> - forceConcrete4 (extAccount', memOffset', codeOffset', codeSize') $ - \(extAccount, memOffset, codeOffset, codeSize) -> do - acc <- accessAccountForGas (num extAccount) - let cost = if acc then g_warm_storage_read else g_cold_account_access - burn (cost + g_copy * ceilDiv (num codeSize) 32) $ - accessUnboundedMemoryRange fees memOffset codeSize $ - fetchAccount (num extAccount) $ \c -> do - next - assign (state . stack) xs - copyBytesToMemory (view bytecode c) - codeSize codeOffset memOffset - _ -> underrun - - -- op: RETURNDATASIZE - 0x3d -> - limitStack 1 . burn g_base $ - next >> push (num $ len (the state returndata)) - - -- op: RETURNDATACOPY - 0x3e -> - case stk of - (xTo' : xFrom' : xSize' :xs) -> forceConcrete3 (xTo', xFrom', xSize') $ - \(xTo, xFrom, xSize) -> - burn (g_verylow + g_copy * ceilDiv (num xSize) 32) $ - accessUnboundedMemoryRange fees xTo xSize $ do - next - assign (state . stack) xs - if num (len (the state returndata)) < xFrom + xSize || xFrom + xSize < xFrom - then vmError InvalidMemoryAccess - else copyBytesToMemory (the state returndata) xSize xFrom xTo - _ -> underrun - - -- op: EXTCODEHASH - 0x3f -> - case stk of - (x':xs) -> forceConcrete x' $ \x -> - accessAndBurn (num x) $ do - next - assign (state . stack) xs - fetchAccount (num x) $ \c -> - if accountEmpty c - then push (num (0 :: Int)) - else case view bytecode c of - ConcreteBuffer b -> push (num (keccak b)) - b'@(SymbolicBuffer b) -> pushSym (S (FromKeccak b') $ symkeccak' b) - [] -> - underrun - - -- op: BLOCKHASH - 0x40 -> do - -- We adopt the fake block hash scheme of the VMTests, - -- so that blockhash(i) is the hash of i as decimal ASCII. - stackOp1 (const g_blockhash) $ - \(forceLit -> i) -> - if i + 256 < the block number || i >= the block number - then 0 - else - (num i :: Integer) - & show & Char8.pack & keccak & num - - -- op: COINBASE - 0x41 -> - limitStack 1 . burn g_base $ - next >> push (num (the block coinbase)) - - -- op: TIMESTAMP - 0x42 -> - limitStack 1 . burn g_base $ - next >> pushSym (the block timestamp) - - -- op: NUMBER - 0x43 -> - limitStack 1 . burn g_base $ - next >> push (the block number) - - -- op: DIFFICULTY - 0x44 -> - limitStack 1 . burn g_base $ - next >> push (the block difficulty) - - -- op: GASLIMIT - 0x45 -> - limitStack 1 . burn g_base $ - next >> push (the block gaslimit) - - -- op: CHAINID - 0x46 -> - limitStack 1 . burn g_base $ - next >> push (the env chainId) - - -- op: SELFBALANCE - 0x47 -> - limitStack 1 . burn g_low $ - next >> push (view balance this) - - -- op: BASEFEE - 0x48 -> - limitStack 1 . burn g_base $ - next >> push (the block baseFee) - - -- op: POP - 0x50 -> - case stk of - (_:xs) -> burn g_base (next >> assign (state . stack) xs) - _ -> underrun - - -- op: MLOAD - 0x51 -> - case stk of - (x':xs) -> forceConcrete x' $ \x -> - burn g_verylow $ - accessMemoryWord fees x $ do - next - assign (state . stack) (view (word256At (num x)) mem : xs) - _ -> underrun - - -- op: MSTORE - 0x52 -> - case stk of - (x':y:xs) -> forceConcrete x' $ \x -> - burn g_verylow $ - accessMemoryWord fees x $ do - next - assign (state . memory . word256At (num x)) y - assign (state . stack) xs - _ -> underrun - - -- op: MSTORE8 - 0x53 -> - case stk of - (x':(S _ y):xs) -> forceConcrete x' $ \x -> - burn g_verylow $ - accessMemoryRange fees x 1 $ do - let yByte = bvExtract (Proxy :: Proxy 7) (Proxy :: Proxy 0) y - next - modifying (state . memory) (setMemoryByte x yByte) - assign (state . stack) xs - _ -> underrun - - -- op: SLOAD - 0x54 -> - case stk of - (x:xs) -> do - acc <- accessStorageForGas self x - let cost = if acc then g_warm_storage_read else g_cold_sload - burn cost $ - accessStorage self x $ \y -> do - next - assign (state . stack) (y:xs) - _ -> underrun - - -- op: SSTORE - 0x55 -> - notStatic $ - case stk of - (x:new:xs) -> - accessStorage self x $ \current -> do - availableGas <- use (state . gas) - - if num availableGas <= g_callstipend - then finishFrame (FrameErrored (OutOfGas availableGas (num g_callstipend))) - else do - let original = case view storage this of - Concrete _ -> fromMaybe 0 (Map.lookup (forceLit x) (view origStorage this)) - Symbolic _ _ -> 0 -- we don't use this value anywhere anyway - storage_cost = case (maybeLitWord current, maybeLitWord new) of - (Just current', Just new') -> - if (current' == new') then g_sload - else if (current' == original) && (original == 0) then g_sset - else if (current' == original) then g_sreset - else g_sload - - -- if any of the arguments are symbolic, - -- assume worst case scenario - _ -> g_sset - - acc <- accessStorageForGas self x - let cold_storage_cost = if acc then 0 else g_cold_sload - burn (storage_cost + cold_storage_cost) $ do - next - assign (state . stack) xs - modifying (env . contracts . ix self . storage) - (writeStorage x new) - - case (maybeLitWord current, maybeLitWord new) of - (Just current', Just new') -> - unless (current' == new') $ - if current' == original - then when (original /= 0 && new' == 0) $ - refund (g_sreset + g_access_list_storage_key) - else do - when (original /= 0) $ - if new' == 0 - then refund (g_sreset + g_access_list_storage_key) - else unRefund (g_sreset + g_access_list_storage_key) - when (original == new') $ - if original == 0 - then refund (g_sset - g_sload) - else refund (g_sreset - g_sload) - -- if any of the arguments are symbolic, - -- don't change the refund counter - _ -> noop - _ -> underrun - - -- op: JUMP - 0x56 -> - case stk of - (x:xs) -> - burn g_mid $ forceConcrete x $ \x' -> - checkJump x' xs - _ -> underrun - - -- op: JUMPI - 0x57 -> do - case stk of - (x:y@(S w _):xs) -> forceConcrete x $ \x' -> - burn g_high $ - let jump :: Bool -> EVM () - jump True = assign (state . stack) xs >> next - jump _ = checkJump x' xs - in case maybeLitWord y of - Just y' -> jump (0 == y') - -- if the jump condition is symbolic, an smt query has to be made. - Nothing -> askSMT (self, the state pc) (0 .== y, IsZero w) jump - _ -> underrun - - -- op: PC - 0x58 -> - limitStack 1 . burn g_base $ - next >> push (num (the state pc)) - - -- op: MSIZE - 0x59 -> - limitStack 1 . burn g_base $ - next >> push (num (the state memorySize)) - - -- op: GAS - 0x5a -> - limitStack 1 . burn g_base $ - next >> push (the state gas - num g_base) - - -- op: JUMPDEST - 0x5b -> burn g_jumpdest next - - -- op: EXP - 0x0a -> - let cost (_ ,(forceLit -> exponent)) = - if exponent == 0 - then g_exp - else g_exp + g_expbyte * num (ceilDiv (1 + log2 exponent) 8) - in stackOp2 cost $ \((S a x),(S b y)) -> S (Exp a b) (x .^ y) - - -- op: SIGNEXTEND - 0x0b -> - stackOp2 (const g_low) $ \((forceLit -> bytes), w@(S a x)) -> - if bytes >= 32 then w - else let n = num bytes * 8 + 7 in - S (Todo "signextend" [a]) $ ite (sTestBit x n) - (x .|. complement (bit n - 1)) - (x .&. (bit n - 1)) - - -- op: CREATE - 0xf0 -> - notStatic $ - case stk of - (xValue' : xOffset' : xSize' : xs) -> forceConcrete3 (xValue', xOffset', xSize') $ - \(xValue, xOffset, xSize) -> do - accessMemoryRange fees xOffset xSize $ do - availableGas <- use (state . gas) - let - newAddr = createAddress self (wordValue (view nonce this)) - (cost, gas') = costOfCreate fees availableGas 0 - _ <- accessAccountForGas newAddr - burn (cost - gas') $ - let initCode = readMemory (num xOffset) (num xSize) vm - in create self this (num gas') xValue xs newAddr initCode - _ -> underrun - - -- op: CALL - 0xf1 -> - case stk of - ( xGas' - : S _ xTo - : (forceLit -> xValue) - : xInOffset' - : xInSize' - : xOutOffset' - : xOutSize' - : xs - ) -> forceConcrete5 (xGas',xInOffset', xInSize', xOutOffset', xOutSize') $ - \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> - (if xValue > 0 then notStatic else id) $ - let target = SAddr $ sFromIntegral xTo in - delegateCall this xGas target target xValue xInOffset xInSize xOutOffset xOutSize xs $ \callee -> do - zoom state $ do - assign callvalue (litWord xValue) - assign caller (litAddr self) - assign contract callee - transfer self callee xValue - touchAccount self - touchAccount callee - _ -> - underrun - - -- op: CALLCODE - 0xf2 -> - case stk of - ( xGas' - : S _ xTo' - : (forceLit -> xValue) - : xInOffset' - : xInSize' - : xOutOffset' - : xOutSize' - : xs - ) -> forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') $ - \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> - let target = SAddr $ sFromIntegral xTo' in - delegateCall this xGas target (litAddr self) xValue xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do - zoom state $ do - assign callvalue (litWord xValue) - assign caller (litAddr self) - touchAccount self - _ -> - underrun - - -- op: RETURN - 0xf3 -> - case stk of - (xOffset' : xSize' :_) -> forceConcrete2 (xOffset', xSize') $ \(xOffset, xSize) -> - accessMemoryRange fees xOffset xSize $ do - let - output = readMemory xOffset xSize vm - codesize = num (len output) - maxsize = the block maxCodeSize - creation = case view frames vm of - [] -> the tx isCreate - frame:_ -> case view frameContext frame of - CreationContext {} -> True - CallContext {} -> False - if creation - then - if codesize > maxsize - then - finishFrame (FrameErrored (MaxCodeSizeExceeded maxsize codesize)) - else - if isConcretely (readByteOrZero 0 output) ((==) 0xef) - then finishFrame $ FrameErrored InvalidFormat - else do - burn (g_codedeposit * num codesize) $ - finishFrame (FrameReturned output) - else - finishFrame (FrameReturned output) - _ -> underrun - - -- op: DELEGATECALL - 0xf4 -> - case stk of - (xGas' - :S _ xTo - :xInOffset' - :xInSize' - :xOutOffset' - :xOutSize' - :xs) -> forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') $ - \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> - let target = SAddr $ sFromIntegral xTo in - delegateCall this xGas target (litAddr self) 0 xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do - touchAccount self - _ -> underrun - - -- op: CREATE2 - 0xf5 -> notStatic $ - case stk of - (xValue' - :xOffset' - :xSize' - :xSalt' - :xs) -> forceConcrete4 (xValue', xOffset', xSize', xSalt') $ - \(xValue, xOffset, xSize, xSalt) -> - accessMemoryRange fees xOffset xSize $ do - availableGas <- use (state . gas) - - forceConcreteBuffer (readMemory (num xOffset) (num xSize) vm) $ \initCode -> do - let - newAddr = create2Address self (num xSalt) initCode - (cost, gas') = costOfCreate fees availableGas xSize - _ <- accessAccountForGas newAddr - burn (cost - gas') $ - create self this (num gas') xValue xs newAddr (ConcreteBuffer initCode) - _ -> underrun - - -- op: STATICCALL - 0xfa -> - case stk of - (xGas' - :S _ xTo - :xInOffset' - :xInSize' - :xOutOffset' - :xOutSize' - :xs) -> forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') $ - \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> do - let target = SAddr $ sFromIntegral xTo - delegateCall this xGas target target 0 xInOffset xInSize xOutOffset xOutSize xs $ \callee -> do - zoom state $ do - assign callvalue 0 - assign caller (litAddr self) - assign contract callee - assign static True - touchAccount self - touchAccount callee - _ -> - underrun - - -- op: SELFDESTRUCT - 0xff -> - notStatic $ - case stk of - [] -> underrun - (xTo':_) -> forceConcrete xTo' $ \(num -> xTo) -> do - acc <- accessAccountForGas (num xTo) - let cost = if acc then 0 else g_cold_account_access - funds = view balance this - recipientExists = accountExists xTo vm - c_new = if not recipientExists && funds /= 0 - then num g_selfdestruct_newaccount - else 0 - burn (g_selfdestruct + c_new + cost) $ do - selfdestruct self - touchAccount xTo - - if funds /= 0 - then fetchAccount xTo $ \_ -> do - env . contracts . ix xTo . balance += funds - assign (env . contracts . ix self . balance) 0 - doStop - else doStop - - -- op: REVERT - 0xfd -> - case stk of - (xOffset':xSize':_) -> forceConcrete2 (xOffset', xSize') $ \(xOffset, xSize) -> - accessMemoryRange fees xOffset xSize $ do - let output = readMemory xOffset xSize vm - finishFrame (FrameReverted output) - _ -> underrun - - xxx -> - vmError (UnrecognizedOpcode xxx) - -transfer :: Addr -> Addr -> Word -> EVM () -transfer xFrom xTo xValue = - zoom (env . contracts) $ do - ix xFrom . balance -= xValue - ix xTo . balance += xValue - --- | Checks a *CALL for failure; OOG, too many callframes, memory access etc. -callChecks - :: (?op :: Word8) - => Contract -> Word -> Addr -> Addr -> Word -> Word -> Word -> Word -> Word -> [SymWord] - -- continuation with gas available for call - -> (Integer -> EVM ()) - -> EVM () -callChecks this xGas xContext xTo xValue xInOffset xInSize xOutOffset xOutSize xs continue = do - vm <- get - let fees = view (block . schedule) vm - accessMemoryRange fees xInOffset xInSize $ - accessMemoryRange fees xOutOffset xOutSize $ do - availableGas <- use (state . gas) - let recipientExists = accountExists xContext vm - (cost, gas') <- costOfCall fees recipientExists xValue availableGas xGas xTo - burn (cost - gas') $ do - if xValue > view balance this - then do - assign (state . stack) (0 : xs) - assign (state . returndata) mempty - pushTrace $ ErrorTrace $ BalanceTooLow xValue (view balance this) - next - else if length (view frames vm) >= 1024 - then do - assign (state . stack) (0 : xs) - assign (state . returndata) mempty - pushTrace $ ErrorTrace CallDepthLimitReached - next - else continue gas' - -precompiledContract - :: (?op :: Word8) - => Contract - -> Word - -> Addr - -> Addr - -> Word - -> Word -> Word -> Word -> Word - -> [SymWord] - -> EVM () -precompiledContract this xGas precompileAddr recipient xValue inOffset inSize outOffset outSize xs = - callChecks this xGas recipient precompileAddr xValue inOffset inSize outOffset outSize xs $ \gas' -> - do - executePrecompile precompileAddr gas' inOffset inSize outOffset outSize xs - self <- use (state . contract) - stk <- use (state . stack) - case stk of - (x:_) -> case maybeLitWord x of - Just 0 -> - return () - Just 1 -> - fetchAccount recipient $ \_ -> do - - transfer self recipient xValue - touchAccount self - touchAccount recipient - _ -> vmError UnexpectedSymbolicArg - _ -> underrun - -executePrecompile - :: (?op :: Word8) - => Addr - -> Integer -> Word -> Word -> Word -> Word -> [SymWord] - -> EVM () -executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = do - vm <- get - let input = readMemory (num inOffset) (num inSize) vm - fees = view (block . schedule) vm - cost = costOfPrecompile fees preCompileAddr input - notImplemented = error $ "precompile at address " <> show preCompileAddr <> " not yet implemented" - precompileFail = burn (num gasCap - cost) $ do - assign (state . stack) (0 : xs) - pushTrace $ ErrorTrace PrecompileFailure - next - if cost > num gasCap then - burn (num gasCap) $ do - assign (state . stack) (0 : xs) - next - else - burn cost $ - case preCompileAddr of - -- ECRECOVER - 0x1 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> - case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of - Nothing -> do - -- return no output for invalid signature - assign (state . stack) (1 : xs) - assign (state . returndata) mempty - next - Just output -> do - assign (state . stack) (1 : xs) - assign (state . returndata) (ConcreteBuffer output) - copyBytesToMemory (ConcreteBuffer output) outSize 0 outOffset - next - - -- SHA2-256 - 0x2 -> - let - hash = case input of - ConcreteBuffer input' -> ConcreteBuffer $ BS.pack $ BA.unpack (Crypto.hash input' :: Digest SHA256) - SymbolicBuffer input' -> SymbolicBuffer $ symSHA256 input' - in do - assign (state . stack) (1 : xs) - assign (state . returndata) hash - copyBytesToMemory hash outSize 0 outOffset - next - - -- RIPEMD-160 - 0x3 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> - - let - padding = BS.pack $ replicate 12 0 - hash' = BS.pack $ BA.unpack (Crypto.hash input' :: Digest RIPEMD160) - hash = ConcreteBuffer $ padding <> hash' - in do - assign (state . stack) (1 : xs) - assign (state . returndata) hash - copyBytesToMemory hash outSize 0 outOffset - next - - -- IDENTITY - 0x4 -> do - assign (state . stack) (1 : xs) - assign (state . returndata) input - copyCallBytesToMemory input outSize 0 outOffset - next - - -- MODEXP - 0x5 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> - - let - (lenb, lene, lenm) = parseModexpLength input' - - output = ConcreteBuffer $ - if isZero (96 + lenb + lene) lenm input' - then truncpadlit (num lenm) (asBE (0 :: Int)) - else - let - b = asInteger $ lazySlice 96 lenb input' - e = asInteger $ lazySlice (96 + lenb) lene input' - m = asInteger $ lazySlice (96 + lenb + lene) lenm input' - in - padLeft (num lenm) (asBE (expFast b e m)) - in do - assign (state . stack) (1 : xs) - assign (state . returndata) output - copyBytesToMemory output outSize 0 outOffset - next - - -- ECADD - 0x6 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> - case EVM.Precompiled.execute 0x6 (truncpadlit 128 input') 64 of - Nothing -> precompileFail - Just output -> do - let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output - assign (state . stack) (1 : xs) - assign (state . returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput outSize 0 outOffset - next - - -- ECMUL - 0x7 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> - - case EVM.Precompiled.execute 0x7 (truncpadlit 96 input') 64 of - Nothing -> precompileFail - Just output -> do - let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output - assign (state . stack) (1 : xs) - assign (state . returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput outSize 0 outOffset - next - - -- ECPAIRING - 0x8 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> - - case EVM.Precompiled.execute 0x8 input' 32 of - Nothing -> precompileFail - Just output -> do - let truncpaddedOutput = ConcreteBuffer $ truncpadlit 32 output - assign (state . stack) (1 : xs) - assign (state . returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput outSize 0 outOffset - next - - -- BLAKE2 - 0x9 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> do - - case (BS.length input', 1 >= BS.last input') of - (213, True) -> case EVM.Precompiled.execute 0x9 input' 64 of - Just output -> do - let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output - assign (state . stack) (1 : xs) - assign (state . returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput outSize 0 outOffset - next - Nothing -> precompileFail - _ -> precompileFail - - - _ -> notImplemented - -truncpadlit :: Int -> ByteString -> ByteString -truncpadlit n xs = if m > n then BS.take n xs - else BS.append xs (BS.replicate (n - m) 0) - where m = BS.length xs - -lazySlice :: Word -> Word -> ByteString -> LS.ByteString -lazySlice offset size bs = - let bs' = LS.take (num size) (LS.drop (num offset) (fromStrict bs)) - in bs' <> LS.replicate ((num size) - LS.length bs') 0 - -parseModexpLength :: ByteString -> (Word, Word, Word) -parseModexpLength input = - let lenb = w256 $ word $ LS.toStrict $ lazySlice 0 32 input - lene = w256 $ word $ LS.toStrict $ lazySlice 32 64 input - lenm = w256 $ word $ LS.toStrict $ lazySlice 64 96 input - in (lenb, lene, lenm) - ---- checks if a range of ByteString bs starting at offset and length size is all zeros. -isZero :: Word -> Word -> ByteString -> Bool -isZero offset size bs = - LS.all (== 0) $ - LS.take (num size) $ - LS.drop (num offset) $ - fromStrict bs - -asInteger :: LS.ByteString -> Integer -asInteger xs = if xs == mempty then 0 - else 256 * asInteger (LS.init xs) - + num (LS.last xs) - --- * Opcode helper actions - -noop :: Monad m => m () -noop = pure () - -pushTo :: MonadState s m => ASetter s s [a] [a] -> a -> m () -pushTo f x = f %= (x :) - -pushToSequence :: MonadState s m => ASetter s s (Seq a) (Seq a) -> a -> m () -pushToSequence f x = f %= (Seq.|> x) - -getCodeLocation :: VM -> CodeLocation -getCodeLocation vm = (view (state . contract) vm, view (state . pc) vm) - --- | Ask the SMT solver to provide a concrete model for val iff a unique model exists -makeUnique :: SymWord -> (Word -> EVM ()) -> EVM () -makeUnique sw@(S w val) cont = case maybeLitWord sw of - Nothing -> do - conditions <- use constraints - assign result . Just . VMFailure . Query $ PleaseMakeUnique val (fst <$> conditions) $ \case - Unique a -> do - assign result Nothing - cont (C w $ fromSizzle a) - InconsistentU -> vmError DeadPath - TimeoutU -> vmError SMTTimeout - Multiple -> vmError $ NotUnique w - Just a -> cont a - --- | Construct SMT Query and halt execution until resolved -askSMT :: CodeLocation -> (SBool, Whiff) -> (Bool -> EVM ()) -> EVM () -askSMT codeloc (condition, whiff) continue = do - -- We keep track of how many times we have come across this particular - -- (contract, pc) combination in the `iteration` mapping. - iteration <- use (iterations . at codeloc . non 0) - - -- If we are backstepping, the result of this query should be cached - -- already. So we first check the cache to see if the result is known - use (cache . path . at (codeloc, iteration)) >>= \case - -- If the query has been done already, select path or select the only available - Just w -> choosePath (Case w) - -- If this is a new query, run the query, cache the result - -- increment the iterations and select appropriate path - Nothing -> do pathconds <- use constraints - assign result . Just . VMFailure . Query $ PleaseAskSMT - condition' (fst <$> pathconds) choosePath - - where condition' = simplifyCondition condition whiff - - choosePath :: BranchCondition -> EVM () - -- Only one path is possible - choosePath (Case v) = do assign result Nothing - pushTo constraints $ if v then (condition', whiff) else (sNot condition', IsZero whiff) - iteration <- use (iterations . at codeloc . non 0) - assign (cache . path . at (codeloc, iteration)) (Just v) - assign (iterations . at codeloc) (Just (iteration + 1)) - continue v - -- Both paths are possible; we ask for more input - choosePath Unknown = assign result . Just . VMFailure . Choose . PleaseChoosePath whiff $ choosePath . Case - -- None of the paths are possible; fail this branch - choosePath Inconsistent = vmError DeadPath - --- | Construct RPC Query and halt execution until resolved -fetchAccount :: Addr -> (Contract -> EVM ()) -> EVM () -fetchAccount addr continue = - use (env . contracts . at addr) >>= \case - Just c -> continue c - Nothing -> - use (cache . fetched . at addr) >>= \case - Just c -> do - assign (env . contracts . at addr) (Just c) - continue c - Nothing -> do - model <- use (env . storageModel) - assign result . Just . VMFailure $ Query $ - PleaseFetchContract addr model - (\c -> do assign (cache . fetched . at addr) (Just c) - assign (env . contracts . at addr) (Just c) - assign result Nothing - continue c) - -readStorage :: Storage -> SymWord -> Maybe (SymWord) -readStorage (Symbolic _ s) (S w loc) = Just $ S (FromStorage w s) $ readArray s loc -readStorage (Concrete s) loc = Map.lookup (forceLit loc) s - -writeStorage :: SymWord -> SymWord -> Storage -> Storage -writeStorage k@(S _ loc) v@(S _ val) (Symbolic xs s) = Symbolic ((k,v):xs) (writeArray s loc val) -writeStorage loc val (Concrete s) = Concrete (Map.insert (forceLit loc) val s) - -accessStorage - :: Addr -- ^ Contract address - -> SymWord -- ^ Storage slot key - -> (SymWord -> EVM ()) -- ^ Continuation - -> EVM () -accessStorage addr slot continue = - use (env . contracts . at addr) >>= \case - Just c -> - case readStorage (view storage c) slot of - -- Notice that if storage is symbolic, we always continue straight away - Just x -> - continue x - Nothing -> - if view external c - then - -- check if the slot is cached - use (cache . fetched . at addr) >>= \case - Nothing -> mkQuery - Just cachedContract -> - maybe mkQuery continue (readStorage (view storage cachedContract) slot) - else do - modifying (env . contracts . ix addr . storage) (writeStorage slot 0) - continue 0 - Nothing -> - fetchAccount addr $ \_ -> - accessStorage addr slot continue - where - mkQuery = assign result . Just . VMFailure . Query $ - PleaseFetchSlot addr (forceLit slot) - (\(litWord -> x) -> do - modifying (cache . fetched . ix addr . storage) (writeStorage slot x) - modifying (env . contracts . ix addr . storage) (writeStorage slot x) - assign result Nothing - continue x) - -accountExists :: Addr -> VM -> Bool -accountExists addr vm = - case view (env . contracts . at addr) vm of - Just c -> not (accountEmpty c) - Nothing -> False - --- EIP 161 -accountEmpty :: Contract -> Bool -accountEmpty c = - case view contractcode c of - RuntimeCode b -> len b == 0 - _ -> False - && (view nonce c == 0) - && (view balance c == 0) - --- * How to finalize a transaction -finalize :: EVM () -finalize = do - let - revertContracts = use (tx . txReversion) >>= assign (env . contracts) - revertSubstate = assign (tx . substate) (SubState mempty mempty mempty mempty mempty) - - use result >>= \case - Nothing -> - error "Finalising an unfinished tx." - Just (VMFailure (Revert _)) -> do - revertContracts - revertSubstate - Just (VMFailure _) -> do - -- burn remaining gas - assign (state . gas) 0 - revertContracts - revertSubstate - Just (VMSuccess output) -> do - -- deposit the code from a creation tx - creation <- use (tx . isCreate) - createe <- use (state . contract) - createeExists <- (Map.member createe) <$> use (env . contracts) - - when (creation && createeExists) $ replaceCode createe (RuntimeCode output) - - -- compute and pay the refund to the caller and the - -- corresponding payment to the miner - txOrigin <- use (tx . origin) - sumRefunds <- (sum . (snd <$>)) <$> (use (tx . substate . refunds)) - miner <- use (block . coinbase) - blockReward <- num . r_block <$> (use (block . schedule)) - gasPrice <- use (tx . gasprice) - priorityFee <- use (tx . txPriorityFee) - gasLimit <- use (tx . txgaslimit) - gasRemaining <- use (state . gas) - - let - gasUsed = gasLimit - gasRemaining - cappedRefund = min (quot gasUsed 5) (num sumRefunds) - originPay = (gasRemaining + cappedRefund) * gasPrice - - minerPay = priorityFee * gasUsed - - modifying (env . contracts) - (Map.adjust (over balance (+ originPay)) txOrigin) - modifying (env . contracts) - (Map.adjust (over balance (+ minerPay)) miner) - touchAccount miner - - -- pay out the block reward, recreating the miner if necessary - preuse (env . contracts . ix miner) >>= \case - Nothing -> modifying (env . contracts) - (Map.insert miner (initialContract (EVM.RuntimeCode mempty))) - Just _ -> noop - modifying (env . contracts) - (Map.adjust (over balance (+ blockReward)) miner) - - -- perform state trie clearing (EIP 161), of selfdestructs - -- and touched accounts. addresses are cleared if they have - -- a) selfdestructed, or - -- b) been touched and - -- c) are empty. - -- (see Yellow Paper "Accrued Substate") - -- - -- remove any destructed addresses - destroyedAddresses <- use (tx . substate . selfdestructs) - modifying (env . contracts) - (Map.filterWithKey (\k _ -> (notElem k destroyedAddresses))) - -- then, clear any remaining empty and touched addresses - touchedAddresses <- use (tx . substate . touchedAccounts) - modifying (env . contracts) - (Map.filterWithKey - (\k a -> not ((elem k touchedAddresses) && accountEmpty a))) - --- | Loads the selected contract as the current contract to execute -loadContract :: Addr -> EVM () -loadContract target = - preuse (env . contracts . ix target . contractcode) >>= - \case - Nothing -> - error "Call target doesn't exist" - Just (InitCode targetCode) -> do - assign (state . contract) target - assign (state . code) targetCode - assign (state . codeContract) target - Just (RuntimeCode targetCode) -> do - assign (state . contract) target - assign (state . code) targetCode - assign (state . codeContract) target - -limitStack :: Int -> EVM () -> EVM () -limitStack n continue = do - stk <- use (state . stack) - if length stk + n > 1024 - then vmError StackLimitExceeded - else continue - -notStatic :: EVM () -> EVM () -notStatic continue = do - bad <- use (state . static) - if bad - then vmError StateChangeWhileStatic - else continue - --- | Burn gas, failing if insufficient gas is available --- We use the `Integer` type to avoid overflows in intermediate --- calculations and throw if the value won't fit into a uint64 -burn :: Integer -> EVM () -> EVM () -burn n' continue = - if n' > (2 :: Integer) ^ (64 :: Integer) - 1 - then vmError IllegalOverflow - else do - let n = num n' - available <- use (state . gas) - if n <= available - then do - state . gas -= n - burned += n - continue - else - vmError (OutOfGas available n) - -forceConcreteAddr :: SAddr -> (Addr -> EVM ()) -> EVM () -forceConcreteAddr n continue = case maybeLitAddr n of - Nothing -> vmError UnexpectedSymbolicArg - Just c -> continue c - -forceConcrete :: SymWord -> (Word -> EVM ()) -> EVM () -forceConcrete n continue = case maybeLitWord n of - Nothing -> vmError UnexpectedSymbolicArg - Just c -> continue c - -forceConcrete2 :: (SymWord, SymWord) -> ((Word, Word) -> EVM ()) -> EVM () -forceConcrete2 (n,m) continue = case (maybeLitWord n, maybeLitWord m) of - (Just c, Just d) -> continue (c, d) - _ -> vmError UnexpectedSymbolicArg - -forceConcrete3 :: (SymWord, SymWord, SymWord) -> ((Word, Word, Word) -> EVM ()) -> EVM () -forceConcrete3 (k,n,m) continue = case (maybeLitWord k, maybeLitWord n, maybeLitWord m) of - (Just c, Just d, Just f) -> continue (c, d, f) - _ -> vmError UnexpectedSymbolicArg - -forceConcrete4 :: (SymWord, SymWord, SymWord, SymWord) -> ((Word, Word, Word, Word) -> EVM ()) -> EVM () -forceConcrete4 (k,l,n,m) continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord n, maybeLitWord m) of - (Just b, Just c, Just d, Just f) -> continue (b, c, d, f) - _ -> vmError UnexpectedSymbolicArg - -forceConcrete5 :: (SymWord, SymWord, SymWord, SymWord, SymWord) -> ((Word, Word, Word, Word, Word) -> EVM ()) -> EVM () -forceConcrete5 (k,l,m,n,o) continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord m, maybeLitWord n, maybeLitWord o) of - (Just a, Just b, Just c, Just d, Just e) -> continue (a, b, c, d, e) - _ -> vmError UnexpectedSymbolicArg - -forceConcrete6 :: (SymWord, SymWord, SymWord, SymWord, SymWord, SymWord) -> ((Word, Word, Word, Word, Word, Word) -> EVM ()) -> EVM () -forceConcrete6 (k,l,m,n,o,p) continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord m, maybeLitWord n, maybeLitWord o, maybeLitWord p) of - (Just a, Just b, Just c, Just d, Just e, Just f) -> continue (a, b, c, d, e, f) - _ -> vmError UnexpectedSymbolicArg - -forceConcreteBuffer :: Buffer -> (ByteString -> EVM ()) -> EVM () -forceConcreteBuffer (SymbolicBuffer b) continue = case maybeLitBytes b of - Nothing -> vmError UnexpectedSymbolicArg - Just bs -> continue bs -forceConcreteBuffer (ConcreteBuffer b) continue = continue b - --- * Substate manipulation -refund :: Integer -> EVM () -refund n = do - self <- use (state . contract) - pushTo (tx . substate . refunds) (self, n) - -unRefund :: Integer -> EVM () -unRefund n = do - self <- use (state . contract) - refs <- use (tx . substate . refunds) - assign (tx . substate . refunds) - (filter (\(a,b) -> not (a == self && b == n)) refs) - -touchAccount :: Addr -> EVM() -touchAccount = pushTo ((tx . substate) . touchedAccounts) - -selfdestruct :: Addr -> EVM() -selfdestruct = pushTo ((tx . substate) . selfdestructs) - -accessAndBurn :: Addr -> EVM () -> EVM () -accessAndBurn x cont = do - FeeSchedule {..} <- use ( block . schedule ) - acc <- accessAccountForGas x - let cost = if acc then g_warm_storage_read else g_cold_account_access - burn cost cont - --- | returns a wrapped boolean- if true, this address has been touched before in the txn (warm gas cost as in EIP 2929) --- otherwise cold -accessAccountForGas :: Addr -> EVM Bool -accessAccountForGas addr = do - accessedAddrs <- use (tx . substate . accessedAddresses) - let accessed = member addr accessedAddrs - assign (tx . substate . accessedAddresses) (insert addr accessedAddrs) - return accessed - --- | returns a wrapped boolean- if true, this slot has been touched before in the txn (warm gas cost as in EIP 2929) --- otherwise cold -accessStorageForGas :: Addr -> SymWord -> EVM Bool -accessStorageForGas addr key = do - accessedStrkeys <- use (tx . substate . accessedStorageKeys) - case maybeLitWord key of - Just litword -> do - let litword256 = wordValue litword - let accessed = member (addr, litword256) accessedStrkeys - assign (tx . substate . accessedStorageKeys) (insert (addr, litword256) accessedStrkeys) - return accessed - _ -> return False - --- * Cheat codes - --- The cheat code is 7109709ecfa91a80626ff3989d68f67f5b1dd12d. --- Call this address using one of the cheatActions below to do --- special things, e.g. changing the block timestamp. Beware that --- these are necessarily hevm specific. -cheatCode :: Addr -cheatCode = num (keccak "hevm cheat code") - -cheat - :: (?op :: Word8) - => (Word, Word) -> (Word, Word) - -> EVM () -cheat (inOffset, inSize) (outOffset, outSize) = do - mem <- use (state . memory) - vm <- get - let - abi = readMemoryWord32 inOffset mem - input = readMemory (inOffset + 4) (inSize - 4) vm - case fromSized <$> unliteral abi of - Nothing -> vmError UnexpectedSymbolicArg - Just abi' -> - case Map.lookup abi' cheatActions of - Nothing -> - vmError (BadCheatCode (Just abi')) - Just action -> do - action outOffset outSize input - next - push 1 - -type CheatAction = Word -> Word -> Buffer -> EVM () - -cheatActions :: Map Word32 CheatAction -cheatActions = - Map.fromList - [ action "ffi(string[])" $ - \sig outOffset outSize input -> do - vm <- get - if view EVM.allowFFI vm then - case decodeBuffer [AbiArrayDynamicType AbiStringType] input of - CAbi valsArr -> case valsArr of - [AbiArrayDynamic AbiStringType strsV] -> - let - cmd = (flip fmap) (V.toList strsV) (\case - (AbiString a) -> unpack $ decodeUtf8 a - _ -> "") - cont bs = do - let encoded = ConcreteBuffer bs - assign (state . returndata) encoded - copyBytesToMemory encoded outSize 0 outOffset - assign result Nothing - in assign result (Just . VMFailure . Query $ (PleaseDoFFI cmd cont)) - _ -> vmError (BadCheatCode sig) - _ -> vmError (BadCheatCode sig) - else - let msg = encodeUtf8 "ffi disabled: run again with --ffi if you want to allow tests to call external scripts" - in vmError . Revert $ abiMethod "Error(string)" (AbiTuple . V.fromList $ [AbiString msg]), - - action "warp(uint256)" $ - \sig _ _ input -> case decodeStaticArgs input of - [x] -> assign (block . timestamp) x - _ -> vmError (BadCheatCode sig), - - action "roll(uint256)" $ - \sig _ _ input -> case decodeStaticArgs input of - [x] -> forceConcrete x (assign (block . number)) - _ -> vmError (BadCheatCode sig), - - action "store(address,bytes32,bytes32)" $ - \sig _ _ input -> case decodeStaticArgs input of - [a, slot, new] -> - makeUnique a $ \(C _ (num -> a')) -> - fetchAccount a' $ \_ -> do - modifying (env . contracts . ix a' . storage) (writeStorage slot new) - _ -> vmError (BadCheatCode sig), - - action "load(address,bytes32)" $ - \sig outOffset _ input -> case decodeStaticArgs input of - [a, slot] -> - makeUnique a $ \(C _ (num -> a'))-> - accessStorage a' slot $ \res -> do - assign (state . returndata . word256At 0) res - assign (state . memory . word256At outOffset) res - _ -> vmError (BadCheatCode sig), - - action "sign(uint256,bytes32)" $ - \sig outOffset _ input -> case decodeStaticArgs input of - [sk, hash] -> - forceConcrete sk $ \sk' -> - forceConcrete hash $ \(C _ hash') -> let - curve = getCurveByName SEC_p256k1 - priv = PrivateKey curve (num sk') - digest = digestFromByteString (word256Bytes hash') - in do - case digest of - Nothing -> vmError (BadCheatCode sig) - Just digest' -> do - let s = ethsign priv digest' - v = if (sign_s s) % 2 == 0 then 27 else 28 - encoded = encodeAbiValue $ - AbiTuple (RegularVector.fromList - [ AbiUInt 8 v - , AbiBytes 32 (word256Bytes . fromInteger $ sign_r s) - , AbiBytes 32 (word256Bytes . fromInteger $ sign_s s) - ]) - assign (state . returndata) (ConcreteBuffer encoded) - copyBytesToMemory (ConcreteBuffer encoded) (num . BS.length $ encoded) 0 outOffset - _ -> vmError (BadCheatCode sig), - - action "addr(uint256)" $ - \sig outOffset _ input -> case decodeStaticArgs input of - [sk] -> forceConcrete sk $ \sk' -> let - curve = getCurveByName SEC_p256k1 - pubPoint = generateQ curve (num sk') - encodeInt = encodeAbiValue . AbiUInt 256 . fromInteger - in do - case pubPoint of - PointO -> do vmError (BadCheatCode sig) - Point x y -> do - -- See yellow paper #286 - let - pub = BS.concat [ encodeInt x, encodeInt y ] - addr = w256lit . num . word256 . BS.drop 12 . BS.take 32 . keccakBytes $ pub - assign (state . returndata . word256At 0) addr - assign (state . memory . word256At outOffset) addr - _ -> vmError (BadCheatCode sig) - - ] - where - action s f = (abiKeccak s, f (Just $ abiKeccak s)) - --- | Hack deterministic signing, totally insecure... -ethsign :: PrivateKey -> Digest Crypto.Keccak_256 -> Signature -ethsign sk digest = go 420 - where - go k = case signDigestWith k sk digest of - Nothing -> go (k + 1) - Just sig -> sig - --- * General call implementation ("delegateCall") --- note that the continuation is ignored in the precompile case -delegateCall - :: (?op :: Word8) - => Contract -> Word -> SAddr -> SAddr -> Word -> Word -> Word -> Word -> Word -> [SymWord] - -> (Addr -> EVM ()) - -> EVM () -delegateCall this gasGiven (SAddr xTo) (SAddr xContext) xValue xInOffset xInSize xOutOffset xOutSize xs continue = - makeUnique (S (Todo "xTo" []) $ sFromIntegral xTo) $ \(C _ (num -> xTo')) -> - makeUnique (S (Todo "xcontext" []) $ sFromIntegral xContext) $ \(C _ (num -> xContext')) -> - if xTo' > 0 && xTo' <= 9 - then precompiledContract this gasGiven xTo' xContext' xValue xInOffset xInSize xOutOffset xOutSize xs - else if num xTo' == cheatCode then - do - assign (state . stack) xs - cheat (xInOffset, xInSize) (xOutOffset, xOutSize) - else - callChecks this gasGiven xContext' xTo' xValue xInOffset xInSize xOutOffset xOutSize xs $ - \xGas -> do - vm0 <- get - fetchAccount xTo' $ \target -> - burn xGas $ do - let newContext = CallContext - { callContextTarget = xTo' - , callContextContext = xContext' - , callContextOffset = xOutOffset - , callContextSize = xOutSize - , callContextCodehash = view codehash target - , callContextReversion = view (env . contracts) vm0 - , callContextSubState = view (tx . substate) vm0 - , callContextAbi = - if xInSize >= 4 - then case unliteral $ readMemoryWord32 xInOffset (view (state . memory) vm0) - of Nothing -> Nothing - Just abi -> Just . w256 $ num abi - else Nothing - , callContextData = (readMemory (num xInOffset) (num xInSize) vm0) - } - - pushTrace (FrameTrace newContext) - next - vm1 <- get - - pushTo frames $ Frame - { _frameState = (set stack xs) (view state vm1) - , _frameContext = newContext - } - - zoom state $ do - assign gas (num xGas) - assign pc 0 - assign code (view bytecode target) - assign codeContract xTo' - assign stack mempty - assign memory mempty - assign memorySize 0 - assign returndata mempty - assign calldata (readMemory (num xInOffset) (num xInSize) vm0, w256lit (num xInSize)) - - continue xTo' - --- -- * Contract creation - --- EIP 684 -collision :: Maybe Contract -> Bool -collision c' = case c' of - Just c -> (view nonce c /= 0) || case view contractcode c of - RuntimeCode b -> len b /= 0 - _ -> True - Nothing -> False - -create :: (?op :: Word8) - => Addr -> Contract - -> Word -> Word -> [SymWord] -> Addr -> Buffer -> EVM () -create self this xGas' xValue xs newAddr initCode = do - vm0 <- get - let xGas = num xGas' - if xValue > view balance this - then do - assign (state . stack) (0 : xs) - assign (state . returndata) mempty - pushTrace $ ErrorTrace $ BalanceTooLow xValue (view balance this) - next - else if length (view frames vm0) >= 1024 - then do - assign (state . stack) (0 : xs) - assign (state . returndata) mempty - pushTrace $ ErrorTrace CallDepthLimitReached - next - else if collision $ view (env . contracts . at newAddr) vm0 - then burn xGas $ do - assign (state . stack) (0 : xs) - modifying (env . contracts . ix self . nonce) succ - next - else burn xGas $ do - touchAccount self - touchAccount newAddr - let - store = case view (env . storageModel) vm0 of - ConcreteS -> Concrete mempty - SymbolicS -> Symbolic [] $ sListArray 0 [] - InitialS -> Symbolic [] $ sListArray 0 [] - newContract = - initialContract (InitCode initCode) & set storage store - newContext = - CreationContext { creationContextAddress = newAddr - , creationContextCodehash = view codehash newContract - , creationContextReversion = view (env . contracts) vm0 - , creationContextSubstate = view (tx . substate) vm0 - } - - zoom (env . contracts) $ do - oldAcc <- use (at newAddr) - let oldBal = maybe 0 (view balance) oldAcc - - assign (at newAddr) (Just (newContract & balance .~ oldBal)) - modifying (ix self . nonce) succ - - transfer self newAddr xValue - - pushTrace (FrameTrace newContext) - next - vm1 <- get - pushTo frames $ Frame - { _frameContext = newContext - , _frameState = (set stack xs) (view state vm1) - } - - assign state $ - blankState - & set contract newAddr - & set codeContract newAddr - & set code initCode - & set callvalue (litWord xValue) - & set caller (litAddr self) - & set gas xGas' - --- | Replace a contract's code, like when CREATE returns --- from the constructor code. -replaceCode :: Addr -> ContractCode -> EVM () -replaceCode target newCode = - zoom (env . contracts . at target) $ - get >>= \case - Just now -> case (view contractcode now) of - InitCode _ -> - put . Just $ - initialContract newCode - & set storage (view storage now) - & set balance (view balance now) - & set nonce (view nonce now) - RuntimeCode _ -> - error ("internal error: can't replace code of deployed contract " <> show target) - Nothing -> - error "internal error: can't replace code of nonexistent contract" - -replaceCodeOfSelf :: ContractCode -> EVM () -replaceCodeOfSelf newCode = do - vm <- get - replaceCode (view (state . contract) vm) newCode - -resetState :: EVM () -resetState = do - assign result Nothing - assign frames [] - assign state blankState - - --- * VM error implementation - -vmError :: Error -> EVM () -vmError e = finishFrame (FrameErrored e) - -underrun :: EVM () -underrun = vmError StackUnderrun - --- | A stack frame can be popped in three ways. -data FrameResult - = FrameReturned Buffer -- ^ STOP, RETURN, or no more code - | FrameReverted Buffer -- ^ REVERT - | FrameErrored Error -- ^ Any other error - deriving Show - --- | This function defines how to pop the current stack frame in either of --- the ways specified by 'FrameResult'. --- --- It also handles the case when the current stack frame is the only one; --- in this case, we set the final '_result' of the VM execution. -finishFrame :: FrameResult -> EVM () -finishFrame how = do - oldVm <- get - - case view frames oldVm of - -- Is the current frame the only one? - [] -> do - case how of - FrameReturned output -> assign result . Just $ VMSuccess output - FrameReverted buffer -> forceConcreteBuffer buffer $ \out -> assign result . Just $ VMFailure (Revert out) - FrameErrored e -> assign result . Just $ VMFailure e - finalize - - -- Are there some remaining frames? - nextFrame : remainingFrames -> do - - -- Insert a debug trace. - insertTrace $ - case how of - FrameErrored e -> - ErrorTrace e - FrameReverted (ConcreteBuffer output) -> - ErrorTrace (Revert output) - FrameReverted (SymbolicBuffer output) -> - ErrorTrace (Revert (forceLitBytes output)) - FrameReturned output -> - ReturnTrace output (view frameContext nextFrame) - -- Pop to the previous level of the debug trace stack. - popTrace - - -- Pop the top frame. - assign frames remainingFrames - -- Install the state of the frame to which we shall return. - assign state (view frameState nextFrame) - - -- When entering a call, the gas allowance is counted as burned - -- in advance; this unburns the remainder and adds it to the - -- parent frame. - let remainingGas = view (state . gas) oldVm - reclaimRemainingGasAllowance = do - modifying burned (subtract remainingGas) - modifying (state . gas) (+ remainingGas) - - FeeSchedule {..} = view ( block . schedule ) oldVm - - -- Now dispatch on whether we were creating or calling, - -- and whether we shall return, revert, or error (six cases). - case view frameContext nextFrame of - - -- Were we calling? - CallContext _ _ (num -> outOffset) (num -> outSize) _ _ _ reversion substate' -> do - - -- Excerpt K.1. from the yellow paper: - -- K.1. Deletion of an Account Despite Out-of-gas. - -- At block 2675119, in the transaction 0xcf416c536ec1a19ed1fb89e4ec7ffb3cf73aa413b3aa9b77d60e4fd81a4296ba, - -- an account at address 0x03 was called and an out-of-gas occurred during the call. - -- Against the equation (197), this added 0x03 in the set of touched addresses, and this transaction turned σ[0x03] into ∅. - - -- In other words, we special case address 0x03 and keep it in the set of touched accounts during revert - touched <- use (tx . substate . touchedAccounts) - - let - substate'' = over touchedAccounts (maybe id cons (find ((==) 3) touched)) substate' - revertContracts = assign (env . contracts) reversion - revertSubstate = assign (tx . substate) substate'' - - case how of - -- Case 1: Returning from a call? - FrameReturned output -> do - assign (state . returndata) output - copyCallBytesToMemory output outSize 0 outOffset - reclaimRemainingGasAllowance - push 1 - - -- Case 2: Reverting during a call? - FrameReverted output -> do - revertContracts - revertSubstate - assign (state . returndata) output - copyCallBytesToMemory output outSize 0 outOffset - reclaimRemainingGasAllowance - push 0 - - -- Case 3: Error during a call? - FrameErrored _ -> do - revertContracts - revertSubstate - assign (state . returndata) mempty - push 0 - -- Or were we creating? - CreationContext _ _ reversion substate' -> do - creator <- use (state . contract) - let - createe = view (state . contract) oldVm - revertContracts = assign (env . contracts) reversion' - revertSubstate = assign (tx . substate) substate' - - -- persist the nonce through the reversion - reversion' = (Map.adjust (over nonce (+ 1)) creator) reversion - - case how of - -- Case 4: Returning during a creation? - FrameReturned output -> do - replaceCode createe (RuntimeCode output) - assign (state . returndata) mempty - reclaimRemainingGasAllowance - push (num createe) - - -- Case 5: Reverting during a creation? - FrameReverted output -> do - revertContracts - revertSubstate - assign (state . returndata) output - reclaimRemainingGasAllowance - push 0 - - -- Case 6: Error during a creation? - FrameErrored _ -> do - revertContracts - revertSubstate - assign (state . returndata) mempty - push 0 - - --- * Memory helpers - -accessUnboundedMemoryRange - :: FeeSchedule Integer - -> Word - -> Word - -> EVM () - -> EVM () -accessUnboundedMemoryRange _ _ 0 continue = continue -accessUnboundedMemoryRange fees f l continue = do - m0 <- num <$> use (state . memorySize) - do - let m1 = 32 * ceilDiv (max m0 (num f + num l)) 32 - burn (memoryCost fees m1 - memoryCost fees m0) $ do - assign (state . memorySize) (num m1) - continue - -accessMemoryRange - :: FeeSchedule Integer - -> Word - -> Word - -> EVM () - -> EVM () -accessMemoryRange _ _ 0 continue = continue -accessMemoryRange fees f l continue = - if f + l < l - then vmError IllegalOverflow - else accessUnboundedMemoryRange fees f l continue - -accessMemoryWord - :: FeeSchedule Integer -> Word -> EVM () -> EVM () -accessMemoryWord fees x = accessMemoryRange fees x 32 - -copyBytesToMemory - :: Buffer -> Word -> Word -> Word -> EVM () -copyBytesToMemory bs size xOffset yOffset = - if size == 0 then noop - else do - mem <- use (state . memory) - assign (state . memory) $ - writeMemory bs size xOffset yOffset mem - -copyCallBytesToMemory - :: Buffer -> Word -> Word -> Word -> EVM () -copyCallBytesToMemory bs size xOffset yOffset = - if size == 0 then noop - else do - mem <- use (state . memory) - assign (state . memory) $ - writeMemory bs (min size (num (len bs))) xOffset yOffset mem - -readMemory :: Word -> Word -> VM -> Buffer -readMemory offset size vm = sliceWithZero (num offset) (num size) (view (state . memory) vm) - -word256At - :: Functor f - => Word -> (SymWord -> f (SymWord)) - -> Buffer -> f Buffer -word256At i = lens getter setter where - getter = EVM.Symbolic.readMemoryWord i - setter m x = setMemoryWord i x m - --- * Tracing - -withTraceLocation - :: (MonadState VM m) => TraceData -> m Trace -withTraceLocation x = do - vm <- get - let - Just this = - currentContract vm - pure Trace - { _traceData = x - , _traceContract = this - , _traceOpIx = fromMaybe 0 $ (view opIxMap this) Vector.!? (view (state . pc) vm) - } - -pushTrace :: TraceData -> EVM () -pushTrace x = do - trace <- withTraceLocation x - modifying traces $ - \t -> Zipper.children $ Zipper.insert (Node trace []) t - -insertTrace :: TraceData -> EVM () -insertTrace x = do - trace <- withTraceLocation x - modifying traces $ - \t -> Zipper.nextSpace $ Zipper.insert (Node trace []) t - -popTrace :: EVM () -popTrace = - modifying traces $ - \t -> case Zipper.parent t of - Nothing -> error "internal error (trace root)" - Just t' -> Zipper.nextSpace t' - -zipperRootForest :: Zipper.TreePos Zipper.Empty a -> Forest a -zipperRootForest z = - case Zipper.parent z of - Nothing -> Zipper.toForest z - Just z' -> zipperRootForest (Zipper.nextSpace z') - -traceForest :: VM -> Forest Trace -traceForest = view (traces . to zipperRootForest) - -traceLog :: (MonadState VM m) => Log -> m () -traceLog log = do - trace <- withTraceLocation (EventTrace log) - modifying traces $ - \t -> Zipper.nextSpace (Zipper.insert (Node trace []) t) - --- * Stack manipulation - -push :: Word -> EVM () -push = pushSym . w256lit . num - -pushSym :: SymWord -> EVM () -pushSym x = state . stack %= (x :) - - -stackOp1 - :: (?op :: Word8) - => ((SymWord) -> Integer) - -> ((SymWord) -> (SymWord)) - -> EVM () -stackOp1 cost f = - use (state . stack) >>= \case - (x:xs) -> - burn (cost x) $ do - next - let !y = f x - state . stack .= y : xs - _ -> - underrun - -stackOp2 - :: (?op :: Word8) - => (((SymWord), (SymWord)) -> Integer) - -> (((SymWord), (SymWord)) -> (SymWord)) - -> EVM () -stackOp2 cost f = - use (state . stack) >>= \case - (x:y:xs) -> - burn (cost (x, y)) $ do - next - state . stack .= f (x, y) : xs - _ -> - underrun - -stackOp3 - :: (?op :: Word8) - => (((SymWord), (SymWord), (SymWord)) -> Integer) - -> (((SymWord), (SymWord), (SymWord)) -> (SymWord)) - -> EVM () -stackOp3 cost f = - use (state . stack) >>= \case - (x:y:z:xs) -> - burn (cost (x, y, z)) $ do - next - state . stack .= f (x, y, z) : xs - _ -> - underrun - --- * Bytecode data functions - -checkJump :: (Integral n) => n -> [SymWord] -> EVM () -checkJump x xs = do - theCode <- use (state . code) - self <- use (state . codeContract) - theCodeOps <- use (env . contracts . ix self . codeOps) - theOpIxMap <- use (env . contracts . ix self . opIxMap) - if x < num (len theCode) && 0x5b == (fromMaybe (error "tried to jump to symbolic code location") $ unliteral $ EVM.Symbolic.index (num x) theCode) - then - if OpJumpdest == snd (theCodeOps RegularVector.! (theOpIxMap Vector.! num x)) - then do - state . stack .= xs - state . pc .= num x - else - vmError BadJumpDestination - else vmError BadJumpDestination - -opSize :: Word8 -> Int -opSize x | x >= 0x60 && x <= 0x7f = num x - 0x60 + 2 -opSize _ = 1 - --- Index i of the resulting vector contains the operation index for --- the program counter value i. This is needed because source map --- entries are per operation, not per byte. -mkOpIxMap :: Buffer -> Vector Int -mkOpIxMap xs = Vector.create $ Vector.new (len xs) >>= \v -> - -- Loop over the byte string accumulating a vector-mutating action. - -- This is somewhat obfuscated, but should be fast. - case xs of - ConcreteBuffer xs' -> - let (_, _, _, m) = - BS.foldl' (go v) (0 :: Word8, 0, 0, return ()) xs' - in m >> return v - SymbolicBuffer xs' -> - let (_, _, _, m) = - foldl (go' v) (0, 0, 0, return ()) (stripBytecodeMetadataSym xs') - in m >> return v - - where - -- concrete case - go v (0, !i, !j, !m) x | x >= 0x60 && x <= 0x7f = - {- Start of PUSH op. -} (x - 0x60 + 1, i + 1, j, m >> 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) - - -- symbolic case - go' v (0, !i, !j, !m) x = case unliteral x of - Just x' -> if x' >= 0x60 && x' <= 0x7f - -- start of PUSH op -- - then (x' - 0x60 + 1, i + 1, j, m >> Vector.write v i j) - -- other data -- - else (0, i + 1, j + 1, m >> Vector.write v i j) - _ -> error "cannot analyze symbolic code" - - {- 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 (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 - code' = vm ^. state . code - xs = case code' of - ConcreteBuffer xs' -> ConcreteBuffer (BS.drop i xs') - SymbolicBuffer xs' -> SymbolicBuffer (drop i xs') - op = case xs of - ConcreteBuffer b -> BS.index b 0 - SymbolicBuffer b -> fromSized $ fromMaybe (error "unexpected symbolic code") (unliteral (b !! 0)) - in if (len code' < i) - then Nothing - else Just (readOp op xs) - -vmOpIx :: VM -> Maybe Int -vmOpIx vm = - do self <- currentContract vm - (view opIxMap self) Vector.!? (view (state . pc) vm) - -opParams :: VM -> Map String (SymWord) -opParams vm = - case vmOp vm of - Just OpCreate -> - params $ words "value offset size" - Just OpCall -> - params $ words "gas to value in-offset in-size out-offset out-size" - Just OpSstore -> - params $ words "index value" - Just OpCodecopy -> - params $ words "mem-offset code-offset code-size" - Just OpSha3 -> - params $ words "offset size" - Just OpCalldatacopy -> - params $ words "to from size" - Just OpExtcodecopy -> - params $ words "account mem-offset code-offset code-size" - Just OpReturn -> - params $ words "offset size" - Just OpJumpi -> - params $ words "destination condition" - _ -> mempty - where - params xs = - if length (vm ^. state . stack) >= length xs - then Map.fromList (zip xs (vm ^. state . stack)) - else mempty - -readOp :: Word8 -> Buffer -> 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'' = case xs of - ConcreteBuffer xs' -> num $ EVM.Concrete.readMemoryWord 0 $ BS.take (num n) xs' - SymbolicBuffer xs' -> readSWord' 0 $ take (num n) xs' - in OpPush xs'' -readOp x _ = case x of - 0x00 -> OpStop - 0x01 -> OpAdd - 0x02 -> OpMul - 0x03 -> OpSub - 0x04 -> OpDiv - 0x05 -> OpSdiv - 0x06 -> OpMod - 0x07 -> OpSmod - 0x08 -> OpAddmod - 0x09 -> OpMulmod - 0x0a -> OpExp - 0x0b -> OpSignextend - 0x10 -> OpLt - 0x11 -> OpGt - 0x12 -> OpSlt - 0x13 -> OpSgt - 0x14 -> OpEq - 0x15 -> OpIszero - 0x16 -> OpAnd - 0x17 -> OpOr - 0x18 -> OpXor - 0x19 -> OpNot - 0x1a -> OpByte - 0x1b -> OpShl - 0x1c -> OpShr - 0x1d -> OpSar - 0x20 -> OpSha3 - 0x30 -> OpAddress - 0x31 -> OpBalance - 0x32 -> OpOrigin - 0x33 -> OpCaller - 0x34 -> OpCallvalue - 0x35 -> OpCalldataload - 0x36 -> OpCalldatasize - 0x37 -> OpCalldatacopy - 0x38 -> OpCodesize - 0x39 -> OpCodecopy - 0x3a -> OpGasprice - 0x3b -> OpExtcodesize - 0x3c -> OpExtcodecopy - 0x3d -> OpReturndatasize - 0x3e -> OpReturndatacopy - 0x3f -> OpExtcodehash - 0x40 -> OpBlockhash - 0x41 -> OpCoinbase - 0x42 -> OpTimestamp - 0x43 -> OpNumber - 0x44 -> OpDifficulty - 0x45 -> OpGaslimit - 0x46 -> OpChainid - 0x47 -> OpSelfbalance - 0x50 -> OpPop - 0x51 -> OpMload - 0x52 -> OpMstore - 0x53 -> OpMstore8 - 0x54 -> OpSload - 0x55 -> OpSstore - 0x56 -> OpJump - 0x57 -> OpJumpi - 0x58 -> OpPc - 0x59 -> OpMsize - 0x5a -> OpGas - 0x5b -> OpJumpdest - 0xf0 -> OpCreate - 0xf1 -> OpCall - 0xf2 -> OpCallcode - 0xf3 -> OpReturn - 0xf4 -> OpDelegatecall - 0xf5 -> OpCreate2 - 0xfd -> OpRevert - 0xfa -> OpStaticcall - 0xff -> OpSelfdestruct - _ -> OpUnknown x - -mkCodeOps :: Buffer -> RegularVector.Vector (Int, Op) -mkCodeOps (ConcreteBuffer 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 (ConcreteBuffer xs')) Seq.<| go (i + j) (BS.drop j xs) -mkCodeOps (SymbolicBuffer bytes) = RegularVector.fromList . toList $ go' 0 (stripBytecodeMetadataSym bytes) - where - go' !i !xs = - case uncons xs of - Nothing -> - mempty - Just (x, xs') -> - let x' = fromSized $ fromMaybe (error "unexpected symbolic code argument") $ unliteral x - j = opSize x' - in (i, readOp x' (SymbolicBuffer xs')) Seq.<| go' (i + j) (drop j xs) - --- * Gas cost calculation helpers - --- Gas cost function for CALL, transliterated from the Yellow Paper. -costOfCall - :: FeeSchedule Integer - -> Bool -> Word -> Word -> Word -> Addr - -> EVM (Integer, Integer) -costOfCall (FeeSchedule {..}) recipientExists xValue availableGas' xGas' target = do - acc <- accessAccountForGas target - let call_base_gas = if acc then g_warm_storage_read else g_cold_account_access - availableGas = num availableGas' - xGas = num xGas' - c_new = if not recipientExists && xValue /= 0 - then num g_newaccount - else 0 - c_xfer = if xValue /= 0 then num g_callvalue else 0 - c_extra = num call_base_gas + c_xfer + c_new - c_gascap = if availableGas >= c_extra - then min xGas (allButOne64th (availableGas - c_extra)) - else xGas - c_callgas = if xValue /= 0 then c_gascap + num g_callstipend else c_gascap - return (c_gascap + c_extra, c_callgas) - --- Gas cost of create, including hash cost if needed -costOfCreate - :: FeeSchedule Integer - -> Word -> Word -> (Integer, Integer) -costOfCreate (FeeSchedule {..}) availableGas' hashSize = - (createCost + initGas, initGas) - where - availableGas = num availableGas' - createCost = g_create + hashCost - hashCost = g_sha3word * ceilDiv (num hashSize) 32 - initGas = allButOne64th (availableGas - createCost) - -concreteModexpGasFee :: ByteString -> Integer -concreteModexpGasFee input = max 200 ((multiplicationComplexity * iterCount) `div` 3) - where (lenb, lene, lenm) = parseModexpLength input - ez = isZero (96 + lenb) lene input - e' = w256 $ word $ LS.toStrict $ - lazySlice (96 + lenb) (min 32 lene) input - nwords :: Integer - nwords = ceilDiv (num $ max lenb lenm) 8 - multiplicationComplexity = nwords * nwords - iterCount' :: Integer - iterCount' | lene <= 32 && ez = 0 - | lene <= 32 = num (log2 e') - | e' == 0 = 8 * (num lene - 32) - | otherwise = num (log2 e') + 8 * (num lene - 32) - iterCount = max iterCount' 1 - --- Gas cost of precompiles -costOfPrecompile :: FeeSchedule Integer -> Addr -> Buffer -> Integer -costOfPrecompile (FeeSchedule {..}) precompileAddr input = - case precompileAddr of - -- ECRECOVER - 0x1 -> 3000 - -- SHA2-256 - 0x2 -> num $ (((len input + 31) `div` 32) * 12) + 60 - -- RIPEMD-160 - 0x3 -> num $ (((len input + 31) `div` 32) * 120) + 600 - -- IDENTITY - 0x4 -> num $ (((len input + 31) `div` 32) * 3) + 15 - -- MODEXP - 0x5 -> concreteModexpGasFee input' - where input' = case input of - SymbolicBuffer _ -> error "unsupported: symbolic MODEXP gas cost calc" - ConcreteBuffer b -> b - -- ECADD - 0x6 -> g_ecadd - -- ECMUL - 0x7 -> g_ecmul - -- ECPAIRING - 0x8 -> num $ ((len input) `div` 192) * (num g_pairing_point) + (num g_pairing_base) - -- BLAKE2 - 0x9 -> let input' = case input of - SymbolicBuffer _ -> error "unsupported: symbolic BLAKE2B gas cost calc" - ConcreteBuffer b -> b - in g_fround * (num $ asInteger $ lazySlice 0 4 input') - _ -> error ("unimplemented precompiled contract " ++ show precompileAddr) - --- Gas cost of memory expansion -memoryCost :: FeeSchedule Integer -> Integer -> Integer -memoryCost FeeSchedule{..} byteCount = - let - wordCount = ceilDiv byteCount 32 - linearCost = g_memory * wordCount - quadraticCost = div (wordCount * wordCount) 512 - in - 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 - +{-# Language DataKinds #-} +{-# Language GADTs #-} +{-# Language StrictData #-} +{-# Language TemplateHaskell #-} + +module EVM where + +import Prelude hiding (log, exponent, GT, LT) + +import Data.Text (unpack) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import EVM.ABI +import EVM.Types hiding (IllegalOverflow) +import EVM.Solidity +import EVM.Concrete (createAddress, create2Address) +import EVM.Op +import EVM.Expr (readStorage, writeStorage, readByte, readWord, writeWord, writeByte, bufLength, indexWord, litAddr, readBytes, word256At, copySlice, isLitByte) +import EVM.FeeSchedule (FeeSchedule (..)) +import Options.Generic as Options +import qualified EVM.Precompiled +import qualified EVM.Expr as Expr + +import Control.Lens hiding (op, (:<), (|>), (.>)) +import Control.Monad.State.Strict hiding (state) + +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (fromStrict) +import Data.Map.Strict (Map) +import Data.Set (Set, insert, member, fromList) +import Data.Maybe (fromMaybe) +import Data.Sequence (Seq) +import Data.Vector.Storable (Vector) +import Data.Foldable (toList) +import Data.Word (Word8, Word32, Word64) +import Data.Bits (FiniteBits, countLeadingZeros, finiteBitSize) + +import Data.Tree +import Data.Tuple.Curry +import Data.List (find) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LS +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteArray as BA +import qualified Data.Map.Strict as Map +import qualified Data.Sequence as Seq +import qualified Data.Tree.Zipper as Zipper +import qualified Data.Vector as V +import qualified Data.Vector.Storable as Vector +import qualified Data.Vector.Storable.Mutable as Vector + +import qualified Data.Vector as RegularVector + +import Crypto.Number.ModArithmetic (expFast) +import qualified Crypto.Hash as Crypto +import Crypto.Hash (Digest, SHA256, RIPEMD160, digestFromByteString) +import Crypto.PubKey.ECC.ECDSA (signDigestWith, PrivateKey(..), Signature(..)) +import Crypto.PubKey.ECC.Types (getCurveByName, CurveName(..), Point(..)) +import Crypto.PubKey.ECC.Generate (generateQ) +import Data.DoubleWord (Word256(Word256), Word128 (Word128)) + +-- * Data types + +-- | EVM failure modes +data Error + = BalanceTooLow W256 W256 + | UnrecognizedOpcode Word8 + | SelfDestruction + | StackUnderrun + | BadJumpDestination + | Revert (Expr Buf) + | OutOfGas Word64 Word64 + | BadCheatCode (Maybe Word32) + | StackLimitExceeded + | IllegalOverflow + | Query Query + | Choose Choose + | StateChangeWhileStatic + | InvalidMemoryAccess + | CallDepthLimitReached + | MaxCodeSizeExceeded W256 W256 + | InvalidFormat + | PrecompileFailure + | forall a . UnexpectedSymbolicArg Int String [Expr a] + | DeadPath + | NotUnique (Expr EWord) + | SMTTimeout + | FFI [AbiValue] + | NonceOverflow +deriving instance Show Error + +-- | The possible result states of a VM +data VMResult + = VMFailure Error -- ^ An operation failed + | VMSuccess (Expr Buf) -- ^ 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 :: [Expr Log] + , _traces :: Zipper.TreePos Zipper.Empty Trace + , _cache :: Cache + , _burned :: Word64 + , _iterations :: Map CodeLocation Int + , _constraints :: [Prop] + , _keccakEqs :: [Prop] + , _allowFFI :: Bool + } + deriving (Show) + +data Trace = Trace + { _traceOpIx :: Int + , _traceContract :: Contract + , _traceData :: TraceData + } + deriving (Show) + +data TraceData + = EventTrace (Expr EWord) (Expr Buf) [Expr EWord] + | FrameTrace FrameContext + | QueryTrace Query + | ErrorTrace Error + | EntryTrace Text + | ReturnTrace (Expr Buf) FrameContext + deriving (Show) + +-- | Queries halt execution until resolved through RPC calls or SMT queries +data Query where + PleaseFetchContract :: Addr -> (Contract -> EVM ()) -> Query + --PleaseMakeUnique :: SBV a -> [SBool] -> (IsUnique a -> EVM ()) -> Query + PleaseFetchSlot :: Addr -> W256 -> (W256 -> EVM ()) -> Query + PleaseAskSMT :: Expr EWord -> [Prop] -> (BranchCondition -> EVM ()) -> Query + PleaseDoFFI :: [String] -> (ByteString -> EVM ()) -> Query + +data Choose where + PleaseChoosePath :: Expr EWord -> (Bool -> EVM ()) -> Choose + +instance Show Query where + showsPrec _ = \case + PleaseFetchContract addr _ -> + (("") ++) + PleaseFetchSlot addr slot _ -> + (("") ++) + PleaseAskSMT condition constraints _ -> + (("") ++) +-- PleaseMakeUnique val constraints _ -> +-- (("") ++) + PleaseDoFFI cmd _ -> + ((" + ((" b = Cache + { _fetchedContracts = Map.unionWith unifyCachedContract (view fetchedContracts a) (view fetchedContracts b) + , _fetchedStorage = Map.unionWith unifyCachedStorage (view fetchedStorage a) (view fetchedStorage b) + , _path = mappend (view path a) (view path b) + } + +unifyCachedStorage :: Map W256 W256 -> Map W256 W256 -> Map W256 W256 +unifyCachedStorage _ _ = undefined + +-- only intended for use in Cache merges, where we expect +-- everything to be Concrete +unifyCachedContract :: Contract -> Contract -> Contract +unifyCachedContract _ _ = undefined + {- +unifyCachedContract a b = a & set storage merged + where merged = case (view storage a, view storage b) of + (ConcreteStore sa, ConcreteStore sb) -> + ConcreteStore (mappend sa sb) + _ -> + view storage a + -} + +instance Monoid Cache where + mempty = Cache { _fetchedContracts = mempty, + _fetchedStorage = mempty, + _path = mempty + } + +-- * Data accessors + +currentContract :: VM -> Maybe Contract +currentContract vm = + view (env . contracts . at (view (state . codeContract) vm)) vm + +-- * Data constructors + +makeVm :: VMOpts -> VM +makeVm o = + let txaccessList = vmoptTxAccessList o + txorigin = vmoptOrigin o + txtoAddr = vmoptAddress o + initialAccessedAddrs = fromList $ [txorigin, txtoAddr] ++ [1..9] ++ (Map.keys txaccessList) + initialAccessedStorageKeys = fromList $ foldMap (uncurry (map . (,))) (Map.toList txaccessList) + touched = if vmoptCreate o then [txorigin] else [txorigin, txtoAddr] + in + VM + { _result = Nothing + , _frames = mempty + , _tx = TxState + { _gasprice = vmoptGasprice o + , _txgaslimit = vmoptGaslimit o + , _txPriorityFee = vmoptPriorityFee o + , _origin = txorigin + , _toAddr = txtoAddr + , _value = vmoptValue o + , _substate = SubState mempty touched initialAccessedAddrs initialAccessedStorageKeys mempty + --, _accessList = txaccessList + , _isCreate = vmoptCreate o + , _txReversion = Map.fromList + [(vmoptAddress o, vmoptContract o)] + } + , _logs = [] + , _traces = Zipper.fromForest [] + , _block = Block + { _coinbase = vmoptCoinbase o + , _timestamp = vmoptTimestamp o + , _number = vmoptNumber o + , _prevRandao = vmoptPrevRandao o + , _maxCodeSize = vmoptMaxCodeSize o + , _gaslimit = vmoptBlockGaslimit o + , _baseFee = vmoptBaseFee o + , _schedule = vmoptSchedule o + } + , _state = FrameState + { _pc = 0 + , _stack = mempty + , _memory = mempty + , _memorySize = 0 + , _code = view contractcode $ vmoptContract o + , _contract = vmoptAddress o + , _codeContract = vmoptAddress o + , _calldata = fst $ vmoptCalldata o + , _callvalue = vmoptValue o + , _caller = vmoptCaller o + , _gas = vmoptGas o + , _returndata = mempty + , _static = False + } + , _env = Env + { _sha3Crack = mempty + , _chainId = vmoptChainId o + , _storage = if vmoptStorageBase o == Concrete then EmptyStore else AbstractStore + , _origStorage = mempty + , _contracts = Map.fromList + [(vmoptAddress o, vmoptContract o)] + --, _keccakUsed = mempty + --, _storageModel = vmoptStorageModel o + } + , _cache = Cache mempty mempty mempty + , _burned = 0 + , _constraints = snd $ vmoptCalldata o + , _keccakEqs = mempty + , _iterations = mempty + , _allowFFI = vmoptAllowFFI o + } + +-- | Initialize empty contract with given code +initialContract :: ContractCode -> Contract +initialContract theContractCode = Contract + { _contractcode = theContractCode + , _codehash = hashcode theContractCode + , _balance = 0 + , _nonce = if creation then 1 else 0 + , _opIxMap = mkOpIxMap theContractCode + , _codeOps = mkCodeOps theContractCode + , _external = False + } where + creation = case theContractCode of + InitCode _ _ -> True + RuntimeCode _ -> False + +-- * Opcode dispatch (exec1) + +-- | Update program counter +next :: (?op :: Word8) => EVM () +next = modifying (state . pc) (+ (opSize ?op)) + +-- | Executes the EVM one step +exec1 :: EVM () +exec1 = do + vm <- get + + let + -- Convenience function to access parts of the current VM state. + -- Arcane type signature needed to avoid monomorphism restriction. + the :: (b -> VM -> Const a VM) -> ((a -> Const a a) -> b) -> a + the f g = view (f . g) vm + + -- Convenient aliases + mem = the state memory + stk = the state stack + self = the state contract + this = fromMaybe (error "internal error: state contract") (preview (ix self) (the env contracts)) + + fees@FeeSchedule {..} = the block schedule + + doStop = finishFrame (FrameReturned mempty) + + if self > 0x0 && self <= 0x9 then do + -- call to precompile + let ?op = 0x00 -- dummy value + case bufLength (the state calldata) of + (Lit calldatasize) -> do + copyBytesToMemory (the state calldata) (Lit calldatasize) (Lit 0) (Lit 0) + executePrecompile self (the state gas) 0 calldatasize 0 0 [] + vmx <- get + case view (state.stack) vmx of + (x:_) -> case x of + Lit (num -> x' :: Integer) -> case x' of + 0 -> do + fetchAccount self $ \_ -> do + touchAccount self + vmError PrecompileFailure + _ -> fetchAccount self $ \_ -> do + touchAccount self + out <- use (state . returndata) + finishFrame (FrameReturned out) + e -> vmError $ + UnexpectedSymbolicArg (view (state . pc) vmx) "precompile returned a symbolic value" [e] + _ -> + underrun + e -> vmError $ UnexpectedSymbolicArg (the state pc) "cannot call precompiles with symbolic data" [e] + + else if the state pc >= opslen (the state code) + then doStop + + else do + let ?op = case (the state code) of + InitCode conc _ -> BS.index conc (the state pc) + RuntimeCode ops -> + fromMaybe (error "could not analyze symbolic code") $ + unlitByte $ ops V.! the state pc + + case ?op of + + -- op: PUSH + x | x >= 0x60 && x <= 0x7f -> do + let !n = num x - 0x60 + 1 + !xs = case the state code of + InitCode conc _ -> Lit $ word $ padRight n $ BS.take n (BS.drop (1 + the state pc) conc) + RuntimeCode ops -> + let bytes = V.take n $ V.drop (1 + the state pc) ops + in if all isLitByte bytes then -- optimize concrete path + let litBytes = V.toList $ V.catMaybes $ unlitByte <$> bytes + padded = BS.replicate (32 - length litBytes) 0 <> BS.pack litBytes + in Lit $ word padded + else readWord (Lit 0) $ Expr.fromList $ padLeft' 32 bytes + limitStack 1 $ + burn g_verylow $ do + next + pushSym xs + + -- op: DUP + x | x >= 0x80 && x <= 0x8f -> do + let !i = x - 0x80 + 1 + case preview (ix (num i - 1)) stk of + Nothing -> underrun + Just y -> + limitStack 1 $ + burn g_verylow $ do + next + pushSym y + + -- op: SWAP + x | x >= 0x90 && x <= 0x9f -> do + let i = num (x - 0x90 + 1) + if length stk < i + 1 + then underrun + else + burn g_verylow $ do + next + zoom (state . stack) $ do + assign (ix 0) (stk ^?! ix i) + assign (ix i) (stk ^?! ix 0) + + -- op: LOG + x | x >= 0xa0 && x <= 0xa4 -> + notStatic $ + let n = (num x - 0xa0) in + case stk of + (xOffset':xSize':xs) -> + if length xs < n + then underrun + else + forceConcrete2 (xOffset', xSize') "LOG" $ \(xOffset, xSize) -> do + let (topics, xs') = splitAt n xs + bytes = readMemory xOffset' xSize' vm + logs' = (LogEntry (litAddr self) bytes topics) : (view logs vm) + burn (g_log + g_logdata * (num xSize) + num n * g_logtopic) $ + accessMemoryRange fees xOffset xSize $ do + traceTopLog logs' + next + assign (state . stack) xs' + assign logs logs' + _ -> + underrun + + -- op: STOP + 0x00 -> doStop + + -- op: ADD + 0x01 -> stackOp2 (const g_verylow) (uncurry Expr.add) + -- op: MUL + 0x02 -> stackOp2 (const g_low) (uncurry Expr.mul) + -- op: SUB + 0x03 -> stackOp2 (const g_verylow) (uncurry Expr.sub) + + -- op: DIV + 0x04 -> stackOp2 (const g_low) (uncurry Expr.div) + + -- op: SDIV + 0x05 -> stackOp2 (const g_low) (uncurry Expr.sdiv) + + -- op: MOD + 0x06 -> stackOp2 (const g_low) (uncurry Expr.mod) + + -- op: SMOD + 0x07 -> stackOp2 (const g_low) (uncurry Expr.smod) + -- op: ADDMOD + 0x08 -> stackOp3 (const g_mid) (uncurryN Expr.addmod) + -- op: MULMOD + 0x09 -> stackOp3 (const g_mid) (uncurryN Expr.mulmod) + + -- op: LT + 0x10 -> stackOp2 (const g_verylow) (uncurry Expr.lt) + -- op: GT + 0x11 -> stackOp2 (const g_verylow) (uncurry Expr.gt) + -- op: SLT + 0x12 -> stackOp2 (const g_verylow) (uncurry Expr.slt) + -- op: SGT + 0x13 -> stackOp2 (const g_verylow) (uncurry Expr.sgt) + + -- op: EQ + 0x14 -> stackOp2 (const g_verylow) (uncurry Expr.eq) + -- op: ISZERO + 0x15 -> stackOp1 (const g_verylow) Expr.iszero + + -- op: AND + 0x16 -> stackOp2 (const g_verylow) (uncurry Expr.and) + -- op: OR + 0x17 -> stackOp2 (const g_verylow) (uncurry Expr.or) + -- op: XOR + 0x18 -> stackOp2 (const g_verylow) (uncurry Expr.xor) + -- op: NOT + 0x19 -> stackOp1 (const g_verylow) Expr.not + + -- op: BYTE + 0x1a -> stackOp2 (const g_verylow) (\(i, w) -> Expr.padByte $ Expr.indexWord i w) + + -- op: SHL + 0x1b -> stackOp2 (const g_verylow) (uncurry Expr.shl) + -- op: SHR + 0x1c -> stackOp2 (const g_verylow) (uncurry Expr.shr) + -- op: SAR + 0x1d -> stackOp2 (const g_verylow) (uncurry Expr.sar) + + -- op: SHA3 + -- more accurately refered to as KECCAK + 0x20 -> + case stk of + (xOffset' : xSize' : xs) -> + forceConcrete xOffset' "sha3 offset must be concrete" $ + \xOffset -> forceConcrete xSize' "sha3 size must be concrete" $ \xSize -> + burn (g_sha3 + g_sha3word * ceilDiv (num xSize) 32) $ + accessMemoryRange fees xOffset xSize $ do + (hash, invMap) <- case readMemory xOffset' xSize' vm of + ConcreteBuf bs -> do + let hash' = keccak' bs + eqs <- use keccakEqs + assign keccakEqs $ PEq (Lit hash') (Keccak (ConcreteBuf bs)):eqs + pure (Lit hash', Map.singleton hash' bs) + buf -> pure (Keccak buf, mempty) + next + assign (state . stack) (hash : xs) + (env . sha3Crack) <>= invMap + _ -> underrun + + -- op: ADDRESS + 0x30 -> + limitStack 1 $ + burn g_base (next >> push (num self)) + + -- op: BALANCE + 0x31 -> + case stk of + (x':xs) -> forceConcrete x' "BALANCE" $ \x -> + accessAndBurn (num x) $ + fetchAccount (num x) $ \c -> do + next + assign (state . stack) xs + push (num $ view balance c) + [] -> + underrun + + -- op: ORIGIN + 0x32 -> + limitStack 1 . burn g_base $ + next >> push (num (the tx origin)) + + -- op: CALLER + 0x33 -> + limitStack 1 . burn g_base $ + next >> pushSym (the state caller) + + -- op: CALLVALUE + 0x34 -> + limitStack 1 . burn g_base $ + next >> pushSym (the state callvalue) + + -- op: CALLDATALOAD + 0x35 -> stackOp1 (const g_verylow) $ + \ind -> Expr.readWord ind (the state calldata) + + -- op: CALLDATASIZE + 0x36 -> + limitStack 1 . burn g_base $ + next >> pushSym (bufLength (the state calldata)) + + -- op: CALLDATACOPY + 0x37 -> + case stk of + (xTo' : xFrom : xSize' : xs) -> + forceConcrete2 (xTo', xSize') "CALLDATACOPY" $ + \(xTo, xSize) -> + burn (g_verylow + g_copy * ceilDiv (num xSize) 32) $ + 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 >> pushSym (codelen (the state code)) + + -- op: CODECOPY + 0x39 -> + case stk of + (memOffset' : codeOffset : n' : xs) -> + forceConcrete2 (memOffset', n') "CODECOPY" $ + \(memOffset,n) -> do + case toWord64 n of + Nothing -> vmError IllegalOverflow + Just n'' -> + if n'' <= ( (maxBound :: Word64) - g_verylow ) `div` g_copy * 32 then + burn (g_verylow + g_copy * ceilDiv (num n) 32) $ + accessMemoryRange fees memOffset n $ do + next + assign (state . stack) xs + copyBytesToMemory (toBuf $ the state code) n' codeOffset memOffset' + else vmError IllegalOverflow + _ -> underrun + + -- op: GASPRICE + 0x3a -> + limitStack 1 . burn g_base $ + next >> push (the tx gasprice) + + -- op: EXTCODESIZE + 0x3b -> + case stk of + (x':xs) -> case x' of + (Lit x) -> if x == num cheatCode + then do + next + assign (state . stack) xs + pushSym (Lit 1) + else + accessAndBurn (num x) $ + fetchAccount (num x) $ \c -> do + next + assign (state . stack) xs + pushSym (bufLength (view bytecode c)) + _ -> do + assign (state . stack) xs + pushSym (CodeSize x') + [] -> + underrun + + -- op: EXTCODECOPY + 0x3c -> + case stk of + ( extAccount' + : memOffset' + : codeOffset + : codeSize' + : xs ) -> + forceConcrete3 (extAccount', memOffset', codeSize') "EXTCODECOPY" $ + \(extAccount, memOffset, codeSize) -> do + acc <- accessAccountForGas (num extAccount) + let cost = if acc then g_warm_storage_read else g_cold_account_access + burn (cost + g_copy * ceilDiv (num codeSize) 32) $ + accessMemoryRange fees memOffset codeSize $ + fetchAccount (num extAccount) $ \c -> do + next + assign (state . stack) xs + copyBytesToMemory (view bytecode c) codeSize' codeOffset memOffset' + _ -> underrun + + -- op: RETURNDATASIZE + 0x3d -> + limitStack 1 . burn g_base $ + next >> pushSym (bufLength (the state returndata)) + + -- op: RETURNDATACOPY + 0x3e -> + case stk of + (xTo' : xFrom : xSize' :xs) -> forceConcrete2 (xTo', xSize') "RETURNDATACOPY" $ + \(xTo, xSize) -> + burn (g_verylow + g_copy * ceilDiv (num xSize) 32) $ + accessMemoryRange fees xTo xSize $ do + next + assign (state . stack) xs + + let jump True = vmError EVM.InvalidMemoryAccess + jump False = copyBytesToMemory (the state returndata) xSize' xFrom xTo' + + case (xFrom, bufLength (the state returndata)) of + (Lit f, Lit l) -> + jump $ l < f + xSize || f + xSize < f + _ -> do + let oob = Expr.lt (bufLength $ the state returndata) (Expr.add xFrom xSize') + overflow = Expr.lt (Expr.add xFrom xSize') (xFrom) + loc <- codeloc + branch loc (Expr.or oob overflow) jump + _ -> underrun + + -- op: EXTCODEHASH + 0x3f -> + case stk of + (x':xs) -> forceConcrete x' "EXTCODEHASH" $ \x -> + accessAndBurn (num x) $ do + next + assign (state . stack) xs + fetchAccount (num x) $ \c -> + if accountEmpty c + then push (num (0 :: Int)) + else pushSym $ keccak (view bytecode c) + [] -> + underrun + + -- op: BLOCKHASH + 0x40 -> do + -- We adopt the fake block hash scheme of the VMTests, + -- so that blockhash(i) is the hash of i as decimal ASCII. + stackOp1 (const g_blockhash) $ \case + (Lit i) -> if i + 256 < the block number || i >= the block number + then Lit 0 + else (num i :: Integer) & show & Char8.pack & keccak' & Lit + i -> BlockHash i + + -- op: COINBASE + 0x41 -> + limitStack 1 . burn g_base $ + next >> push (num (the block coinbase)) + + -- op: TIMESTAMP + 0x42 -> + limitStack 1 . burn g_base $ + next >> pushSym (the block timestamp) + + -- op: NUMBER + 0x43 -> + limitStack 1 . burn g_base $ + next >> push (the block number) + + -- op: PREVRANDAO + 0x44 -> do + limitStack 1 . burn g_base $ + next >> push (the block prevRandao) + + -- op: GASLIMIT + 0x45 -> + limitStack 1 . burn g_base $ + next >> push (num $ the block gaslimit) + + -- op: CHAINID + 0x46 -> + limitStack 1 . burn g_base $ + next >> push (the env chainId) + + -- op: SELFBALANCE + 0x47 -> + limitStack 1 . burn g_low $ + next >> push (view balance this) + + -- op: BASEFEE + 0x48 -> + limitStack 1 . burn g_base $ + next >> push (the block baseFee) + + -- op: POP + 0x50 -> + case stk of + (_:xs) -> burn g_base (next >> assign (state . stack) xs) + _ -> underrun + + -- op: MLOAD + 0x51 -> + case stk of + (x':xs) -> forceConcrete x' "MLOAD" $ \x -> + burn g_verylow $ + accessMemoryWord fees x $ do + next + assign (state . stack) (readWord (Lit x) mem : xs) + _ -> underrun + + -- op: MSTORE + 0x52 -> + case stk of + (x':y:xs) -> forceConcrete x' "MSTORE index" $ \x -> + burn g_verylow $ + accessMemoryWord fees x $ do + next + assign (state . memory) (writeWord (Lit x) y mem) + assign (state . stack) xs + _ -> underrun + + -- op: MSTORE8 + 0x53 -> + case stk of + (x':y:xs) -> forceConcrete x' "MSTORE8" $ \x -> + burn g_verylow $ + accessMemoryRange fees x 1 $ do + let yByte = indexWord (Lit 31) y + next + modifying (state . memory) (writeByte (Lit x) yByte) + assign (state . stack) xs + _ -> underrun + + -- op: SLOAD + 0x54 -> + case stk of + (x:xs) -> do + acc <- accessStorageForGas self x + let cost = if acc then g_warm_storage_read else g_cold_sload + burn cost $ + accessStorage self x $ \y -> do + next + assign (state . stack) (y:xs) + _ -> underrun + + -- op: SSTORE + 0x55 -> + notStatic $ + case stk of + (x:new:xs) -> + accessStorage self x $ \current -> do + availableGas <- use (state . gas) + + if num availableGas <= g_callstipend + then finishFrame (FrameErrored (OutOfGas availableGas (num g_callstipend))) + else do + let original = case readStorage (litAddr self) x (ConcreteStore $ the env origStorage) of + Just (Lit v) -> v + _ -> 0 + let storage_cost = case (maybeLitWord current, maybeLitWord new) of + (Just current', Just new') -> + if (current' == new') then g_sload + else if (current' == original) && (original == 0) then g_sset + else if (current' == original) then g_sreset + else g_sload + + -- if any of the arguments are symbolic, + -- assume worst case scenario + _ -> g_sset + + acc <- accessStorageForGas self x + let cold_storage_cost = if acc then 0 else g_cold_sload + burn (storage_cost + cold_storage_cost) $ do + next + assign (state . stack) xs + modifying (env . storage) + (writeStorage (litAddr self) x new) + + case (maybeLitWord current, maybeLitWord new) of + (Just current', Just new') -> + unless (current' == new') $ + if current' == original + then when (original /= 0 && new' == 0) $ + refund (g_sreset + g_access_list_storage_key) + else do + when (original /= 0) $ + if new' == 0 + then refund (g_sreset + g_access_list_storage_key) + else unRefund (g_sreset + g_access_list_storage_key) + when (original == new') $ + if original == 0 + then refund (g_sset - g_sload) + else refund (g_sreset - g_sload) + -- if any of the arguments are symbolic, + -- don't change the refund counter + _ -> noop + _ -> underrun + + -- op: JUMP + 0x56 -> + case stk of + (x:xs) -> + burn g_mid $ forceConcrete x "JUMP: symbolic jumpdest" $ \x' -> + checkJump x' xs + _ -> underrun + + -- op: JUMPI + 0x57 -> do + case stk of + (x:y:xs) -> forceConcrete x "JUMPI: symbolic jumpdest" $ \x' -> + burn g_high $ + let jump :: Bool -> EVM () + jump False = assign (state . stack) xs >> next + jump _ = checkJump x' xs + in case maybeLitWord y of + Just y' -> jump (0 /= y') + -- if the jump condition is symbolic, we explore both sides + Nothing -> do + loc <- codeloc + branch loc y jump + _ -> underrun + + -- op: PC + 0x58 -> + limitStack 1 . burn g_base $ + next >> push (num (the state pc)) + + -- op: MSIZE + 0x59 -> + limitStack 1 . burn g_base $ + next >> push (num (the state memorySize)) + + -- op: GAS + 0x5a -> + limitStack 1 . burn g_base $ + next >> push (num (the state gas - g_base)) + + -- op: JUMPDEST + 0x5b -> burn g_jumpdest next + + -- op: EXP + 0x0a -> + -- NOTE: this can be done symbolically using unrolling like this: + -- https://hackage.haskell.org/package/sbv-9.0/docs/src/Data.SBV.Core.Model.html#.%5E + -- However, it requires symbolic gas, since the gas depends on the exponent + case stk of + (base:exponent':xs) -> forceConcrete exponent' "EXP: symbolic exponent" $ \exponent -> + let cost = if exponent == 0 + then g_exp + else g_exp + g_expbyte * num (ceilDiv (1 + log2 exponent) 8) + in burn cost $ do + next + state . stack .= Expr.exp base exponent' : xs + _ -> underrun + + -- op: SIGNEXTEND + 0x0b -> stackOp2 (const g_low) (uncurry Expr.sex) + + -- op: CREATE + 0xf0 -> + notStatic $ + case stk of + (xValue' : xOffset' : xSize' : xs) -> forceConcrete3 (xValue', xOffset', xSize') "CREATE" $ + \(xValue, xOffset, xSize) -> do + accessMemoryRange fees xOffset xSize $ do + availableGas <- use (state . gas) + let + newAddr = createAddress self (view nonce this) + (cost, gas') = costOfCreate fees availableGas 0 + _ <- accessAccountForGas newAddr + burn (cost - gas') $ do + -- unfortunately we have to apply some (pretty hacky) + -- heuristics here to parse the unstructured buffer read + -- from memory into a code and data section + let initCode = readMemory xOffset' xSize' vm + create self this (num gas') xValue xs newAddr initCode + _ -> underrun + + -- op: CALL + 0xf1 -> + case stk of + ( xGas' + : xTo + : xValue' + : xInOffset' + : xInSize' + : xOutOffset' + : xOutSize' + : xs + ) -> forceConcrete6 (xGas', xValue', xInOffset', xInSize', xOutOffset', xOutSize') "CALL" $ + \(xGas, xValue, xInOffset, xInSize, xOutOffset, xOutSize) -> + (if xValue > 0 then notStatic else id) $ + delegateCall this (num xGas) xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ \callee -> do + zoom state $ do + assign callvalue (Lit xValue) + assign caller (litAddr self) + assign contract callee + transfer self callee xValue + touchAccount self + touchAccount callee + _ -> + underrun + + -- op: CALLCODE + 0xf2 -> + case stk of + ( xGas' + : xTo + : xValue' + : xInOffset' + : xInSize' + : xOutOffset' + : xOutSize' + : xs + ) -> forceConcrete6 (xGas', xValue', xInOffset', xInSize', xOutOffset', xOutSize') "CALLCODE" $ + \(xGas, xValue, xInOffset, xInSize, xOutOffset, xOutSize) -> + delegateCall this (num xGas) xTo (litAddr self) xValue xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do + zoom state $ do + assign callvalue (Lit xValue) + assign caller (litAddr self) + touchAccount self + _ -> + underrun + + -- op: RETURN + 0xf3 -> + case stk of + (xOffset' : xSize' :_) -> forceConcrete2 (xOffset', xSize') "RETURN" $ \(xOffset, xSize) -> + accessMemoryRange fees xOffset xSize $ do + let + output = readMemory xOffset' xSize' vm + codesize = fromMaybe (error "RETURN: cannot return dynamically sized abstract data") + . unlit . bufLength $ output + maxsize = the block maxCodeSize + creation = case view frames vm of + [] -> the tx isCreate + frame:_ -> case view frameContext frame of + CreationContext {} -> True + CallContext {} -> False + if creation + then + if codesize > maxsize + then + finishFrame (FrameErrored (MaxCodeSizeExceeded maxsize codesize)) + else do + let frameReturned = burn (g_codedeposit * num codesize) $ + finishFrame (FrameReturned output) + frameErrored = finishFrame $ FrameErrored InvalidFormat + case readByte (Lit 0) output of + LitByte 0xef -> frameErrored + LitByte _ -> frameReturned + y -> do + loc <- codeloc + branch loc (Expr.eqByte y (LitByte 0xef)) $ \case + True -> frameErrored + False -> frameReturned + else + finishFrame (FrameReturned output) + _ -> underrun + + -- op: DELEGATECALL + 0xf4 -> + case stk of + (xGas' + :xTo + :xInOffset' + :xInSize' + :xOutOffset' + :xOutSize' + :xs) -> forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') "DELEGATECALL" $ + \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> + delegateCall this (num xGas) xTo (litAddr self) 0 xInOffset xInSize xOutOffset xOutSize xs $ \_ -> do + touchAccount self + _ -> underrun + + -- op: CREATE2 + 0xf5 -> notStatic $ + case stk of + (xValue' + :xOffset' + :xSize' + :xSalt' + :xs) -> forceConcrete4 (xValue', xOffset', xSize', xSalt') "CREATE2" $ + \(xValue, xOffset, xSize, xSalt) -> + accessMemoryRange fees xOffset xSize $ do + availableGas <- use (state . gas) + + forceConcreteBuf (readMemory xOffset' xSize' vm) "CREATE2" $ + \initCode -> do + let + newAddr = create2Address self xSalt initCode + (cost, gas') = costOfCreate fees availableGas xSize + _ <- accessAccountForGas newAddr + burn (cost - gas') $ create self this gas' xValue xs newAddr (ConcreteBuf initCode) + _ -> underrun + + -- op: STATICCALL + 0xfa -> + case stk of + (xGas' + :xTo + :xInOffset' + :xInSize' + :xOutOffset' + :xOutSize' + :xs) -> forceConcrete5 (xGas', xInOffset', xInSize', xOutOffset', xOutSize') "STATICCALL" $ + \(xGas, xInOffset, xInSize, xOutOffset, xOutSize) -> do + delegateCall this (num xGas) xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs $ \callee -> do + zoom state $ do + assign callvalue (Lit 0) + assign caller (litAddr self) + assign contract callee + assign static True + touchAccount self + touchAccount callee + _ -> + underrun + + -- op: SELFDESTRUCT + 0xff -> + notStatic $ + case stk of + [] -> underrun + (xTo':_) -> forceConcrete xTo' "SELFDESTRUCT" $ \(num -> xTo) -> do + acc <- accessAccountForGas (num xTo) + let cost = if acc then 0 else g_cold_account_access + funds = view balance this + recipientExists = accountExists xTo vm + c_new = if not recipientExists && funds /= 0 + then g_selfdestruct_newaccount + else 0 + burn (g_selfdestruct + c_new + cost) $ do + selfdestruct self + touchAccount xTo + + if funds /= 0 + then fetchAccount xTo $ \_ -> do + env . contracts . ix xTo . balance += funds + assign (env . contracts . ix self . balance) 0 + doStop + else doStop + + -- op: REVERT + 0xfd -> + case stk of + (xOffset':xSize':_) -> forceConcrete2 (xOffset', xSize') "REVERT" $ \(xOffset, xSize) -> + accessMemoryRange fees xOffset xSize $ do + let output = readMemory xOffset' xSize' vm + finishFrame (FrameReverted output) + _ -> underrun + + xxx -> + vmError (UnrecognizedOpcode xxx) + +transfer :: Addr -> Addr -> W256 -> EVM () +transfer xFrom xTo xValue = + zoom (env . contracts) $ do + ix xFrom . balance -= xValue + ix xTo . balance += xValue + +-- | Checks a *CALL for failure; OOG, too many callframes, memory access etc. +callChecks + :: (?op :: Word8) + => Contract -> Word64 -> Addr -> Addr -> W256 -> W256 -> W256 -> W256 -> W256 -> [Expr EWord] + -- continuation with gas available for call + -> (Word64 -> EVM ()) + -> EVM () +callChecks this xGas xContext xTo xValue xInOffset xInSize xOutOffset xOutSize xs continue = do + vm <- get + let fees = view (block . schedule) vm + accessMemoryRange fees xInOffset xInSize $ + accessMemoryRange fees xOutOffset xOutSize $ do + availableGas <- use (state . gas) + let recipientExists = accountExists xContext vm + (cost, gas') <- costOfCall fees recipientExists xValue availableGas xGas xTo + burn (cost - gas') $ do + if xValue > num (view balance this) + then do + assign (state . stack) (Lit 0 : xs) + assign (state . returndata) mempty + pushTrace $ ErrorTrace $ BalanceTooLow xValue (view balance this) + next + else if length (view frames vm) >= 1024 + then do + assign (state . stack) (Lit 0 : xs) + assign (state . returndata) mempty + pushTrace $ ErrorTrace CallDepthLimitReached + next + else continue gas' + +precompiledContract + :: (?op :: Word8) + => Contract + -> Word64 + -> Addr + -> Addr + -> W256 + -> W256 -> W256 -> W256 -> W256 + -> [Expr EWord] + -> EVM () +precompiledContract this xGas precompileAddr recipient xValue inOffset inSize outOffset outSize xs = + callChecks this xGas recipient precompileAddr xValue inOffset inSize outOffset outSize xs $ \gas' -> + do + executePrecompile precompileAddr gas' inOffset inSize outOffset outSize xs + self <- use (state . contract) + stk <- use (state . stack) + pc' <- use (state . pc) + case stk of + (x:_) -> case maybeLitWord x of + Just 0 -> + return () + Just 1 -> + fetchAccount recipient $ \_ -> do + + transfer self recipient xValue + touchAccount self + touchAccount recipient + _ -> vmError $ UnexpectedSymbolicArg pc' "symbolic return value from precompile" [x] + _ -> underrun + +executePrecompile + :: (?op :: Word8) + => Addr + -> Word64 -> W256 -> W256 -> W256 -> W256 -> [Expr EWord] + -> EVM () +executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = do + vm <- get + let input = readMemory (Lit inOffset) (Lit inSize) vm + fees = view (block . schedule) vm + cost = costOfPrecompile fees preCompileAddr input + notImplemented = error $ "precompile at address " <> show preCompileAddr <> " not yet implemented" + precompileFail = burn (gasCap - cost) $ do + assign (state . stack) (Lit 0 : xs) + pushTrace $ ErrorTrace PrecompileFailure + next + if cost > gasCap then + burn gasCap $ do + assign (state . stack) (Lit 0 : xs) + next + else + burn cost $ + case preCompileAddr of + -- ECRECOVER + 0x1 -> + -- TODO: support symbolic variant + forceConcreteBuf input "ECRECOVER" $ \input' -> + case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of + Nothing -> do + -- return no output for invalid signature + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) mempty + next + Just output -> do + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) (ConcreteBuf output) + copyBytesToMemory (ConcreteBuf output) (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- SHA2-256 + 0x2 -> + let + hash = case input of + ConcreteBuf input' -> sha256Buf input' + _ -> WriteWord (Lit 0) (SHA256 input) mempty + sha256Buf x = ConcreteBuf $ BA.convert (Crypto.hash x :: Digest SHA256) + in do + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) hash + copyBytesToMemory hash (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- RIPEMD-160 + 0x3 -> + -- TODO: support symbolic variant + forceConcreteBuf input "RIPEMD160" $ \input' -> + + let + padding = BS.pack $ replicate 12 0 + hash' = BA.convert (Crypto.hash input' :: Digest RIPEMD160) + hash = ConcreteBuf $ padding <> hash' + in do + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) hash + copyBytesToMemory hash (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- IDENTITY + 0x4 -> do + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) input + copyCallBytesToMemory input (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- MODEXP + 0x5 -> + -- TODO: support symbolic variant + forceConcreteBuf input "MODEXP" $ \input' -> + + let + (lenb, lene, lenm) = parseModexpLength input' + + output = ConcreteBuf $ + if isZero (96 + lenb + lene) lenm input' + then truncpadlit (num lenm) (asBE (0 :: Int)) + else + let + b = asInteger $ lazySlice 96 lenb input' + e = asInteger $ lazySlice (96 + lenb) lene input' + m = asInteger $ lazySlice (96 + lenb + lene) lenm input' + in + padLeft (num lenm) (asBE (expFast b e m)) + in do + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) output + copyBytesToMemory output (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- ECADD + 0x6 -> + -- TODO: support symbolic variant + forceConcreteBuf input "ECADD" $ \input' -> + case EVM.Precompiled.execute 0x6 (truncpadlit 128 input') 64 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- ECMUL + 0x7 -> + -- TODO: support symbolic variant + forceConcreteBuf input "ECMUL" $ \input' -> + + case EVM.Precompiled.execute 0x7 (truncpadlit 96 input') 64 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- ECPAIRING + 0x8 -> + -- TODO: support symbolic variant + forceConcreteBuf input "ECPAIR" $ \input' -> + + case EVM.Precompiled.execute 0x8 input' 32 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuf $ truncpadlit 32 output + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) + next + + -- BLAKE2 + 0x9 -> + -- TODO: support symbolic variant + forceConcreteBuf input "BLAKE2" $ \input' -> do + + case (BS.length input', 1 >= BS.last input') of + (213, True) -> case EVM.Precompiled.execute 0x9 input' 64 of + Just output -> do + let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output + assign (state . stack) (Lit 1 : xs) + assign (state . returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput (Lit outSize) (Lit 0) (Lit outOffset) + next + Nothing -> precompileFail + _ -> precompileFail + + + _ -> notImplemented + +truncpadlit :: Int -> ByteString -> ByteString +truncpadlit n xs = if m > n then BS.take n xs + else BS.append xs (BS.replicate (n - m) 0) + where m = BS.length xs + +lazySlice :: W256 -> W256 -> ByteString -> LS.ByteString +lazySlice offset size bs = + let bs' = LS.take (num size) (LS.drop (num offset) (fromStrict bs)) + in bs' <> LS.replicate ((num size) - LS.length bs') 0 + +parseModexpLength :: ByteString -> (W256, W256, W256) +parseModexpLength input = + let lenb = word $ LS.toStrict $ lazySlice 0 32 input + lene = word $ LS.toStrict $ lazySlice 32 64 input + lenm = word $ LS.toStrict $ lazySlice 64 96 input + in (lenb, lene, lenm) + +--- checks if a range of ByteString bs starting at offset and length size is all zeros. +isZero :: W256 -> W256 -> ByteString -> Bool +isZero offset size bs = + LS.all (== 0) $ + LS.take (num size) $ + LS.drop (num offset) $ + fromStrict bs + +asInteger :: LS.ByteString -> Integer +asInteger xs = if xs == mempty then 0 + else 256 * asInteger (LS.init xs) + + num (LS.last xs) + +-- * Opcode helper actions + +noop :: Monad m => m () +noop = pure () + +pushTo :: MonadState s m => ASetter s s [a] [a] -> a -> m () +pushTo f x = f %= (x :) + +pushToSequence :: MonadState s m => ASetter s s (Seq a) (Seq a) -> a -> m () +pushToSequence f x = f %= (Seq.|> x) + +getCodeLocation :: VM -> CodeLocation +getCodeLocation vm = (view (state . contract) vm, view (state . pc) vm) + +branch :: CodeLocation -> Expr EWord -> (Bool -> EVM ()) -> EVM () +branch loc cond continue = do + pathconds <- use constraints + assign result . Just . VMFailure . Query $ PleaseAskSMT cond pathconds choosePath + where + choosePath (Case v) = do assign result Nothing + pushTo constraints $ if v then (cond ./= (Lit 0)) else (cond .== (Lit 0)) + iteration <- use (iterations . at loc . non 0) + assign (cache . path . at (loc, iteration)) (Just v) + assign (iterations . at loc) (Just (iteration + 1)) + continue v + -- Both paths are possible; we ask for more input + choosePath Unknown = assign result . Just . VMFailure . Choose . PleaseChoosePath cond $ choosePath . Case + -- None of the paths are possible; fail this branch + choosePath Inconsistent = vmError DeadPath + + +-- | Construct RPC Query and halt execution until resolved +fetchAccount :: Addr -> (Contract -> EVM ()) -> EVM () +fetchAccount addr continue = + use (env . contracts . at addr) >>= \case + Just c -> continue c + Nothing -> + use (cache . fetchedContracts . at addr) >>= \case + Just c -> do + assign (env . contracts . at addr) (Just c) + continue c + Nothing -> do + assign result . Just . VMFailure $ Query $ + PleaseFetchContract addr + (\c -> do assign (cache . fetchedContracts . at addr) (Just c) + assign (env . contracts . at addr) (Just c) + assign result Nothing + continue c) + +accessStorage + :: Addr -- ^ Contract address + -> Expr EWord -- ^ Storage slot key + -> (Expr EWord -> EVM ()) -- ^ Continuation + -> EVM () +accessStorage addr slot continue = do + store <- use (env . storage) + use (env . contracts . at addr) >>= \case + Just c -> + case readStorage (litAddr addr) slot store of + -- Notice that if storage is symbolic, we always continue straight away + Just x -> + continue x + Nothing -> + if view external c + then + -- check if the slot is cached + use (cache . fetchedContracts . at addr) >>= \case + Nothing -> forceConcrete slot "cannot read symbolic slots via RPC" mkQuery + Just _ -> forceConcrete slot "cannot read symbolic slots via rpc" $ + \s -> maybe (mkQuery s) continue (readStorage (litAddr addr) slot store) + else do + modifying (env . storage) (writeStorage (litAddr addr) slot (Lit 0)) + continue $ Lit 0 + Nothing -> + fetchAccount addr $ \_ -> + accessStorage addr slot continue + where + mkQuery s = assign result . Just . VMFailure . Query $ + PleaseFetchSlot addr s + (\x -> do + modifying (cache . fetchedStorage . ix (num addr)) (Map.insert s x) + modifying (env . storage) (writeStorage (litAddr addr) slot (Lit x)) + assign result Nothing + continue (Lit x)) + +accountExists :: Addr -> VM -> Bool +accountExists addr vm = + case view (env . contracts . at addr) vm of + Just c -> not (accountEmpty c) + Nothing -> False + +-- EIP 161 +accountEmpty :: Contract -> Bool +accountEmpty c = + case view contractcode c of + RuntimeCode b -> null b + _ -> False + && (view nonce c == 0) + && (view balance c == 0) + +-- * How to finalize a transaction +finalize :: EVM () +finalize = do + let + revertContracts = use (tx . txReversion) >>= assign (env . contracts) + revertSubstate = assign (tx . substate) (SubState mempty mempty mempty mempty mempty) + + use result >>= \case + Nothing -> + error "Finalising an unfinished tx." + Just (VMFailure (EVM.Revert _)) -> do + revertContracts + revertSubstate + Just (VMFailure _) -> do + -- burn remaining gas + assign (state . gas) 0 + revertContracts + revertSubstate + Just (VMSuccess output) -> do + -- deposit the code from a creation tx + pc' <- use (state . pc) + creation <- use (tx . isCreate) + createe <- use (state . contract) + createeExists <- (Map.member createe) <$> use (env . contracts) + case Expr.toList output of + Nothing -> vmError $ UnexpectedSymbolicArg pc' "runtime code cannot have an abstract lentgh" [output] + Just ops -> + when (creation && createeExists) $ replaceCode createe (RuntimeCode ops) + + -- compute and pay the refund to the caller and the + -- corresponding payment to the miner + txOrigin <- use (tx . origin) + sumRefunds <- (sum . (snd <$>)) <$> (use (tx . substate . refunds)) + miner <- use (block . coinbase) + blockReward <- num . r_block <$> (use (block . schedule)) + gasPrice <- use (tx . gasprice) + priorityFee <- use (tx . txPriorityFee) + gasLimit <- use (tx . txgaslimit) + gasRemaining <- use (state . gas) + + let + gasUsed = gasLimit - gasRemaining + cappedRefund = min (quot gasUsed 5) (num sumRefunds) + originPay = (num $ gasRemaining + cappedRefund) * gasPrice + + minerPay = priorityFee * (num gasUsed) + + modifying (env . contracts) + (Map.adjust (over balance (+ originPay)) txOrigin) + modifying (env . contracts) + (Map.adjust (over balance (+ minerPay)) miner) + touchAccount miner + + -- pay out the block reward, recreating the miner if necessary + preuse (env . contracts . ix miner) >>= \case + Nothing -> modifying (env . contracts) + (Map.insert miner (initialContract (EVM.RuntimeCode mempty))) + Just _ -> noop + modifying (env . contracts) + (Map.adjust (over balance (+ blockReward)) miner) + + -- perform state trie clearing (EIP 161), of selfdestructs + -- and touched accounts. addresses are cleared if they have + -- a) selfdestructed, or + -- b) been touched and + -- c) are empty. + -- (see Yellow Paper "Accrued Substate") + -- + -- remove any destructed addresses + destroyedAddresses <- use (tx . substate . selfdestructs) + modifying (env . contracts) + (Map.filterWithKey (\k _ -> (k `notElem` destroyedAddresses))) + -- then, clear any remaining empty and touched addresses + touchedAddresses <- use (tx . substate . touchedAccounts) + modifying (env . contracts) + (Map.filterWithKey + (\k a -> not ((k `elem` touchedAddresses) && accountEmpty a))) + +-- | Loads the selected contract as the current contract to execute +loadContract :: Addr -> EVM () +loadContract target = + preuse (env . contracts . ix target . contractcode) >>= + \case + Nothing -> + 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 EVM.StackLimitExceeded + else continue + +notStatic :: EVM () -> EVM () +notStatic continue = do + bad <- use (state . static) + if bad + then vmError StateChangeWhileStatic + else continue + +-- | Burn gas, failing if insufficient gas is available +burn :: Word64 -> EVM () -> EVM () +burn n continue = do + available <- use (state . gas) + if n <= available + then do + state . gas -= n + burned += n + continue + else + vmError (OutOfGas available n) + +--forceConcreteAddr :: SAddr -> (Addr -> EVM ()) -> EVM () +--forceConcreteAddr n continue = case maybeLitAddr n of + --Nothing -> vmError UnexpectedSymbolicArg + --Just c -> continue c + +forceConcrete :: Expr EWord -> String -> (W256 -> EVM ()) -> EVM () +forceConcrete n msg continue = case maybeLitWord n of + Nothing -> do + vm <- get + vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [n] + Just c -> continue c + +forceConcrete2 :: (Expr EWord, Expr EWord) -> String -> ((W256, W256) -> EVM ()) -> EVM () +forceConcrete2 (n,m) msg continue = case (maybeLitWord n, maybeLitWord m) of + (Just c, Just d) -> continue (c, d) + _ -> do + vm <- get + vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [n, m] + +forceConcrete3 :: (Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256) -> EVM ()) -> EVM () +forceConcrete3 (k,n,m) msg continue = case (maybeLitWord k, maybeLitWord n, maybeLitWord m) of + (Just c, Just d, Just f) -> continue (c, d, f) + _ -> do + vm <- get + vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [k, n, m] + +forceConcrete4 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256) -> EVM ()) -> EVM () +forceConcrete4 (k,l,n,m) msg continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord n, maybeLitWord m) of + (Just b, Just c, Just d, Just f) -> continue (b, c, d, f) + _ -> do + vm <- get + vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [k, l, n, m] + +forceConcrete5 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256, W256) -> EVM ()) -> EVM () +forceConcrete5 (k,l,m,n,o) msg continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord m, maybeLitWord n, maybeLitWord o) of + (Just a, Just b, Just c, Just d, Just e) -> continue (a, b, c, d, e) + _ -> do + vm <- get + vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [k, l, m, n, o] + +forceConcrete6 :: (Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord, Expr EWord) -> String -> ((W256, W256, W256, W256, W256, W256) -> EVM ()) -> EVM () +forceConcrete6 (k,l,m,n,o,p) msg continue = case (maybeLitWord k, maybeLitWord l, maybeLitWord m, maybeLitWord n, maybeLitWord o, maybeLitWord p) of + (Just a, Just b, Just c, Just d, Just e, Just f) -> continue (a, b, c, d, e, f) + _ -> do + vm <- get + vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [k, l, m, n, o, p] + +forceConcreteBuf :: Expr Buf -> String -> (ByteString -> EVM ()) -> EVM () +forceConcreteBuf (ConcreteBuf b) _ continue = continue b +forceConcreteBuf b msg _ = do + vm <- get + vmError $ UnexpectedSymbolicArg (view (state . pc) vm) msg [b] + +-- * Substate manipulation +refund :: Word64 -> EVM () +refund n = do + self <- use (state . contract) + pushTo (tx . substate . refunds) (self, n) + +unRefund :: Word64 -> EVM () +unRefund n = do + self <- use (state . contract) + refs <- use (tx . substate . refunds) + assign (tx . substate . refunds) + (filter (\(a,b) -> not (a == self && b == n)) refs) + +touchAccount :: Addr -> EVM() +touchAccount = pushTo ((tx . substate) . touchedAccounts) + +selfdestruct :: Addr -> EVM() +selfdestruct = pushTo ((tx . substate) . selfdestructs) + +accessAndBurn :: Addr -> EVM () -> EVM () +accessAndBurn x cont = do + FeeSchedule {..} <- use ( block . schedule ) + acc <- accessAccountForGas x + let cost = if acc then g_warm_storage_read else g_cold_account_access + burn cost cont + +-- | returns a wrapped boolean- if true, this address has been touched before in the txn (warm gas cost as in EIP 2929) +-- otherwise cold +accessAccountForGas :: Addr -> EVM Bool +accessAccountForGas addr = do + accessedAddrs <- use (tx . substate . accessedAddresses) + let accessed = member addr accessedAddrs + assign (tx . substate . accessedAddresses) (insert addr accessedAddrs) + return accessed + +-- | returns a wrapped boolean- if true, this slot has been touched before in the txn (warm gas cost as in EIP 2929) +-- otherwise cold +accessStorageForGas :: Addr -> Expr EWord -> EVM Bool +accessStorageForGas addr key = do + accessedStrkeys <- use (tx . substate . accessedStorageKeys) + case maybeLitWord key of + Just litword -> do + let accessed = member (addr, litword) accessedStrkeys + assign (tx . substate . accessedStorageKeys) (insert (addr, litword) accessedStrkeys) + return accessed + _ -> return False + +-- * Cheat codes + +-- The cheat code is 7109709ecfa91a80626ff3989d68f67f5b1dd12d. +-- Call this address using one of the cheatActions below to do +-- special things, e.g. changing the block timestamp. Beware that +-- these are necessarily hevm specific. +cheatCode :: Addr +cheatCode = num (keccak' "hevm cheat code") + +cheat + :: (?op :: Word8) + => (W256, W256) -> (W256, W256) + -> EVM () +cheat (inOffset, inSize) (outOffset, outSize) = do + mem <- use (state . memory) + vm <- get + let + abi = readBytes 4 (Lit inOffset) mem + input = readMemory (Lit $ inOffset + 4) (Lit $ inSize - 4) vm + case maybeLitWord abi of + Nothing -> vmError $ UnexpectedSymbolicArg (view (state . pc) vm) "symbolic cheatcode selector" [abi] + Just (fromIntegral -> abi') -> + case Map.lookup abi' cheatActions of + Nothing -> + vmError (BadCheatCode (Just abi')) + Just action -> do + action (Lit outOffset) (Lit outSize) input + next + push 1 + +type CheatAction = Expr EWord -> Expr EWord -> Expr Buf -> EVM () + +cheatActions :: Map Word32 CheatAction +cheatActions = + Map.fromList + [ action "ffi(string[])" $ + \sig outOffset outSize input -> do + vm <- get + if view EVM.allowFFI vm then + case decodeBuf [AbiArrayDynamicType AbiStringType] input of + CAbi valsArr -> case valsArr of + [AbiArrayDynamic AbiStringType strsV] -> + let + cmd = fmap + (\case + (AbiString a) -> unpack $ decodeUtf8 a + _ -> "") + (V.toList strsV) + cont bs = do + let encoded = ConcreteBuf bs + assign (state . returndata) encoded + copyBytesToMemory encoded outSize (Lit 0) outOffset + assign result Nothing + in assign result (Just . VMFailure . Query $ (PleaseDoFFI cmd cont)) + _ -> vmError (BadCheatCode sig) + _ -> vmError (BadCheatCode sig) + else + let msg = encodeUtf8 "ffi disabled: run again with --ffi if you want to allow tests to call external scripts" + in vmError . EVM.Revert . ConcreteBuf $ + abiMethod "Error(string)" (AbiTuple . V.fromList $ [AbiString msg]), + + action "warp(uint256)" $ + \sig _ _ input -> case decodeStaticArgs 0 1 input of + [x] -> assign (block . timestamp) x + _ -> vmError (BadCheatCode sig), + + action "roll(uint256)" $ + \sig _ _ input -> case decodeStaticArgs 0 1 input of + [x] -> forceConcrete x "cannot roll to a symbolic block number" (assign (block . number)) + _ -> vmError (BadCheatCode sig), + + action "store(address,bytes32,bytes32)" $ + \sig _ _ input -> case decodeStaticArgs 0 3 input of + [a, slot, new] -> + forceConcrete a "cannot store at a symbolic address" $ \(num -> a') -> + fetchAccount a' $ \_ -> do + modifying (env . storage) (writeStorage (litAddr a') slot new) + _ -> vmError (BadCheatCode sig), + + action "load(address,bytes32)" $ + \sig outOffset _ input -> case decodeStaticArgs 0 2 input of + [a, slot] -> + forceConcrete a "cannot load from a symbolic address" $ \(num -> a') -> + accessStorage a' slot $ \res -> do + assign (state . returndata . word256At (Lit 0)) res + assign (state . memory . word256At outOffset) res + _ -> vmError (BadCheatCode sig), + + action "sign(uint256,bytes32)" $ + \sig outOffset _ input -> case decodeStaticArgs 0 2 input of + [sk, hash] -> + forceConcrete2 (sk, hash) "cannot sign symbolic data" $ \(sk', hash') -> let + curve = getCurveByName SEC_p256k1 + priv = PrivateKey curve (num sk') + digest = digestFromByteString (word256Bytes hash') + in do + case digest of + Nothing -> vmError (BadCheatCode sig) + Just digest' -> do + let s = ethsign priv digest' + -- calculating the V value is pretty annoying if you + -- don't have access to the full X/Y coords of the + -- signature (which we don't get back from cryptonite). + -- Luckily since we use a fixed nonce (to avoid the + -- overhead of bringing randomness into the core EVM + -- semantics), it would appear that every signature we + -- produce has v == 28. Definitely a hack, and also bad + -- for code that somehow depends on the value of v, but + -- that seems acceptable for now. + v = 28 + encoded = encodeAbiValue $ + AbiTuple (RegularVector.fromList + [ AbiUInt 8 v + , AbiBytes 32 (word256Bytes . fromInteger $ sign_r s) + , AbiBytes 32 (word256Bytes . fromInteger $ sign_s s) + ]) + assign (state . returndata) (ConcreteBuf encoded) + copyBytesToMemory (ConcreteBuf encoded) (Lit . num . BS.length $ encoded) (Lit 0) outOffset + _ -> vmError (BadCheatCode sig), + + action "addr(uint256)" $ + \sig outOffset _ input -> case decodeStaticArgs 0 1 input of + [sk] -> forceConcrete sk "cannot derive address for a symbolic key" $ \sk' -> let + curve = getCurveByName SEC_p256k1 + pubPoint = generateQ curve (num sk') + encodeInt = encodeAbiValue . AbiUInt 256 . fromInteger + in do + case pubPoint of + PointO -> do vmError (BadCheatCode sig) + Point x y -> do + -- See yellow paper #286 + let + pub = BS.concat [ encodeInt x, encodeInt y ] + addr = Lit . W256 . word256 . BS.drop 12 . BS.take 32 . keccakBytes $ pub + assign (state . returndata . word256At (Lit 0)) addr + assign (state . memory . word256At outOffset) addr + _ -> vmError (BadCheatCode sig) + + ] + where + action s f = (abiKeccak s, f (Just $ abiKeccak s)) + +-- | We don't wanna introduce the machinery needed to sign with a random nonce, +-- so we just use the same nonce every time (420). This is obviusly very +-- insecure, but fine for testing purposes. +ethsign :: PrivateKey -> Digest Crypto.Keccak_256 -> Signature +ethsign sk digest = go 420 + where + go k = case signDigestWith k sk digest of + Nothing -> go (k + 1) + Just sig -> sig + +-- * General call implementation ("delegateCall") +-- note that the continuation is ignored in the precompile case +delegateCall + :: (?op :: Word8) + => Contract -> Word64 -> Expr EWord -> Expr EWord -> W256 -> W256 -> W256 -> W256 -> W256 + -> [Expr EWord] + -> (Addr -> EVM ()) + -> EVM () +delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue = + forceConcrete2 (xTo, xContext) "cannot delegateCall with symbolic target or context" $ + \((num -> xTo'), (num -> xContext')) -> + if xTo' > 0 && xTo' <= 9 + then precompiledContract this gasGiven xTo' xContext' xValue xInOffset xInSize xOutOffset xOutSize xs + else if xTo' == cheatCode then + do + assign (state . stack) xs + cheat (xInOffset, xInSize) (xOutOffset, xOutSize) + else + callChecks this gasGiven xContext' xTo' xValue xInOffset xInSize xOutOffset xOutSize xs $ + \xGas -> do + vm0 <- get + fetchAccount xTo' $ \target -> + burn xGas $ do + let newContext = CallContext + { callContextTarget = xTo' + , callContextContext = xContext' + , callContextOffset = xOutOffset + , callContextSize = xOutSize + , callContextCodehash = view codehash target + , callContextReversion = (view (env . contracts) vm0, view (env . storage) vm0) + , callContextSubState = view (tx . substate) vm0 + , callContextAbi = + if xInSize >= 4 + then case unlit $ readBytes 4 (Lit xInOffset) (view (state . memory) vm0) + of Nothing -> Nothing + Just abi -> Just $ num abi + else Nothing + , callContextData = (readMemory (Lit xInOffset) (Lit xInSize) vm0) + } + + pushTrace (FrameTrace newContext) + next + vm1 <- get + + pushTo frames $ Frame + { _frameState = (set stack xs) (view state vm1) + , _frameContext = newContext + } + + let clearInitCode = \case + (InitCode _ _) -> InitCode mempty mempty + a -> a + + zoom state $ do + assign gas (num xGas) + assign pc 0 + assign code (clearInitCode (view contractcode target)) + assign codeContract xTo' + assign stack mempty + assign memory mempty + assign memorySize 0 + assign returndata mempty + assign calldata (copySlice (Lit xInOffset) (Lit 0) (Lit xInSize) (view (state . memory) vm0) mempty) + + continue xTo' + +-- -- * Contract creation + +-- EIP 684 +collision :: Maybe Contract -> Bool +collision c' = case c' of + Just c -> (view nonce c /= 0) || case view contractcode c of + RuntimeCode b -> not $ null b + _ -> True + Nothing -> False + +create :: (?op :: Word8) + => Addr -> Contract + -> Word64 -> W256 -> [Expr EWord] -> Addr -> Expr Buf -> EVM () +create self this xGas' xValue xs newAddr initCode = do + vm0 <- get + let xGas = num xGas' + if view nonce this == num (maxBound :: Word64) + then do + assign (state . stack) (Lit 0 : xs) + assign (state . returndata) mempty + pushTrace $ ErrorTrace NonceOverflow + next + else if xValue > view balance this + then do + assign (state . stack) (Lit 0 : xs) + assign (state . returndata) mempty + pushTrace $ ErrorTrace $ BalanceTooLow xValue (view balance this) + next + else if length (view frames vm0) >= 1024 + then do + assign (state . stack) (Lit 0 : xs) + assign (state . returndata) mempty + pushTrace $ ErrorTrace CallDepthLimitReached + next + else if collision $ view (env . contracts . at newAddr) vm0 + then burn xGas $ do + assign (state . stack) (Lit 0 : xs) + assign (state . returndata) mempty + modifying (env . contracts . ix self . nonce) succ + next + else burn xGas $ do + touchAccount self + touchAccount newAddr + let + -- unfortunately we have to apply some (pretty hacky) + -- heuristics here to parse the unstructured buffer read + -- from memory into a code and data section + -- TODO: comment explaining whats going on here + let contract' = do + prefixLen <- Expr.concPrefix initCode + prefix <- Expr.toList $ Expr.take (num prefixLen) initCode + let sym = Expr.drop (num prefixLen) initCode + conc <- mapM unlitByte prefix + pure $ InitCode (BS.pack $ V.toList conc) sym + case contract' of + Nothing -> + vmError $ UnexpectedSymbolicArg (view (state . pc) vm0) "initcode must have a concrete prefix" [] + Just c -> do + let + newContract = initialContract c + newContext = + CreationContext { creationContextAddress = newAddr + , creationContextCodehash = view codehash newContract + , creationContextReversion = view (env . contracts) vm0 + , creationContextSubstate = view (tx . substate) vm0 + } + + zoom (env . contracts) $ do + oldAcc <- use (at newAddr) + let oldBal = maybe 0 (view balance) oldAcc + + assign (at newAddr) (Just (newContract & balance .~ oldBal)) + modifying (ix self . nonce) succ + + let resetStorage = \case + ConcreteStore s -> ConcreteStore (Map.delete (num newAddr) s) + AbstractStore -> AbstractStore + EmptyStore -> EmptyStore + SStore {} -> error "trying to reset symbolic storage with writes in create" + GVar _ -> error "unexpected global variable" + + modifying (env . storage) resetStorage + modifying (env . origStorage) (Map.delete (num newAddr)) + + transfer self newAddr xValue + + pushTrace (FrameTrace newContext) + next + vm1 <- get + pushTo frames $ Frame + { _frameContext = newContext + , _frameState = (set stack xs) (view state vm1) + } + + assign state $ + blankState + & set contract newAddr + & set codeContract newAddr + & set code c + & set callvalue (Lit xValue) + & set caller (litAddr self) + & set gas xGas' + +-- | Replace a contract's code, like when CREATE returns +-- from the constructor code. +replaceCode :: Addr -> ContractCode -> EVM () +replaceCode target newCode = + zoom (env . contracts . at target) $ + get >>= \case + Just now -> case (view contractcode now) of + InitCode _ _ -> + put . Just $ + initialContract newCode + & set balance (view balance now) + & set nonce (view nonce now) + RuntimeCode _ -> + error ("internal error: can't replace code of deployed contract " <> show target) + Nothing -> + error "internal error: can't replace code of nonexistent contract" + +replaceCodeOfSelf :: ContractCode -> EVM () +replaceCodeOfSelf newCode = do + vm <- get + replaceCode (view (state . contract) vm) newCode + +resetState :: EVM () +resetState = do + assign result Nothing + assign frames [] + assign state blankState + + +-- * VM error implementation + +vmError :: Error -> EVM () +vmError e = finishFrame (FrameErrored e) + +underrun :: EVM () +underrun = vmError StackUnderrun + +-- | A stack frame can be popped in three ways. +data FrameResult + = FrameReturned (Expr Buf) -- ^ STOP, RETURN, or no more code + | FrameReverted (Expr Buf) -- ^ REVERT + | FrameErrored Error -- ^ Any other error + deriving Show + +-- | This function defines how to pop the current stack frame in either of +-- the ways specified by 'FrameResult'. +-- +-- It also handles the case when the current stack frame is the only one; +-- in this case, we set the final '_result' of the VM execution. +finishFrame :: FrameResult -> EVM () +finishFrame how = do + oldVm <- get + + case view frames oldVm of + -- Is the current frame the only one? + [] -> do + case how of + FrameReturned output -> assign result . Just $ VMSuccess output + FrameReverted buffer -> assign result . Just $ VMFailure (EVM.Revert buffer) + FrameErrored e -> assign result . Just $ VMFailure e + finalize + + -- Are there some remaining frames? + nextFrame : remainingFrames -> do + + -- Insert a debug trace. + insertTrace $ + case how of + FrameErrored e -> + ErrorTrace e + FrameReverted e -> + ErrorTrace (EVM.Revert e) + FrameReturned output -> + ReturnTrace output (view frameContext nextFrame) + -- Pop to the previous level of the debug trace stack. + popTrace + + -- Pop the top frame. + assign frames remainingFrames + -- Install the state of the frame to which we shall return. + assign state (view frameState nextFrame) + + -- When entering a call, the gas allowance is counted as burned + -- in advance; this unburns the remainder and adds it to the + -- parent frame. + let remainingGas = view (state . gas) oldVm + reclaimRemainingGasAllowance = do + modifying burned (subtract remainingGas) + modifying (state . gas) (+ remainingGas) + + -- Now dispatch on whether we were creating or calling, + -- and whether we shall return, revert, or error (six cases). + case view frameContext nextFrame of + + -- Were we calling? + CallContext _ _ (Lit -> outOffset) (Lit -> outSize) _ _ _ reversion substate' -> do + + -- Excerpt K.1. from the yellow paper: + -- K.1. Deletion of an Account Despite Out-of-gas. + -- At block 2675119, in the transaction 0xcf416c536ec1a19ed1fb89e4ec7ffb3cf73aa413b3aa9b77d60e4fd81a4296ba, + -- an account at address 0x03 was called and an out-of-gas occurred during the call. + -- Against the equation (197), this added 0x03 in the set of touched addresses, and this transaction turned σ[0x03] into ∅. + + -- In other words, we special case address 0x03 and keep it in the set of touched accounts during revert + touched <- use (tx . substate . touchedAccounts) + + let + substate'' = over touchedAccounts (maybe id cons (find (3 ==) touched)) substate' + (contractsReversion, storageReversion) = reversion + revertContracts = assign (env . contracts) contractsReversion + revertStorage = assign (env . storage) storageReversion + revertSubstate = assign (tx . substate) substate'' + + case how of + -- Case 1: Returning from a call? + FrameReturned output -> do + assign (state . returndata) output + copyCallBytesToMemory output outSize (Lit 0) outOffset + reclaimRemainingGasAllowance + push 1 + + -- Case 2: Reverting during a call? + FrameReverted output -> do + revertContracts + revertStorage + revertSubstate + assign (state . returndata) output + copyCallBytesToMemory output outSize (Lit 0) outOffset + reclaimRemainingGasAllowance + push 0 + + -- Case 3: Error during a call? + FrameErrored _ -> do + revertContracts + revertStorage + revertSubstate + assign (state . returndata) mempty + push 0 + -- Or were we creating? + CreationContext _ _ reversion substate' -> do + creator <- use (state . contract) + let + createe = view (state . contract) oldVm + revertContracts = assign (env . contracts) reversion' + revertSubstate = assign (tx . substate) substate' + + -- persist the nonce through the reversion + reversion' = (Map.adjust (over nonce (+ 1)) creator) reversion + + case how of + -- Case 4: Returning during a creation? + FrameReturned output -> do + case Expr.toList output of + Nothing -> vmError $ + UnexpectedSymbolicArg + (view (state . pc) oldVm) + "runtime code cannot have an abstract length" + [output] + Just newCode -> do + replaceCode createe (RuntimeCode newCode) + assign (state . returndata) mempty + reclaimRemainingGasAllowance + push (num createe) + + -- Case 5: Reverting during a creation? + FrameReverted output -> do + revertContracts + revertSubstate + assign (state . returndata) output + reclaimRemainingGasAllowance + push 0 + + -- Case 6: Error during a creation? + FrameErrored _ -> do + revertContracts + revertSubstate + assign (state . returndata) mempty + push 0 + + +-- * Memory helpers + +accessUnboundedMemoryRange + :: FeeSchedule Word64 + -> Word64 + -> Word64 + -> EVM () + -> EVM () +accessUnboundedMemoryRange _ _ 0 continue = continue +accessUnboundedMemoryRange fees f l continue = do + m0 <- num <$> use (state . memorySize) + do + let m1 = 32 * ceilDiv (max m0 (f + l)) 32 + burn (memoryCost fees m1 - memoryCost fees m0) $ do + assign (state . memorySize) m1 + continue + +accessMemoryRange + :: FeeSchedule Word64 + -> W256 + -> W256 + -> EVM () + -> EVM () +accessMemoryRange _ _ 0 continue = continue +accessMemoryRange fees f l continue = + case (,) <$> toWord64 f <*> toWord64 l of + Nothing -> vmError IllegalOverflow + Just (f64, l64) -> + if f64 + l64 < l64 + then vmError IllegalOverflow + else accessUnboundedMemoryRange fees f64 l64 continue + +accessMemoryWord + :: FeeSchedule Word64 -> W256 -> EVM () -> EVM () +accessMemoryWord fees x = accessMemoryRange fees x 32 + +copyBytesToMemory + :: Expr Buf -> Expr EWord -> Expr EWord -> Expr EWord -> EVM () +copyBytesToMemory bs size xOffset yOffset = + if size == (Lit 0) then noop + else do + mem <- use (state . memory) + assign (state . memory) $ + copySlice xOffset yOffset size bs mem + +copyCallBytesToMemory + :: Expr Buf -> Expr EWord -> Expr EWord -> Expr EWord -> EVM () +copyCallBytesToMemory bs size xOffset yOffset = + if size == (Lit 0) then noop + else do + mem <- use (state . memory) + assign (state . memory) $ + copySlice xOffset yOffset (Expr.min size (bufLength bs)) bs mem + +readMemory :: Expr EWord -> Expr EWord -> VM -> Expr Buf +readMemory offset size vm = copySlice offset (Lit 0) size (view (state . memory) vm) mempty + +-- * Tracing + +withTraceLocation + :: (MonadState VM m) => TraceData -> m Trace +withTraceLocation x = do + vm <- get + let + Just this = + currentContract vm + pure Trace + { _traceData = x + , _traceContract = this + , _traceOpIx = fromMaybe 0 $ (view opIxMap this) Vector.!? (view (state . pc) vm) + } + +pushTrace :: TraceData -> EVM () +pushTrace x = do + trace <- withTraceLocation x + modifying traces $ + \t -> Zipper.children $ Zipper.insert (Node trace []) t + +insertTrace :: TraceData -> EVM () +insertTrace x = do + trace <- withTraceLocation x + modifying traces $ + \t -> Zipper.nextSpace $ Zipper.insert (Node trace []) t + +popTrace :: EVM () +popTrace = + modifying traces $ + \t -> case Zipper.parent t of + Nothing -> error "internal error (trace root)" + Just t' -> Zipper.nextSpace t' + +zipperRootForest :: Zipper.TreePos Zipper.Empty a -> Forest a +zipperRootForest z = + case Zipper.parent z of + Nothing -> Zipper.toForest z + Just z' -> zipperRootForest (Zipper.nextSpace z') + +traceForest :: VM -> Forest Trace +traceForest = view (traces . to zipperRootForest) + +traceTopLog :: (MonadState VM m) => [Expr Log] -> m () +traceTopLog [] = noop +traceTopLog ((LogEntry addr bytes topics) : _) = do + trace <- withTraceLocation (EventTrace addr bytes topics) + modifying traces $ + \t -> Zipper.nextSpace (Zipper.insert (Node trace []) t) +traceTopLog ((GVar _) : _) = error "unexpected global variable" + +-- * Stack manipulation + +push :: W256 -> EVM () +push = pushSym . Lit + +pushSym :: Expr EWord -> EVM () +pushSym x = state . stack %= (x :) + + +stackOp1 + :: (?op :: Word8) + => ((Expr EWord) -> Word64) + -> ((Expr EWord) -> (Expr EWord)) + -> 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) + => (((Expr EWord), (Expr EWord)) -> Word64) + -> (((Expr EWord), (Expr EWord)) -> (Expr EWord)) + -> 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) + => (((Expr EWord), (Expr EWord), (Expr EWord)) -> Word64) + -> (((Expr EWord), (Expr EWord), (Expr EWord)) -> (Expr EWord)) + -> 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 -> [Expr EWord] -> EVM () +checkJump x xs = do + theCode <- use (state . code) + self <- use (state . codeContract) + theCodeOps <- use (env . contracts . ix self . codeOps) + theOpIxMap <- use (env . contracts . ix self . opIxMap) + let ops = case theCode of + InitCode ops' _ -> V.fromList $ LitByte <$> BS.unpack ops' + RuntimeCode ops' -> ops' + op = do + -- TODO: not a big fan of how bounds are checked, change this + b <- if x < num (length ops) then ops V.!? num x else Nothing + unlitByte b + case op of + Nothing -> vmError EVM.BadJumpDestination + Just b -> + if 0x5b == b && OpJumpdest == snd (theCodeOps RegularVector.! (theOpIxMap Vector.! num x)) + then do + state . stack .= xs + state . pc .= num x + else + vmError EVM.BadJumpDestination + +opSize :: Word8 -> Int +opSize x | x >= 0x60 && x <= 0x7f = num x - 0x60 + 2 +opSize _ = 1 + +-- i of the resulting vector contains the operation index for +-- the program counter value i. This is needed because source map +-- entries are per operation, not per byte. +mkOpIxMap :: ContractCode -> Vector Int +mkOpIxMap (InitCode conc _) + = Vector.create $ Vector.new (BS.length conc) >>= \v -> + -- Loop over the byte string accumulating a vector-mutating action. + -- This is somewhat obfuscated, but should be fast. + let (_, _, _, m) = BS.foldl' (go v) (0 :: Word8, 0, 0, return ()) conc + in m >> return v + where + -- concrete case + go v (0, !i, !j, !m) x | x >= 0x60 && x <= 0x7f = + {- Start of PUSH op. -} (x - 0x60 + 1, i + 1, j, m >> 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) + +mkOpIxMap (RuntimeCode ops) + = Vector.create $ Vector.new (length ops) >>= \v -> + let (_, _, _, m) = foldl (go v) (0, 0, 0, return ()) (stripBytecodeMetadataSym $ V.toList ops) + in m >> return v + where + go v (0, !i, !j, !m) x = case unlitByte x of + Just x' -> if x' >= 0x60 && x' <= 0x7f + -- start of PUSH op -- + then (x' - 0x60 + 1, i + 1, j, m >> Vector.write v i j) + -- other data -- + else (0, i + 1, j + 1, m >> Vector.write v i j) + _ -> error $ "cannot analyze symbolic code:\nx: " <> show x <> " i: " <> show i <> " j: " <> show j + + go v (1, !i, !j, !m) _ = + {- End of PUSH op. -} (0, i + 1, j + 1, m >> 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 + code' = vm ^. state . code + (op, pushdata) = case code' of + InitCode xs' _ -> + (BS.index xs' i, fmap LitByte $ BS.unpack $ BS.drop i xs') + RuntimeCode xs' -> + ( fromMaybe (error "unexpected symbolic code") . unlitByte $ xs' V.! i , V.toList $ V.drop i xs') + in if (opslen code' < i) + then Nothing + else Just (readOp op pushdata) + +vmOpIx :: VM -> Maybe Int +vmOpIx vm = + do self <- currentContract vm + (view opIxMap self) Vector.!? (view (state . pc) vm) + +opParams :: VM -> Map String (Expr EWord) +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 + +-- | Reads +readOp :: Word8 -> [Expr Byte] -> 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 = num $ x - 0x60 + 1 + in OpPush (readBytes n (Lit 0) (Expr.fromList $ V.fromList xs)) +readOp x _ = case x of + 0x00 -> OpStop + 0x01 -> OpAdd + 0x02 -> OpMul + 0x03 -> OpSub + 0x04 -> OpDiv + 0x05 -> OpSdiv + 0x06 -> OpMod + 0x07 -> OpSmod + 0x08 -> OpAddmod + 0x09 -> OpMulmod + 0x0a -> OpExp + 0x0b -> OpSignextend + 0x10 -> OpLt + 0x11 -> OpGt + 0x12 -> OpSlt + 0x13 -> OpSgt + 0x14 -> OpEq + 0x15 -> OpIszero + 0x16 -> OpAnd + 0x17 -> OpOr + 0x18 -> OpXor + 0x19 -> OpNot + 0x1a -> OpByte + 0x1b -> OpShl + 0x1c -> OpShr + 0x1d -> OpSar + 0x20 -> OpSha3 + 0x30 -> OpAddress + 0x31 -> OpBalance + 0x32 -> OpOrigin + 0x33 -> OpCaller + 0x34 -> OpCallvalue + 0x35 -> OpCalldataload + 0x36 -> OpCalldatasize + 0x37 -> OpCalldatacopy + 0x38 -> OpCodesize + 0x39 -> OpCodecopy + 0x3a -> OpGasprice + 0x3b -> OpExtcodesize + 0x3c -> OpExtcodecopy + 0x3d -> OpReturndatasize + 0x3e -> OpReturndatacopy + 0x3f -> OpExtcodehash + 0x40 -> OpBlockhash + 0x41 -> OpCoinbase + 0x42 -> OpTimestamp + 0x43 -> OpNumber + 0x44 -> OpPrevRandao + 0x45 -> OpGaslimit + 0x46 -> OpChainid + 0x47 -> OpSelfbalance + 0x50 -> OpPop + 0x51 -> OpMload + 0x52 -> OpMstore + 0x53 -> OpMstore8 + 0x54 -> OpSload + 0x55 -> OpSstore + 0x56 -> OpJump + 0x57 -> OpJumpi + 0x58 -> OpPc + 0x59 -> OpMsize + 0x5a -> OpGas + 0x5b -> OpJumpdest + 0xf0 -> OpCreate + 0xf1 -> OpCall + 0xf2 -> OpCallcode + 0xf3 -> OpReturn + 0xf4 -> OpDelegatecall + 0xf5 -> OpCreate2 + 0xfd -> OpRevert + 0xfa -> OpStaticcall + 0xff -> OpSelfdestruct + _ -> OpUnknown x + +-- Maps operation indicies into a pair of (bytecode index, operation) +mkCodeOps :: ContractCode -> RegularVector.Vector (Int, Op) +mkCodeOps (InitCode 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 (fmap LitByte $ BS.unpack xs')) Seq.<| go (i + j) (BS.drop j xs) +mkCodeOps (RuntimeCode ops) = RegularVector.fromList . toList $ go' 0 (stripBytecodeMetadataSym $ V.toList ops) + where + go' !i !xs = + case uncons xs of + Nothing -> + mempty + Just (x, xs') -> + let x' = fromMaybe (error "unexpected symbolic code argument") $ unlitByte x + j = opSize x' + in (i, readOp x' xs') Seq.<| go' (i + j) (drop j xs) + +-- * Gas cost calculation helpers + +-- Gas cost function for CALL, transliterated from the Yellow Paper. +costOfCall + :: FeeSchedule Word64 + -> Bool -> W256 -> Word64 -> Word64 -> Addr + -> EVM (Word64, Word64) +costOfCall (FeeSchedule {..}) recipientExists xValue availableGas xGas target = do + acc <- accessAccountForGas target + let call_base_gas = if acc then g_warm_storage_read else g_cold_account_access + c_new = if not recipientExists && xValue /= 0 + then g_newaccount + else 0 + c_xfer = if xValue /= 0 then num g_callvalue else 0 + c_extra = call_base_gas + c_xfer + c_new + c_gascap = if availableGas >= c_extra + then min xGas (allButOne64th (availableGas - c_extra)) + else xGas + c_callgas = if xValue /= 0 then c_gascap + g_callstipend else c_gascap + return (c_gascap + c_extra, c_callgas) + +-- Gas cost of create, including hash cost if needed +costOfCreate + :: FeeSchedule Word64 + -> Word64 -> W256 -> (Word64, Word64) +costOfCreate (FeeSchedule {..}) availableGas hashSize = + (createCost + initGas, initGas) + where + createCost = g_create + hashCost + hashCost = g_sha3word * ceilDiv (num hashSize) 32 + initGas = allButOne64th (availableGas - createCost) + +concreteModexpGasFee :: ByteString -> Word64 +concreteModexpGasFee input = + if lenb < num (maxBound :: Word32) && + (lene < num (maxBound :: Word32) || (lenb == 0 && lenm == 0)) && + lenm < num (maxBound :: Word64) + then + max 200 ((multiplicationComplexity * iterCount) `div` 3) + else + maxBound -- TODO: this is not 100% correct, return Nothing on overflow + where (lenb, lene, lenm) = parseModexpLength input + ez = isZero (96 + lenb) lene input + e' = word $ LS.toStrict $ + lazySlice (96 + lenb) (min 32 lene) input + nwords :: Word64 + nwords = ceilDiv (num $ max lenb lenm) 8 + multiplicationComplexity = nwords * nwords + iterCount' :: Word64 + iterCount' | lene <= 32 && ez = 0 + | lene <= 32 = num (log2 e') + | e' == 0 = 8 * (num lene - 32) + | otherwise = num (log2 e') + 8 * (num lene - 32) + iterCount = max iterCount' 1 + +-- Gas cost of precompiles +costOfPrecompile :: FeeSchedule Word64 -> Addr -> Expr Buf -> Word64 +costOfPrecompile (FeeSchedule {..}) precompileAddr input = + let errorDynamicSize = error "precompile input cannot have a dynamic size" + inputLen = case input of + ConcreteBuf bs -> fromIntegral $ BS.length bs + AbstractBuf _ -> errorDynamicSize + buf -> case bufLength buf of + Lit l -> num l -- TODO: overflow + _ -> errorDynamicSize + in case precompileAddr of + -- ECRECOVER + 0x1 -> 3000 + -- SHA2-256 + 0x2 -> num $ (((inputLen + 31) `div` 32) * 12) + 60 + -- RIPEMD-160 + 0x3 -> num $ (((inputLen + 31) `div` 32) * 120) + 600 + -- IDENTITY + 0x4 -> num $ (((inputLen + 31) `div` 32) * 3) + 15 + -- MODEXP + 0x5 -> case input of + ConcreteBuf i -> concreteModexpGasFee i + _ -> error "Unsupported symbolic modexp gas calc " + -- ECADD + 0x6 -> g_ecadd + -- ECMUL + 0x7 -> g_ecmul + -- ECPAIRING + 0x8 -> (inputLen `div` 192) * g_pairing_point + g_pairing_base + -- BLAKE2 + 0x9 -> case input of + ConcreteBuf i -> g_fround * (num $ asInteger $ lazySlice 0 4 i) + _ -> error "Unsupported symbolic blake2 gas calc" + _ -> error ("unimplemented precompiled contract " ++ show precompileAddr) + +-- Gas cost of memory expansion +memoryCost :: FeeSchedule Word64 -> Word64 -> Word64 +memoryCost FeeSchedule{..} byteCount = + let + wordCount = ceilDiv byteCount 32 + linearCost = g_memory * wordCount + quadraticCost = div (wordCount * wordCount) 512 + in + linearCost + quadraticCost + +-- * 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 + +hashcode :: ContractCode -> Expr EWord +hashcode (InitCode ops args) = keccak $ (ConcreteBuf ops) <> args +hashcode (RuntimeCode ops) = keccak . Expr.fromList $ ops + +-- | The length of the code ignoring any constructor args. +-- This represents the region that can contain executable opcodes +opslen :: ContractCode -> Int +opslen (InitCode ops _) = BS.length ops +opslen (RuntimeCode ops) = length ops + +-- | The length of the code including any constructor args. +-- This can return an abstract value +codelen :: ContractCode -> Expr EWord +codelen c@(InitCode {}) = bufLength $ toBuf c +codelen (RuntimeCode ops) = Lit . num $ length ops + +toBuf :: ContractCode -> Expr Buf +toBuf (InitCode ops args) = ConcreteBuf ops <> args +toBuf (RuntimeCode ops) = Expr.fromList ops + + +codeloc :: EVM CodeLocation +codeloc = do + vm <- get + let self = view (state . contract) vm + loc = view (state . pc) vm + pure (self, loc) + +toWord64 :: W256 -> Maybe Word64 +toWord64 n = + if n <= num (maxBound :: Word64) + then let (W256 (Word256 _ (Word128 _ n'))) = n in Just n' + else Nothing -- * Emacs setup diff --git a/src/EVM/ABI.hs b/src/EVM/ABI.hs --- a/src/EVM/ABI.hs +++ b/src/EVM/ABI.hs @@ -32,7 +32,7 @@ ( AbiValue (..) , AbiType (..) , AbiKind (..) - , AbiVals (..) + , AbiVals(..) , abiKind , Event (..) , SolError (..) @@ -48,8 +48,8 @@ , emptyAbi , encodeAbiValue , decodeAbiValue + , decodeBuf , decodeStaticArgs - , decodeBuffer , formatString , parseTypeName , makeAbiValue @@ -58,6 +58,7 @@ ) where import EVM.Types +import EVM.Expr (readWord, isLitWord) import Control.Monad (replicateM, replicateM_, forM_, void) import Data.Binary.Get (Get, runGet, runGetOrFail, label, getWord8, getWord32be, skip) @@ -72,7 +73,7 @@ import Data.Vector (Vector, toList) import Data.Word (Word32) import Data.List (intercalate) -import Data.SBV (fromBytes) +import Data.Maybe (mapMaybe) import GHC.Generics import Test.QuickCheck hiding ((.&.), label) @@ -432,7 +433,7 @@ genUInt n = AbiUInt n <$> arbitraryIntegralWithMax (2^n-1) instance Arbitrary AbiType where - arbitrary = oneof $ -- doesn't create any tuples + arbitrary = oneof [ (AbiUIntType . (* 8)) <$> choose (1, 32) , (AbiIntType . (* 8)) <$> choose (1, 32) , pure AbiAddressType @@ -472,7 +473,7 @@ -- Bool synonym with custom read instance -- to be able to parse lower case 'false' and 'true' -data Boolz = Boolz Bool +newtype Boolz = Boolz Bool instance Read Boolz where readsPrec _ ('T':'r':'u':'e':x) = [(Boolz True, x)] @@ -522,35 +523,40 @@ bytesP :: ReadP ByteStringS bytesP = do - string "0x" + _ <- string "0x" hex <- munch isHexDigit case BS16.decode (encodeUtf8 (Text.pack hex)) of Right d -> pure $ ByteStringS d - Left d -> pfail + Left _ -> pfail -data AbiVals = NoVals | CAbi [AbiValue] | SAbi [SymWord] +data AbiVals = NoVals | CAbi [AbiValue] | SAbi [Expr EWord] deriving (Show) -decodeBuffer :: [AbiType] -> Buffer -> AbiVals -decodeBuffer tps (ConcreteBuffer b) +decodeBuf :: [AbiType] -> Expr Buf -> AbiVals +decodeBuf tps (ConcreteBuf b) = case runGetOrFail (getAbiSeq (length tps) tps) (BSLazy.fromStrict b) of - Right ("", _, args) -> CAbi . toList $ args + Right ("", _, args) -> CAbi (toList args) _ -> NoVals -decodeBuffer tps b@(SymbolicBuffer _) +decodeBuf tps buf = if containsDynamic tps then NoVals - else SAbi . decodeStaticArgs $ b + else let + vs = decodeStaticArgs 0 (length tps) buf + allLit = Prelude.and . (fmap isLitWord) $ vs + asBS = mconcat $ fmap word256Bytes (mapMaybe maybeLitWord vs) + in if not allLit + then SAbi vs + else case runGetOrFail (getAbiSeq (length tps) tps) (BSLazy.fromStrict asBS) of + Right ("", _, args) -> CAbi (toList args) + _ -> NoVals + where isDynamic t = abiKind t == Dynamic containsDynamic = or . fmap isDynamic -decodeStaticArgs :: Buffer -> [SymWord] -decodeStaticArgs buffer = let - bs = case buffer of - ConcreteBuffer b -> litBytes b - SymbolicBuffer b -> b - in fmap (\i -> S (FromBytes buffer) $ - fromBytes $ take 32 (drop (i*32) bs)) [0..((length bs) `div` 32 - 1)] +decodeStaticArgs :: Int -> Int -> Expr Buf -> [Expr EWord] +decodeStaticArgs offset numArgs b = [readWord (Lit . num $ i) b | i <- [offset,(offset+32) .. (offset + (numArgs-1)*32)]] + -- A modification of 'arbitrarySizedBoundedIntegral' quickcheck library -- which takes the maxbound explicitly rather than relying on a Bounded instance. diff --git a/src/EVM/CSE.hs b/src/EVM/CSE.hs new file mode 100644 --- /dev/null +++ b/src/EVM/CSE.hs @@ -0,0 +1,109 @@ +{-# Language DataKinds #-} + +{- | + Module: EVM.CSE + Description: Common subexpression elimination for Expr ast +-} + +module EVM.CSE (BufEnv, StoreEnv, eliminateExpr, eliminateProps) where + +import Prelude hiding (Word, LT, GT) + +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Monad.State + +import EVM.Types +import EVM.Traversals + +-- maps expressions to variable names +data BuilderState = BuilderState + { bufs :: Map (Expr Buf) Int + , stores :: Map (Expr Storage) Int + , count :: Int + } + deriving (Show) + +type BufEnv = Map Int (Expr Buf) +type StoreEnv = Map Int (Expr Storage) + +initState :: BuilderState +initState = BuilderState + { bufs = mempty + , stores = mempty + , count = 0 + } + + +go :: Expr a -> State BuilderState (Expr a) +go = \case + -- buffers + e@(WriteWord {}) -> do + s <- get + case Map.lookup e (bufs s) of + Just v -> pure $ GVar (BufVar v) + Nothing -> do + let + next = count s + bs' = Map.insert e next (bufs s) + put $ s{bufs=bs', count=next+1} + pure $ GVar (BufVar next) + e@(WriteByte {}) -> do + s <- get + case Map.lookup e (bufs s) of + Just v -> pure $ GVar (BufVar v) + Nothing -> do + let + next = count s + bs' = Map.insert e next (bufs s) + put $ s{bufs=bs', count=next+1} + pure $ GVar (BufVar next) + e@(CopySlice {}) -> do + s <- get + case Map.lookup e (bufs s) of + Just v -> pure $ GVar (BufVar v) + Nothing -> do + let + next = count s + bs' = Map.insert e next (bufs s) + put $ s{count=next+1, bufs=bs'} + pure $ GVar (BufVar next) + -- storage + e@(SStore {}) -> do + s <- get + case Map.lookup e (stores s) of + Just v -> pure $ GVar (StoreVar v) + Nothing -> do + let + next = count s + ss' = Map.insert e next (stores s) + put $ s{count=next+1, stores=ss'} + pure $ GVar (StoreVar next) + e -> pure e + +invertKeyVal :: forall a. Map a Int -> Map Int a +invertKeyVal = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList + +-- | Common subexpression elimination pass for Expr +eliminateExpr' :: Expr a -> State BuilderState (Expr a) +eliminateExpr' e = mapExprM go e + +eliminateExpr :: Expr a -> (Expr a, BufEnv, StoreEnv) +eliminateExpr e = + let (e', st) = runState (eliminateExpr' e) initState in + (e', invertKeyVal (bufs st), invertKeyVal (stores st)) + +-- | Common subexpression elimination pass for Prop +eliminateProp' :: Prop -> State BuilderState Prop +eliminateProp' prop = mapPropM go prop + +-- | Common subexpression elimination pass for list of Prop +eliminateProps' :: [Prop] -> State BuilderState [Prop] +eliminateProps' props = mapM eliminateProp' props + + +-- | Common subexpression elimination pass for list of Prop +eliminateProps :: [Prop] -> ([Prop], BufEnv, StoreEnv) +eliminateProps props = + let (props', st) = runState (eliminateProps' props) initState in + (props', invertKeyVal (bufs st), invertKeyVal (stores st)) diff --git a/src/EVM/Concrete.hs b/src/EVM/Concrete.hs --- a/src/EVM/Concrete.hs +++ b/src/EVM/Concrete.hs @@ -1,4 +1,3 @@ -{-# Language FlexibleInstances #-} {-# Language StrictData #-} module EVM.Concrete where @@ -9,7 +8,7 @@ import EVM.Types import Control.Lens ((^?), ix) -import Data.Bits (Bits (..), shiftL, shiftR) +import Data.Bits (Bits (..), shiftR) import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Data.Word (Word8) @@ -35,15 +34,12 @@ in bs' <> BS.replicate (size - BS.length bs') 0 -wordValue :: Word -> W256 -wordValue (C _ x) = x - sliceMemory :: (Integral a, Integral b) => a -> b -> ByteString -> ByteString sliceMemory o s = byteStringSliceWithDefaultZeroes (num o) (num s) -writeMemory :: ByteString -> Word -> Word -> Word -> ByteString -> ByteString -writeMemory bs1 (C _ n) (C _ src) (C _ dst) bs0 = +writeMemory :: ByteString -> W256 -> W256 -> W256 -> ByteString -> ByteString +writeMemory bs1 n src dst bs0 = let (a, b) = BS.splitAt (num dst) bs0 a' = BS.replicate (num dst - BS.length a) 0 @@ -58,37 +54,6 @@ in a <> a' <> c <> b' -readMemoryWord :: Word -> ByteString -> Word -readMemoryWord (C _ i) m = - if i > (num $ BS.length m) then 0 else - let - go !a (-1) = a - go !a !n = go (a + shiftL (num $ readByteOrZero (num i + n) m) - (8 * (31 - n))) (n - 1) - w = go (0 :: W256) (31 :: Int) - in {-# SCC "readMemoryWord" #-} - C (Literal w) w - -readMemoryWord32 :: Word -> ByteString -> Word -readMemoryWord32 (C _ i) 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 -> ByteString -> ByteString -setMemoryWord (C _ i) (C _ x) = - writeMemory (word256Bytes x) 32 0 (num i) - -setMemoryByte :: Word -> Word8 -> ByteString -> ByteString -setMemoryByte (C _ i) x = - writeMemory (BS.singleton x) 1 0 (num i) - -keccakBlob :: ByteString -> Word -keccakBlob x = C (FromKeccak (ConcreteBuffer x)) (keccak x) - -- Copied from the standard library just to get specialization. -- We also use bit operations instead of modulo and multiply. -- (This operation was significantly slow.) @@ -105,8 +70,8 @@ | otherwise = g (x * x) ((y - 1) `shiftR` 1) (x * z) createAddress :: Addr -> W256 -> Addr -createAddress a n = num $ keccak $ rlpList [rlpAddrFull a, rlpWord256 n] +createAddress a n = num $ keccak' $ rlpList [rlpAddrFull a, rlpWord256 n] create2Address :: Addr -> W256 -> ByteString -> Addr -create2Address a s b = num $ keccak $ mconcat - [BS.singleton 0xff, word160Bytes a, word256Bytes $ num s, word256Bytes $ keccak b] +create2Address a s b = num $ keccak' $ mconcat + [BS.singleton 0xff, word160Bytes a, word256Bytes s, word256Bytes $ keccak' b] diff --git a/src/EVM/Dapp.hs b/src/EVM/Dapp.hs --- a/src/EVM/Dapp.hs +++ b/src/EVM/Dapp.hs @@ -1,5 +1,4 @@ {-# Language TemplateHaskell #-} -{-# Language OverloadedStrings #-} module EVM.Dapp where @@ -7,8 +6,7 @@ import EVM.ABI (Event, AbiType, SolError) import EVM.Debug (srcMapCodePos) import EVM.Solidity -import EVM.Types (W256, abiKeccak, keccak, Buffer(..), Addr, regexMatches) -import EVM.Concrete +import EVM.Types (W256, abiKeccak, keccak', Addr, regexMatches, unlit, unlitByte) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -18,14 +16,16 @@ import Data.Text.Encoding (encodeUtf8) import Data.Map (Map, toList, elems) import Data.List (sort) -import Data.Maybe (isJust, fromJust) +import Data.Maybe (isJust, fromJust, mapMaybe) import Data.Word (Word32) +import EVM.Concrete import Control.Arrow ((>>>)) import Control.Lens import Data.List (find) import qualified Data.Map as Map +import qualified Data.Vector as V data DappInfo = DappInfo { _dappRoot :: FilePath @@ -160,26 +160,27 @@ srcMap dapp contr opIndex = do sol <- findSrc contr dapp case view contractcode contr of - (InitCode _) -> + (InitCode _ _) -> preview (creationSrcmap . ix opIndex) sol (RuntimeCode _) -> preview (runtimeSrcmap . ix opIndex) sol findSrc :: Contract -> DappInfo -> Maybe SolcContract -findSrc c dapp = case preview (dappSolcByHash . ix (view codehash c)) dapp of - Just (_, v) -> Just v - Nothing -> lookupCode (view contractcode c) dapp +findSrc c dapp = do + hash <- unlit (view codehash c) + case preview (dappSolcByHash . ix hash) dapp of + Just (_, v) -> Just v + Nothing -> lookupCode (view contractcode c) dapp lookupCode :: ContractCode -> DappInfo -> Maybe SolcContract -lookupCode (InitCode (SymbolicBuffer _)) _ = Nothing -- TODO: srcmaps for symbolic bytecode -lookupCode (RuntimeCode (SymbolicBuffer _)) _ = Nothing -- TODO: srcmaps for symbolic bytecode -lookupCode (InitCode (ConcreteBuffer c)) a = - snd <$> preview (dappSolcByHash . ix (keccak (stripBytecodeMetadata c))) a -lookupCode (RuntimeCode (ConcreteBuffer c)) a = - case snd <$> preview (dappSolcByHash . ix (keccak (stripBytecodeMetadata c))) a of +lookupCode (InitCode c _) a = + snd <$> preview (dappSolcByHash . ix (keccak' (stripBytecodeMetadata c))) a +lookupCode (RuntimeCode c) a = let + code = BS.pack $ mapMaybe unlitByte $ V.toList c + in case snd <$> preview (dappSolcByHash . ix (keccak' (stripBytecodeMetadata code))) a of Just x -> return x - Nothing -> snd <$> find (compareCode c . fst) (view dappSolcByCode a) + Nothing -> snd <$> find (compareCode code . fst) (view dappSolcByCode a) compareCode :: ByteString -> Code -> Bool compareCode raw (Code template locs) = diff --git a/src/EVM/Debug.hs b/src/EVM/Debug.hs --- a/src/EVM/Debug.hs +++ b/src/EVM/Debug.hs @@ -1,9 +1,9 @@ module EVM.Debug where -import EVM (Contract, storage, nonce, balance, bytecode, codehash) +import EVM (Contract, nonce, balance, bytecode, codehash) import EVM.Solidity (SrcMap, srcMapFile, srcMapOffset, srcMapLength, SourceCache, sourceFiles) import EVM.Types (Addr) -import EVM.Symbolic (len) +import EVM.Expr (bufLength) import Control.Arrow (second) import Control.Lens @@ -29,11 +29,10 @@ prettyContract :: Contract -> Doc prettyContract c = object - [ (text "codesize", int (len (c ^. bytecode))) + [ (text "codesize", text . show $ (bufLength (c ^. bytecode))) , (text "codehash", text (show (c ^. codehash))) , (text "balance", int (fromIntegral (c ^. balance))) , (text "nonce", int (fromIntegral (c ^. nonce))) - , (text "storage", text (show (c ^. storage))) ] prettyContracts :: Map Addr Contract -> Doc @@ -41,66 +40,6 @@ 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 srcMapCodePos :: SourceCache -> SrcMap -> Maybe (Text, Int) srcMapCodePos cache sm = diff --git a/src/EVM/Dev.hs b/src/EVM/Dev.hs --- a/src/EVM/Dev.hs +++ b/src/EVM/Dev.hs @@ -1,263 +1,497 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# Language DataKinds #-} +{-# Language QuasiQuotes #-} + +{- | +Module: EVM.Dev +Description: Helpers for repl driven hevm hacking +-} module EVM.Dev where +import Data.ByteString hiding (putStrLn, writeFile, zip) +import Control.Monad.State.Strict hiding (state) +import Data.Maybe (fromJust) import System.Directory +import Data.Typeable -import Prelude hiding (Word) +import Data.String.Here +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy.IO as TL +import EVM +import EVM.SMT import EVM.Types -import EVM.Dapp +import EVM.Expr (numBranches, simplify) +import EVM.SymExec import EVM.Solidity import EVM.UnitTest -import EVM.Symbolic +import EVM.Format (formatExpr) +import EVM.Dapp (dappInfo) +import GHC.Conc +import System.Exit (exitFailure) +import qualified EVM.Fetch as Fetch +import qualified EVM.FeeSchedule as FeeSchedule +import qualified Data.Vector as V -import EVM hiding (path) -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 qualified EVM.Stepper -import qualified EVM.VMTest as VMTest +checkEquiv :: (Typeable a) => Expr a -> Expr a -> IO () +checkEquiv a b = withSolvers Z3 1 Nothing $ \s -> do + let smt = assertProps [a ./= b] + res <- checkSat s smt + print res -import Data.SBV hiding (Word) -import qualified Data.Aeson as JSON -import Options.Generic -import Data.SBV.Trans.Control -import Data.Maybe (fromMaybe) -import Control.Monad.State.Strict (execStateT) +runDappTest :: FilePath -> IO () +runDappTest root = + withCurrentDirectory root $ do + cores <- num <$> getNumProcessors + let testFile = root <> "/out/dapp.sol.json" + withSolvers Z3 cores Nothing $ \solvers -> do + opts <- testOpts solvers root testFile + res <- dappTest opts testFile Nothing + unless res exitFailure -import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as LazyByteString -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy.Char8 as B -import qualified Control.Monad.State.Class as State -import Control.Monad.State.Strict (runState, liftIO, StateT, get) -import Control.Lens hiding (op, passing) -import Control.Monad.Operational (ProgramViewT(..), ProgramView) -import qualified Control.Monad.Operational as Operational +testOpts :: SolverGroup -> FilePath -> FilePath -> IO UnitTestOptions +testOpts solvers root testFile = do + srcInfo <- readSolc testFile >>= \case + Nothing -> error "Could not read .sol.json file" + Just (contractMap, sourceCache) -> + pure $ dappInfo root contractMap sourceCache -loadDappInfo :: String -> String -> IO DappInfo -loadDappInfo path file = - withCurrentDirectory path $ - readSolc file >>= - \case - Just (contractMap, sourcecache) -> - pure (dappInfo "." contractMap sourcecache) - _ -> - error "nope, sorry" + params <- getParametersFromEnvironmentVariables Nothing + pure EVM.UnitTest.UnitTestOptions + { EVM.UnitTest.solvers = solvers + , EVM.UnitTest.rpcInfo = Nothing + , EVM.UnitTest.maxIter = Nothing + , EVM.UnitTest.askSmtIters = Nothing + , EVM.UnitTest.smtTimeout = Nothing + , EVM.UnitTest.smtDebug = False + , EVM.UnitTest.solver = Nothing + , EVM.UnitTest.covMatch = Nothing + , EVM.UnitTest.verbose = Nothing + , EVM.UnitTest.match = ".*" + , EVM.UnitTest.maxDepth = Nothing + , EVM.UnitTest.fuzzRuns = 100 + , EVM.UnitTest.replay = Nothing + , EVM.UnitTest.vmModifier = id + , EVM.UnitTest.testParams = params + , EVM.UnitTest.dapp = srcInfo + , EVM.UnitTest.ffiAllowed = True + } -ghciTest :: String -> String -> Maybe String -> IO [Bool] -ghciTest root path statePath = - withCurrentDirectory root $ do - loadFacts <- - case statePath of - Nothing -> - pure id - Just repoPath -> do - facts <- Git.loadFacts (Git.RepoAt repoPath) - pure (flip Facts.apply facts) - params <- getParametersFromEnvironmentVariables Nothing - dapp <- loadDappInfo root path - let - opts = UnitTestOptions - { oracle = EVM.Fetch.zero - , verbose = Nothing - , maxIter = Nothing - , askSmtIters = Nothing - , smtTimeout = Nothing - , smtState = Nothing - , solver = Nothing - , match = "" - , covMatch = Nothing - , fuzzRuns = 100 - , replay = Nothing - , vmModifier = loadFacts - , dapp = dapp - , testParams = params - , maxDepth = Nothing - , ffiAllowed = False - } - readSolc path >>= - \case - Just (contractMap, _) -> do - let unitTests = findAllUnitTests (Map.elems contractMap) - results <- runSMT $ query $ concatMapM (runUnitTestContract opts contractMap) unitTests - let (passing, _) = unzip results - pure passing +doTest :: IO () +doTest = do + c <- testContract + reachable' False c + --e <- simplify <$> buildExpr c + --Prelude.putStrLn (formatExpr e) - Nothing -> - error ("Failed to read Solidity JSON for `" ++ path ++ "'") +analyzeDai :: IO () +analyzeDai = do + d <- dai + reachable' False d -runBCTest :: (String, VMTest.Case) -> IO Bool -runBCTest (name, x) = do - let vm0 = VMTest.vmForCase x - putStr (name ++ " ") - out <- - execStateT (EVM.Stepper.interpret EVM.Fetch.zero EVM.Stepper.execFully) vm0 - ok <- VMTest.checkExpectation False x out - putStrLn (if ok then "ok" else "") - return ok +daiExpr :: IO (Expr End) +daiExpr = do + d <- dai + withSolvers Z3 1 Nothing $ \s -> buildExpr s d -ghciBCTest :: String -> IO () -ghciBCTest file = do - let parser = VMTest.parseBCSuite - parsed <- parser <$> LazyByteString.readFile file - case parsed of - Left "No cases to check." -> putStrLn "no-cases ok" - Left err -> print err - Right allTests -> - mapM_ runBCTest (Map.toList allTests) +analyzeVat :: IO () +analyzeVat = do + putStrLn "starting" + v <- vat + withSolvers Z3 1 Nothing $ \s -> do + e <- buildExpr s v + putStrLn $ "done (" <> show (numBranches e) <> " branches)" + reachable' False v -ghciTty :: String -> String -> Maybe String -> IO () -ghciTty root path statePath = - withCurrentDirectory root $ do - loadFacts <- - case statePath of - Nothing -> - pure id - Just repoPath -> do - facts <- Git.loadFacts (Git.RepoAt repoPath) - pure (flip Facts.apply facts) - params <- getParametersFromEnvironmentVariables Nothing - let - testOpts = UnitTestOptions - { oracle = EVM.Fetch.zero - , verbose = Nothing - , maxIter = Nothing - , askSmtIters = Nothing - , smtTimeout = Nothing - , smtState = Nothing - , solver = Nothing - , match = "" - , covMatch = Nothing - , fuzzRuns = 100 - , replay = Nothing - , vmModifier = loadFacts - , dapp = emptyDapp - , testParams = params - , maxDepth = Nothing - , ffiAllowed = False - } - EVM.TTY.main testOpts root path +analyzeDeposit :: IO () +analyzeDeposit = do + Just c <- solcRuntime "Deposit" + [i| + contract Deposit { + function deposit(uint256 deposit_count) external pure { + require(deposit_count < 2**32 - 1); + ++deposit_count; + bool found = false; + for (uint height = 0; height < 32; height++) { + if ((deposit_count & 1) == 1) { + found = true; + break; + } + deposit_count = deposit_count >> 1; + } + assert(found); + } + } + |] + withSolvers Z3 1 Nothing $ \s -> do + putStrLn "Exploring Contract" + e <- simplify <$> buildExpr s c + putStrLn "Writing AST" + T.writeFile "full.ast" (formatExpr e) -ghciEmacs :: IO () -ghciEmacs = - EVM.Emacs.main -foo :: IO () -foo = ghciEmacs +reachable' :: Bool -> ByteString -> IO () +reachable' smtdebug c = do + putStrLn "Exploring contract" + withSolvers Z3 4 Nothing $ \s -> do + full <- simplify <$> buildExpr s c + putStrLn $ "Explored contract (" <> (show $ numBranches full) <> " branches)" + --putStrLn $ formatExpr full + T.writeFile "full.ast" $ formatExpr full + putStrLn "Dumped to full.ast" + putStrLn "Checking reachability" + (qs, less) <- reachable s full + putStrLn $ "Checked reachability (" <> (show $ numBranches less) <> " reachable branches)" + T.writeFile "reachable.ast" $ formatExpr less + putStrLn "Dumped to reachable.ast" + --putStrLn $ formatExpr less + when smtdebug $ do + putStrLn "\n\nQueries\n\n" + forM_ qs $ \q -> do + putStrLn "\n\n-- Query --" + TL.putStrLn $ formatSMT2 q -data VMTrace = - VMTrace - { pc :: Int - , op :: Int - , stack :: [Word] - , memSize :: Int - , depth :: Int - , gas :: Word - } deriving (Generic, JSON.ToJSON) -data VMTraceResult = - VMTraceResult - { output :: String - , gasUsed :: Word - } deriving (Generic, JSON.ToJSON) +showExpr :: ByteString -> IO () +showExpr c = do + withSolvers Z3 1 Nothing $ \s -> do + e <- buildExpr s c + T.putStrLn $ formatExpr (simplify e) -getOp :: VM -> Word8 -getOp vm = - let i = vm ^. state . EVM.pc - code' = vm ^. state . code - xs = case code' of - ConcreteBuffer xs' -> ConcreteBuffer (BS.drop i xs') - SymbolicBuffer xs' -> SymbolicBuffer (drop i xs') - in if len xs == 0 then 0 - else case xs of - ConcreteBuffer b -> BS.index b 0 - SymbolicBuffer b -> fromSized $ fromMaybe (error "unexpected symbolic code") (unliteral (b !! 0)) +summaryStore :: IO ByteString +summaryStore = do + let src = + [i| + contract A { + uint x; + function f(uint256 y) public { + unchecked { + x += y; + x += y; + } + } + } + |] + fmap fromJust (solcRuntime "A" src) -vmtrace :: VM -> VMTrace -vmtrace vm = - 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 - memsize = the state memorySize - in VMTrace { pc = the state EVM.pc - , op = num $ getOp vm - , gas = the state EVM.gas - , memSize = memsize - -- increment to match geth format - , depth = 1 + length (view frames vm) - -- reverse to match geth format - , stack = reverse $ forceLit <$> the state EVM.stack - } +safeAdd :: IO ByteString +safeAdd = do + let src = + [i| + contract SafeAdd { + function add(uint x, uint y) public pure returns (uint z) { + require((z = x + y) >= x); + } + } + |] + fmap fromJust (solcRuntime "SafeAdd" src) -vmres :: VM -> VMTraceResult -vmres vm = - let - gasUsed' = view (tx . txgaslimit) vm - view (state . EVM.gas) vm - res = case view result vm of - Just (VMSuccess out) -> forceBuffer out - Just (VMFailure (Revert out)) -> out - _ -> mempty - in VMTraceResult - -- more oddities to comply with geth - { output = drop 2 $ show $ ByteStringS res - , gasUsed = gasUsed' - } -interpretWithTrace :: EVM.Fetch.Fetcher -> EVM.Stepper.Stepper a -> StateT VM IO a -interpretWithTrace fetcher = - eval . Operational.view +testContract :: IO ByteString +testContract = do + let src = + [i| + contract C { + uint x; + function set(uint v) public { + x = v + v; + } + } + |] + fmap fromJust (solcRuntime "C" src) + +vat :: IO ByteString +vat = do + let src = + [i| + /// vat.sol -- Dai CDP database + + // Copyright (C) 2018 Rain + // + // This program is free software: you can redistribute it and/or modify + // it under the terms of the GNU Affero General Public License as published by + // the Free Software Foundation, either version 3 of the License, or + // (at your option) any later version. + // + // This program is distributed in the hope that it will be useful, + // but WITHOUT ANY WARRANTY; without even the implied warranty of + // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + // GNU Affero General Public License for more details. + // + // You should have received a copy of the GNU Affero General Public License + // along with this program. If not, see . + + // FIXME: This contract was altered compared to the production version. + // It doesn't use LibNote anymore. + // New deployments of this contract will need to include custom events (TO DO). + + contract Vat { + // --- Auth --- + mapping (address => uint) public wards; + function rely(address usr) external auth { require(live == 1, "Vat/not-live"); wards[usr] = 1; } + function deny(address usr) external auth { require(live == 1, "Vat/not-live"); wards[usr] = 0; } + modifier auth { + require(wards[msg.sender] == 1, "Vat/not-authorized"); + _; + } + + mapping(address => mapping (address => uint)) public can; + function hope(address usr) external { can[msg.sender][usr] = 1; } + function nope(address usr) external { can[msg.sender][usr] = 0; } + function wish(address bit, address usr) internal view returns (bool) { + return either(bit == usr, can[bit][usr] == 1); + } + + // --- Data --- + struct Ilk { + uint256 Art; // Total Normalised Debt [wad] + uint256 rate; // Accumulated Rates [ray] + uint256 spot; // Price with Safety Margin [ray] + uint256 line; // Debt Ceiling [rad] + uint256 dust; // Urn Debt Floor [rad] + } + struct Urn { + uint256 ink; // Locked Collateral [wad] + uint256 art; // Normalised Debt [wad] + } + + mapping (bytes32 => Ilk) public ilks; + mapping (bytes32 => mapping (address => Urn )) public urns; + mapping (bytes32 => mapping (address => uint)) public gem; // [wad] + mapping (address => uint256) public dai; // [rad] + mapping (address => uint256) public sin; // [rad] + + uint256 public debt; // Total Dai Issued [rad] + uint256 public vice; // Total Unbacked Dai [rad] + uint256 public Line; // Total Debt Ceiling [rad] + uint256 public live; // Active Flag + + // --- Init --- + constructor() public { + wards[msg.sender] = 1; + live = 1; + } + + // --- Math --- + function _add(uint x, int y) internal pure returns (uint z) { + z = x + uint(y); + require(y >= 0 || z <= x); + require(y <= 0 || z >= x); + } + function _sub(uint x, int y) internal pure returns (uint z) { + z = x - uint(y); + require(y <= 0 || z <= x); + require(y >= 0 || z >= x); + } + function _mul(uint x, int y) internal pure returns (int z) { + z = int(x) * y; + require(int(x) >= 0); + require(y == 0 || z / y == int(x)); + } + function _add(uint x, uint y) internal pure returns (uint z) { + require((z = x + y) >= x); + } + function _sub(uint x, uint y) internal pure returns (uint z) { + require((z = x - y) <= x); + } + function _mul(uint x, uint y) internal pure returns (uint z) { + require(y == 0 || (z = x * y) / y == x); + } + + // --- Administration --- + function init(bytes32 ilk) external auth { + require(ilks[ilk].rate == 0, "Vat/ilk-already-init"); + ilks[ilk].rate = 10 ** 27; + } + function file(bytes32 what, uint data) external auth { + require(live == 1, "Vat/not-live"); + if (what == "Line") Line = data; + else revert("Vat/file-unrecognized-param"); + } + function file(bytes32 ilk, bytes32 what, uint data) external auth { + require(live == 1, "Vat/not-live"); + if (what == "spot") ilks[ilk].spot = data; + else if (what == "line") ilks[ilk].line = data; + else if (what == "dust") ilks[ilk].dust = data; + else revert("Vat/file-unrecognized-param"); + } + function cage() external auth { + live = 0; + } + + // --- Fungibility --- + function slip(bytes32 ilk, address usr, int256 wad) external auth { + gem[ilk][usr] = _add(gem[ilk][usr], wad); + } + function flux(bytes32 ilk, address src, address dst, uint256 wad) external { + require(wish(src, msg.sender), "Vat/not-allowed"); + gem[ilk][src] = _sub(gem[ilk][src], wad); + gem[ilk][dst] = _add(gem[ilk][dst], wad); + } + function move(address src, address dst, uint256 rad) external { + require(wish(src, msg.sender), "Vat/not-allowed"); + dai[src] = _sub(dai[src], rad); + dai[dst] = _add(dai[dst], rad); + } + + function either(bool x, bool y) internal pure returns (bool z) { + assembly{ z := or(x, y)} + } + function both(bool x, bool y) internal pure returns (bool z) { + assembly{ z := and(x, y)} + } + + // --- CDP Confiscation --- + function grab(bytes32 i, address u, address v, address w, int dink, int dart) external auth { + Urn storage urn = urns[i][u]; + Ilk storage ilk = ilks[i]; + + urn.ink = _add(urn.ink, dink); + urn.art = _add(urn.art, dart); + ilk.Art = _add(ilk.Art, dart); + + int dtab = _mul(ilk.rate, dart); + + gem[i][v] = _sub(gem[i][v], dink); + sin[w] = _sub(sin[w], dtab); + vice = _sub(vice, dtab); + } + } + |] + fmap fromJust (solcRuntime "Vat" src) + +initVm :: ByteString -> VM +initVm bs = vm where - eval - :: ProgramView EVM.Stepper.Action a - -> StateT VM IO a + contractCode = RuntimeCode $ V.fromList $ LitByte <$> unpack bs + c = Contract + { _contractcode = contractCode + , _balance = 0 + , _nonce = 0 + , _codehash = keccak (ConcreteBuf bs) + , _opIxMap = mkOpIxMap contractCode + , _codeOps = mkCodeOps contractCode + , _external = False + } + vm = makeVm $ VMOpts + { EVM.vmoptContract = c + , EVM.vmoptCalldata = (AbstractBuf "txdata", []) + , EVM.vmoptValue = CallValue 0 + , EVM.vmoptAddress = Addr 0xffffffffffffffff + , EVM.vmoptCaller = Lit 0 + , EVM.vmoptOrigin = Addr 0xffffffffffffffff + , EVM.vmoptGas = 0xffffffffffffffff + , EVM.vmoptGaslimit = 0xffffffffffffffff + , EVM.vmoptStorageBase = Symbolic + , EVM.vmoptBaseFee = 0 + , EVM.vmoptPriorityFee = 0 + , EVM.vmoptCoinbase = 0 + , EVM.vmoptNumber = 0 + , EVM.vmoptTimestamp = Var "timestamp" + , EVM.vmoptBlockGaslimit = 0 + , EVM.vmoptGasprice = 0 + , EVM.vmoptMaxCodeSize = 0xffffffff + , EVM.vmoptPrevRandao = 420 + , EVM.vmoptSchedule = FeeSchedule.berlin + , EVM.vmoptChainId = 1 + , EVM.vmoptCreate = False + , EVM.vmoptTxAccessList = mempty + , EVM.vmoptAllowFFI = False + } - eval (Return x) = do - vm <- get - liftIO $ B.putStrLn $ JSON.encode $ vmres vm - pure x - eval (action :>>= k) = do - vm <- get - case action of - EVM.Stepper.Run -> do - -- Have we reached the final result of this action? - use result >>= \case - Just _ -> do - -- Yes, proceed with the next action. - interpretWithTrace fetcher (k vm) - Nothing -> do - liftIO $ B.putStrLn $ JSON.encode $ vmtrace vm +-- | Builds the Expr for the given evm bytecode object +buildExpr :: SolverGroup -> ByteString -> IO (Expr End) +buildExpr solvers bs = evalStateT (interpret (Fetch.oracle solvers Nothing) Nothing Nothing runExpr) (initVm bs) - -- No, keep performing the current action - State.state (runState exec1) - interpretWithTrace fetcher (EVM.Stepper.run >>= k) +dai :: IO ByteString +dai = do + let src = + [i| + contract Dai { + // --- Auth --- + mapping (address => uint) public wards; + function rely(address guy) external auth { wards[guy] = 1; } + function deny(address guy) external auth { wards[guy] = 0; } + modifier auth { + require(wards[msg.sender] == 1, "Dai/not-authorized"); + _; + } - -- Stepper wants to keep executing? - EVM.Stepper.Exec -> do - -- Have we reached the final result of this action? - use result >>= \case - Just r -> do - -- Yes, proceed with the next action. - interpretWithTrace fetcher (k r) - Nothing -> do - liftIO $ B.putStrLn $ JSON.encode $ vmtrace vm + // --- ERC20 Data --- + string public constant name = "Dai Stablecoin"; + string public constant symbol = "DAI"; + string public constant version = "1"; + uint8 public constant decimals = 18; + uint256 public totalSupply; - -- No, keep performing the current action - State.state (runState exec1) - interpretWithTrace fetcher (EVM.Stepper.exec >>= k) - EVM.Stepper.Wait q -> - do m <- liftIO (fetcher q) - State.state (runState m) >> interpretWithTrace fetcher (k ()) - EVM.Stepper.Ask _ -> - error "cannot make choices with this interpretWithTraceer" - EVM.Stepper.IOAct m -> - m >>= interpretWithTrace fetcher . k - EVM.Stepper.EVM m -> do - r <- State.state (runState m) - interpretWithTrace fetcher (k r) + mapping (address => uint) public balanceOf; + mapping (address => mapping (address => uint)) public allowance; + + event Approval(address indexed src, address indexed guy, uint wad); + event Transfer(address indexed src, address indexed dst, uint wad); + + // --- Math --- + function add(uint x, uint y) internal pure returns (uint z) { + require((z = x + y) >= x); + } + function sub(uint x, uint y) internal pure returns (uint z) { + require((z = x - y) <= x); + } + + // --- EIP712 niceties --- + constructor() public { + wards[msg.sender] = 1; + } + + // --- Token --- + function transfer(address dst, uint wad) external returns (bool) { + return transferFrom(msg.sender, dst, wad); + } + function transferFrom(address src, address dst, uint wad) + public returns (bool) + { + require(balanceOf[src] >= wad, "Dai/insufficient-balance"); + if (src != msg.sender && allowance[src][msg.sender] != type(uint).max) { + require(allowance[src][msg.sender] >= wad, "Dai/insufficient-allowance"); + allowance[src][msg.sender] = sub(allowance[src][msg.sender], wad); + } + balanceOf[src] = sub(balanceOf[src], wad); + balanceOf[dst] = add(balanceOf[dst], wad); + emit Transfer(src, dst, wad); + return true; + } + function mint(address usr, uint wad) external auth { + balanceOf[usr] = add(balanceOf[usr], wad); + totalSupply = add(totalSupply, wad); + emit Transfer(address(0), usr, wad); + } + function burn(address usr, uint wad) external { + require(balanceOf[usr] >= wad, "Dai/insufficient-balance"); + if (usr != msg.sender && allowance[usr][msg.sender] != type(uint).max) { + require(allowance[usr][msg.sender] >= wad, "Dai/insufficient-allowance"); + allowance[usr][msg.sender] = sub(allowance[usr][msg.sender], wad); + } + balanceOf[usr] = sub(balanceOf[usr], wad); + totalSupply = sub(totalSupply, wad); + emit Transfer(usr, address(0), wad); + } + function approve(address usr, uint wad) external returns (bool) { + allowance[msg.sender][usr] = wad; + emit Approval(msg.sender, usr, wad); + return true; + } + + // --- Alias --- + function push(address usr, uint wad) external { + transferFrom(msg.sender, usr, wad); + } + function pull(address usr, uint wad) external { + transferFrom(usr, msg.sender, wad); + } + function move(address src, address dst, uint wad) external { + transferFrom(src, dst, wad); + } + } + |] + fmap fromJust (solcRuntime "Dai" src) diff --git a/src/EVM/Emacs.hs b/src/EVM/Emacs.hs deleted file mode 100644 --- a/src/EVM/Emacs.hs +++ /dev/null @@ -1,555 +0,0 @@ -{-# Language ImplicitParams #-} -{-# Language TemplateHaskell #-} -{-# Language DataKinds #-} -{-# 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.Set (Set) -import Data.Text (Text, pack, unpack) -import Data.SBV hiding (Word, output) -import EVM -import EVM.ABI -import EVM.Symbolic -import EVM.Dapp -import EVM.Debug (srcMapCodePos) -import EVM.Fetch (Fetcher) -import EVM.Solidity -import EVM.Stepper (Stepper) -import EVM.TTY (currentSrcMap) -import EVM.Types -import EVM.UnitTest -import Prelude hiding (Word) -import System.Directory -import System.IO -import qualified Control.Monad.Operational as Operational -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Set as Set -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 - , _uiVmSentHashes :: Set W256 - } - -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 -> - -- Finish the continuation until the next instruction; - -- then, pause & await user. - interpret StepNone restart - - StepMany i -> - -- 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) - modify updateSentHashes - interpret mode (k r) - -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 - -updateSentHashes :: UiVmState -> UiVmState -updateSentHashes ui = - let sent = allHashes (view uiVm ui) in - ui & set uiVmSentHashes sent - -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 _) = \case - ("run-test", [WFSAtom (HSString contractPath), - WFSAtom (HSString testName)]) -> do - opts <- defaultUnitTestOptions - put (UiVm (initialStateForTest opts (contractPath, testName))) - outputVm - _ -> - output (L [A ("unrecognized-command" :: Text)]) - -handleCmd (UiVm s) = \case - ("step", [WFSAtom (HSString modeName)]) -> - case parseStepMode s modeName of - Just mode -> do - takeStep s StepNormally mode - outputVm - Nothing -> - output (L [A ("unrecognized-command" :: Text)]) - ("step", [WFSList [ WFSAtom (HSString "file-line") - , WFSAtom (HSString fileName) - , WFSAtom (HSInt (fromIntegral -> lineNumber)) - ]]) -> - case view uiVmDapp s of - Nothing -> - output (L [A ("impossible" :: Text)]) - Just dapp -> do - takeStep s StepNormally - (StepUntil (atFileLine dapp fileName lineNumber)) - outputVm - _ -> - output (L [A ("unrecognized-command" :: Text)]) - -atFileLine :: DappInfo -> Text -> Int -> VM -> Bool -atFileLine dapp wantedFileName wantedLineNumber vm = - case currentSrcMap dapp vm of - Nothing -> False - Just sm -> - let - (currentFileName, currentLineNumber) = - fromJust (srcMapCodePos (view dappSources dapp) sm) - in - currentFileName == wantedFileName && - currentLineNumber == wantedLineNumber - -codeByHash :: W256 -> VM -> Maybe Buffer -codeByHash h vm = do - let cs = view (env . contracts) vm - c <- List.find (\c -> h == (view codehash c)) (Map.elems cs) - return (view bytecode c) - -allHashes :: VM -> Set W256 -allHashes vm = let cs = view (env . contracts) vm - in Set.fromList ((view codehash) <$> Map.elems cs) - -outputVm :: Console () -outputVm = do - UiVm s <- get - let vm = view uiVm s - sendHashes = Set.difference (allHashes vm) (view uiVmSentHashes s) - sendCodes = Map.fromSet (`codeByHash` vm) sendHashes - noMap = - output $ - L [ A "step" - , L [A ("vm" :: Text), sexp (view uiVm s)] - ] - fromMaybe noMap $ do - dapp <- view uiVmDapp s - sm <- currentSrcMap dapp (view uiVm s) - let (fileName, _) = view (dappSources . sourceFiles) dapp !! srcMapFile sm - 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') -> - 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 Storage where - sexp (Symbolic _ _) = error "idk" - sexp (Concrete d) = sexp d - -instance SDisplay VM where - sexp x = - L [ L [A "result", sexp (view result x)] - , 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 . show - -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)) - --- no idea what's going on here -instance SDisplay (SWord 256) where - sexp x = A (txt (txt x)) - --- no idea what's going on here -instance SDisplay (SymWord) where - sexp x = A (txt (txt x)) - --- no idea what's going on here -instance SDisplay (SWord 8) where - sexp x = A (txt (txt x)) - --- no idea what's going on here -instance SDisplay Buffer where - sexp (SymbolicBuffer x) = sexp x - sexp (ConcreteBuffer x) = sexp x - -instance (SDisplay k, SDisplay v) => SDisplay (Map k v) where - sexp x = L [L [sexp k, sexp v] | (k, v) <- Map.toList x] - -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 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", sexpMemory (view memory x)] - ] - -instance SDisplay a => SDisplay [a] where - sexp = L . map sexp - --- this overlaps the neighbouring [a] instance -instance {-# OVERLAPPING #-} SDisplay String where - sexp x = A (txt x) - -instance SDisplay Word where - sexp (C (FromKeccak bs) x) = - L [A "hash", A (txt x), sexp bs] - sexp (C _ x) = A (quoted (txt x)) - -instance SDisplay ByteString where - sexp = A . txt . pack . show . ByteStringS - -sexpMemory :: Buffer -> SExpr Text -sexpMemory bs = - if len bs > 1024 - then L [A "large-memory", A (txt (len bs))] - else sexp bs - -defaultUnitTestOptions :: MonadIO m => m UnitTestOptions -defaultUnitTestOptions = do - params <- liftIO $ getParametersFromEnvironmentVariables Nothing - pure UnitTestOptions - { oracle = Fetch.zero - , verbose = Nothing - , maxIter = Nothing - , askSmtIters = Nothing - , smtTimeout = Nothing - , smtState = Nothing - , solver = Nothing - , match = "" - , covMatch = Nothing - , fuzzRuns = 100 - , replay = Nothing - , vmModifier = id - , dapp = emptyDapp - , testParams = params - , maxDepth = Nothing - , ffiAllowed = False - } - -initialStateForTest - :: UnitTestOptions - -> (Text, Text) - -> UiVmState -initialStateForTest opts@(UnitTestOptions {..}) (contractPath, testName) = - ui1 - where - script = do - Stepper.evm . pushTrace . EntryTrace $ - "test " <> testName <> " (" <> contractPath <> ")" - initializeUnitTest opts testContract - void (runUnitTest opts testName (AbiTuple mempty)) - ui0 = - UiVmState - { _uiVm = vm0 - , _uiVmNextStep = script - , _uiVmSolc = Just testContract - , _uiVmDapp = Nothing - , _uiVmStepCount = 0 - , _uiVmFirstState = undefined - , _uiVmFetcher = oracle - , _uiVmMessage = Nothing - , _uiVmSentHashes = Set.empty - } - Just testContract = - view (dappSolcByName . at contractPath) dapp - vm0 = - initialUnitTestVm opts testContract - ui1 = - updateUiVmState ui0 vm0 & set uiVmFirstState ui1 diff --git a/src/EVM/Exec.hs b/src/EVM/Exec.hs --- a/src/EVM/Exec.hs +++ b/src/EVM/Exec.hs @@ -2,8 +2,8 @@ import EVM import EVM.Concrete (createAddress) -import EVM.Symbolic (litAddr) import EVM.Types +import EVM.Expr (litAddr) import qualified EVM.FeeSchedule as FeeSchedule @@ -21,18 +21,19 @@ vmForEthrunCreation :: ByteString -> VM vmForEthrunCreation creationCode = (makeVm $ VMOpts - { vmoptContract = initialContract (InitCode (ConcreteBuffer creationCode)) - , vmoptCalldata = (mempty, 0) - , vmoptValue = 0 + { vmoptContract = initialContract (InitCode creationCode mempty) + , vmoptCalldata = mempty + , vmoptValue = (Lit 0) + , vmoptStorageBase = Concrete , vmoptAddress = createAddress ethrunAddress 1 , vmoptCaller = litAddr ethrunAddress , vmoptOrigin = ethrunAddress , vmoptCoinbase = 0 , vmoptNumber = 0 - , vmoptTimestamp = 0 + , vmoptTimestamp = (Lit 0) , vmoptBlockGaslimit = 0 , vmoptGasprice = 0 - , vmoptDifficulty = 0 + , vmoptPrevRandao = 42069 , vmoptGas = 0xffffffffffffffff , vmoptGaslimit = 0xffffffffffffffff , vmoptBaseFee = 0 @@ -41,7 +42,6 @@ , vmoptSchedule = FeeSchedule.berlin , vmoptChainId = 1 , vmoptCreate = False - , vmoptStorageModel = ConcreteS , vmoptTxAccessList = mempty , vmoptAllowFFI = False }) & set (env . contracts . at ethrunAddress) @@ -70,23 +70,3 @@ 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 --- )) diff --git a/src/EVM/Expr.hs b/src/EVM/Expr.hs new file mode 100644 --- /dev/null +++ b/src/EVM/Expr.hs @@ -0,0 +1,910 @@ +{-# Language DataKinds #-} +{-# Language PatternGuards #-} + +{-| + Helper functions for working with Expr instances. + All functions here will return a concrete result if given a concrete input. +-} +module EVM.Expr where + +import Prelude hiding (LT, GT) +import Data.Bits +import Data.DoubleWord (Int256, Word256(Word256), Word128(Word128)) +import Data.Int (Int32) +import Data.Word +import Data.Maybe +import Data.List + +import Control.Lens (lens) + +import EVM.Types +import EVM.Traversals +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as Map +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import Data.Vector.Storable.ByteString + + +-- ** Stack Ops ** --------------------------------------------------------------------------------- + + +op1 :: (Expr EWord -> Expr EWord) + -> (W256 -> W256) + -> Expr EWord -> Expr EWord +op1 _ concrete (Lit x) = Lit (concrete x) +op1 symbolic _ x = symbolic x + +op2 :: (Expr EWord -> Expr EWord -> Expr EWord) + -> (W256 -> W256 -> W256) + -> Expr EWord -> Expr EWord -> Expr EWord +op2 _ concrete (Lit x) (Lit y) = Lit (concrete x y) +op2 symbolic _ x y = symbolic x y + +op3 :: (Expr EWord -> Expr EWord -> Expr EWord -> Expr EWord) + -> (W256 -> W256 -> W256 -> W256) + -> Expr EWord -> Expr EWord -> Expr EWord -> Expr EWord +op3 _ concrete (Lit x) (Lit y) (Lit z) = Lit (concrete x y z) +op3 symbolic _ x y z = symbolic x y z + +-- | If a given binary op is commutative, then we always force Lits to the lhs if +-- only one argument is a Lit. This makes writing pattern matches in the +-- simplifier easier. +normArgs :: (Expr EWord -> Expr EWord -> Expr EWord) -> (W256 -> W256 -> W256) -> Expr EWord -> Expr EWord -> Expr EWord +normArgs sym conc l r = case (l, r) of + (Lit _, _) -> doOp l r + (_, Lit _) -> doOp r l + _ -> doOp l r + where + doOp = op2 sym conc + +-- Integers + +add :: Expr EWord -> Expr EWord -> Expr EWord +add = normArgs Add (+) + +sub :: Expr EWord -> Expr EWord -> Expr EWord +sub = op2 Sub (-) + +mul :: Expr EWord -> Expr EWord -> Expr EWord +mul = normArgs Mul (*) + +div :: Expr EWord -> Expr EWord -> Expr EWord +div = op2 Div (\x y -> if y == 0 then 0 else Prelude.div x y) + +sdiv :: Expr EWord -> Expr EWord -> Expr EWord +sdiv = op2 SDiv (\x y -> let sx, sy :: Int256 + sx = fromIntegral x + sy = fromIntegral y + in if y == 0 then 0 else fromIntegral (sx `quot` sy)) + +mod :: Expr EWord -> Expr EWord -> Expr EWord +mod = op2 Mod (\x y -> if y == 0 then 0 else x `Prelude.mod` y) + +smod :: Expr EWord -> Expr EWord -> Expr EWord +smod = op2 SMod (\x y -> + let sx, sy :: Int256 + sx = fromIntegral x + sy = fromIntegral y + in if y == 0 + then 0 + else fromIntegral (sx `rem` sy)) + +addmod :: Expr EWord -> Expr EWord -> Expr EWord -> Expr EWord +addmod = op3 AddMod (\x y z -> + if z == 0 + then 0 + else fromIntegral $ (to512 x + to512 y) `Prelude.mod` to512 z) + +mulmod :: Expr EWord -> Expr EWord -> Expr EWord -> Expr EWord +mulmod = op3 MulMod (\x y z -> + if z == 0 + then 0 + else fromIntegral $ (to512 x * to512 y) `Prelude.mod` to512 z) + +exp :: Expr EWord -> Expr EWord -> Expr EWord +exp = op2 Exp (^) + +sex :: Expr EWord -> Expr EWord -> Expr EWord +sex = op2 SEx (\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)) + +-- Booleans + +lt :: Expr EWord -> Expr EWord -> Expr EWord +lt = op2 LT (\x y -> if x < y then 1 else 0) + +gt :: Expr EWord -> Expr EWord -> Expr EWord +gt = op2 GT (\x y -> if x > y then 1 else 0) + +leq :: Expr EWord -> Expr EWord -> Expr EWord +leq = op2 LEq (\x y -> if x <= y then 1 else 0) + +geq :: Expr EWord -> Expr EWord -> Expr EWord +geq = op2 GEq (\x y -> if x >= y then 1 else 0) + +slt :: Expr EWord -> Expr EWord -> Expr EWord +slt = op2 SLT (\x y -> + let sx, sy :: Int256 + sx = fromIntegral x + sy = fromIntegral y + in if sx < sy then 1 else 0) + +sgt :: Expr EWord -> Expr EWord -> Expr EWord +sgt = op2 SLT (\x y -> + let sx, sy :: Int256 + sx = fromIntegral x + sy = fromIntegral y + in if sx > sy then 1 else 0) + +eq :: Expr EWord -> Expr EWord -> Expr EWord +eq = normArgs Eq (\x y -> if x == y then 1 else 0) + +iszero :: Expr EWord -> Expr EWord +iszero = op1 IsZero (\x -> if x == 0 then 1 else 0) + +-- Bits + +and :: Expr EWord -> Expr EWord -> Expr EWord +and = normArgs And (.&.) + +or :: Expr EWord -> Expr EWord -> Expr EWord +or = normArgs Or (.|.) + +xor :: Expr EWord -> Expr EWord -> Expr EWord +xor = normArgs Xor Data.Bits.xor + +not :: Expr EWord -> Expr EWord +not = op1 Not complement + +shl :: Expr EWord -> Expr EWord -> Expr EWord +shl = op2 SHL (\x y -> if x > 256 then 0 else shiftL y (fromIntegral x)) + +shr :: Expr EWord -> Expr EWord -> Expr EWord +shr = op2 + (\x y -> case (x, y) of + -- simplify function selector checks + (Lit 0xe0, ReadWord (Lit idx) buf) + -> joinBytes ( + replicate 28 (LitByte 0) <> + [ readByte (Lit idx) buf + , readByte (Lit $ idx + 1) buf + , readByte (Lit $ idx + 2) buf + , readByte (Lit $ idx + 3) buf]) + _ -> SHR x y) + (\x y -> if x > 256 then 0 else shiftR y (fromIntegral x)) + +sar :: Expr EWord -> Expr EWord -> Expr EWord +sar = op2 SAR (\x y -> + let asSigned = (fromIntegral y) :: Int256 + in fromIntegral $ shiftR asSigned (fromIntegral x)) + +-- ** Bufs ** -------------------------------------------------------------------------------------- + + +-- | Extracts the byte at a given index from a Buf. +-- +-- We do our best to return a concrete value wherever possible, but fallback to +-- an abstract expresion if nescessary. Note that a Buf is an infinite +-- structure, so reads outside of the bounds of a ConcreteBuf return 0. This is +-- inline with the semantics of calldata and memory, but not of returndata. + +-- fuly concrete reads +readByte :: Expr EWord -> Expr Buf -> Expr Byte +readByte (Lit x) (ConcreteBuf b) + = if x <= num (maxBound :: Int) && i < BS.length b + then LitByte (BS.index b i) + else LitByte 0x0 + where + i :: Int + i = case x of + (W256 (Word256 _ (Word128 _ x'))) -> num x' + +readByte i@(Lit x) (WriteByte (Lit idx) val src) + = if x == idx + then val + else readByte i src +readByte i@(Lit x) (WriteWord (Lit idx) val src) + = if idx <= x && x <= idx + 31 + then case val of + (Lit _) -> indexWord (Lit $ x - idx) val + _ -> IndexWord (Lit $ x - idx) val + else readByte i src +readByte i@(Lit x) (CopySlice (Lit srcOffset) (Lit dstOffset) (Lit size) src dst) + = if dstOffset <= x && x < (dstOffset + size) + then readByte (Lit $ x - (dstOffset - srcOffset)) src + else readByte i dst +readByte i@(Lit x) buf@(CopySlice _ (Lit dstOffset) (Lit size) _ dst) + = if x < dstOffset || x >= dstOffset + size + then readByte i dst + else ReadByte (Lit x) buf +readByte i@(Lit x) buf@(CopySlice _ (Lit dstOffset) _ _ dst) + = if x < dstOffset + then readByte i dst + else ReadByte (Lit x) buf + +-- fully abstract reads +readByte i buf = ReadByte i buf + + +-- | Reads n bytes starting from idx in buf and returns a left padded word +-- +-- If n is >= 32 this is the same as readWord +readBytes :: Int -> Expr EWord -> Expr Buf -> Expr EWord +readBytes (Prelude.min 32 -> n) idx buf + = joinBytes [readByte (add idx (Lit . num $ i)) buf | i <- [0 .. n - 1]] + +-- | Reads the word starting at idx from the given buf +readWord :: Expr EWord -> Expr Buf -> Expr EWord +readWord idx b@(WriteWord idx' val buf) + -- the word we are trying to read exactly matches a WriteWord + | idx == idx' = val + | otherwise = case (idx, idx') of + (Lit i, Lit i') -> + if i >= i' + 32 || i + 32 <= i' + -- the region we are trying to read is completely outside of the WriteWord + then readWord idx buf + -- the region we are trying to read partially overlaps the WriteWord + else readWordFromBytes idx b + -- we do not have enough information to statically determine whether or not + -- the region we want to read overlaps the WriteWord + _ -> readWordFromBytes idx b +readWord (Lit idx) b@(CopySlice (Lit srcOff) (Lit dstOff) (Lit size) src dst) + -- the region we are trying to read is enclosed in the sliced region + | idx >= dstOff && idx + 32 <= dstOff + size = readWord (Lit $ srcOff + (idx - dstOff)) src + -- the region we are trying to read is compeletely outside of the sliced reegion + | idx >= dstOff + size || idx + 32 <= dstOff = readWord (Lit idx) dst + -- the region we are trying to read partially overlaps the sliced region + | otherwise = readWordFromBytes (Lit idx) b +readWord i b = readWordFromBytes i b + +-- Attempts to read a concrete word from a buffer by reading 32 individual bytes and joining them together +-- returns an abstract ReadWord expression if a concrete word cannot be constructed +readWordFromBytes :: Expr EWord -> Expr Buf -> Expr EWord +readWordFromBytes i@(Lit idx) buf = let + bytes = [readByte (Lit i') buf | i' <- [idx .. idx + 31]] + in if Prelude.and . (fmap isLitByte) $ bytes + then Lit (bytesToW256 . mapMaybe unlitByte $ bytes) + else ReadWord i buf +readWordFromBytes idx buf = ReadWord idx buf + + +{- | Copies a slice of src into dst. + + 0 srcOffset srcOffset + size length src + ┌--------------┬------------------┬-----------------┐ + src: | | ------ sl ------ | | + └--------------┴------------------┴-----------------┘ + + 0 dstOffset dstOffset + size length dst + ┌--------┬------------------┬-----------------┐ + dst: | hd | | tl | + └--------┴------------------┴-----------------┘ +-} + +-- The maximum number of bytes we will expand as part of simplification +-- this limits the amount of memory we will use while simplifying to ~1 GB / rewrite +-- note that things can still stack up, e.g. N such rewrites could eventually eat +-- N*1GB. +maxBytes :: W256 +maxBytes = num (maxBound :: Int32) `Prelude.div` 4 + +copySlice :: Expr EWord -> Expr EWord -> Expr EWord -> Expr Buf -> Expr Buf -> Expr Buf + +-- Copies from empty buffers +copySlice _ _ (Lit 0) (ConcreteBuf "") dst = dst +copySlice a b c@(Lit size) d@(ConcreteBuf "") e@(ConcreteBuf "") + | size < maxBytes = ConcreteBuf $ BS.replicate (num size) 0 + | otherwise = CopySlice a b c d e +copySlice srcOffset dstOffset sz@(Lit size) src@(ConcreteBuf "") dst + | size < maxBytes = copySlice srcOffset dstOffset (Lit size) (ConcreteBuf $ BS.replicate (num size) 0) dst + | otherwise = CopySlice srcOffset dstOffset sz src dst + +-- Fully concrete copies +copySlice a@(Lit srcOffset) b@(Lit dstOffset) c@(Lit size) d@(ConcreteBuf src) e@(ConcreteBuf "") + | srcOffset > num (BS.length src), size < maxBytes = ConcreteBuf $ BS.replicate (num size) 0 + | srcOffset <= num (BS.length src), dstOffset < maxBytes, size < maxBytes = let + hd = BS.replicate (num dstOffset) 0 + sl = padRight (num size) $ BS.take (num size) (BS.drop (num srcOffset) src) + in ConcreteBuf $ hd <> sl + | otherwise = CopySlice a b c d e + +copySlice a@(Lit srcOffset) b@(Lit dstOffset) c@(Lit size) d@(ConcreteBuf src) e@(ConcreteBuf dst) + | dstOffset < maxBytes + , srcOffset < maxBytes + , size < maxBytes = + let hd = padRight (num dstOffset) $ BS.take (num dstOffset) dst + sl = if srcOffset > num (BS.length src) + then BS.replicate (num size) 0 + else padRight (num size) $ BS.take (num size) (BS.drop (num srcOffset) src) + tl = BS.drop (num dstOffset + num size) dst + in ConcreteBuf $ hd <> sl <> tl + | otherwise = CopySlice a b c d e + +-- copying 32 bytes can be rewritten to a WriteWord on dst (e.g. CODECOPY of args during constructors) +copySlice srcOffset dstOffset (Lit 32) src dst = writeWord dstOffset (readWord srcOffset src) dst + +-- concrete indicies & abstract src (may produce a concrete result if we are +-- copying from a concrete region of src) +copySlice s@(Lit srcOffset) d@(Lit dstOffset) sz@(Lit size) src ds@(ConcreteBuf dst) + | dstOffset < maxBytes, size < maxBytes = let + hd = padRight (num dstOffset) $ BS.take (num dstOffset) dst + sl = [readByte (Lit i) src | i <- [srcOffset .. srcOffset + (size - 1)]] + tl = BS.drop (num dstOffset + num size) dst + in if Prelude.and . (fmap isLitByte) $ sl + then ConcreteBuf $ hd <> (BS.pack . (mapMaybe unlitByte) $ sl) <> tl + else CopySlice s d sz src ds + | otherwise = CopySlice s d sz src ds + +-- abstract indicies +copySlice srcOffset dstOffset size src dst = CopySlice srcOffset dstOffset size src dst + + +writeByte :: Expr EWord -> Expr Byte -> Expr Buf -> Expr Buf +writeByte (Lit offset) (LitByte val) (ConcreteBuf "") + | offset < maxBytes + = ConcreteBuf $ BS.replicate (num offset) 0 <> BS.singleton val +writeByte o@(Lit offset) b@(LitByte byte) buf@(ConcreteBuf src) + | offset < maxBytes + = ConcreteBuf $ (padRight (num offset) $ BS.take (num offset) src) + <> BS.pack [byte] + <> BS.drop (num offset + 1) src + | otherwise = WriteByte o b buf +writeByte offset byte src = WriteByte offset byte src + + +writeWord :: Expr EWord -> Expr EWord -> Expr Buf -> Expr Buf +writeWord (Lit offset) (Lit val) (ConcreteBuf "") + | offset + 32 < maxBytes + = ConcreteBuf $ BS.replicate (num offset) 0 <> word256Bytes val +writeWord o@(Lit offset) v@(Lit val) buf@(ConcreteBuf src) + | offset + 32 < maxBytes + = ConcreteBuf $ (padRight (num offset) $ BS.take (num offset) src) + <> word256Bytes val + <> BS.drop ((num offset) + 32) src + | otherwise = WriteWord o v buf +writeWord idx val b@(WriteWord idx' val' buf) + -- if the indices match exactly then we just replace the value in the current write and return + | idx == idx' = WriteWord idx val buf + | otherwise + = case (idx, idx') of + (Lit i, Lit i') -> if i >= i' + 32 + -- if we can statically determine that the write at + -- idx doesn't overlap the write at idx', then we + -- push the write down we only consider writes where + -- i > i' to avoid infinite loops in this routine. + -- This also has the nice side effect of imposing a + -- canonical ordering on write chains, making exact + -- syntactic equalities between abstract terms more + -- likely to occur + then WriteWord idx' val' (writeWord idx val buf) + -- if we cannot statically determine freedom from + -- overlap, then we just return an abstract term + else WriteWord idx val b + -- if we cannot determine statically that the write at idx' is out of + -- bounds for idx, then we return an abstract term + _ -> WriteWord idx val b +writeWord offset val src = WriteWord offset val src + + +-- | Returns the length of a given buffer +-- +-- If there are any writes to abstract locations, or CopySlices with an +-- abstract size or dstOffset, an abstract expresion will be returned. +bufLength :: Expr Buf -> Expr EWord +bufLength buf = case go 0 buf of + Just len -> len + Nothing -> BufLength buf + where + go :: W256 -> Expr Buf -> Maybe (Expr EWord) + go l (ConcreteBuf b) = Just . Lit $ max (num . BS.length $ b) l + go l (WriteWord (Lit idx) _ b) = go (max l (idx + 32)) b + go l (WriteByte (Lit idx) _ b) = go (max l (idx + 1)) b + go l (CopySlice _ (Lit dstOffset) (Lit size) _ dst) = go (max (dstOffset + size) l) dst + go _ _ = Nothing + +-- | If a buffer has a concrete prefix, we return it's length here +concPrefix :: Expr Buf -> Maybe Integer +concPrefix (CopySlice (Lit srcOff) (Lit _) (Lit _) src (ConcreteBuf "")) = do + sz <- go 0 src + pure . num $ (num sz) - srcOff + where + go :: W256 -> Expr Buf -> Maybe Integer + -- base cases + go _ (AbstractBuf _) = Nothing + go l (ConcreteBuf b) = Just . num $ max (num . BS.length $ b) l + + -- writes to a concrete index + go l (WriteWord (Lit idx) (Lit _) b) = go (max l (idx + 32)) b + go l (WriteByte (Lit idx) (LitByte _) b) = go (max l (idx + 1)) b + go l (CopySlice _ (Lit dstOffset) (Lit size) _ dst) = go (max (dstOffset + size) l) dst + + -- writes to an abstract index are ignored + go l (WriteWord _ _ b) = go l b + go l (WriteByte _ _ b) = go l b + go _ (CopySlice _ _ _ _ _) = error "Internal Error: cannot compute a concrete prefix length for nested copySlice expressions" + go _ (GVar _) = error "Internal error: cannot calculate minLength of an open expression" +concPrefix (ConcreteBuf b) = Just (num . BS.length $ b) +concPrefix e = error $ "Internal error: cannot compute a concrete prefix length for: " <> show e + + +word256At + :: Functor f + => Expr EWord -> (Expr EWord -> f (Expr EWord)) + -> Expr Buf -> f (Expr Buf) +word256At i = lens getter setter where + getter = readWord i + setter m x = writeWord i x m + + +-- | Returns the first n bytes of buf +take :: W256 -> Expr Buf -> Expr Buf +take n = slice (Lit 0) (Lit n) + + +-- | Returns everything but the first n bytes of buf +drop :: W256 -> Expr Buf -> Expr Buf +drop n buf = slice (Lit n) (sub (bufLength buf) (Lit n)) buf + +slice :: Expr EWord -> Expr EWord -> Expr Buf -> Expr Buf +slice offset size src = copySlice offset (Lit 0) size src mempty + + +toList :: Expr Buf -> Maybe (V.Vector (Expr Byte)) +toList (AbstractBuf _) = Nothing +toList (ConcreteBuf bs) = Just $ V.fromList $ LitByte <$> BS.unpack bs +toList buf = case bufLength buf of + Lit l -> if l <= num (maxBound :: Int) + then Just $ V.generate (num l) (\i -> readByte (Lit $ num i) buf) + else error "Internal Error: overflow when converting buffer to list" + _ -> Nothing + +fromList :: V.Vector (Expr Byte) -> Expr Buf +fromList bs = case Prelude.and (fmap isLitByte bs) of + True -> ConcreteBuf . BS.pack . V.toList . V.mapMaybe unlitByte $ bs + -- we want to minimize the size of the resulting expresion, so we do two passes: + -- 1. write all concrete bytes to some base buffer + -- 2. write all symbolic writes on top of this buffer + -- this is safe because each write in the input vec is to a single byte at a distinct location + -- runs in O(2n) time, and has pretty minimal allocation & copy overhead in + -- the concrete part (a single preallocated vec, with no copies) + False -> V.ifoldl' applySymWrites (ConcreteBuf concreteBytes) bs + where + concreteBytes :: ByteString + concreteBytes = vectorToByteString $ VS.generate (V.length bs) (\idx -> + case bs V.! idx of + LitByte b -> b + _ -> 0) + + applySymWrites :: Expr Buf -> Int -> Expr Byte -> Expr Buf + applySymWrites buf _ (LitByte _) = buf + applySymWrites buf idx by = WriteByte (Lit $ num idx) by buf + +instance Semigroup (Expr Buf) where + (ConcreteBuf a) <> (ConcreteBuf b) = ConcreteBuf $ a <> b + a <> b = copySlice (Lit 0) (bufLength a) (bufLength b) b a + +instance Monoid (Expr Buf) where + mempty = ConcreteBuf "" + +-- | Removes any irrelevant writes when reading from a buffer +simplifyReads :: Expr a -> Expr a +simplifyReads = \case + ReadWord (Lit idx) b -> readWord (Lit idx) (stripWrites idx (idx + 31) b) + ReadByte (Lit idx) b -> readByte (Lit idx) (stripWrites idx idx b) + a -> a + +-- | Strips writes from the buffer that can be statically determined to be out of range +-- TODO: are the bounds here correct? I think there might be some off by one mistakes... +stripWrites :: W256 -> W256 -> Expr Buf -> Expr Buf +stripWrites bottom top = \case + AbstractBuf s -> AbstractBuf s + ConcreteBuf b -> ConcreteBuf $ BS.take (num top+1) b + WriteByte (Lit idx) v prev + -> if idx < bottom || idx > top + then stripWrites bottom top prev + else WriteByte (Lit idx) v (stripWrites bottom top prev) + -- TODO: handle partial overlaps + WriteWord (Lit idx) v prev + -> if idx + 31 < bottom || idx > top + then stripWrites bottom top prev + else WriteWord (Lit idx) v (stripWrites bottom top prev) + CopySlice (Lit srcOff) (Lit dstOff) (Lit size) src dst + -> if dstOff + size < bottom || dstOff > top + then stripWrites bottom top dst + else CopySlice (Lit srcOff) (Lit dstOff) (Lit size) + (stripWrites srcOff (srcOff + size) src) + (stripWrites bottom top dst) + WriteByte i v prev -> WriteByte i v (stripWrites bottom top prev) + WriteWord i v prev -> WriteWord i v (stripWrites bottom top prev) + CopySlice srcOff dstOff size src dst -> CopySlice srcOff dstOff size src dst + GVar _ -> error "unexpected GVar in stripWrites" + + +-- ** Storage ** ----------------------------------------------------------------------------------- + + +-- | Reads the word at the given slot from the given storage expression. +-- +-- Note that we return a Nothing instead of a 0x0 if we are reading from a +-- store that is backed by a ConcreteStore or an EmptyStore and there have been +-- no explicit writes to the requested slot. This makes implementing rpc +-- storage lookups much easier. If the store is backed by an AbstractStore we +-- always return a symbolic value. +readStorage :: Expr EWord -> Expr EWord -> Expr Storage -> Maybe (Expr EWord) +readStorage _ _ EmptyStore = Nothing +readStorage addr slot store@(ConcreteStore s) = case (addr, slot) of + (Lit a, Lit l) -> do + ctrct <- Map.lookup a s + val <- Map.lookup l ctrct + pure $ Lit val + _ -> Just $ SLoad addr slot store +readStorage addr' slot' s@AbstractStore = Just $ SLoad addr' slot' s +readStorage addr' slot' s@(SStore addr slot val prev) = + if addr == addr' + then if slot == slot' + -- if address and slot match then we return the val in this write + then Just val + else case (slot, slot') of + -- if the slots don't match and are lits, we can skip this write + (Lit _, Lit _) -> readStorage addr' slot' prev + -- if the slots don't match syntactically and are abstract then we can't skip this write + _ -> Just $ SLoad addr' slot' s + else case (addr, addr') of + -- if the the addresses don't match and are lits, we can skip this write + (Lit _, Lit _) -> readStorage addr' slot' prev + -- if the the addresses don't match syntactically and are abstract then we can't skip this write + _ -> Just $ SLoad addr' slot' s +readStorage _ _ (GVar _) = error "Can't read from a GVar" + +readStorage' :: Expr EWord -> Expr EWord -> Expr Storage -> Expr EWord +readStorage' addr loc store = case readStorage addr loc store of + Just v -> v + Nothing -> Lit 0 + + +-- | Writes a value to a key in a storage expression. +-- +-- Concrete writes on top of a concrete or empty store will produce a new +-- ConcreteStore, otherwise we add a new write to the storage expression. +writeStorage :: Expr EWord -> Expr EWord -> Expr EWord -> Expr Storage -> Expr Storage +writeStorage a@(Lit addr) k@(Lit key) v@(Lit val) store = case store of + EmptyStore -> ConcreteStore (Map.singleton addr (Map.singleton key val)) + ConcreteStore s -> let + ctrct = Map.findWithDefault Map.empty addr s + in ConcreteStore (Map.insert addr (Map.insert key val ctrct) s) + _ -> SStore a k v store +writeStorage addr key val store@(SStore addr' key' val' prev) + | addr == addr' + = if key == key' + -- if we're overwriting an existing location, then drop the write + then SStore addr key val prev + else case (addr, addr', key, key') of + -- if we can know statically that the new write doesn't overlap with the existing write, then we continue down the write chain + -- we impose an ordering relation on the writes that we push down to ensure termination when this routine is called from the simplifier + (Lit a, Lit a', Lit k, Lit k') -> if a > a' || (a == a' && k > k') + then SStore addr' key' val' (writeStorage addr key val prev) + else SStore addr key val store + -- otherwise stack a new write on top of the the existing write chain + _ -> SStore addr key val store + | otherwise + = case (addr, addr') of + -- if we can know statically that the new write doesn't overlap with the existing write, then we continue down the write chain + -- once again we impose an ordering relation on the pushed down writes to ensure termination + (Lit a, Lit a') -> if a > a' + then SStore addr' key' val' (writeStorage addr key val prev) + else SStore addr key val store + -- otherwise stack a new write on top of the the existing write chain + _ -> SStore addr key val store +writeStorage addr key val store = SStore addr key val store + + +-- ** Whole Expression Simplification ** ----------------------------------------------------------- + + +-- | Simple recursive match based AST simplification +-- Note: may not terminate! +simplify :: Expr a -> Expr a +simplify e = if (mapExpr go e == e) + then e + else simplify (mapExpr go e) + where + go :: Expr a -> Expr a + -- redundant CopySlice + go (CopySlice (Lit 0x0) (Lit 0x0) (Lit 0x0) _ dst) = dst + + -- simplify storage + go (SLoad addr slot store) = readStorage' addr slot store + go (SStore addr slot val store) = writeStorage addr slot val store + + -- simplify buffers + go o@(ReadWord (Lit _) _) = simplifyReads o + go (ReadWord idx buf) = readWord idx buf + go o@(ReadByte (Lit _) _) = simplifyReads o + go (ReadByte idx buf) = readByte idx buf + + -- We can zero out any bytes in a base ConcreteBuf that we know will be overwritten by a later write + -- TODO: make this fully general for entire write chains, not just a single write. + go o@(WriteWord (Lit idx) val (ConcreteBuf b)) + | idx < maxBytes + = (writeWord (Lit idx) val ( + ConcreteBuf $ + (BS.take (num idx) (padRight (num idx) b)) + <> (BS.replicate 32 0) + <> (BS.drop (num idx + 32) b))) + | otherwise = o + go (WriteWord a b c) = writeWord a b c + + go (WriteByte a b c) = writeByte a b c + go (CopySlice a b c d f) = copySlice a b c d f + + go (IndexWord a b) = indexWord a b + + -- LT + go (EVM.Types.LT (Lit a) (Lit b)) + | a < b = Lit 1 + | otherwise = Lit 0 + go (EVM.Types.LT _ (Lit 0)) = Lit 0 + + -- normalize all comparisons in terms of LT + go (EVM.Types.GT a b) = EVM.Types.LT b a + go (EVM.Types.GEq a b) = EVM.Types.LEq b a + go (EVM.Types.LEq a b) = EVM.Types.IsZero (EVM.Types.GT a b) + + go (IsZero a) = iszero a + + -- syntactic Eq reduction + go (Eq (Lit a) (Lit b)) + | a == b = Lit 1 + | otherwise = Lit 0 + go (Eq (Lit 0) (Sub a b)) = Eq a b + go o@(Eq a b) + | a == b = Lit 1 + | otherwise = o + + -- redundant ITE + go (ITE (Lit x) a b) + | x == 0 = b + | otherwise = a + + -- redundant add / sub + go o@(Sub (Add a b) c) + | a == c = b + | b == c = a + | otherwise = o + + -- add / sub identities + go o@(Add a b) + | b == (Lit 0) = a + | a == (Lit 0) = b + | otherwise = o + go o@(Sub a b) + | a == b = Lit 0 + | b == (Lit 0) = a + | otherwise = o + + -- SHL / SHR by 0 + go o@(SHL a v) + | a == (Lit 0) = v + | otherwise = o + go o@(SHR a v) + | a == (Lit 0) = v + | otherwise = o + + -- doubled And + go o@(And a (And b c)) + | a == c = (And a b) + | a == b = (And b c) + | otherwise = o + + -- Bitwise AND & OR. These MUST preserve bitwise equivalence + go o@(And (Lit x) _) + | x == 0 = Lit 0 + | otherwise = o + go o@(And _ (Lit x)) + | x == 0 = Lit 0 + | otherwise = o + go o@(Or (Lit x) b) + | x == 0 = b + | otherwise = o + go o@(Or a (Lit x)) + | x == 0 = a + | otherwise = o + + -- If x is ever non zero the Or will always evaluate to some non zero value and the false branch will be unreachable + -- NOTE: with AND this does not work, because and(0x8, 0x4) = 0 + go (ITE (Or (Lit x) a) t f) + | x == 0 = ITE a t f + | otherwise = t + go (ITE (Or a b@(Lit _)) t f) = ITE (Or b a) t f + + -- we write at least 32, so if x <= 32, it's FALSE + go o@(EVM.Types.LT (BufLength (WriteWord {})) (Lit x)) + | x <= 32 = Lit 0 + | otherwise = o + -- we write at least 32, so if x < 32, it's TRUE + go o@(EVM.Types.LT (Lit x) (BufLength (WriteWord {}))) + | x < 32 = Lit 1 + | otherwise = o + + -- Double NOT is a no-op, since it's a bitwise inversion + go (EVM.Types.Not (EVM.Types.Not a)) = a + + go a = a + + +-- ** Conversions ** ------------------------------------------------------------------------------- + + +litAddr :: Addr -> Expr EWord +litAddr = Lit . num + +litCode :: BS.ByteString -> [Expr Byte] +litCode bs = fmap LitByte (BS.unpack bs) + +to512 :: W256 -> Word512 +to512 = fromIntegral + + +-- ** Helpers ** ----------------------------------------------------------------------------------- + + +-- Is the given expr a literal byte? +isLitByte :: Expr Byte -> Bool +isLitByte (LitByte _) = True +isLitByte _ = False + +-- Is the given expr a literal word? +isLitWord :: Expr EWord -> Bool +isLitWord (Lit _) = True +isLitWord _ = False + +-- | Returns the byte at idx from the given word. +indexWord :: Expr EWord -> Expr EWord -> Expr Byte +-- Simplify masked reads: +-- +-- +-- reads across the mask boundry +-- return an abstract expression +-- │ +-- │ +-- reads outside of │ reads over the mask read +-- the mask return 0 │ from the underlying word +-- │ │ │ +-- │ ┌─────┘ │ +-- ▼ ▼ ▼ +-- ┌───┐ ┌─┬─┬─────────────────────────┬───┬──────────────┐ +-- │ │ │ │ │ │ │ │ mask +-- │ │ │ └─┼─────────────────────────┼───┼──────────────┘ +-- │ │ │ │ │ │ +-- ┌───┼───┼───────┼───┼─────────────────────────┼───┼──────────────┐ +-- │ │┼┼┼│ │┼┼┼│ │┼┼┼│ │ w +-- └───┴───┴───────┴───┴─────────────────────────┴───┴──────────────┘ +-- MSB LSB +-- ────────────────────────────────────────────────────────────────► +-- 0 31 +-- +-- indexWord 0 reads from the MSB +-- indexWord 31 reads from the LSB +-- +indexWord i@(Lit idx) e@(And (Lit mask) w) + -- if the mask is all 1s then read from the undelrying word + -- we need this case to avoid overflow + | mask == fullWordMask = indexWord (Lit idx) w + -- if the index is a read from the masked region then read from the underlying word + | idx <= 31 + , isPower2 (mask + 1) + , isByteAligned mask + , idx >= unmaskedBytes + = indexWord (Lit idx) w + -- if the read is outside of the masked region return 0 + | idx <= 31 + , isPower2 (mask + 1) + , isByteAligned mask + , idx < unmaskedBytes + = LitByte 0 + -- if the mask is not a power of 2, or it does not align with a byte boundry return an abstract expression + | idx <= 31 = IndexWord i e + -- reads outside the range of the source word return 0 + | otherwise = LitByte 0 + where + isPower2 n = n .&. (n-1) == 0 + fullWordMask = (2 ^ (256 :: W256)) - 1 + unmaskedBytes = fromIntegral $ (countLeadingZeros mask) `Prelude.div` 8 + isByteAligned m = (countLeadingZeros m) `Prelude.mod` 8 == 0 +indexWord (Lit idx) (Lit w) + | idx <= 31 = LitByte . fromIntegral $ shiftR w (248 - num idx * 8) + | otherwise = LitByte 0 +indexWord (Lit idx) (JoinBytes zero one two three + four five six seven + eight nine ten eleven + twelve thirteen fourteen fifteen + sixteen seventeen eighteen nineteen + twenty twentyone twentytwo twentythree + twentyfour twentyfive twentysix twentyseven + twentyeight twentynine thirty thirtyone) + | idx == 0 = zero + | idx == 1 = one + | idx == 2 = two + | idx == 3 = three + | idx == 4 = four + | idx == 5 = five + | idx == 6 = six + | idx == 7 = seven + | idx == 8 = eight + | idx == 9 = nine + | idx == 10 = ten + | idx == 11 = eleven + | idx == 12 = twelve + | idx == 13 = thirteen + | idx == 14 = fourteen + | idx == 15 = fifteen + | idx == 16 = sixteen + | idx == 17 = seventeen + | idx == 18 = eighteen + | idx == 19 = nineteen + | idx == 20 = twenty + | idx == 21 = twentyone + | idx == 22 = twentytwo + | idx == 23 = twentythree + | idx == 24 = twentyfour + | idx == 25 = twentyfive + | idx == 26 = twentysix + | idx == 27 = twentyseven + | idx == 28 = twentyeight + | idx == 29 = twentynine + | idx == 30 = thirty + | idx == 31 = thirtyone + | otherwise = LitByte 0 +indexWord idx w = IndexWord idx w + + +padByte :: Expr Byte -> Expr EWord +padByte (LitByte b) = Lit . bytesToW256 $ [b] +padByte b = joinBytes [b] + +-- | Converts a list of bytes into a W256. +-- TODO: semantics if the input is too large? +bytesToW256 :: [Word8] -> W256 +bytesToW256 = word . BS.pack + +padBytesLeft :: Int -> [Expr Byte] -> [Expr Byte] +padBytesLeft n bs + | length bs > n = Prelude.take n bs + | length bs == n = bs + | otherwise = padBytesLeft n (LitByte 0 : bs) + +joinBytes :: [Expr Byte] -> Expr EWord +joinBytes bs + | Prelude.and . (fmap isLitByte) $ bs = Lit . bytesToW256 . (mapMaybe unlitByte) $ bs + | otherwise = let + bytes = padBytesLeft 32 bs + in JoinBytes + (bytes !! 0) (bytes !! 1) (bytes !! 2) (bytes !! 3) + (bytes !! 4) (bytes !! 5) (bytes !! 6) (bytes !! 7) + (bytes !! 8) (bytes !! 9) (bytes !! 10) (bytes !! 11) + (bytes !! 12) (bytes !! 13) (bytes !! 14) (bytes !! 15) + (bytes !! 16) (bytes !! 17) (bytes !! 18) (bytes !! 19) + (bytes !! 20) (bytes !! 21) (bytes !! 22) (bytes !! 23) + (bytes !! 24) (bytes !! 25) (bytes !! 26) (bytes !! 27) + (bytes !! 28) (bytes !! 29) (bytes !! 30) (bytes !! 31) + +eqByte :: Expr Byte -> Expr Byte -> Expr EWord +eqByte (LitByte x) (LitByte y) = Lit $ if x == y then 1 else 0 +eqByte x y = EqByte x y + +min :: Expr EWord -> Expr EWord -> Expr EWord +min (Lit x) (Lit y) = if x < y then Lit x else Lit y +min x y = Min x y + +numBranches :: Expr End -> Int +numBranches (ITE _ t f) = numBranches t + numBranches f +numBranches _ = 1 + +allLit :: [Expr Byte] -> Bool +allLit = Data.List.and . fmap (isLitByte) diff --git a/src/EVM/Facts.hs b/src/EVM/Facts.hs --- a/src/EVM/Facts.hs +++ b/src/EVM/Facts.hs @@ -1,10 +1,7 @@ {-# Language PartialTypeSignatures #-} -{-# Language FlexibleInstances #-} +{-# Language DataKinds #-} {-# Language ExtendedDefaultRules #-} {-# 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 @@ -36,9 +33,9 @@ ) where import EVM (VM, Contract, Cache) -import EVM.Symbolic (litWord, forceLit) -import EVM (balance, nonce, storage, bytecode, env, contracts, contract, state, cache, fetched) -import EVM.Types (Addr, Word, SymWord, Buffer(..)) +import EVM (balance, nonce, storage, bytecode, env, contracts, contract, state, cache, fetchedStorage, fetchedContracts) +import EVM.Types (Addr, W256, Expr(..), num) +import EVM.Expr (writeStorage, litAddr) import qualified EVM @@ -47,9 +44,9 @@ import Control.Lens (view, set, at, ix, (&), over, assign) import Control.Monad.State.Strict (execState, when) import Data.ByteString (ByteString) -import Data.Monoid ((<>)) import Data.Ord (comparing) import Data.Set (Set) +import Data.Map (Map) import Text.Read (readMaybe) import qualified Data.ByteString.Base16 as BS16 @@ -57,6 +54,7 @@ import qualified Data.ByteString.Char8 as Char8 import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Vector as V -- We treat everything as ASCII byte strings because -- we only use hex digits (and the letter 'x'). @@ -71,9 +69,9 @@ -- 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 } + = BalanceFact { addr :: Addr, what :: W256 } + | NonceFact { addr :: Addr, what :: W256 } + | StorageFact { addr :: Addr, what :: W256, which :: W256 } | CodeFact { addr :: Addr, blob :: ByteString } deriving (Eq, Show) @@ -100,7 +98,7 @@ dump = Char8.pack . show load = readMaybe . Char8.unpack -instance AsASCII Word where +instance AsASCII W256 where dump = Char8.pack . show load = readMaybe . Char8.unpack @@ -111,43 +109,44 @@ Right y -> Just y _ -> Nothing -contractFacts :: Addr -> Contract -> [Fact] -contractFacts a x = case view bytecode x of - ConcreteBuffer b -> - storageFacts a x ++ +contractFacts :: Addr -> Contract -> Map W256 (Map W256 W256) -> [Fact] +contractFacts a x store = case view bytecode x of + ConcreteBuf b -> + storageFacts a store ++ [ BalanceFact a (view balance x) , NonceFact a (view nonce x) , CodeFact a b ] - SymbolicBuffer b -> + _ -> -- here simply ignore storing the bytecode - storageFacts a x ++ + storageFacts a store ++ [ BalanceFact a (view balance x) , NonceFact a (view nonce x) ] -storageFacts :: Addr -> Contract -> [Fact] -storageFacts a x = case view storage x of - EVM.Symbolic _ _ -> [] - EVM.Concrete s -> map f (Map.toList s) +storageFacts :: Addr -> Map W256 (Map W256 W256) -> [Fact] +storageFacts a store = map f (Map.toList (Map.findWithDefault Map.empty (num a) store)) where - f :: (Word, SymWord) -> Fact + f :: (W256, W256) -> Fact f (k, v) = StorageFact { addr = a - , what = fromIntegral (forceLit v) + , what = fromIntegral v , which = fromIntegral k } cacheFacts :: Cache -> Set Fact cacheFacts c = Set.fromList $ do - (k, v) <- Map.toList (view EVM.fetched c) - contractFacts k v + (k, v) <- Map.toList (view EVM.fetchedContracts c) + contractFacts k v (view EVM.fetchedStorage c) vmFacts :: VM -> Set Fact vmFacts vm = Set.fromList $ do (k, v) <- Map.toList (view (env . contracts) vm) - contractFacts k v + case view (env . storage) vm of + EmptyStore -> contractFacts k v Map.empty + ConcreteStore s -> contractFacts k v s + _ -> error "cannot serialize an abstract store" -- Somewhat stupidly, this function demands that for each contract, -- the code fact for that contract comes before the other facts for @@ -160,10 +159,10 @@ apply1 vm fact = case fact of CodeFact {..} -> flip execState vm $ do - assign (env . contracts . at addr) (Just (EVM.initialContract (EVM.RuntimeCode (ConcreteBuffer blob)))) + assign (env . contracts . at addr) (Just (EVM.initialContract (EVM.RuntimeCode (V.fromList $ LitByte <$> BS.unpack blob)))) when (view (state . contract) vm == addr) $ EVM.loadContract addr StorageFact {..} -> - vm & over (env . contracts . ix addr . storage) (EVM.writeStorage (litWord which) (litWord what)) + vm & over (env . storage) (writeStorage (litAddr addr) (Lit which) (Lit what)) BalanceFact {..} -> vm & set (env . contracts . ix addr . balance) what NonceFact {..} -> @@ -173,20 +172,23 @@ apply2 vm fact = case fact of CodeFact {..} -> flip execState vm $ do - assign (cache . fetched . at addr) (Just (EVM.initialContract (EVM.RuntimeCode (ConcreteBuffer blob)))) + assign (cache . fetchedContracts . at addr) (Just (EVM.initialContract (EVM.RuntimeCode (V.fromList $ LitByte <$> BS.unpack blob)))) when (view (state . contract) vm == addr) $ EVM.loadContract addr - StorageFact {..} -> - vm & over (cache . fetched . ix addr . storage) (EVM.writeStorage (litWord which) (litWord what)) + StorageFact {..} -> let + store = view (cache . fetchedStorage) vm + ctrct = Map.findWithDefault Map.empty (num addr) store + in + vm & set (cache . fetchedStorage) (Map.insert (num addr) (Map.insert which what ctrct) store) BalanceFact {..} -> - vm & set (cache . fetched . ix addr . balance) what + vm & set (cache . fetchedContracts . ix addr . balance) what NonceFact {..} -> - vm & set (cache . fetched . ix addr . nonce) what + vm & set (cache . fetchedContracts . ix addr . nonce) what -- Sort facts in the right order for `apply1` to work. instance Ord Fact where compare = comparing f where - f :: Fact -> (Int, Addr, Word) + f :: Fact -> (Int, Addr, W256) f (CodeFact a _) = (0, a, 0) f (BalanceFact a _) = (1, a, 0) f (NonceFact a _) = (2, a, 0) diff --git a/src/EVM/Fetch.hs b/src/EVM/Fetch.hs --- a/src/EVM/Fetch.hs +++ b/src/EVM/Fetch.hs @@ -1,30 +1,27 @@ {-# Language GADTs #-} -{-# Language StandaloneDeriving #-} -{-# Language LambdaCase #-} +{-# Language DataKinds #-} module EVM.Fetch where import Prelude hiding (Word) import EVM.ABI -import EVM.Types (Addr, w256, W256, hexText, Word, Buffer(..)) -import EVM.Symbolic (litWord) -import EVM (IsUnique(..), EVM, Contract, Block, initialContract, nonce, balance, external) +import EVM.Types (Addr, W256, hexText, Expr(Lit, LitByte), Expr(..), Prop(..), (.&&), (./=)) +import EVM.SMT +import EVM (EVM, Contract, Block, initialContract, nonce, balance, external) import qualified EVM.FeeSchedule as FeeSchedule import qualified EVM import Control.Lens hiding ((.=)) -import Control.Monad.Reader import Control.Monad.Trans.Maybe -import Data.SBV.Trans.Control -import qualified Data.SBV.Internals as SBV -import Data.SBV.Trans hiding (Word) -import Data.Aeson +import Data.Aeson hiding (Error) import Data.Aeson.Lens import qualified Data.ByteString as BS import Data.Text (Text, unpack, pack) import Data.Maybe (fromMaybe) +import Data.List (foldl') +import qualified Data.Text as T import qualified Data.Vector as RegularVector import Network.Wreq @@ -32,6 +29,8 @@ import System.Process import qualified Network.Wreq.Session as Session +import qualified Data.Vector as V +import Numeric.Natural (Natural) -- | Abstract representation of an RPC fetch request data RpcQuery a where @@ -43,9 +42,12 @@ QueryChainId :: RpcQuery W256 data BlockNumber = Latest | BlockNumber W256 + deriving (Show, Eq) deriving instance Show (RpcQuery a) +type RpcInfo = Maybe (BlockNumber, Text) + rpc :: String -> [Value] -> Value rpc method args = object [ "jsonrpc" .= ("2.0" :: String) @@ -68,7 +70,7 @@ instance ToRPC BlockNumber where toRPC Latest = String "latest" - toRPC (BlockNumber n) = String . pack $ show n + toRPC (EVM.Fetch.BlockNumber n) = String . pack $ show n readText :: Read a => Text -> a readText = read . unpack @@ -105,13 +107,24 @@ parseBlock :: (AsValue s, Show s) => s -> Maybe EVM.Block parseBlock j = do coinbase <- readText <$> j ^? key "miner" . _String - timestamp <- litWord . readText <$> j ^? key "timestamp" . _String + timestamp <- Lit . readText <$> j ^? key "timestamp" . _String number <- readText <$> j ^? key "number" . _String - difficulty <- readText <$> j ^? key "difficulty" . _String gasLimit <- readText <$> j ^? key "gasLimit" . _String - let baseFee = readText <$> j ^? key "baseFeePerGas" . _String + let + baseFee = readText <$> j ^? key "baseFeePerGas" . _String + -- It seems unclear as to whether this field should still be called mixHash or renamed to prevRandao + -- According to https://github.com/ethereum/EIPs/blob/master/EIPS/eip-4399.md it should be renamed + -- but alchemy is still returning mixHash + mixhash = readText <$> j ^? key "mixHash" . _String + prevRandao = readText <$> j ^? key "prevRandao" . _String + difficulty = readText <$> j ^? key "difficulty" . _String + prd = case (prevRandao, mixhash, difficulty) of + (Just p, _, _) -> p + (Nothing, Just mh, Just 0x0) -> mh + (Nothing, Just _, Just d) -> d + _ -> error "Internal Error: block contains both difficulty and prevRandao" -- default codesize, default gas limit, default feescedule - return $ EVM.Block coinbase timestamp number difficulty gasLimit (fromMaybe 0 baseFee) 0xffffffff FeeSchedule.berlin + return $ EVM.Block coinbase timestamp number prd gasLimit (fromMaybe 0 baseFee) 0xffffffff FeeSchedule.berlin fetchWithSession :: Text -> Session -> Value -> IO (Maybe Value) fetchWithSession url sess x = do @@ -130,16 +143,15 @@ theBalance <- MaybeT $ fetch (QueryBalance addr) return $ - initialContract (EVM.RuntimeCode (ConcreteBuffer theCode)) - & set nonce (w256 theNonce) - & set balance (w256 theBalance) + initialContract (EVM.RuntimeCode (V.fromList $ LitByte <$> BS.unpack theCode)) + & set nonce theNonce + & set balance theBalance & set external True fetchSlotWithSession - :: BlockNumber -> Text -> Session -> Addr -> W256 -> IO (Maybe Word) + :: BlockNumber -> Text -> Session -> Addr -> W256 -> IO (Maybe W256) fetchSlotWithSession n url sess addr slot = - fmap w256 <$> - fetchQuery n (fetchWithSession url sess) (QuerySlot addr slot) + fetchQuery n (fetchWithSession url sess) (QuerySlot addr slot) fetchBlockWithSession :: BlockNumber -> Text -> Session -> IO (Maybe Block) @@ -156,20 +168,24 @@ Session.withAPISession (fetchContractWithSession n url addr) -fetchSlotFrom :: BlockNumber -> Text -> Addr -> W256 -> IO (Maybe Word) +fetchSlotFrom :: BlockNumber -> Text -> Addr -> W256 -> IO (Maybe W256) fetchSlotFrom n url addr slot = Session.withAPISession (\s -> fetchSlotWithSession n url s addr slot) -http :: BlockNumber -> Text -> Fetcher -http n url = oracle Nothing (Just (n, url)) True +http :: Natural -> Maybe Natural -> BlockNumber -> Text -> Fetcher +http smtjobs smttimeout n url q = + withSolvers Z3 smtjobs smttimeout $ \s -> + oracle s (Just (n, url)) q -zero :: Fetcher -zero = oracle Nothing Nothing True +zero :: Natural -> Maybe Natural -> Fetcher +zero smtjobs smttimeout q = + withSolvers Z3 smtjobs smttimeout $ \s -> + oracle s Nothing q -- smtsolving + (http or zero) -oracle :: Maybe SBV.State -> Maybe (BlockNumber, Text) -> Bool -> Fetcher -oracle smtstate info ensureConsistency q = do +oracle :: SolverGroup -> RpcInfo -> Fetcher +oracle solvers info q = do case q of EVM.PleaseDoFFI vals continue -> case vals of cmd : args -> do @@ -178,51 +194,36 @@ AbiTuple (RegularVector.fromList [ AbiBytesDynamic . hexText . pack $ stdout']) _ -> error (show vals) - EVM.PleaseAskSMT branchcondition pathconditions continue -> - case smtstate of - Nothing -> return $ continue EVM.Unknown - Just state -> flip runReaderT state $ SBV.runQueryT $ do - let pathconds = sAnd pathconditions + EVM.PleaseAskSMT branchcondition pathconditions continue -> do + let pathconds = foldl' PAnd (PBool True) pathconditions -- Is is possible to satisfy the condition? - continue <$> checkBranch pathconds branchcondition ensureConsistency + continue <$> checkBranch solvers (branchcondition ./= (Lit 0)) pathconds -- if we are using a symbolic storage model, -- we generate a new array to the fetched contract here - EVM.PleaseFetchContract addr model continue -> do + EVM.PleaseFetchContract addr continue -> do contract <- case info of Nothing -> return $ Just $ initialContract (EVM.RuntimeCode mempty) Just (n, url) -> fetchContractFrom n url addr case contract of - Just x -> case model of - EVM.ConcreteS -> return $ continue x - EVM.InitialS -> return $ continue $ x - & set EVM.storage (EVM.Symbolic [] $ SBV.sListArray 0 []) - EVM.SymbolicS -> case smtstate of - Nothing -> return (continue $ x - & set EVM.storage (EVM.Symbolic [] $ SBV.sListArray 0 [])) - - Just state -> - flip runReaderT state $ SBV.runQueryT $ do - store <- freshArray_ Nothing - return $ continue $ x - & set EVM.storage (EVM.Symbolic [] store) + Just x -> return $ continue x Nothing -> error ("oracle error: " ++ show q) - EVM.PleaseMakeUnique val pathconditions continue -> - case smtstate of - Nothing -> return $ continue Multiple - Just state -> flip runReaderT state $ SBV.runQueryT $ do - constrain $ sAnd $ pathconditions <> [val .== val] -- dummy proposition just to make sure `val` is defined when we do `getValue` later. - checkSat >>= \case - Sat -> do - val' <- getValue val - s <- checksat (val ./= literal val') - case s of - Unsat -> pure $ continue $ Unique val' - _ -> pure $ continue Multiple - Unsat -> pure $ continue InconsistentU - Unk -> pure $ continue TimeoutU - DSat _ -> error "unexpected DSAT" + --EVM.PleaseMakeUnique val pathconditions continue -> + --case smtstate of + --Nothing -> return $ continue Multiple + --Just state -> flip runReaderT state $ SBV.runQueryT $ do + --constrain $ sAnd $ pathconditions <> [val .== val] -- dummy proposition just to make sure `val` is defined when we do `getValue` later. + --checkSat >>= \case + --Sat -> do + --val' <- getValue val + --s <- checksat (val ./= literal val') + --case s of + --Unsat -> pure $ continue $ Unique val' + --_ -> pure $ continue Multiple + --Unsat -> pure $ continue InconsistentU + --Unk -> pure $ continue TimeoutU + --DSat _ -> error "unexpected DSAT" EVM.PleaseFetchSlot addr slot continue -> @@ -236,63 +237,27 @@ type Fetcher = EVM.Query -> IO (EVM ()) -checksat :: SBool -> Query CheckSatResult -checksat b = do push 1 - constrain b - m <- checkSat - pop 1 - return m - -- | Checks which branches are satisfiable, checking the pathconditions for consistency -- if the third argument is true. -- When in debug mode, we do not want to be able to navigate to dead paths, -- but for normal execution paths with inconsistent pathconditions -- will be pruned anyway. -checkBranch :: SBool -> SBool -> Bool -> Query EVM.BranchCondition -checkBranch pathconds branchcondition False = do - constrain pathconds - checksat branchcondition >>= \case +checkBranch :: SolverGroup -> Prop -> Prop -> IO EVM.BranchCondition +checkBranch solvers branchcondition pathconditions = do + checkSat solvers (assertProps [(branchcondition .&& pathconditions)]) >>= \case -- the condition is unsatisfiable Unsat -> -- if pathconditions are consistent then the condition must be false return $ EVM.Case False -- Sat means its possible for condition to hold - Sat -> -- is its negation also possible? - checksat (sNot branchcondition) >>= \case - -- No. The condition must hold - Unsat -> return $ EVM.Case True - -- Yes. Both branches possible - Sat -> return EVM.Unknown - -- Explore both branches in case of timeout - Unk -> return EVM.Unknown - DSat _ -> error "checkBranch: unexpected SMT result" - -- If the query times out, we simply explore both paths - Unk -> return EVM.Unknown - DSat _ -> error "checkBranch: unexpected SMT result" - -checkBranch pathconds branchcondition True = do - constrain pathconds - checksat branchcondition >>= \case - -- the condition is unsatisfiable - Unsat -> -- are the pathconditions even consistent? - checksat (sNot branchcondition) >>= \case - -- No. We are on an inconsistent path. - Unsat -> return EVM.Inconsistent - -- Yes. The condition must be false. - Sat -> return $ EVM.Case False - -- Assume the negated condition is still possible. - Unk -> return $ EVM.Case False - DSat _ -> error "checkBranch: unexpected SMT result" - -- Sat means its possible for condition to hold - Sat -> -- is its negation also possible? - checksat (sNot branchcondition) >>= \case + Sat _ -> -- is its negation also possible? + checkSat solvers (assertProps [(pathconditions .&& (PNeg branchcondition))]) >>= \case -- No. The condition must hold Unsat -> return $ EVM.Case True -- Yes. Both branches possible - Sat -> return EVM.Unknown + Sat _ -> return EVM.Unknown -- Explore both branches in case of timeout - Unk -> return EVM.Unknown - DSat _ -> error "checkBranch: unexpected SMT result" - + Unknown -> return EVM.Unknown + Error e -> error $ "Internal Error: SMT Solver returned with an error: " <> T.unpack e -- If the query times out, we simply explore both paths - Unk -> return EVM.Unknown - DSat _ -> error "Internal Error: unexpected SMT result" + Unknown -> return EVM.Unknown + Error e -> error $ "Internal Error: SMT Solver returned with an error: " <> T.unpack e diff --git a/src/EVM/Format.hs b/src/EVM/Format.hs --- a/src/EVM/Format.hs +++ b/src/EVM/Format.hs @@ -1,27 +1,46 @@ {-# Language DataKinds #-} {-# Language ImplicitParams #-} -{-# Language TemplateHaskell #-} -module EVM.Format where + +module EVM.Format + ( formatExpr + , contractNamePart + , contractPathPart + , showTree + , showTraceTree + , prettyvmresult + , showCall + , showWordExact + , showWordExplanation + , parenthesise + , unindexed + , showValue + , textValues + , showAbiValue + , prettyIfConcreteWord + , formatBytes + , formatBinary + , indent + ) where + import Prelude hiding (Word) + import qualified EVM import EVM.Dapp (DappInfo (..), dappSolcByHash, dappAbiMap, showTraceLocation, dappEventMap, dappErrorMap) import EVM.Dapp (DappContext (..), contextInfo, contextEnv) -import EVM.Concrete ( wordValue ) -import EVM (VM, VMResult(..), cheatCode, traceForest, traceData, Error (..), result) -import EVM (Trace, TraceData (..), Log (..), Query (..), FrameContext (..), Storage(..)) -import EVM.SymExec -import EVM.Symbolic (len, litWord) -import EVM.Types (maybeLitWord, Word (..), Whiff(..), SymWord(..), W256 (..), num, word) -import EVM.Types (Addr, Buffer(..), ByteStringS(..)) +import EVM (VM, cheatCode, traceForest, traceData, Error (..)) +import EVM (Trace, TraceData (..), Query (..), FrameContext (..)) +import EVM.Types (maybeLitWord, W256 (..), num, word, Expr(..), EType(..)) +import EVM.Types (Addr, ByteStringS(..)) import EVM.ABI (AbiValue (..), Event (..), AbiType (..), SolError (..)) import EVM.ABI (Indexed (NotIndexed), getAbiSeq) import EVM.ABI (parseTypeName, formatString) import EVM.Solidity (SolcContract(..), contractName, abiMap) import EVM.Solidity (methodOutput, methodSignature, methodName) +import EVM.Hexdump import Control.Arrow ((>>>)) -import Control.Lens (view, preview, ix, _2, to, makeLenses, over, each, (^?!)) +import Control.Lens (view, preview, ix, _2, to, (^?!)) import Data.Binary.Get (runGetOrFail) import Data.Bits (shiftR) import Data.ByteString (ByteString) @@ -33,15 +52,17 @@ import Data.Text (Text, pack, unpack, intercalate) import Data.Text (dropEnd, splitOn) import Data.Text.Encoding (decodeUtf8, decodeUtf8') -import Data.Tree (Tree (Node)) import Data.Tree.View (showTree) import Data.Vector (Vector) import Data.Word (Word32) +import Numeric (showHex) import qualified Data.ByteString as BS import qualified Data.Char as Char import qualified Data.Map as Map import qualified Data.Text as Text +import qualified EVM.Expr as Expr +import qualified Data.Text as T data Signedness = Signed | Unsigned deriving (Show) @@ -59,8 +80,8 @@ then "MAX_UINT256" else Text.pack (show (i :: Integer)) -showWordExact :: Word -> Text -showWordExact (C _ (W256 w)) = humanizeInteger w +showWordExact :: W256 -> Text +showWordExact w = humanizeInteger w showWordExplanation :: W256 -> DappInfo -> Text showWordExplanation w _ | w > 0xffffffff = showDec Unsigned w @@ -79,58 +100,65 @@ . Text.pack . show +prettyIfConcreteWord :: Expr EWord -> Text +prettyIfConcreteWord = \case + Lit w -> T.pack $ "0x" <> showHex w "" + w -> T.pack $ show w + showAbiValue :: (?context :: DappContext) => AbiValue -> Text -showAbiValue (AbiBytes _ bs) = - formatBytes bs -- opportunistically decodes recognisable strings +showAbiValue (AbiString bs) = formatBytes bs +showAbiValue (AbiBytesDynamic bs) = formatBytes bs +showAbiValue (AbiBytes _ bs) = formatBinary bs showAbiValue (AbiAddress addr) = let dappinfo = view contextInfo ?context contracts = view contextEnv ?context name = case (Map.lookup addr contracts) of Nothing -> "" Just contract -> - let hash = view EVM.codehash contract - solcContract = (preview (dappSolcByHash . ix hash . _2) dappinfo) - in maybeContractName' solcContract + let hash = maybeLitWord $ view EVM.codehash contract + in case hash of + Just h -> maybeContractName' (preview (dappSolcByHash . ix h . _2) dappinfo) + Nothing -> "" in name <> "@" <> (pack $ show addr) showAbiValue v = pack $ show v -showAbiValues :: (?context :: DappContext) => Vector AbiValue -> Text -showAbiValues vs = parenthesise (textAbiValues vs) - textAbiValues :: (?context :: DappContext) => Vector AbiValue -> [Text] textAbiValues vs = toList (fmap showAbiValue vs) -textValues :: (?context :: DappContext) => [AbiType] -> Buffer -> [Text] -textValues ts (SymbolicBuffer _) = [pack $ show t | t <- ts] -textValues ts (ConcreteBuffer bs) = +textValues :: (?context :: DappContext) => [AbiType] -> Expr Buf -> [Text] +textValues ts (ConcreteBuf bs) = case runGetOrFail (getAbiSeq (length ts) ts) (fromStrict bs) of Right (_, _, xs) -> textAbiValues xs Left (_, _, _) -> [formatBinary bs] +textValues ts _ = fmap (const "") ts parenthesise :: [Text] -> Text parenthesise ts = "(" <> intercalate ", " ts <> ")" -showValues :: (?context :: DappContext) => [AbiType] -> Buffer -> Text +showValues :: (?context :: DappContext) => [AbiType] -> Expr Buf -> Text showValues ts b = parenthesise $ textValues ts b -showValue :: (?context :: DappContext) => AbiType -> Buffer -> Text +showValue :: (?context :: DappContext) => AbiType -> Expr Buf -> Text showValue t b = head $ textValues [t] b -showCall :: (?context :: DappContext) => [AbiType] -> Buffer -> Text -showCall ts (SymbolicBuffer bs) = showValues ts $ SymbolicBuffer (drop 4 bs) -showCall ts (ConcreteBuffer bs) = showValues ts $ ConcreteBuffer (BS.drop 4 bs) +showCall :: (?context :: DappContext) => [AbiType] -> Expr Buf -> Text +showCall ts (ConcreteBuf bs) = showValues ts $ ConcreteBuf (BS.drop 4 bs) +showCall _ _ = "" -showError :: (?context :: DappContext) => ByteString -> Text -showError bs = +showError :: (?context :: DappContext) => Expr Buf -> Text +showError (ConcreteBuf bs) = let dappinfo = view contextInfo ?context bs4 = BS.take 4 bs in case Map.lookup (word bs4) (view dappErrorMap dappinfo) of - Just (SolError errName ts) -> errName <> " " <> showCall ts (ConcreteBuffer bs) + Just (SolError errName ts) -> errName <> " " <> showCall ts (ConcreteBuf bs) Nothing -> case bs4 of -- Method ID for Error(string) - "\b\195y\160" -> showCall [AbiStringType] (ConcreteBuffer bs) + "\b\195y\160" -> showCall [AbiStringType] (ConcreteBuf bs) + -- Method ID for Panic(uint256) + "NH{q" -> "Panic" <> showCall [AbiUIntType 256] (ConcreteBuf bs) _ -> formatBinary bs +showError b = T.pack $ show b -- the conditions under which bytes will be decoded and rendered as a string isPrintable :: ByteString -> Bool @@ -148,25 +176,18 @@ then formatBString s else formatBinary b -formatSBytes :: Buffer -> Text -formatSBytes (SymbolicBuffer b) = "<" <> pack (show (length b)) <> " symbolic bytes>" -formatSBytes (ConcreteBuffer b) = formatBytes b - -- a string that came from bytes, displayed with special quotes formatBString :: ByteString -> Text formatBString b = mconcat [ "«", Text.dropAround (=='"') (pack $ formatString b), "»" ] -formatSString :: Buffer -> Text -formatSString (SymbolicBuffer bs) = "<" <> pack (show (length bs)) <> " symbolic bytes (string)>" -formatSString (ConcreteBuffer bs) = pack $ formatString bs - formatBinary :: ByteString -> Text formatBinary = (<>) "0x" . decodeUtf8 . toStrict . toLazyByteString . byteStringHex -formatSBinary :: Buffer -> Text -formatSBinary (SymbolicBuffer bs) = "<" <> pack (show (length bs)) <> " symbolic bytes>" -formatSBinary (ConcreteBuffer bs) = formatBinary bs +formatSBinary :: Expr Buf -> Text +formatSBinary (ConcreteBuf bs) = formatBinary bs +formatSBinary (AbstractBuf t) = "<" <> t <> " abstract buf>" +formatSBinary _ = error "formatSBinary: implement me" showTraceTree :: DappInfo -> VM -> Text showTraceTree dapp vm = @@ -187,7 +208,7 @@ Right x -> " \x1b[1m(" <> x <> ")\x1b[0m" fullAbiMap = view dappAbiMap dapp in case view traceData trace of - EventTrace (Log _ bytes topics) -> + EventTrace _ bytes topics -> let logn = mconcat [ "\x1b[36m" , "log" <> (pack (show (length topics))) @@ -213,7 +234,7 @@ (t1:_) -> case maybeLitWord t1 of Just topic -> - case Map.lookup (wordValue topic) (view dappEventMap dapp) of + case Map.lookup (topic) (view dappEventMap dapp) of Just (Event name _ types) -> knownTopic name types Nothing -> @@ -228,16 +249,16 @@ -- bytes data -- ) anonymous; let - sig = fromIntegral $ shiftR (wordValue topic) 224 :: Word32 + sig = fromIntegral $ shiftR topic 224 :: Word32 usr = case maybeLitWord t2 of Just w -> - pack $ show $ (fromIntegral w :: Addr) + pack $ show (fromIntegral w :: Addr) Nothing -> "" in case Map.lookup sig (view dappAbiMap dapp) of Just m -> - lognote (view methodSignature m) usr + lognote (view methodSignature m) usr Nothing -> logn _ -> @@ -247,20 +268,20 @@ QueryTrace q -> case q of - PleaseFetchContract addr _ _ -> + PleaseFetchContract addr _ -> "fetch contract " <> pack (show addr) <> pos PleaseFetchSlot addr slot _ -> "fetch storage slot " <> pack (show slot) <> " from " <> pack (show addr) <> pos PleaseAskSMT {} -> "ask smt" <> pos - PleaseMakeUnique {} -> - "make unique value" <> pos + --PleaseMakeUnique {} -> + --"make unique value" <> pos PleaseDoFFI cmd _ -> "execute ffi " <> pack (show cmd) <> pos ErrorTrace e -> case e of - Revert out -> + EVM.Revert out -> "\x1b[91merror\x1b[0m " <> "Revert " <> showError out <> pos _ -> "\x1b[91merror\x1b[0m " <> pack (show e) <> pos @@ -279,20 +300,26 @@ ReturnTrace out (CallContext {}) -> "← " <> formatSBinary out ReturnTrace out (CreationContext {}) -> - "← " <> pack (show (len out)) <> " bytes of code" - + let l = Expr.bufLength out + in "← " <> formatExpr l <> " bytes of code" EntryTrace t -> t - FrameTrace (CreationContext addr hash _ _ ) -> + FrameTrace (CreationContext addr (Lit hash) _ _ ) -> -- FIXME: irrefutable pattern "create " <> maybeContractName (preview (dappSolcByHash . ix hash . _2) dapp) <> "@" <> pack (show addr) <> pos + FrameTrace (CreationContext addr _ _ _ ) -> + "create " + <> "" + <> "@" <> pack (show addr) + <> pos FrameTrace (CallContext target context _ _ hash abi calldata _ _) -> let calltype = if target == context then "call " else "delegatecall " - in case preview (dappSolcByHash . ix hash . _2) dapp of + Lit hash' = hash -- FIXME: irrefutable pattern, handle symbolic + in case preview (dappSolcByHash . ix hash' . _2) dapp of Nothing -> calltype <> pack (show target) @@ -336,7 +363,7 @@ maybeContractName' = maybe "" (view (contractName . to contractNamePart)) -maybeAbiName :: SolcContract -> Word -> Maybe Text +maybeAbiName :: SolcContract -> W256 -> Maybe Text maybeAbiName solc abi = preview (abiMap . ix (fromIntegral abi) . methodSignature) solc contractNamePart :: Text -> Text @@ -345,112 +372,175 @@ contractPathPart :: Text -> Text contractPathPart x = Text.split (== ':') x !! 0 -prettyvmresult :: (?context :: DappContext) => VMResult -> String -prettyvmresult (EVM.VMFailure (EVM.Revert "")) = "Revert" -prettyvmresult (EVM.VMFailure (EVM.Revert msg)) = "Revert" ++ (unpack $ showError msg) -prettyvmresult (EVM.VMFailure (EVM.UnrecognizedOpcode 254)) = "Assertion violation" -prettyvmresult (EVM.VMFailure err) = "Failed: " <> show err -prettyvmresult (EVM.VMSuccess (ConcreteBuffer msg)) = +prettyvmresult :: (?context :: DappContext) => Expr End -> String +prettyvmresult (EVM.Types.Revert _ (ConcreteBuf "")) = "Revert" +prettyvmresult (EVM.Types.Revert _ msg) = "Revert: " ++ (unpack $ showError msg) +prettyvmresult (EVM.Types.Invalid _) = "Invalid Opcode" +prettyvmresult (EVM.Types.Return _ (ConcreteBuf msg) _) = if BS.null msg then "Stop" else "Return: " <> show (ByteStringS msg) -prettyvmresult (EVM.VMSuccess (SymbolicBuffer msg)) = - "Return: " <> show (length msg) <> " symbolic bytes" - -currentSolc :: DappInfo -> VM -> Maybe SolcContract -currentSolc dapp vm = - let - this = vm ^?! EVM.env . EVM.contracts . ix (view (EVM.state . EVM.contract) vm) - h = view EVM.codehash this - in - preview (dappSolcByHash . ix h . _2) dapp - --- TODO: display in an 'act' format +prettyvmresult (EVM.Types.Return _ _ _) = + "Return: " +prettyvmresult (EVM.Types.IllegalOverflow _) = "Illegal Overflow" +prettyvmresult (EVM.Types.SelfDestruct _) = "Self Destruct" +prettyvmresult e = error "Internal Error: Invalid Result: " <> show e --- TreeLine describes a singe line of the tree --- it contains the indentation which is prefixed to it --- and its content which contains the rest -data TreeLine = TreeLine { - _indent :: String, - _content :: String - } +indent :: Int -> Text -> Text +indent n = rstrip . T.unlines . fmap (T.replicate n (T.pack [' ']) <>) . T.lines -makeLenses ''TreeLine +rstrip :: Text -> Text +rstrip = T.reverse . T.dropWhile (=='\n') . T.reverse --- SHOW TREE +formatExpr :: Expr a -> Text +formatExpr = go + where + go :: Expr a -> Text + go = \case + Lit w -> T.pack $ show w + LitByte w -> T.pack $ show w -showTreeIndentSymbol :: Bool -- ^ isLastChild - -> Bool -- ^ isTreeHead - -> String -showTreeIndentSymbol True True = "\x2514" -- └ -showTreeIndentSymbol False True = "\x251c" -- ├ -showTreeIndentSymbol True False = " " -showTreeIndentSymbol False False = "\x2502" -- │ + ITE c t f -> rstrip . T.unlines $ + [ "(ITE (" <> formatExpr c <> ")" + , indent 2 (formatExpr t) + , indent 2 (formatExpr f) + , ")"] + EVM.Types.Revert asserts buf -> case buf of + ConcreteBuf "" -> "(Revert " <> formatExpr buf <> ")" + _ -> T.unlines + [ "(Revert" + , indent 2 $ T.unlines + [ "Code:" + , indent 2 (formatExpr buf) + , "Assertions:" + , indent 2 $ T.pack $ show asserts + ] + , ")" + ] + Return asserts buf store -> T.unlines + [ "(Return" + , indent 2 $ T.unlines + [ "Data:" + , indent 2 $ formatExpr buf + , "" + , "Store:" + , indent 2 $ formatExpr store + , "Assertions:" + , indent 2 $ T.pack $ show asserts + ] + , ")" + ] -flattenTree :: Int -> -- total number of cases - Int -> -- case index - Tree [String] -> - [TreeLine] --- this case should never happen for our use case, here for generality -flattenTree _ _ (Node [] _) = [] + IndexWord idx val -> T.unlines + [ "(IndexWord" + , indent 2 $ T.unlines + [ "idx:" + , indent 2 $ formatExpr idx + , "val: " + , indent 2 $ formatExpr val + ] + , ")" + ] + ReadWord idx buf -> T.unlines + [ "(ReadWord" + , indent 2 $ T.unlines + [ "idx:" + , indent 2 $ formatExpr idx + , "buf: " + , indent 2 $ formatExpr buf + ] + , ")" + ] -flattenTree totalCases i (Node (x:xs) cs) = let - isLastCase = i + 1 == totalCases - indenthead = showTreeIndentSymbol isLastCase True <> " " <> show i <> " " - indentchild = showTreeIndentSymbol isLastCase False <> " " - in TreeLine indenthead x - : ((TreeLine indentchild <$> xs) ++ over (each . indent) ((<>) indentchild) (flattenForest cs)) + And a b -> T.unlines + [ "(And" + , indent 2 $ T.unlines + [ formatExpr a + , formatExpr b + ] + , ")" + ] -flattenForest :: [Tree [String]] -> [TreeLine] -flattenForest forest = concat $ zipWith (flattenTree (length forest)) [0..] forest + -- Stores + SLoad addr slot store -> T.unlines + [ "(SLoad" + , indent 2 $ T.unlines + [ "addr:" + , indent 2 $ formatExpr addr + , "slot:" + , indent 2 $ formatExpr slot + , "store:" + , indent 2 $ formatExpr store + ] + , ")" + ] + SStore addr slot val prev -> T.unlines + [ "(SStore" + , indent 2 $ T.unlines + [ "addr:" + , indent 2 $ formatExpr addr + , "slot:" + , indent 2 $ formatExpr slot + , "val:" + , indent 2 $ formatExpr val + ] + , ")" + , formatExpr prev + ] + ConcreteStore s -> T.unlines + [ "(ConcreteStore" + , indent 2 $ T.unlines $ fmap (T.pack . show) $ Map.toList $ fmap (T.pack . show . Map.toList) s + , ")" + ] -leftpad :: Int -> String -> String -leftpad n = (<>) $ replicate n ' ' + -- Buffers -showTree' :: Tree [String] -> String -showTree' (Node s []) = unlines s -showTree' (Node _ children) = - let - treeLines = flattenForest children - maxIndent = 2 + maximum (length . _indent <$> treeLines) - showTreeLine (TreeLine colIndent colContent) = - let indentSize = maxIndent - length colIndent - in colIndent <> leftpad indentSize colContent - in unlines $ showTreeLine <$> treeLines + CopySlice srcOff dstOff size src dst -> T.unlines + [ "(CopySlice" + , indent 2 $ T.unlines + [ "srcOffset: " <> formatExpr srcOff + , "dstOffset: " <> formatExpr dstOff + , "size: " <> formatExpr size + , "src:" + , indent 2 $ formatExpr src + ] + , ")" + , formatExpr dst + ] + WriteWord idx val buf -> T.unlines + [ "(WriteWord" + , indent 2 $ T.unlines + [ "idx:" + , indent 2 $ formatExpr idx + , "val:" + , indent 2 $ formatExpr val + ] + , ")" + , formatExpr buf + ] + WriteByte idx val buf -> T.unlines + [ "(WriteByte" + , indent 2 $ T.unlines + [ "idx: " <> formatExpr idx + , "val: " <> formatExpr val + ] + , ")" + , formatExpr buf + ] + ConcreteBuf bs -> case bs of + "" -> "(ConcreteBuf \"\")" + _ -> T.unlines + [ "(ConcreteBuf" + , indent 2 $ T.pack $ prettyHex 0 bs + , ")" + ] --- RENDER TREE - -showStorage :: [(SymWord, SymWord)] -> [String] -showStorage = fmap (\(k, v) -> show k <> " => " <> show v) - -showLeafInfo :: DappInfo -> BranchInfo -> [String] -showLeafInfo srcInfo (BranchInfo vm _) = let - ?context = DappContext { _contextInfo = srcInfo, _contextEnv = vm ^?! EVM.env . EVM.contracts } - in let - self = view (EVM.state . EVM.contract) vm - updates = case view (EVM.env . EVM.contracts) vm ^?! ix self . EVM.storage of - Symbolic v _ -> v - Concrete x -> [(litWord k,v) | (k, v) <- Map.toList x] - showResult = [prettyvmresult res | Just res <- [view result vm]] - in showResult - ++ showStorage updates - ++ [""] - -showBranchInfoWithAbi :: DappInfo -> BranchInfo -> [String] -showBranchInfoWithAbi _ (BranchInfo _ Nothing) = [""] -showBranchInfoWithAbi srcInfo (BranchInfo vm (Just y)) = - case y of - (IsZero (Eq (Literal x) _)) -> - let - abimap = view abiMap <$> currentSolc srcInfo vm - method = abimap >>= Map.lookup (num x) - in [maybe (show y) (show . view methodSignature) method] - y' -> [show y'] + -- Hashes + Keccak b -> T.unlines + [ "(Keccak" + , indent 2 $ formatExpr b + , ")" + ] -renderTree :: (a -> [String]) - -> (a -> [String]) - -> Tree a - -> Tree [String] -renderTree showBranch showLeaf (Node b []) = Node (showBranch b ++ showLeaf b) [] -renderTree showBranch showLeaf (Node b cs) = Node (showBranch b) (renderTree showBranch showLeaf <$> cs) + a -> T.pack $ show a diff --git a/src/EVM/Keccak.hs b/src/EVM/Keccak.hs new file mode 100644 --- /dev/null +++ b/src/EVM/Keccak.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DataKinds #-} +{- | + Module: EVM.Keccak + Description: Expr passes to determine Keccak assumptions +-} + +module EVM.Keccak (keccakAssumptions) where + +import Prelude hiding (Word, LT, GT) + +import Data.Set (Set) +import qualified Data.Set as Set +import Control.Monad.State + +import EVM.Types +import EVM.Traversals + + +data BuilderState = BuilderState + { keccaks :: Set (Expr EWord) } + deriving (Show) + +initState :: BuilderState +initState = BuilderState { keccaks = Set.empty } + +go :: forall a. Expr a -> State BuilderState (Expr a) +go = \case + e@(Keccak _) -> do + s <- get + put $ s{keccaks=Set.insert e (keccaks s)} + pure e + e -> pure e + +findKeccakExpr :: forall a. Expr a -> State BuilderState (Expr a) +findKeccakExpr e = mapExprM go e + +findKeccakProp :: Prop -> State BuilderState Prop +findKeccakProp p = mapPropM go p + +findKeccakPropsExprs :: [Prop] -> [Expr Buf] -> [Expr Storage]-> State BuilderState () +findKeccakPropsExprs ps bufs stores = do + mapM_ findKeccakProp ps; + mapM_ findKeccakExpr bufs; + mapM_ findKeccakExpr stores + + +combine :: [a] -> [(a,a)] +combine lst = combine' lst [] + where + combine' [] acc = concat acc + combine' (x:xs) acc = + let xcomb = [ (x, y) | y <- xs] in + combine' xs (xcomb:acc) + +minProp :: Expr EWord -> Prop +minProp k@(Keccak _) = PGT k (Lit 50) +minProp _ = error "Internal error: expected keccak expression" + +injProp :: (Expr EWord, Expr EWord) -> Prop +injProp (k1@(Keccak b1), k2@(Keccak b2)) = + POr (PEq b1 b2) (PNeg (PEq k1 k2)) +injProp _ = error "Internal error: expected keccak expression" + +-- Takes a list of props, find all keccak occurences and generates two kinds of assumptions: +-- 1. Minimum output value: That the output of the invocation is greater than +-- 50 (needed to avoid spurious counterexamples due to storage collisions +-- with solidity mappings & value type storage slots) +-- 2. Injectivity: That keccak is an injective function (we avoid quantifiers +-- here by making this claim for each unique pair of keccak invocations +-- discovered in the input expressions) +keccakAssumptions :: [Prop] -> [Expr Buf] -> [Expr Storage] -> [Prop] +keccakAssumptions ps bufs stores = injectivity <> minValue + where + (_, st) = runState (findKeccakPropsExprs ps bufs stores) initState + + injectivity = fmap injProp $ combine (Set.toList (keccaks st)) + minValue = fmap minProp (Set.toList (keccaks st)) + + diff --git a/src/EVM/Op.hs b/src/EVM/Op.hs --- a/src/EVM/Op.hs +++ b/src/EVM/Op.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE DataKinds #-} + module EVM.Op ( Op (..) , opString ) where -import EVM.Types (SymWord) +import EVM.Types + import Data.Word (Word8) import Numeric (showHex) @@ -55,7 +58,7 @@ | OpCoinbase | OpTimestamp | OpNumber - | OpDifficulty + | OpPrevRandao | OpGaslimit | OpChainid | OpSelfbalance @@ -83,7 +86,7 @@ | OpDup !Word8 | OpSwap !Word8 | OpLog !Word8 - | OpPush !SymWord + | OpPush (Expr EWord) | OpUnknown Word8 deriving (Show, Eq) @@ -138,7 +141,7 @@ OpCoinbase -> "COINBASE" OpTimestamp -> "TIMESTAMP" OpNumber -> "NUMBER" - OpDifficulty -> "DIFFICULTY" + OpPrevRandao -> "PREVRANDAO" OpGaslimit -> "GASLIMIT" OpChainid -> "CHAINID" OpSelfbalance -> "SELFBALANCE" @@ -165,7 +168,9 @@ OpDup x -> "DUP" ++ show x OpSwap x -> "SWAP" ++ show x OpLog x -> "LOG" ++ show x - OpPush x -> "PUSH " ++ show x + OpPush x -> case x of + Lit x' -> "PUSH 0x" ++ (showHex x' "") + _ -> "PUSH " ++ show x OpRevert -> "REVERT" OpUnknown x -> case x of 254 -> "INVALID" diff --git a/src/EVM/Patricia.hs b/src/EVM/Patricia.hs --- a/src/EVM/Patricia.hs +++ b/src/EVM/Patricia.hs @@ -1,11 +1,7 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} - module EVM.Patricia where import EVM.RLP -import EVM.Types hiding (Literal) +import EVM.Types import Control.Monad.Free import Control.Monad.State @@ -84,7 +80,7 @@ putNode :: Node -> NodeDB Ref putNode node = let bytes = rlpencode $ rlpNode node - digest = word256Bytes $ keccak bytes + digest = word256Bytes $ keccak' bytes in if BS.length bytes < 32 then return $ Literal node else do @@ -226,5 +222,5 @@ calcRoot :: [(ByteString, ByteString)] -> Maybe ByteString calcRoot vs = case insertValues vs of Just (Hash b) -> Just b - Just (Literal n) -> Just $ word256Bytes $ keccak $ rlpencode $ rlpNode n + Just (Literal n) -> Just $ word256Bytes $ keccak' $ rlpencode $ rlpNode n Nothing -> Nothing diff --git a/src/EVM/Precompiled.hs b/src/EVM/Precompiled.hs --- a/src/EVM/Precompiled.hs +++ b/src/EVM/Precompiled.hs @@ -1,5 +1,3 @@ -{-# Language ForeignFunctionInterface #-} - module EVM.Precompiled (execute) where import Data.ByteString (ByteString) diff --git a/src/EVM/SMT.hs b/src/EVM/SMT.hs new file mode 100644 --- /dev/null +++ b/src/EVM/SMT.hs @@ -0,0 +1,1099 @@ +{-# Language DataKinds #-} +{-# Language GADTs #-} +{-# Language PolyKinds #-} +{-# Language ScopedTypeVariables #-} +{-# Language TypeApplications #-} +{-# Language QuasiQuotes #-} + +{- | + Module: EVM.SMT + Description: Utilities for building and executing SMT queries from Expr instances +-} +module EVM.SMT where + +import Prelude hiding (LT, GT) + +import GHC.Natural +import Control.Monad +import GHC.IO.Handle (Handle, hFlush, hSetBuffering, BufferMode(..)) +import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan) +import Control.Concurrent (forkIO, killThread) +import Data.Char (isSpace) +import Data.Containers.ListUtils (nubOrd) +import Language.SMT2.Parser (getValueRes, parseCommentFreeFileMsg) +import Language.SMT2.Syntax (SpecConstant(..), GeneralRes(..), Term(..), QualIdentifier(..), Identifier(..), Sort(..), Index(..), VarBinding(..)) +import Data.Word +import Numeric (readHex) +import Data.ByteString (ByteString) +import Data.Maybe (fromMaybe) + +import qualified Data.ByteString as BS +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.String.Here +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text.Lazy (Text) +import qualified Data.Text as TS +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as T +import Data.Text.Lazy.Builder +import Data.Bifunctor (second) +import System.Process (createProcess, cleanupProcess, proc, ProcessHandle, std_in, std_out, std_err, StdStream(..)) + +import EVM.Types +import EVM.Traversals +import EVM.CSE +import EVM.Keccak +import EVM.Expr hiding (copySlice, writeWord, op1, op2, op3, drop) + + +-- ** Encoding ** ---------------------------------------------------------------------------------- +-- variable names in SMT that we want to get values for +data CexVars = CexVars + { calldataV :: [Text] + , buffersV :: [Text] + , blockContextV :: [Text] + , txContextV :: [Text] + } + deriving (Eq, Show) + +instance Semigroup CexVars where + (CexVars a b c d) <> (CexVars a2 b2 c2 d2) = CexVars (a <> a2) (b <> b2) (c <> c2) (d <> d2) + +instance Monoid CexVars where + mempty = CexVars + { calldataV = mempty + , buffersV = mempty + , blockContextV = mempty + , txContextV = mempty + } + +data SMTCex = SMTCex + { vars :: Map (Expr EWord) W256 + , buffers :: Map (Expr Buf) ByteString + , blockContext :: Map (Expr EWord) W256 + , txContext :: Map (Expr EWord) W256 + } + deriving (Eq, Show) + +getVar :: EVM.SMT.SMTCex -> TS.Text -> W256 +getVar cex name = fromJust $ Map.lookup (Var name) (vars cex) + +data SMT2 = SMT2 [Builder] CexVars + deriving (Eq, Show) + +instance Semigroup SMT2 where + (SMT2 a b) <> (SMT2 a2 b2) = SMT2 (a <> a2) (b <> b2) + +instance Monoid SMT2 where + mempty = SMT2 mempty mempty + +formatSMT2 :: SMT2 -> Text +formatSMT2 (SMT2 ls _) = T.unlines (fmap toLazyText ls) + +-- | Reads all intermediate variables from the builder state and produces SMT declaring them as constants +declareIntermediates :: BufEnv -> StoreEnv -> SMT2 +declareIntermediates bufs stores = + let encSs = Map.mapWithKey encodeStore stores + encBs = Map.mapWithKey encodeBuf bufs + sorted = List.sortBy compareFst $ Map.toList $ encSs <> encBs + decls = fmap snd sorted + in SMT2 ([fromText "; intermediate buffers & stores"] <> decls) mempty + where + compareFst (l, _) (r, _) = compare l r + encodeBuf n expr = + fromLazyText ("(define-const buf" <> (T.pack . show $ n) <> " Buf ") <> exprToSMT expr <> ")" + encodeStore n expr = + fromLazyText ("(define-const store" <> (T.pack . show $ n) <> " Storage ") <> exprToSMT expr <> ")" + +assertProps :: [Prop] -> SMT2 +assertProps ps = + let encs = map propToSMT ps_elim + intermediates = declareIntermediates bufs stores in + prelude + <> (declareBufs . nubOrd $ foldl (<>) [] allBufs) + <> SMT2 [""] mempty + <> (declareVars . nubOrd $ foldl (<>) [] allVars) + <> SMT2 [""] mempty + <> (declareFrameContext . nubOrd $ foldl (<>) [] frameCtx) + <> SMT2 [""] mempty + <> (declareBlockContext . nubOrd $ foldl (<>) [] blockCtx) + <> SMT2 [""] mempty + <> intermediates + <> SMT2 [""] mempty + <> keccakAssumes + <> SMT2 [""] mempty + <> SMT2 (fmap (\p -> "(assert " <> p <> ")") encs) mempty + + where + (ps_elim, bufs, stores) = eliminateProps ps + + allBufs = fmap referencedBufs' ps_elim <> fmap referencedBufs bufVals <> fmap referencedBufs storeVals + allVars = fmap referencedVars' ps_elim <> fmap referencedVars bufVals <> fmap referencedVars storeVals + frameCtx = fmap referencedFrameContext' ps_elim <> fmap referencedFrameContext bufVals <> fmap referencedFrameContext storeVals + blockCtx = fmap referencedBlockContext' ps_elim <> fmap referencedBlockContext bufVals <> fmap referencedBlockContext storeVals + + bufVals = Map.elems bufs + storeVals = Map.elems stores + + keccakAssumes + = SMT2 ["; keccak assumptions"] mempty + <> SMT2 (fmap (\p -> "(assert " <> propToSMT p <> ")") (keccakAssumptions ps_elim bufVals storeVals)) mempty + + +prelude :: SMT2 +prelude = (flip SMT2) mempty $ fmap (fromLazyText . T.drop 2) . T.lines $ [i| + ; logic + ; TODO: this creates an error when used with z3? + ;(set-logic QF_AUFBV) + (set-logic ALL) + + ; types + (define-sort Byte () (_ BitVec 8)) + (define-sort Word () (_ BitVec 256)) + (define-sort Buf () (Array Word Byte)) + + ; address -> slot -> value + (define-sort Storage () (Array Word (Array Word Word))) + + ; hash functions + (declare-fun keccak (Buf) Word) + (declare-fun sha256 (Buf) Word) + + ; word indexing + (define-fun indexWord31 ((w Word)) Byte ((_ extract 7 0) w)) + (define-fun indexWord30 ((w Word)) Byte ((_ extract 15 8) w)) + (define-fun indexWord29 ((w Word)) Byte ((_ extract 23 16) w)) + (define-fun indexWord28 ((w Word)) Byte ((_ extract 31 24) w)) + (define-fun indexWord27 ((w Word)) Byte ((_ extract 39 32) w)) + (define-fun indexWord26 ((w Word)) Byte ((_ extract 47 40) w)) + (define-fun indexWord25 ((w Word)) Byte ((_ extract 55 48) w)) + (define-fun indexWord24 ((w Word)) Byte ((_ extract 63 56) w)) + (define-fun indexWord23 ((w Word)) Byte ((_ extract 71 64) w)) + (define-fun indexWord22 ((w Word)) Byte ((_ extract 79 72) w)) + (define-fun indexWord21 ((w Word)) Byte ((_ extract 87 80) w)) + (define-fun indexWord20 ((w Word)) Byte ((_ extract 95 88) w)) + (define-fun indexWord19 ((w Word)) Byte ((_ extract 103 96) w)) + (define-fun indexWord18 ((w Word)) Byte ((_ extract 111 104) w)) + (define-fun indexWord17 ((w Word)) Byte ((_ extract 119 112) w)) + (define-fun indexWord16 ((w Word)) Byte ((_ extract 127 120) w)) + (define-fun indexWord15 ((w Word)) Byte ((_ extract 135 128) w)) + (define-fun indexWord14 ((w Word)) Byte ((_ extract 143 136) w)) + (define-fun indexWord13 ((w Word)) Byte ((_ extract 151 144) w)) + (define-fun indexWord12 ((w Word)) Byte ((_ extract 159 152) w)) + (define-fun indexWord11 ((w Word)) Byte ((_ extract 167 160) w)) + (define-fun indexWord10 ((w Word)) Byte ((_ extract 175 168) w)) + (define-fun indexWord9 ((w Word)) Byte ((_ extract 183 176) w)) + (define-fun indexWord8 ((w Word)) Byte ((_ extract 191 184) w)) + (define-fun indexWord7 ((w Word)) Byte ((_ extract 199 192) w)) + (define-fun indexWord6 ((w Word)) Byte ((_ extract 207 200) w)) + (define-fun indexWord5 ((w Word)) Byte ((_ extract 215 208) w)) + (define-fun indexWord4 ((w Word)) Byte ((_ extract 223 216) w)) + (define-fun indexWord3 ((w Word)) Byte ((_ extract 231 224) w)) + (define-fun indexWord2 ((w Word)) Byte ((_ extract 239 232) w)) + (define-fun indexWord1 ((w Word)) Byte ((_ extract 247 240) w)) + (define-fun indexWord0 ((w Word)) Byte ((_ extract 255 248) w)) + + ; symbolic word indexing + ; a bitshift based version might be more performant here... + (define-fun indexWord ((idx Word) (w Word)) Byte + (ite (bvuge idx (_ bv32 256)) (_ bv0 8) + (ite (= idx (_ bv31 256)) (indexWord31 w) + (ite (= idx (_ bv30 256)) (indexWord30 w) + (ite (= idx (_ bv29 256)) (indexWord29 w) + (ite (= idx (_ bv28 256)) (indexWord28 w) + (ite (= idx (_ bv27 256)) (indexWord27 w) + (ite (= idx (_ bv26 256)) (indexWord26 w) + (ite (= idx (_ bv25 256)) (indexWord25 w) + (ite (= idx (_ bv24 256)) (indexWord24 w) + (ite (= idx (_ bv23 256)) (indexWord23 w) + (ite (= idx (_ bv22 256)) (indexWord22 w) + (ite (= idx (_ bv21 256)) (indexWord21 w) + (ite (= idx (_ bv20 256)) (indexWord20 w) + (ite (= idx (_ bv19 256)) (indexWord19 w) + (ite (= idx (_ bv18 256)) (indexWord18 w) + (ite (= idx (_ bv17 256)) (indexWord17 w) + (ite (= idx (_ bv16 256)) (indexWord16 w) + (ite (= idx (_ bv15 256)) (indexWord15 w) + (ite (= idx (_ bv14 256)) (indexWord14 w) + (ite (= idx (_ bv13 256)) (indexWord13 w) + (ite (= idx (_ bv12 256)) (indexWord12 w) + (ite (= idx (_ bv11 256)) (indexWord11 w) + (ite (= idx (_ bv10 256)) (indexWord10 w) + (ite (= idx (_ bv9 256)) (indexWord9 w) + (ite (= idx (_ bv8 256)) (indexWord8 w) + (ite (= idx (_ bv7 256)) (indexWord7 w) + (ite (= idx (_ bv6 256)) (indexWord6 w) + (ite (= idx (_ bv5 256)) (indexWord5 w) + (ite (= idx (_ bv4 256)) (indexWord4 w) + (ite (= idx (_ bv3 256)) (indexWord3 w) + (ite (= idx (_ bv2 256)) (indexWord2 w) + (ite (= idx (_ bv1 256)) (indexWord1 w) + (indexWord0 w) + )))))))))))))))))))))))))))))))) + ) + + ; buffers + (declare-fun bufLength (Buf) Word) + (define-const emptyBuf Buf ((as const Buf) #b00000000)) + + (define-fun readWord ((idx Word) (buf Buf)) Word + (concat + (select buf idx) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000001)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000002)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000003)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000004)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000005)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000006)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000007)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000008)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000009)) + (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000a)) + (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000b)) + (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000c)) + (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000d)) + (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000e)) + (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000f)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000010)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000011)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000012)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000013)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000014)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000015)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000016)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000017)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000018)) + (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000019)) + (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001a)) + (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001b)) + (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001c)) + (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001d)) + (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001e)) + (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001f)) + ) + ) + + (define-fun writeWord ((idx Word) (val Word) (buf Buf)) Buf + (store (store (store (store (store (store (store (store (store (store (store (store (store (store (store (store (store + (store (store (store (store (store (store (store (store (store (store (store (store (store (store (store buf + (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001f) (indexWord31 val)) + (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001e) (indexWord30 val)) + (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001d) (indexWord29 val)) + (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001c) (indexWord28 val)) + (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001b) (indexWord27 val)) + (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001a) (indexWord26 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000019) (indexWord25 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000018) (indexWord24 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000017) (indexWord23 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000016) (indexWord22 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000015) (indexWord21 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000014) (indexWord20 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000013) (indexWord19 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000012) (indexWord18 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000011) (indexWord17 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000010) (indexWord16 val)) + (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000f) (indexWord15 val)) + (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000e) (indexWord14 val)) + (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000d) (indexWord13 val)) + (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000c) (indexWord12 val)) + (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000b) (indexWord11 val)) + (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000a) (indexWord10 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000009) (indexWord9 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000008) (indexWord8 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000007) (indexWord7 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000006) (indexWord6 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000005) (indexWord5 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000004) (indexWord4 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000003) (indexWord3 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000002) (indexWord2 val)) + (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000001) (indexWord1 val)) + idx (indexWord0 val)) + ) + + ; block context + (declare-fun blockhash (Word) Word) + + ; macros + (define-fun signext ( (b Word) (val Word)) Word + (ite (= b (_ bv0 256)) ((_ sign_extend 248) ((_ extract 7 0) val)) + (ite (= b (_ bv1 256)) ((_ sign_extend 240) ((_ extract 15 0) val)) + (ite (= b (_ bv2 256)) ((_ sign_extend 232) ((_ extract 23 0) val)) + (ite (= b (_ bv3 256)) ((_ sign_extend 224) ((_ extract 31 0) val)) + (ite (= b (_ bv4 256)) ((_ sign_extend 216) ((_ extract 39 0) val)) + (ite (= b (_ bv5 256)) ((_ sign_extend 208) ((_ extract 47 0) val)) + (ite (= b (_ bv6 256)) ((_ sign_extend 200) ((_ extract 55 0) val)) + (ite (= b (_ bv7 256)) ((_ sign_extend 192) ((_ extract 63 0) val)) + (ite (= b (_ bv8 256)) ((_ sign_extend 184) ((_ extract 71 0) val)) + (ite (= b (_ bv9 256)) ((_ sign_extend 176) ((_ extract 79 0) val)) + (ite (= b (_ bv10 256)) ((_ sign_extend 168) ((_ extract 87 0) val)) + (ite (= b (_ bv11 256)) ((_ sign_extend 160) ((_ extract 95 0) val)) + (ite (= b (_ bv12 256)) ((_ sign_extend 152) ((_ extract 103 0) val)) + (ite (= b (_ bv13 256)) ((_ sign_extend 144) ((_ extract 111 0) val)) + (ite (= b (_ bv14 256)) ((_ sign_extend 136) ((_ extract 119 0) val)) + (ite (= b (_ bv15 256)) ((_ sign_extend 128) ((_ extract 127 0) val)) + (ite (= b (_ bv16 256)) ((_ sign_extend 120) ((_ extract 135 0) val)) + (ite (= b (_ bv17 256)) ((_ sign_extend 112) ((_ extract 143 0) val)) + (ite (= b (_ bv18 256)) ((_ sign_extend 104) ((_ extract 151 0) val)) + (ite (= b (_ bv19 256)) ((_ sign_extend 96 ) ((_ extract 159 0) val)) + (ite (= b (_ bv20 256)) ((_ sign_extend 88 ) ((_ extract 167 0) val)) + (ite (= b (_ bv21 256)) ((_ sign_extend 80 ) ((_ extract 175 0) val)) + (ite (= b (_ bv22 256)) ((_ sign_extend 72 ) ((_ extract 183 0) val)) + (ite (= b (_ bv23 256)) ((_ sign_extend 64 ) ((_ extract 191 0) val)) + (ite (= b (_ bv24 256)) ((_ sign_extend 56 ) ((_ extract 199 0) val)) + (ite (= b (_ bv25 256)) ((_ sign_extend 48 ) ((_ extract 207 0) val)) + (ite (= b (_ bv26 256)) ((_ sign_extend 40 ) ((_ extract 215 0) val)) + (ite (= b (_ bv27 256)) ((_ sign_extend 32 ) ((_ extract 223 0) val)) + (ite (= b (_ bv28 256)) ((_ sign_extend 24 ) ((_ extract 231 0) val)) + (ite (= b (_ bv29 256)) ((_ sign_extend 16 ) ((_ extract 239 0) val)) + (ite (= b (_ bv30 256)) ((_ sign_extend 8 ) ((_ extract 247 0) val)) val)))))))))))))))))))))))))))))))) + ; storage + (declare-const abstractStore Storage) + (define-const emptyStore Storage ((as const Storage) ((as const (Array (_ BitVec 256) (_ BitVec 256))) #x0000000000000000000000000000000000000000000000000000000000000000))) + + (define-fun sstore ((addr Word) (key Word) (val Word) (storage Storage)) Storage (store storage addr (store (select storage addr) key val))) + + (define-fun sload ((addr Word) (key Word) (storage Storage)) Word (select (select storage addr) key)) + |] + +declareBufs :: [Builder] -> SMT2 +declareBufs names = SMT2 ("; buffers" : fmap declareBuf names <> ("; buffer lengths" : fmap declareLength names)) cexvars + where + declareBuf n = "(declare-const " <> n <> " (Array (_ BitVec 256) (_ BitVec 8)))" + declareLength n = "(define-const " <> n <> "_length" <> " (_ BitVec 256) (bufLength " <> n <> "))" + cexvars = CexVars + { calldataV = mempty + , buffersV = (fmap toLazyText names) + , blockContextV = mempty + , txContextV = mempty + } + +referencedBufs :: Expr a -> [Builder] +referencedBufs expr = nubOrd (foldExpr go [] expr) + where + go :: Expr a -> [Builder] + go = \case + AbstractBuf s -> [fromText s] + _ -> [] + +referencedBufs' :: Prop -> [Builder] +referencedBufs' = \case + PEq a b -> nubOrd $ referencedBufs a <> referencedBufs b + PLT a b -> nubOrd $ referencedBufs a <> referencedBufs b + PGT a b -> nubOrd $ referencedBufs a <> referencedBufs b + PLEq a b -> nubOrd $ referencedBufs a <> referencedBufs b + PGEq a b -> nubOrd $ referencedBufs a <> referencedBufs b + PAnd a b -> nubOrd $ referencedBufs' a <> referencedBufs' b + POr a b -> nubOrd $ referencedBufs' a <> referencedBufs' b + PNeg a -> referencedBufs' a + PBool _ -> [] + +referencedVars' :: Prop -> [Builder] +referencedVars' = \case + PEq a b -> nubOrd $ referencedVars a <> referencedVars b + PLT a b -> nubOrd $ referencedVars a <> referencedVars b + PGT a b -> nubOrd $ referencedVars a <> referencedVars b + PLEq a b -> nubOrd $ referencedVars a <> referencedVars b + PGEq a b -> nubOrd $ referencedVars a <> referencedVars b + PAnd a b -> nubOrd $ referencedVars' a <> referencedVars' b + POr a b -> nubOrd $ referencedVars' a <> referencedVars' b + PNeg a -> referencedVars' a + PBool _ -> [] + +referencedFrameContext' :: Prop -> [Builder] +referencedFrameContext' = \case + PEq a b -> nubOrd $ referencedFrameContext a <> referencedFrameContext b + PLT a b -> nubOrd $ referencedFrameContext a <> referencedFrameContext b + PGT a b -> nubOrd $ referencedFrameContext a <> referencedFrameContext b + PLEq a b -> nubOrd $ referencedFrameContext a <> referencedFrameContext b + PGEq a b -> nubOrd $ referencedFrameContext a <> referencedFrameContext b + PAnd a b -> nubOrd $ referencedFrameContext' a <> referencedFrameContext' b + POr a b -> nubOrd $ referencedFrameContext' a <> referencedFrameContext' b + PNeg a -> referencedFrameContext' a + PBool _ -> [] + +referencedBlockContext' :: Prop -> [Builder] +referencedBlockContext' = \case + PEq a b -> nubOrd $ referencedBlockContext a <> referencedBlockContext b + PLT a b -> nubOrd $ referencedBlockContext a <> referencedBlockContext b + PGT a b -> nubOrd $ referencedBlockContext a <> referencedBlockContext b + PLEq a b -> nubOrd $ referencedBlockContext a <> referencedBlockContext b + PGEq a b -> nubOrd $ referencedBlockContext a <> referencedBlockContext b + PAnd a b -> nubOrd $ referencedBlockContext' a <> referencedBlockContext' b + POr a b -> nubOrd $ referencedBlockContext' a <> referencedBlockContext' b + PNeg a -> referencedBlockContext' a + PBool _ -> [] + +-- Given a list of 256b VM variable names, create an SMT2 object with the variables declared +declareVars :: [Builder] -> SMT2 +declareVars names = SMT2 (["; variables"] <> fmap declare names) cexvars + where + declare n = "(declare-const " <> n <> " (_ BitVec 256))" + cexvars = CexVars + { calldataV = fmap toLazyText names + , buffersV = mempty + , blockContextV = mempty + , txContextV = mempty + } + +referencedVars :: Expr a -> [Builder] +referencedVars expr = nubOrd (foldExpr go [] expr) + where + go :: Expr a -> [Builder] + go = \case + Var s -> [fromText s] + _ -> [] + +declareFrameContext :: [Builder] -> SMT2 +declareFrameContext names = SMT2 (["; frame context"] <> fmap declare names) cexvars + where + declare n = "(declare-const " <> n <> " (_ BitVec 256))" + cexvars = CexVars + { calldataV = mempty + , buffersV = mempty + , blockContextV = mempty + , txContextV = fmap toLazyText names + } + +referencedFrameContext :: Expr a -> [Builder] +referencedFrameContext expr = nubOrd (foldExpr go [] expr) + where + go :: Expr a -> [Builder] + go = \case + CallValue a -> [fromLazyText $ T.append "callvalue_" (T.pack . show $ a)] + Caller a -> [fromLazyText $ T.append "caller_" (T.pack . show $ a)] + Address a -> [fromLazyText $ T.append "address_" (T.pack . show $ a)] + Balance {} -> error "TODO: BALANCE" + SelfBalance {} -> error "TODO: SELFBALANCE" + Gas {} -> error "TODO: GAS" + _ -> [] + +declareBlockContext :: [Builder] -> SMT2 +declareBlockContext names = SMT2 (["; block context"] <> fmap declare names) cexvars + where + declare n = "(declare-const " <> n <> " (_ BitVec 256))" + cexvars = CexVars + { calldataV = mempty + , buffersV = mempty + , blockContextV = fmap toLazyText names + , txContextV = mempty + } + +referencedBlockContext :: Expr a -> [Builder] +referencedBlockContext expr = nubOrd (foldExpr go [] expr) + where + go :: Expr a -> [Builder] + go = \case + Origin -> ["origin"] + Coinbase -> ["coinbase"] + Timestamp -> ["timestamp"] + BlockNumber -> ["blocknumber"] + PrevRandao -> ["prevrandao"] + GasLimit -> ["gaslimit"] + ChainId -> ["chainid"] + BaseFee -> ["basefee"] + _ -> [] + + +exprToSMT :: Expr a -> Builder +exprToSMT = \case + Lit w -> fromLazyText $ "(_ bv" <> (T.pack $ show (num w :: Integer)) <> " 256)" + Var s -> fromText s + GVar (BufVar n) -> fromLazyText $ "buf" <> (T.pack . show $ n) + GVar (StoreVar n) -> fromLazyText $ "store" <> (T.pack . show $ n) + JoinBytes + z o two three four five six seven + eight nine ten eleven twelve thirteen fourteen fifteen + sixteen seventeen eighteen nineteen twenty twentyone twentytwo twentythree + twentyfour twentyfive twentysix twentyseven twentyeight twentynine thirty thirtyone + -> concatBytes [ + z, o, two, three, four, five, six, seven + , eight, nine, ten, eleven, twelve, thirteen, fourteen, fifteen + , sixteen, seventeen, eighteen, nineteen, twenty, twentyone, twentytwo, twentythree + , twentyfour, twentyfive, twentysix, twentyseven, twentyeight, twentynine, thirty, thirtyone] + + Add a b -> op2 "bvadd" a b + Sub a b -> op2 "bvsub" a b + Mul a b -> op2 "bvmul" a b + Exp a b -> case b of + Lit b' -> expandExp a b' + _ -> error "cannot encode symbolic exponentation into SMT" + Min a b -> + let aenc = exprToSMT a + benc = exprToSMT b in + "(ite (bvule " <> aenc `sp` benc <> ") " <> aenc `sp` benc <> ")" + LT a b -> + let cond = op2 "bvult" a b in + "(ite " <> cond `sp` one `sp` zero <> ")" + SLT a b -> + let cond = op2 "bvslt" a b in + "(ite " <> cond `sp` one `sp` zero <> ")" + GT a b -> + let cond = op2 "bvugt" a b in + "(ite " <> cond `sp` one `sp` zero <> ")" + LEq a b -> + let cond = op2 "bvule" a b in + "(ite " <> cond `sp` one `sp` zero <> ")" + GEq a b -> + let cond = op2 "bvuge" a b in + "(ite " <> cond `sp` one `sp` zero <> ")" + Eq a b -> + let cond = op2 "=" a b in + "(ite " <> cond `sp` one `sp` zero <> ")" + IsZero a -> + let cond = op2 "=" a (Lit 0) in + "(ite " <> cond `sp` one `sp` zero <> ")" + And a b -> op2 "bvand" a b + Or a b -> op2 "bvor" a b + Xor a b -> op2 "bvxor" a b + Not a -> op1 "bvnot" a + SHL a b -> op2 "bvshl" b a + SHR a b -> op2 "bvlshr" b a + SAR a b -> op2 "bvashr" b a + SEx a b -> op2 "signext" a b + Div a b -> op2CheckZero "bvudiv" a b + SDiv a b -> op2CheckZero "bvsdiv" a b + Mod a b -> op2CheckZero "bvurem" a b + SMod a b -> op2CheckZero "bvsrem" a b + -- NOTE: this needs to do the MUL at a higher precision, then MOD, then downcast + MulMod a b c -> + let aExp = exprToSMT a + bExp = exprToSMT b + cExp = exprToSMT c + aLift = "(concat (_ bv0 256) " <> aExp <> ")" + bLift = "(concat (_ bv0 256) " <> bExp <> ")" + cLift = "(concat (_ bv0 256) " <> cExp <> ")" + in "((_ extract 255 0) (ite (= " <> cExp <> " (_ bv0 256)) (_ bv0 512) (bvurem (bvmul " <> aLift `sp` bLift <> ")" <> cLift <> ")))" + EqByte a b -> + let cond = op2 "=" a b in + "(ite " <> cond `sp` one `sp` zero <> ")" + Keccak a -> + let enc = exprToSMT a in + "(keccak " <> enc <> ")" + SHA256 a -> + let enc = exprToSMT a in + "(sha256 " <> enc <> ")" + + CallValue a -> fromLazyText $ T.append "callvalue_" (T.pack . show $ a) + Caller a -> fromLazyText $ T.append "caller_" (T.pack . show $ a) + Address a -> fromLazyText $ T.append "address_" (T.pack . show $ a) + + Origin -> "origin" + BlockHash a -> + let enc = exprToSMT a in + "(blockhash " <> enc <> ")" + Coinbase -> "coinbase" + Timestamp -> "timestamp" + BlockNumber -> "blocknumber" + PrevRandao -> "prevrandao" + GasLimit -> "gaslimit" + ChainId -> "chainid" + BaseFee -> "basefee" + + -- TODO: make me binary... + LitByte b -> fromLazyText $ "(_ bv" <> T.pack (show (num b :: Integer)) <> " 8)" + IndexWord idx w -> case idx of + Lit n -> if n >= 0 && n < 32 + then + let enc = exprToSMT w in + fromLazyText ("(indexWord" <> T.pack (show (num n :: Integer))) `sp` enc <> ")" + else exprToSMT (LitByte 0) + _ -> op2 "indexWord" idx w + ReadByte idx src -> op2 "select" src idx + + ConcreteBuf "" -> "emptyBuf" + ConcreteBuf bs -> writeBytes bs mempty + AbstractBuf s -> fromText s + ReadWord idx prev -> op2 "readWord" idx prev + BufLength b -> op1 "bufLength" b + WriteByte idx val prev -> + let encIdx = exprToSMT idx + encVal = exprToSMT val + encPrev = exprToSMT prev in + "(store " <> encPrev `sp` encIdx `sp` encVal <> ")" + WriteWord idx val prev -> + let encIdx = exprToSMT idx + encVal = exprToSMT val + encPrev = exprToSMT prev in + "(writeWord " <> encIdx `sp` encVal `sp` encPrev <> ")" + CopySlice srcIdx dstIdx size src dst -> + copySlice srcIdx dstIdx size (exprToSMT src) (exprToSMT dst) + EmptyStore -> "emptyStore" + ConcreteStore s -> encodeConcreteStore s + AbstractStore -> "abstractStore" + SStore addr idx val prev -> + let encAddr = exprToSMT addr + encIdx = exprToSMT idx + encVal = exprToSMT val + encPrev = exprToSMT prev in + "(sstore" `sp` encAddr `sp` encIdx `sp` encVal `sp` encPrev <> ")" + SLoad addr idx store -> op3 "sload" addr idx store + + a -> error $ "TODO: implement: " <> show a + where + op1 op a = + let enc = exprToSMT a in + "(" <> op `sp` enc <> ")" + op2 op a b = + let aenc = exprToSMT a + benc = exprToSMT b in + "(" <> op `sp` aenc `sp` benc <> ")" + op3 op a b c = + let aenc = exprToSMT a + benc = exprToSMT b + cenc = exprToSMT c in + "(" <> op `sp` aenc `sp` benc `sp` cenc <> ")" + op2CheckZero op a b = + let aenc = exprToSMT a + benc = exprToSMT b in + "(ite (= " <> benc <> " (_ bv0 256)) (_ bv0 256) " <> "(" <> op `sp` aenc `sp` benc <> "))" + +sp :: Builder -> Builder -> Builder +a `sp` b = a <> (fromText " ") <> b + +zero :: Builder +zero = "(_ bv0 256)" + +one :: Builder +one = "(_ bv1 256)" + +propToSMT :: Prop -> Builder +propToSMT = \case + PEq a b -> op2 "=" a b + PLT a b -> op2 "bvult" a b + PGT a b -> op2 "bvugt" a b + PLEq a b -> op2 "bvule" a b + PGEq a b -> op2 "bvuge" a b + PNeg a -> + let enc = propToSMT a in + "(not " <> enc <> ")" + PAnd a b -> + let aenc = propToSMT a + benc = propToSMT b in + "(and " <> aenc <> " " <> benc <> ")" + POr a b -> + let aenc = propToSMT a + benc = propToSMT b in + "(or " <> aenc <> " " <> benc <> ")" + PBool b -> if b then "true" else "false" + where + op2 op a b = + let aenc = exprToSMT a + benc = exprToSMT b in + "(" <> op <> " " <> aenc <> " " <> benc <> ")" + + +-- ** Execution ** ------------------------------------------------------------------------------- + + +-- | Supported solvers +data Solver + = Z3 + | CVC5 + | Bitwuzla + | Custom Text + +instance Show Solver where + show Z3 = "z3" + show CVC5 = "cvc5" + show Bitwuzla = "bitwuzla" + show (Custom s) = T.unpack s + + +-- | A running solver instance +data SolverInstance = SolverInstance + { _type :: Solver + , _stdin :: Handle + , _stdout :: Handle + , _stderr :: Handle + , _process :: ProcessHandle + } + +-- | A channel representing a group of solvers +newtype SolverGroup = SolverGroup (Chan Task) + +-- | A script to be executed, a list of models to be extracted in the case of a sat result, and a channel where the result should be written +data Task = Task + { script :: SMT2 + , resultChan :: Chan CheckSatResult + } + +-- | The result of a call to (check-sat) +data CheckSatResult + = Sat SMTCex + | Unsat + | Unknown + | Error TS.Text + deriving (Show, Eq) + +isSat :: CheckSatResult -> Bool +isSat (Sat _) = True +isSat _ = False + +isErr :: CheckSatResult -> Bool +isErr (Error _) = True +isErr _ = False + +isUnsat :: CheckSatResult -> Bool +isUnsat Unsat = True +isUnsat _ = False + +checkSat :: SolverGroup -> SMT2 -> IO CheckSatResult +checkSat (SolverGroup taskQueue) script = do + -- prepare result channel + resChan <- newChan + + -- send task to solver group + writeChan taskQueue (Task script resChan) + + -- collect result + readChan resChan + +parseW256 :: SpecConstant -> W256 +parseW256 = parseSC + +parseInteger :: SpecConstant -> Integer +parseInteger = parseSC + +parseW8 :: SpecConstant -> Word8 +parseW8 = parseSC + +parseErr :: (Show a) => a -> b +parseErr res = error $ "Internal Error: cannot parse solver response: " <> show res + +parseVar :: TS.Text -> Expr EWord +parseVar = Var + +parseBlockCtx :: TS.Text -> Expr EWord +parseBlockCtx "origin" = Origin +parseBlockCtx "coinbase" = Coinbase +parseBlockCtx "timestamp" = Timestamp +parseBlockCtx "blocknumber" = BlockNumber +parseBlockCtx "prevrandao" = PrevRandao +parseBlockCtx "gaslimit" = GasLimit +parseBlockCtx "chainid" = ChainId +parseBlockCtx "basefee" = BaseFee +parseBlockCtx t = error $ "Internal Error: cannot parse " <> (TS.unpack t) <> " into an Expr" + +parseFrameCtx :: TS.Text -> Expr EWord +parseFrameCtx name = case TS.unpack name of + ('c':'a':'l':'l':'v':'a':'l':'u':'e':'_':frame) -> CallValue (read frame) + ('c':'a':'l':'l':'e':'r':'_':frame) -> Caller (read frame) + ('a':'d':'d':'r':'e':'s':'s':'_':frame) -> Address (read frame) + t -> error $ "Internal Error: cannot parse " <> t <> " into an Expr" + +getVars :: (TS.Text -> Expr EWord) -> SolverInstance -> [TS.Text] -> IO (Map (Expr EWord) W256) +getVars parseFn inst names = Map.mapKeys parseFn <$> foldM getVar mempty names + where + getVar :: Map TS.Text W256 -> TS.Text -> IO (Map TS.Text W256) + getVar acc name = do + raw <- getValue inst (T.fromStrict name) + let + parsed = case parseCommentFreeFileMsg getValueRes (T.toStrict raw) of + Right (ResSpecific (valParsed :| [])) -> valParsed + r -> parseErr r + val = case parsed of + (TermQualIdentifier ( + Unqualified (IdSymbol symbol)), + TermSpecConstant sc) + -> if symbol == name + then parseW256 sc + else error "Internal Error: solver did not return model for requested value" + r -> parseErr r + pure $ Map.insert name val acc + +getBufs :: SolverInstance -> [TS.Text] -> IO (Map (Expr Buf) ByteString) +getBufs inst names = foldM getBuf mempty names + where + getLength :: TS.Text -> IO Int + getLength name = do + val <- getValue inst (T.fromStrict name <> "_length") + len <- case parseCommentFreeFileMsg getValueRes (T.toStrict val) of + Right (ResSpecific (parsed :| [])) -> case parsed of + (TermQualIdentifier (Unqualified (IdSymbol symbol)), (TermSpecConstant sc)) + -> if symbol == (name <> "_length") + then pure $ parseW256 sc + else error "Internal Error: solver did not return model for requested value" + res -> parseErr res + res -> parseErr res + pure $ if len <= num (maxBound :: Int) + then fromIntegral len + else error $ "Internal Error: buffer: " + <> (TS.unpack name) + <> " is too large to be represented in a ByteString. Length: " + <> show len + + getBuf :: Map (Expr Buf) ByteString -> TS.Text -> IO (Map (Expr Buf) ByteString) + getBuf acc name = do + -- Sometimes the solver gives us back a model for a Buffer that has every + -- element set to some concrete value. This is impossible to represent as + -- a concrete ByteString in haskell (or in any existing computer hardware :D), + -- so we ask the solver to give us back a model for the length of + -- this buffer and then use that to produce a shorter counterexample (by + -- replicating the constant byte up to the length). + len <- getLength name + val <- getValue inst (T.fromStrict name) + buf <- case parseCommentFreeFileMsg getValueRes (T.toStrict val) of + Right (ResSpecific (valParsed :| [])) -> case valParsed of + (TermQualIdentifier (Unqualified (IdSymbol symbol)), term) + -> if symbol == name + then pure $ parseBuf len term + else error "Internal Error: solver did not return model for requested value" + res -> error $ "Internal Error: cannot parse solver response: " <> show res + res -> error $ "Internal Error: cannot parse solver response: " <> show res + let bs = case simplify buf of + ConcreteBuf b -> b + _ -> error "Internal Error: unable to parse solver response into a concrete buffer" + pure $ Map.insert (AbstractBuf name) bs acc + + parseBuf :: Int -> Term -> Expr Buf + parseBuf len = go mempty + where + go env = \case + -- constant arrays + (TermApplication ( + Qualified (IdSymbol "const") ( + SortParameter (IdSymbol "Array") ( + SortSymbol (IdIndexed "BitVec" (IxNumeral "256" :| [])) + :| [SortSymbol (IdIndexed "BitVec" (IxNumeral "8" :| []))] + ) + )) ((TermSpecConstant val :| []))) + -> case val of + SCHexadecimal "00" -> mempty + v -> ConcreteBuf $ BS.replicate len (parseW8 v) + + -- writing a byte over some array + (TermApplication + (Unqualified (IdSymbol "store")) + (base :| [TermSpecConstant idx, TermSpecConstant val]) + ) -> let + pbase = go env base + pidx = parseW256 idx + pval = parseW8 val + in writeByte (Lit pidx) (LitByte pval) pbase + + -- binding a new name + (TermLet ((VarBinding name bound) :| []) term) -> let + pbound = go env bound + in go (Map.insert name pbound env) term + + -- looking up a bound name + (TermQualIdentifier (Unqualified (IdSymbol name))) -> case Map.lookup name env of + Just t -> t + Nothing -> error $ "Internal error: could not find " + <> (TS.unpack name) + <> " in environment mapping" + p -> parseErr p + + +parseSC :: (Num a, Eq a) => SpecConstant -> a +parseSC (SCHexadecimal a) = fst . head . Numeric.readHex . T.unpack . T.fromStrict $ a +parseSC sc = error $ "Internal Error: cannot parse: " <> show sc + +withSolvers :: Solver -> Natural -> Maybe Natural -> (SolverGroup -> IO a) -> IO a +withSolvers solver count timeout cont = do + -- spawn solvers + instances <- mapM (const $ spawnSolver solver timeout) [1..count] + + -- spawn orchestration thread + taskQueue <- newChan + availableInstances <- newChan + forM_ instances (writeChan availableInstances) + orchestrateId <- forkIO $ orchestrate taskQueue availableInstances + + -- run continuation with task queue + res <- cont (SolverGroup taskQueue) + + -- cleanup and return results + mapM_ stopSolver instances + killThread orchestrateId + pure res + where + orchestrate queue avail = do + task <- readChan queue + inst <- readChan avail + _ <- forkIO $ runTask task inst avail + orchestrate queue avail + + runTask (Task (SMT2 cmds cexvars) r) inst availableInstances = do + -- reset solver and send all lines of provided script + out <- sendScript inst (SMT2 ("(reset)" : cmds) cexvars) + case out of + -- if we got an error then return it + Left e -> writeChan r (Error ("error while writing SMT to solver: " <> T.toStrict e)) + -- otherwise call (check-sat), parse the result, and send it down the result channel + Right () -> do + sat <- sendLine inst "(check-sat)" + res <- case sat of + "sat" -> do + calldatamodels <- getVars parseVar inst (fmap T.toStrict $ calldataV cexvars) + buffermodels <- getBufs inst (fmap T.toStrict $ buffersV cexvars) + blockctxmodels <- getVars parseBlockCtx inst (fmap T.toStrict $ blockContextV cexvars) + txctxmodels <- getVars parseFrameCtx inst (fmap T.toStrict $ txContextV cexvars) + pure $ Sat $ SMTCex + { vars = calldatamodels + , buffers = buffermodels + , blockContext = blockctxmodels + , txContext = txctxmodels + } + "unsat" -> pure Unsat + "timeout" -> pure Unknown + "unknown" -> pure Unknown + _ -> pure . Error $ T.toStrict $ "Unable to parse solver output: " <> sat + writeChan r res + + -- put the instance back in the list of available instances + writeChan availableInstances inst + +-- | Arguments used when spawing a solver instance +solverArgs :: Solver -> Maybe (Natural) -> [Text] +solverArgs solver timeout = case solver of + Bitwuzla -> error "TODO: Bitwuzla args" + Z3 -> + [ "-in" ] + CVC5 -> + [ "--lang=smt" + , "--no-interactive" + , "--produce-models" + , "--tlimit-per=" <> T.pack (show (1000 * fromMaybe 10 timeout)) + ] + Custom _ -> [] + +-- | Spawns a solver instance, and sets the various global config options that we use for our queries +spawnSolver :: Solver -> Maybe (Natural) -> IO SolverInstance +spawnSolver solver timeout = do + let cmd = (proc (show solver) (fmap T.unpack $ solverArgs solver timeout)) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } + (Just stdin, Just stdout, Just stderr, process) <- createProcess cmd + hSetBuffering stdin (BlockBuffering (Just 1000000)) + let solverInstance = SolverInstance solver stdin stdout stderr process + case timeout of + Nothing -> pure solverInstance + Just t -> case solver of + CVC5 -> pure solverInstance + _ -> do + _ <- sendLine' solverInstance $ "(set-option :timeout " <> T.pack (show t) <> ")" + pure solverInstance + +-- | Cleanly shutdown a running solver instnace +stopSolver :: SolverInstance -> IO () +stopSolver (SolverInstance _ stdin stdout stderr process) = cleanupProcess (Just stdin, Just stdout, Just stderr, process) + +-- | Sends a list of commands to the solver. Returns the first error, if there was one. +sendScript :: SolverInstance -> SMT2 -> IO (Either Text ()) +sendScript solver (SMT2 cmds _) = do + sendLine' solver (T.unlines $ fmap toLazyText cmds) + pure $ Right() + +-- | Sends a single command to the solver, returns the first available line from the output buffer +sendCommand :: SolverInstance -> Text -> IO Text +sendCommand inst cmd = do + -- trim leading whitespace + let cmd' = T.dropWhile isSpace cmd + case T.unpack cmd' of + "" -> pure "success" -- ignore blank lines + ';' : _ -> pure "success" -- ignore comments + _ -> sendLine inst cmd' + +-- | Sends a string to the solver and appends a newline, returns the first available line from the output buffer +sendLine :: SolverInstance -> Text -> IO Text +sendLine (SolverInstance _ stdin stdout _ _) cmd = do + T.hPutStr stdin (T.append cmd "\n") + hFlush stdin + T.hGetLine stdout + +-- | Sends a string to the solver and appends a newline, doesn't return stdout +sendLine' :: SolverInstance -> Text -> IO () +sendLine' (SolverInstance _ stdin _ _ _) cmd = do + T.hPutStr stdin (T.append cmd "\n") + hFlush stdin + +-- | Returns a string representation of the model for the requested variable +getValue :: SolverInstance -> Text -> IO Text +getValue (SolverInstance _ stdin stdout _ _) var = do + T.hPutStr stdin (T.append (T.append "(get-value (" var) "))\n") + hFlush stdin + fmap (T.unlines . reverse) (readSExpr stdout) + +-- | Reads lines from h until we have a balanced sexpr +readSExpr :: Handle -> IO [Text] +readSExpr h = go 0 0 [] + where + go 0 0 _ = do + line <- T.hGetLine h + let ls = T.length $ T.filter (== '(') line + rs = T.length $ T.filter (== ')') line + if ls == rs + then pure [line] + else go ls rs [line] + go ls rs prev = do + line <- T.hGetLine h + let ls' = T.length $ T.filter (== '(') line + rs' = T.length $ T.filter (== ')') line + if (ls + ls') == (rs + rs') + then pure $ line : prev + else go (ls + ls') (rs + rs') (line : prev) + + + +-- ** Helpers ** --------------------------------------------------------------------------------- + + +-- | Stores a region of src into dst +copySlice :: Expr EWord -> Expr EWord -> Expr EWord -> Builder -> Builder -> Builder +copySlice srcOffset dstOffset size@(Lit _) src dst + | size == (Lit 0) = dst + | otherwise = + let size' = (sub size (Lit 1)) + encDstOff = exprToSMT (add dstOffset size') + encSrcOff = exprToSMT (add srcOffset size') + child = copySlice srcOffset dstOffset size' src dst in + "(store " <> child `sp` encDstOff `sp` "(select " <> src `sp` encSrcOff <> "))" +copySlice _ _ _ _ _ = error "TODO: implement copySlice with a symbolically sized region" + +-- | Unrolls an exponentiation into a series of multiplications +expandExp :: Expr EWord -> W256 -> Builder +expandExp base expnt + | expnt == 1 = exprToSMT base + | otherwise = + let b = exprToSMT base + n = expandExp base (expnt - 1) in + "(bvmul " <> b `sp` n <> ")" + +-- | Concatenates a list of bytes into a larger bitvector +concatBytes :: [Expr Byte] -> Builder +concatBytes bytes = + let bytesRev = reverse bytes + a2 = exprToSMT (head bytesRev) in + foldl wrap a2 $ tail bytesRev + where + wrap inner byte = + let byteSMT = exprToSMT byte in + "(concat " <> byteSMT `sp` inner <> ")" + +-- | Concatenates a list of bytes into a larger bitvector +writeBytes :: ByteString -> Expr Buf -> Builder +writeBytes bytes buf = snd $ BS.foldl' wrap (0, exprToSMT buf) bytes + where + -- we don't need to store zeros if the base buffer is empty + skipZeros = buf == mempty + wrap :: (Int, Builder) -> Word8 -> (Int, Builder) + wrap (idx, inner) byte = + if skipZeros && byte == 0 + then (idx + 1, inner) + else let + byteSMT = exprToSMT (LitByte byte) + idxSMT = exprToSMT . Lit . num $ idx + in (idx + 1, "(store " <> inner `sp` idxSMT `sp` byteSMT <> ")") + +encodeConcreteStore :: Map W256 (Map W256 W256) -> Builder +encodeConcreteStore s = foldl encodeWrite "emptyStore" writes + where + asList = fmap (second Map.toList) $ Map.toList s + writes = concatMap (\(addr, ws) -> fmap (\(k, v) -> (addr, k, v)) ws) asList + encodeWrite prev (addr, key, val) = let + encAddr = exprToSMT (Lit addr) + encKey = exprToSMT (Lit key) + encVal = exprToSMT (Lit val) + in "(sstore " <> encAddr `sp` encKey `sp` encVal `sp` prev <> ")" diff --git a/src/EVM/Solidity.hs b/src/EVM/Solidity.hs --- a/src/EVM/Solidity.hs +++ b/src/EVM/Solidity.hs @@ -2,7 +2,6 @@ {-# Language DataKinds #-} {-# Language StrictData #-} {-# Language TemplateHaskell #-} -{-# Language OverloadedStrings #-} {-# Language QuasiQuotes #-} module EVM.Solidity @@ -59,11 +58,11 @@ , astIdMap , astSrcMap , containsLinkerHole + , makeSourceCache ) where import EVM.ABI import EVM.Types -import Data.SBV import Control.Applicative import Control.Monad @@ -72,6 +71,7 @@ import Data.Aeson hiding (json) import Data.Aeson.Types import Data.Aeson.Lens +import qualified Data.Aeson.KeyMap as KeyMap import Data.Scientific import Data.ByteString (ByteString) import Data.ByteString.Lazy (toStrict) @@ -79,8 +79,8 @@ import Data.Foldable import Data.Map.Strict (Map) import Data.Maybe +import Data.Word (Word8, Word32) import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty import Data.Semigroup import Data.Sequence (Seq) import Data.Text (Text, pack, intercalate) @@ -100,6 +100,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.Vector as Vector +import qualified Data.List.NonEmpty as NonEmpty import Data.List (sort, isPrefixOf, isInfixOf, elemIndex, tails, findIndex) data StorageItem = StorageItem { @@ -297,7 +298,7 @@ Nothing -> return Nothing Just (contracts, asts, sources) -> do sourceCache <- makeSourceCache sources asts - return $! Just (contracts, sourceCache) + return (Just (contracts, sourceCache)) yul :: Text -> Text -> IO (Maybe ByteString) yul contract src = do @@ -362,8 +363,8 @@ in SolcContract { _runtimeCode = theRuntimeCode, _creationCode = theCreationCode, - _runtimeCodehash = keccak (stripBytecodeMetadata theRuntimeCode), - _creationCodehash = keccak (stripBytecodeMetadata 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, @@ -405,8 +406,8 @@ in (s <> ":" <> c, (SolcContract { _runtimeCode = theRuntimeCode, _creationCode = theCreationCode, - _runtimeCodehash = keccak (stripBytecodeMetadata theRuntimeCode), - _creationCodehash = keccak (stripBytecodeMetadata theCreationCode), + _runtimeCodehash = keccak' (stripBytecodeMetadata theRuntimeCode), + _creationCodehash = keccak' (stripBytecodeMetadata theCreationCode), _runtimeSrcmap = force "internal error: srcmap-runtime" (makeSrcMaps (runtime ^?! key "sourceMap" . _String)), _creationSrcmap = force "internal error: srcmap" (makeSrcMaps (creation ^?! key "sourceMap" . _String)), _contractName = s <> ":" <> c, @@ -444,7 +445,7 @@ let relevant = filter (\y -> "event" == y ^?! key "type" . _String) abis f abi = - ( keccak (encodeUtf8 (signature abi)) + ( keccak' (encodeUtf8 (signature abi)) , Event (abi ^?! key "name" . _String) (case abi ^?! key "anonymous" . _Bool of @@ -466,7 +467,7 @@ let relevant = filter (\y -> "error" == y ^?! key "type" . _String) abis f abi = - ( stripKeccak $ keccak (encodeUtf8 (signature abi)) + ( stripKeccak $ keccak' (encodeUtf8 (signature abi)) , SolError (abi ^?! key "name" . _String) (map (\y -> ( force "internal error: type" (parseTypeName' y))) @@ -677,11 +678,11 @@ Nothing -> bs Just (b, _) -> b -stripBytecodeMetadataSym :: [SWord 8] -> [SWord 8] +stripBytecodeMetadataSym :: [Expr Byte] -> [Expr Byte] stripBytecodeMetadataSym b = let concretes :: [Maybe Word8] - concretes = (fmap fromSized) . unliteral <$> b + concretes = unlitByte <$> b bzzrs :: [[Maybe Word8]] bzzrs = fmap (Just) . BS.unpack <$> knownBzzrPrefixes candidates = (flip Data.List.isInfixOf concretes) <$> bzzrs @@ -714,8 +715,8 @@ 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 + let t = foldMap f (KeyMap.elems x) + in case KeyMap.lookup "id" x of Nothing -> t Just (Number i) -> t <> Map.singleton (round i) v Just _ -> t diff --git a/src/EVM/Stepper.hs b/src/EVM/Stepper.hs --- a/src/EVM/Stepper.hs +++ b/src/EVM/Stepper.hs @@ -23,8 +23,6 @@ -- -- 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) @@ -33,7 +31,7 @@ import qualified Control.Monad.State.Class as State import qualified EVM.Exec import Data.Text (Text) -import EVM.Types (Buffer) +import EVM.Types (Expr, EType(..)) import EVM (EVM, VM, VMResult (VMFailure, VMSuccess), Error (Query, Choose), Query, Choose) import qualified EVM @@ -50,13 +48,13 @@ Run :: Action VM -- | Wait for a query to be resolved - Wait :: Query -> Action () + Wait :: Query -> Action () -- | Multiple things can happen Ask :: Choose -> Action () -- | Embed a VM state transformation - EVM :: EVM a -> Action a + EVM :: EVM a -> Action a -- | Perform an IO action IOAct :: StateT VM IO a -> Action a -- they should all just be this? @@ -85,7 +83,7 @@ evmIO = singleton . IOAct -- | Run the VM until final result, resolving all queries -execFully :: Stepper (Either Error Buffer) +execFully :: Stepper (Either Error (Expr Buf)) execFully = exec >>= \case VMFailure (Query q) -> diff --git a/src/EVM/SymExec.hs b/src/EVM/SymExec.hs --- a/src/EVM/SymExec.hs +++ b/src/EVM/SymExec.hs @@ -1,141 +1,201 @@ {-# Language DataKinds #-} -{-# Language OverloadedStrings #-} -{-# Language TypeApplications #-} module EVM.SymExec where import Prelude hiding (Word) import Control.Lens hiding (pre) -import EVM hiding (Query, push) +import EVM hiding (Query, Revert, push) import qualified EVM import EVM.Exec import qualified EVM.Fetch as Fetch import EVM.ABI +import EVM.SMT +import EVM.Traversals +import qualified EVM.Expr as Expr import EVM.Stepper (Stepper) import qualified EVM.Stepper as Stepper import qualified Control.Monad.Operational as Operational import Control.Monad.State.Strict hiding (state) -import Data.Maybe (catMaybes, fromMaybe) import EVM.Types import EVM.Concrete (createAddress) import qualified EVM.FeeSchedule as FeeSchedule -import Data.SBV.Trans.Control -import Data.SBV.Trans hiding (distinct, Word) -import Data.SBV hiding (runSMT, newArray_, addAxiom, distinct, sWord8s, Word) -import Data.Vector (toList, fromList) -import Data.Tree import Data.DoubleWord (Word256) - -import Data.ByteString (ByteString, pack) -import qualified Data.ByteString.Lazy as Lazy -import qualified Data.ByteString as BS -import Data.Text (Text, splitOn, unpack) +import Control.Concurrent.Async +import Data.Maybe +import Data.List (foldl') +import Data.Tuple (swap) +import Data.ByteString (ByteString) +import Data.List (find) +import Data.ByteString (null, pack) import qualified Control.Monad.State.Class as State -import Control.Applicative +import Data.Bifunctor (first, second) +import Data.Text (Text) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TL +import EVM.Format (formatExpr, indent, formatBinary) data ProofResult a b c = Qed a | Cex b | Timeout c -type VerifyResult = ProofResult (Tree BranchInfo) (Tree BranchInfo) (Tree BranchInfo) + deriving (Show, Eq) +type VerifyResult = ProofResult () (Expr End, SMTCex) (Expr End) type EquivalenceResult = ProofResult ([VM], [VM]) VM () --- | Convenience functions for generating large symbolic byte strings -sbytes32, sbytes128, sbytes256, sbytes512, sbytes1024 :: Query ([SWord 8]) -sbytes32 = toBytes <$> freshVar_ @ (WordN 256) -sbytes128 = toBytes <$> freshVar_ @ (WordN 1024) -sbytes256 = liftA2 (++) sbytes128 sbytes128 -sbytes512 = liftA2 (++) sbytes256 sbytes256 -sbytes1024 = liftA2 (++) sbytes512 sbytes512 +isQed :: ProofResult a b c -> Bool +isQed (Qed _) = True +isQed _ = False -mkByte :: Query [SWord 8] -mkByte = do x <- freshVar_ - return [x] +containsA :: Eq a => Eq b => Eq c => ProofResult a b c -> [(d , e, ProofResult a b c)] -> Bool +containsA a lst = isJust $ Data.List.find (\(_, _, c) -> c == a) lst --- | Abstract calldata argument generation -symAbiArg :: AbiType -> Query ([SWord 8], W256) -symAbiArg (AbiUIntType n) | n `mod` 8 == 0 && n <= 256 = - do x <- concatMapM (const mkByte) [0..(n `div` 8) - 1] - return (padLeft' 32 x, 32) - | otherwise = error "bad type" +data VeriOpts = VeriOpts + { simp :: Bool + , debug :: Bool + , maxIter :: Maybe Integer + , askSmtIters :: Maybe Integer + , rpcInfo :: Fetch.RpcInfo + } + deriving (Eq, Show) -symAbiArg (AbiIntType n) | n `mod` 8 == 0 && n <= 256 = - do x <- concatMapM (const mkByte) [(0 :: Int) ..(n `div` 8) - 1] - return (padLeft' 32 x, 32) +defaultVeriOpts :: VeriOpts +defaultVeriOpts = VeriOpts + { simp = True + , debug = False + , maxIter = Nothing + , askSmtIters = Nothing + , rpcInfo = Nothing + } - | otherwise = error "bad type" -symAbiArg AbiBoolType = - do x <- mkByte - return (padLeft' 32 x, 32) +rpcVeriOpts :: (Fetch.BlockNumber, Text) -> VeriOpts +rpcVeriOpts info = defaultVeriOpts { rpcInfo = Just info } -symAbiArg AbiAddressType = - do x <- concatMapM (const mkByte) [(0 :: Int)..19] - return (padLeft' 32 x, 32) +debugVeriOpts :: VeriOpts +debugVeriOpts = defaultVeriOpts { debug = True } -symAbiArg (AbiBytesType n) | n <= 32 = - do x <- concatMapM (const mkByte) [0..n - 1] - return (padLeft' 32 x, 32) +extractCex :: VerifyResult -> Maybe (Expr End, SMTCex) +extractCex (Cex c) = Just c +extractCex _ = Nothing - | otherwise = error "bad type" +inRange :: Int -> Expr EWord -> Prop +inRange sz e = PAnd (PGEq e (Lit 0)) (PLEq e (Lit $ 2 ^ sz - 1)) --- TODO: is this encoding correct? -symAbiArg (AbiArrayType len typ) = - do args <- mapM symAbiArg (replicate len typ) - return (litBytes (encodeAbiValue (AbiUInt 256 (fromIntegral len))) <> (concat $ fst <$> args), - 32 + (sum $ snd <$> args)) +bool :: Expr EWord -> Prop +bool e = POr (PEq e (Lit 1)) (PEq e (Lit 0)) -symAbiArg (AbiTupleType tuple) = - do args <- mapM symAbiArg (toList tuple) - return (concat $ fst <$> args, sum $ snd <$> args) -symAbiArg n = - error $ "Unsupported symbolic abiencoding for" - <> show n - <> ". Please file an issue at https://github.com/dapphub/dapptools if you really need this." +-- | Abstract calldata argument generation +symAbiArg :: Text -> AbiType -> CalldataFragment +symAbiArg name = \case + AbiUIntType n -> + if n `mod` 8 == 0 && n <= 256 + then let v = Var name in St [inRange n v] v + else error "bad type" + AbiIntType n -> + if n `mod` 8 == 0 && n <= 256 + -- TODO: is this correct? + then let v = Var name in St [inRange n v] v + else error "bad type" + AbiBoolType -> let v = Var name in St [bool v] v + AbiAddressType -> let v = Var name in St [inRange 160 v] v + AbiBytesType n + -> if n > 0 && n <= 32 + then let v = Var name in St [inRange (n * 8) v] v + else error "bad type" + AbiArrayType sz tp -> Comp $ fmap (\n -> symAbiArg (name <> n) tp) [T.pack (show n) | n <- [0..sz-1]] + t -> error $ "TODO: symbolic abi encoding for " <> show t +data CalldataFragment + = St [Prop] (Expr EWord) + | Dy [Prop] (Expr EWord) (Expr Buf) + | Comp [CalldataFragment] + deriving (Show, Eq) + -- | Generates calldata matching given type signature, optionally specialized -- with concrete arguments. -- Any argument given as "" or omitted at the tail of the list are -- kept symbolic. -symCalldata :: Text -> [AbiType] -> [String] -> Query ([SWord 8], W256) -symCalldata sig typesignature concreteArgs = +symCalldata :: Text -> [AbiType] -> [String] -> Expr Buf -> (Expr Buf, [Prop]) +symCalldata sig typesignature concreteArgs base = let args = concreteArgs <> replicate (length typesignature - length concreteArgs) "" - mkArg typ "" = symAbiArg typ - mkArg typ arg = let n = litBytes . encodeAbiValue $ makeAbiValue typ arg - in return (n, num (length n)) - sig' = litBytes $ selector sig - in do calldatas <- zipWithM mkArg typesignature args - return (sig' <> concat (fst <$> calldatas), 4 + (sum $ snd <$> calldatas)) + mkArg :: AbiType -> String -> Int -> CalldataFragment + mkArg typ "" n = symAbiArg (T.pack $ "arg" <> show n) typ + mkArg typ arg _ = let v = makeAbiValue typ arg + in case v of + AbiUInt _ w -> St [] . Lit . num $ w + AbiInt _ w -> St [] . Lit . num $ w + AbiAddress w -> St [] . Lit . num $ w + AbiBool w -> St [] . Lit $ if w then 1 else 0 + _ -> error "TODO" + calldatas = zipWith3 mkArg typesignature args [1..] + (cdBuf, props) = combineFragments calldatas base + withSelector = writeSelector cdBuf sig + sizeConstraints + = (Expr.bufLength withSelector .>= cdLen calldatas) + .&& (Expr.bufLength withSelector .< (Lit (2 ^ (64 :: Integer)))) + in (withSelector, sizeConstraints : props) -abstractVM :: Maybe (Text, [AbiType]) -> [String] -> ByteString -> StorageModel -> Query VM -abstractVM typesignature concreteArgs x storagemodel = do - (cd', cdlen, cdconstraint) <- - case typesignature of - Nothing -> do cd <- sbytes256 - len <- freshVar_ - return (cd, var "calldataLength" len, (len .<= 256, Todo "calldatalength < 256" [])) - Just (name, typs) -> do (cd, cdlen) <- symCalldata name typs concreteArgs - return (cd, S (Literal cdlen) (literal $ num cdlen), (sTrue, Todo "Trivial" [])) - symstore <- case storagemodel of - SymbolicS -> Symbolic [] <$> freshArray_ Nothing - InitialS -> Symbolic [] <$> freshArray_ (Just 0) - ConcreteS -> return $ Concrete mempty - c <- SAddr <$> freshVar_ - value' <- var "CALLVALUE" <$> freshVar_ - return $ loadSymVM (RuntimeCode (ConcreteBuffer x)) symstore storagemodel c value' (SymbolicBuffer cd', cdlen) & over constraints ((<>) [cdconstraint]) +cdLen :: [CalldataFragment] -> Expr EWord +cdLen = go (Lit 4) + where + go acc = \case + [] -> acc + (hd:tl) -> case hd of + St _ _ -> go (Expr.add acc (Lit 32)) tl + _ -> error "unsupported" -loadSymVM :: ContractCode -> Storage -> StorageModel -> SAddr -> SymWord -> (Buffer, SymWord) -> VM -loadSymVM x initStore model addr callvalue' calldata' = +writeSelector :: Expr Buf -> Text -> Expr Buf +writeSelector buf sig = writeSel (Lit 0) $ writeSel (Lit 1) $ writeSel (Lit 2) $ writeSel (Lit 3) buf + where + sel = ConcreteBuf $ selector sig + writeSel idx = Expr.writeByte idx (Expr.readByte idx sel) + +combineFragments :: [CalldataFragment] -> Expr Buf -> (Expr Buf, [Prop]) +combineFragments fragments base = go (Lit 4) fragments (base, []) + where + go :: Expr EWord -> [CalldataFragment] -> (Expr Buf, [Prop]) -> (Expr Buf, [Prop]) + go _ [] acc = acc + go idx (f:rest) (buf, ps) = case f of + St p w -> go (Expr.add idx (Lit 32)) rest (Expr.writeWord idx w buf, p <> ps) + s -> error $ "unsupported cd fragment: " <> show s + + +abstractVM :: Maybe (Text, [AbiType]) -> [String] -> ByteString -> Maybe Precondition -> StorageModel -> VM +abstractVM typesignature concreteArgs contractCode maybepre storagemodel = finalVm + where + (calldata', calldataProps) = case typesignature of + Nothing -> (AbstractBuf "txdata", []) + Just (name, typs) -> symCalldata name typs concreteArgs (AbstractBuf "txdata") + store = case storagemodel of + SymbolicS -> AbstractStore + InitialS -> EmptyStore + ConcreteS -> ConcreteStore mempty + caller' = Caller 0 + value' = CallValue 0 + code' = RuntimeCode $ fromJust $ Expr.toList (ConcreteBuf contractCode) + vm' = loadSymVM code' store caller' value' calldata' calldataProps + precond = case maybepre of + Nothing -> [] + Just p -> [p vm'] + finalVm = vm' & over constraints (<> precond) + +loadSymVM :: ContractCode -> Expr Storage -> Expr EWord -> Expr EWord -> Expr Buf -> [Prop] -> VM +loadSymVM x initStore addr callvalue' calldata' calldataProps = (makeVm $ VMOpts - { vmoptContract = contractWithStore x initStore - , vmoptCalldata = calldata' + { vmoptContract = initialContract x + , vmoptCalldata = (calldata', calldataProps) , vmoptValue = callvalue' + , vmoptStorageBase = Symbolic , vmoptAddress = createAddress ethrunAddress 1 , vmoptCaller = addr , vmoptOrigin = ethrunAddress --todo: generalize , vmoptCoinbase = 0 , vmoptNumber = 0 - , vmoptTimestamp = 0 + , vmoptTimestamp = (Lit 0) , vmoptBlockGaslimit = 0 , vmoptGasprice = 0 - , vmoptDifficulty = 0 + , vmoptPrevRandao = 42069 , vmoptGas = 0xffffffffffffffff , vmoptGaslimit = 0xffffffffffffffff , vmoptBaseFee = 0 @@ -144,77 +204,30 @@ , vmoptSchedule = FeeSchedule.berlin , vmoptChainId = 1 , vmoptCreate = False - , vmoptStorageModel = model , vmoptTxAccessList = mempty , vmoptAllowFFI = False }) & set (env . contracts . at (createAddress ethrunAddress 1)) - (Just (contractWithStore x initStore)) + (Just (initialContract x)) + & set (env . EVM.storage) initStore -data BranchInfo = BranchInfo - { _vm :: VM, - _branchCondition :: Maybe Whiff - } -doInterpret :: Fetch.Fetcher -> Maybe Integer -> Maybe Integer -> VM -> Query (Tree BranchInfo) -doInterpret fetcher maxIter askSmtIters vm = let - f (vm', cs) = Node (BranchInfo (if null cs then vm' else vm) Nothing) cs - in f <$> interpret' fetcher maxIter askSmtIters vm - -interpret' :: Fetch.Fetcher -> Maybe Integer -> Maybe Integer -> VM -> Query (VM, [Tree BranchInfo]) -interpret' fetcher maxIter askSmtIters vm = let - cont s = interpret' fetcher maxIter askSmtIters $ execState s vm - in case view EVM.result vm of - - Nothing -> cont exec1 - - Just (VMFailure (EVM.Query q@(PleaseAskSMT _ _ continue))) -> let - codelocation = getCodeLocation vm - iteration = num $ fromMaybe 0 $ view (iterations . at codelocation) vm - -- as an optimization, we skip consulting smt - -- if we've been at the location less than 5 times - in if iteration < (fromMaybe 5 askSmtIters) - then cont $ continue EVM.Unknown - else io (fetcher q) >>= cont - - Just (VMFailure (EVM.Query q)) -> io (fetcher q) >>= cont - - Just (VMFailure (Choose (EVM.PleaseChoosePath whiff continue))) - -> case maxIterationsReached vm maxIter of - Nothing -> let - lvm = execState (continue True) vm - rvm = execState (continue False) vm - in do - push 1 - (leftvm, left) <- interpret' fetcher maxIter askSmtIters lvm - pop 1 - push 1 - (rightvm, right) <- interpret' fetcher maxIter askSmtIters rvm - pop 1 - return (vm, [Node (BranchInfo leftvm (Just whiff)) left, Node (BranchInfo rightvm (Just whiff)) right]) - Just n -> cont $ continue (not n) - - Just _ - -> return (vm, []) - --- | Interpreter which explores all paths at --- | branching points. --- | returns a list of possible final evm states +-- | Interpreter which explores all paths at branching points. +-- returns an Expr representing the possible executions interpret :: Fetch.Fetcher -> Maybe Integer -- max iterations -> Maybe Integer -- ask smt iterations - -> Stepper a - -> StateT VM Query [a] + -> Stepper (Expr End) + -> StateT VM IO (Expr End) interpret fetcher maxIter askSmtIters = eval . Operational.view where eval - :: Operational.ProgramView Stepper.Action a - -> StateT VM Query [a] + :: Operational.ProgramView Stepper.Action (Expr End) + -> StateT VM IO (Expr End) - eval (Operational.Return x) = - pure [x] + eval (Operational.Return x) = pure x eval (action Operational.:>>= k) = case action of @@ -223,20 +236,19 @@ Stepper.Run -> run >>= interpret fetcher maxIter askSmtIters . k Stepper.IOAct q -> - mapStateT io q >>= interpret fetcher maxIter askSmtIters . k - Stepper.Ask (EVM.PleaseChoosePath _ continue) -> do + mapStateT liftIO q >>= interpret fetcher maxIter askSmtIters . k + Stepper.Ask (EVM.PleaseChoosePath cond continue) -> do + assign result Nothing vm <- get case maxIterationsReached vm maxIter of + -- TODO: parallelise Nothing -> do - push 1 a <- interpret fetcher maxIter askSmtIters (Stepper.evm (continue True) >>= k) put vm - pop 1 - push 1 b <- interpret fetcher maxIter askSmtIters (Stepper.evm (continue False) >>= k) - pop 1 - return $ a <> b + return $ ITE cond a b Just n -> + -- Let's escape the loop. We give no guarantees at this point interpret fetcher maxIter askSmtIters (Stepper.evm (continue (not n)) >>= k) Stepper.Wait q -> do let performQuery = do @@ -270,12 +282,14 @@ then view (cache . path . at (codelocation, iters - 1)) vm else Nothing -type Precondition = VM -> SBool -type Postcondition = (VM, VM) -> SBool -checkAssert :: [Word256] -> ByteString -> Maybe (Text, [AbiType]) -> [String] -> Query (VerifyResult, VM) -checkAssert errs c signature' concreteArgs = verifyContract c signature' concreteArgs SymbolicS (const sTrue) (Just $ checkAssertions errs) +type Precondition = VM -> Prop +type Postcondition = VM -> Expr End -> Prop + +checkAssert :: SolverGroup -> [Word256] -> ByteString -> Maybe (Text, [AbiType]) -> [String] -> VeriOpts -> IO (Expr End, [VerifyResult]) +checkAssert solvers errs c signature' concreteArgs opts = verifyContract solvers c signature' concreteArgs opts SymbolicS Nothing (Just $ checkAssertions errs) + {- |Checks if an assertion violation has been encountered hevm recognises the following as an assertion violation: @@ -296,10 +310,10 @@ see: https://docs.soliditylang.org/en/v0.8.6/control-structures.html?highlight=Panic#panic-via-assert-and-error-via-require -} checkAssertions :: [Word256] -> Postcondition -checkAssertions errs (_, out) = case view result out of - Just (EVM.VMFailure (EVM.UnrecognizedOpcode 254)) -> sFalse - Just (EVM.VMFailure (EVM.Revert msg)) -> if msg `elem` (fmap panicMsg errs) then sFalse else sTrue - _ -> sTrue +checkAssertions errs _ = \case + Revert _ (ConcreteBuf msg) -> PBool $ msg `notElem` (fmap panicMsg errs) + Revert _ b -> foldl' PAnd (PBool True) (fmap (PNeg . PEq b . ConcreteBuf . panicMsg) errs) + _ -> PBool True -- |By default hevm checks for all assertions except those which result from arithmetic overflow defaultPanicCodes :: [Word256] @@ -312,13 +326,10 @@ panicMsg :: Word256 -> ByteString panicMsg err = (selector "Panic(uint256)") <> (encodeAbiValue $ AbiUInt 256 err) -verifyContract :: ByteString -> Maybe (Text, [AbiType]) -> [String] -> StorageModel -> Precondition -> Maybe Postcondition -> Query (VerifyResult, VM) -verifyContract theCode signature' concreteArgs storagemodel pre maybepost = do - preStateRaw <- abstractVM signature' concreteArgs theCode storagemodel - -- add the pre condition to the pathconditions to ensure that we are only exploring valid paths - let preState = over constraints ((++) [(pre preStateRaw, Todo "assumptions" [])]) preStateRaw - v <- verify preState Nothing Nothing Nothing maybepost - return (v, preState) +verifyContract :: SolverGroup -> ByteString -> Maybe (Text, [AbiType]) -> [String] -> VeriOpts -> StorageModel -> Maybe Precondition -> Maybe Postcondition -> IO (Expr End, [VerifyResult]) +verifyContract solvers theCode signature' concreteArgs opts storagemodel maybepre maybepost = do + let preState = abstractVM signature' concreteArgs theCode maybepre storagemodel + verify solvers opts preState maybepost pruneDeadPaths :: [VM] -> [VM] pruneDeadPaths = @@ -326,150 +337,363 @@ Just (VMFailure DeadPath) -> False _ -> True -consistentPath :: VM -> Query (Maybe VM) -consistentPath vm = do - resetAssertions - constrain $ sAnd $ fst <$> view constraints vm - checkSat >>= \case - Sat -> return $ Just vm - Unk -> return $ Just vm -- the path may still be consistent - Unsat -> return Nothing - DSat _ -> error "unexpected DSAT" +-- | Stepper that parses the result of Stepper.runFully into an Expr End +runExpr :: Stepper.Stepper (Expr End) +runExpr = do + vm <- Stepper.runFully + let asserts = view keccakEqs vm + pure $ case view result vm of + Nothing -> error "Internal Error: vm in intermediate state after call to runFully" + Just (VMSuccess buf) -> Return asserts buf (view (env . EVM.storage) vm) + Just (VMFailure e) -> case e of + UnrecognizedOpcode _ -> Invalid asserts + SelfDestruction -> SelfDestruct asserts + EVM.StackLimitExceeded -> EVM.Types.StackLimitExceeded asserts + EVM.IllegalOverflow -> EVM.Types.IllegalOverflow asserts + EVM.Revert buf -> EVM.Types.Revert asserts buf + EVM.InvalidMemoryAccess -> EVM.Types.InvalidMemoryAccess asserts + EVM.BadJumpDestination -> EVM.Types.BadJumpDestination asserts + e' -> EVM.Types.TmpErr asserts $ show e' -consistentTree :: Tree BranchInfo -> Query (Maybe (Tree BranchInfo)) -consistentTree (Node (BranchInfo vm w) []) = do - consistentPath vm >>= \case - Nothing -> return Nothing - Just vm' -> return $ Just $ Node (BranchInfo vm' w) [] -consistentTree (Node b xs) = do - consistentChildren <- catMaybes <$> forM xs consistentTree - if null consistentChildren then - return Nothing - else - return $ Just (Node b consistentChildren) +-- | Converts a given top level expr into a list of final states and the associated path conditions for each state +flattenExpr :: Expr End -> [([Prop], Expr End)] +flattenExpr = go [] + where + go :: [Prop] -> Expr End -> [([Prop], Expr End)] + go pcs = \case + ITE c t f -> go (PNeg ((PEq c (Lit 0))) : pcs) t <> go (PEq c (Lit 0) : pcs) f + e@(Invalid _) -> [(pcs, e)] + e@(SelfDestruct _) -> [(pcs, e)] + e@(Revert _ _) -> [(pcs, e)] + e@(Return _ _ _) -> [(pcs, e)] + e@(EVM.Types.IllegalOverflow _) -> [(pcs, e)] + e@(EVM.Types.StackLimitExceeded _ ) -> [(pcs, e)] + e@(EVM.Types.InvalidMemoryAccess _) -> [(pcs, e)] + e@(EVM.Types.BadJumpDestination _) -> [(pcs, e)] + TmpErr _ s -> error s + GVar _ -> error "cannot flatten an Expr containing a GVar" +-- | Strips unreachable branches from a given expr +-- Returns a list of executed SMT queries alongside the reduced expression for debugging purposes +-- Note that the reduced expression loses information relative to the original +-- one if jump conditions are removed. This restriction can be removed once +-- Expr supports attaching knowledge to AST nodes. +-- Although this algorithm currently parallelizes nicely, it does not exploit +-- the incremental nature of the task at hand. Introducing support for +-- incremental queries might let us go even faster here. +-- TODO: handle errors properly +reachable :: SolverGroup -> Expr End -> IO ([SMT2], Expr End) +reachable solvers e = do + res <- go [] e + pure $ second (fromMaybe (error "Internal Error: no reachable paths found")) res + where + {- + Walk down the tree and collect pcs. + Dispatch a reachability query at each leaf. + If reachable return the expr wrapped in a Just. If not return Nothing. + When walking back up the tree drop unreachable subbranches. + -} + go :: [Prop] -> Expr End -> IO ([SMT2], Maybe (Expr End)) + go pcs = \case + ITE c t f -> do + (tres, fres) <- concurrently + (go (PEq (Lit 1) c : pcs) t) + (go (PEq (Lit 0) c : pcs) f) + let subexpr = case (snd tres, snd fres) of + (Just t', Just f') -> Just $ ITE c t' f' + (Just t', Nothing) -> Just t' + (Nothing, Just f') -> Just f' + (Nothing, Nothing) -> Nothing + pure (fst tres <> fst fres, subexpr) + leaf -> do + let query = assertProps pcs + res <- checkSat solvers query + case res of + Sat _ -> pure ([query], Just leaf) + Unsat -> pure ([query], Nothing) + r -> error $ "Invalid solver result: " <> show r -leaves :: Tree BranchInfo -> [VM] -leaves (Node x []) = [_vm x] -leaves (Node _ xs) = concatMap leaves xs +-- | Evaluate the provided proposition down to its most concrete result +evalProp :: Prop -> Prop +evalProp = \case + o@(PBool _) -> o + o@(PNeg p) -> case p of + (PBool b) -> PBool (not b) + _ -> o + o@(PEq l r) -> if l == r + then PBool True + else o + o@(PLT (Lit l) (Lit r)) -> if l < r + then PBool True + else o + o@(PGT (Lit l) (Lit r)) -> if l > r + then PBool True + else o + o@(PGEq (Lit l) (Lit r)) -> if l >= r + then PBool True + else o + o@(PLEq (Lit l) (Lit r)) -> if l <= r + then PBool True + else o + o@(PAnd l r) -> case (evalProp l, evalProp r) of + (PBool True, PBool True) -> PBool True + (PBool _, PBool _) -> PBool False + _ -> o + o@(POr l r) -> case (evalProp l, evalProp r) of + (PBool False, PBool False) -> PBool False + (PBool _, PBool _) -> PBool True + _ -> o + o -> o + +-- | Extract contraints stored in Expr End nodes +extractProps :: Expr End -> [Prop] +extractProps = \case + ITE _ _ _ -> [] + Invalid asserts -> asserts + SelfDestruct asserts -> asserts + Revert asserts _ -> asserts + Return asserts _ _ -> asserts + EVM.Types.IllegalOverflow asserts -> asserts + EVM.Types.StackLimitExceeded asserts -> asserts + EVM.Types.InvalidMemoryAccess asserts -> asserts + EVM.Types.BadJumpDestination asserts -> asserts + TmpErr asserts _ -> asserts + GVar _ -> error "cannot extract props from a GVar" + + -- | Symbolically execute the VM and check all endstates against the postcondition, if available. -verify :: VM -> Maybe Integer -> Maybe Integer -> Maybe (Fetch.BlockNumber, Text) -> Maybe Postcondition -> Query VerifyResult -verify preState maxIter askSmtIters rpcinfo maybepost = do - smtState <- queryState - tree <- doInterpret (Fetch.oracle (Just smtState) rpcinfo False) maxIter askSmtIters preState +verify :: SolverGroup -> VeriOpts -> VM -> Maybe Postcondition -> IO (Expr End, [VerifyResult]) +verify solvers opts preState maybepost = do + putStrLn "Exploring contract" + + exprInter <- evalStateT (interpret (Fetch.oracle solvers (rpcInfo opts)) (maxIter opts) (askSmtIters opts) runExpr) preState + when (debug opts) $ T.writeFile "unsimplified.expr" (formatExpr exprInter) + + putStrLn "Simplifying expression" + expr <- if (simp opts) then (pure $ Expr.simplify exprInter) else pure exprInter + when (debug opts) $ T.writeFile "simplified.expr" (formatExpr expr) + + putStrLn $ "Explored contract (" <> show (Expr.numBranches expr) <> " branches)" + case maybepost of - (Just post) -> do - let livePaths = pruneDeadPaths $ leaves tree - -- have we hit max iterations at any point in a given path - maxReached :: VM -> Bool - maxReached p = case maxIter of - Just maxI -> any (>= (fromInteger maxI)) (view iterations p) - Nothing -> False - -- is there any path which can possibly violate the postcondition? - -- can also do these queries individually (even concurrently!). Could save time and report multiple violations - postC = sOr $ fmap (\postState -> (sAnd (fst <$> view constraints postState)) .&& sNot (post (preState, postState))) livePaths - resetAssertions - constrain postC - io $ putStrLn "checking postcondition..." - checkSat >>= \case - Unk -> do io $ putStrLn "postcondition query timed out" - return $ Timeout tree - Unsat -> do - if any maxReached livePaths - then io $ putStrLn "WARNING: max iterations reached, execution halted prematurely" - else io $ putStrLn "Q.E.D." - return $ Qed tree - Sat -> return $ Cex tree - DSat _ -> error "unexpected DSAT" + Nothing -> pure (expr, [Qed ()]) + Just post -> do + let + -- Filter out any leaves that can be statically shown to be safe + canViolate = flip filter (flattenExpr expr) $ + \(_, leaf) -> case evalProp (post preState leaf) of + PBool True -> False + _ -> True + assumes = view constraints preState + withQueries = fmap (\(pcs, leaf) -> (assertProps (PNeg (post preState leaf) : assumes <> extractProps leaf <> pcs), leaf)) canViolate + putStrLn $ "Checking for reachability of " <> show (length withQueries) <> " potential property violation(s)" - Nothing -> do io $ putStrLn "Nothing to check" - return $ Qed tree + when (debug opts) $ forM_ (zip [(1 :: Int)..] withQueries) $ \(idx, (q, leaf)) -> do + TL.writeFile + ("query-" <> show idx <> ".smt2") + ("; " <> (TL.pack $ show leaf) <> "\n\n" <> formatSMT2 q <> "\n\n(check-sat)") + -- Dispatch the remaining branches to the solver to check for violations + results <- flip mapConcurrently withQueries $ \(query, leaf) -> do + res <- checkSat solvers query + pure (res, leaf) + let cexs = filter (\(res, _) -> not . isUnsat $ res) results + pure $ if Prelude.null cexs then (expr, [Qed ()]) else (expr, fmap toVRes cexs) + where + toVRes :: (CheckSatResult, Expr End) -> VerifyResult + toVRes (res, leaf) = case res of + Sat model -> Cex (leaf, model) + EVM.SMT.Unknown -> Timeout leaf + Unsat -> Qed () + Error e -> error $ "Internal Error: solver responded with error: " <> show e + -- | Compares two contract runtimes for trace equivalence by running two VMs and comparing the end states. -equivalenceCheck :: ByteString -> ByteString -> Maybe Integer -> Maybe Integer -> Maybe (Text, [AbiType]) -> Query EquivalenceResult -equivalenceCheck bytecodeA bytecodeB maxiter askSmtIters signature' = do +equivalenceCheck :: SolverGroup -> ByteString -> ByteString -> VeriOpts -> Maybe (Text, [AbiType]) -> IO [(Maybe SMTCex, Prop, ProofResult () () ())] +equivalenceCheck solvers bytecodeA bytecodeB opts signature' = do let - bytecodeA' = if BS.null bytecodeA then BS.pack [0] else bytecodeA - bytecodeB' = if BS.null bytecodeB then BS.pack [0] else bytecodeB - preStateA <- abstractVM signature' [] bytecodeA' SymbolicS + bytecodeA' = if Data.ByteString.null bytecodeA then Data.ByteString.pack [0] else bytecodeA + bytecodeB' = if Data.ByteString.null bytecodeB then Data.ByteString.pack [0] else bytecodeB + preStateA = abstractVM signature' [] bytecodeA' Nothing SymbolicS + preStateB = abstractVM signature' [] bytecodeB' Nothing SymbolicS - let preself = preStateA ^. state . contract - precaller = preStateA ^. state . caller - callvalue' = preStateA ^. state . callvalue - prestorage = preStateA ^?! env . contracts . ix preself . storage - (calldata', cdlen) = view (state . calldata) preStateA - pathconds = view constraints preStateA - preStateB = loadSymVM (RuntimeCode (ConcreteBuffer bytecodeB')) prestorage SymbolicS precaller callvalue' (calldata', cdlen) & set constraints pathconds + aExpr <- evalStateT (interpret (Fetch.oracle solvers Nothing) (maxIter opts) (askSmtIters opts) runExpr) preStateA + bExpr <- evalStateT (interpret (Fetch.oracle solvers Nothing) (maxIter opts) (askSmtIters opts) runExpr) preStateB + aExprSimp <- if (simp opts) then (pure $ Expr.simplify aExpr) else pure aExpr + bExprSimp <- if (simp opts) then (pure $ Expr.simplify bExpr) else pure bExpr + when (debug opts) $ putStrLn $ "num of aExprSimp endstates:" <> (show $ length $ flattenExpr aExprSimp) <> "\nnum of bExprSimp endstates:" <> (show $ length $ flattenExpr bExprSimp) - smtState <- queryState - push 1 - aVMs <- doInterpret (Fetch.oracle (Just smtState) Nothing False) maxiter askSmtIters preStateA - pop 1 - push 1 - bVMs <- doInterpret (Fetch.oracle (Just smtState) Nothing False) maxiter askSmtIters preStateB - pop 1 - -- Check each pair of endstates for equality: - let differingEndStates = uncurry distinct <$> [(a,b) | a <- pruneDeadPaths (leaves aVMs), b <- pruneDeadPaths (leaves bVMs)] - distinct a b = - let (aPath, bPath) = both' (view constraints) (a, b) - (aSelf, bSelf) = both' (view (state . contract)) (a, b) - (aEnv, bEnv) = both' (view (env . contracts)) (a, b) - (aResult, bResult) = both' (view result) (a, b) - (Symbolic _ aStorage, Symbolic _ bStorage) = (view storage (aEnv ^?! ix aSelf), view storage (bEnv ^?! ix bSelf)) - differingResults = case (aResult, bResult) of + -- Check each pair of end states for equality: + let + differingEndStates = uncurry distinct <$> [(a,b) | a <- flattenExpr aExprSimp, b <- flattenExpr bExprSimp] + distinct :: ([Prop], Expr End) -> ([Prop], Expr End) -> Prop + distinct (aProps, aEnd) (bProps, bEnd) = + let + differingResults = case (aEnd, bEnd) of + (Return _ aOut aStore, Return _ bOut bStore) -> + if aOut == bOut && aStore == bStore then PBool False + else aStore ./= bStore .|| aOut ./= bOut + (Return {}, _) -> PBool True + (_, Return {}) -> PBool True + (Revert _ a, Revert _ b) -> if a==b then PBool False else a ./= b + (Revert _ _, _) -> PBool True + (_, Revert _ _) -> PBool True + (Invalid _, Invalid _) -> PBool False + (Invalid _, _ ) -> PBool True + (_, Invalid _) -> PBool True + (EVM.Types.StackLimitExceeded _, EVM.Types.StackLimitExceeded _ ) -> PBool False + (EVM.Types.StackLimitExceeded _, _) -> PBool True + (_, EVM.Types.StackLimitExceeded _) -> PBool True + (a, b) -> if a == b then PBool False + else error $ "Unimplemented, see TODO about EVM failures and TmpExpr. Left: " <> show a <> " Right: " <> show b - (Just (VMSuccess aOut), Just (VMSuccess bOut)) -> - aOut ./= bOut .|| aStorage ./= bStorage .|| fromBool (aSelf /= bSelf) + -- if the SMT solver can find a common input that satisfies BOTH sets of path conditions + -- AND the output differs, then we are in trouble. We do this for _every_ pair of paths, which + -- makes this exhaustive + in + if differingResults == PBool False + then PBool False + else (foldl PAnd (PBool True) aProps) .&& (foldl PAnd (PBool True) bProps) .&& differingResults + -- If there exists a pair of end states where this is not the case, + -- the following constraint is satisfiable - (Just (VMFailure UnexpectedSymbolicArg), _) -> - error $ "Unexpected symbolic argument at opcode: " <> maybe "??" show (vmOp a) <> ". Not supported (yet!)" + let diffEndStFilt = filter (/= PBool False) differingEndStates + putStrLn $ "Equivalence checking " <> (show $ length diffEndStFilt) <> " combinations" + when (debug opts) $ forM_ (zip diffEndStFilt [1 :: Integer ..]) (\(x, i) -> T.writeFile ("prop-checked-" <> show i) (T.pack $ show x)) + results <- flip mapConcurrently (zip diffEndStFilt [1 :: Integer ..]) $ \(prop, i) -> do + let assertedProps = assertProps [prop] + let filename = "eq-check-" <> show i <> ".smt2" + when (debug opts) $ T.writeFile (filename) $ (TL.toStrict $ formatSMT2 assertedProps) <> "\n(check-sat)" + res <- case prop of + PBool False -> pure Unsat + _ -> checkSat solvers assertedProps + case res of + Sat a -> return (Just a, prop, Cex ()) + Unsat -> return (Nothing, prop, Qed ()) + EVM.SMT.Unknown -> return (Nothing, prop, Timeout ()) + Error txt -> error $ "Error while running solver: `" <> T.unpack txt <> "` SMT file was: `" <> filename <> "`" + return $ filter (\(_, _, res) -> res /= Qed ()) results - (_, Just (VMFailure UnexpectedSymbolicArg)) -> - error $ "Unexpected symbolic argument at opcode: " <> maybe "??" show (vmOp a) <> ". Not supported (yet!)" +both' :: (a -> b) -> (a, a) -> (b, b) +both' f (x, y) = (f x, f y) - (Just (VMFailure _), Just (VMFailure _)) -> sFalse +produceModels :: SolverGroup -> Expr End -> IO [(Expr End, CheckSatResult)] +produceModels solvers expr = do + let flattened = flattenExpr expr + withQueries = fmap (first assertProps) flattened + results <- flip mapConcurrently withQueries $ \(query, leaf) -> do + res <- checkSat solvers query + pure (res, leaf) + pure $ fmap swap $ filter (\(res, _) -> not . isUnsat $ res) results - (Just _, Just _) -> sTrue +showModel :: Expr Buf -> (Expr End, CheckSatResult) -> IO () +showModel cd (expr, res) = do + case res of + Unsat -> pure () -- ignore unreachable branches + Error e -> error $ "Internal error: smt solver returned an error: " <> show e + EVM.SMT.Unknown -> do + putStrLn "--- Branch ---" + putStrLn "" + putStrLn "Unable to produce a model for the following end state:" + putStrLn "" + T.putStrLn $ indent 2 $ formatExpr expr + putStrLn "" + Sat cex -> do + putStrLn "--- Branch ---" + putStrLn "" + putStrLn "Inputs:" + putStrLn "" + T.putStrLn $ indent 2 $ formatCex cd cex + putStrLn "" + putStrLn "End State:" + putStrLn "" + T.putStrLn $ indent 2 $ formatExpr expr + putStrLn "" - errormsg -> error $ show errormsg - in sAnd (fst <$> aPath) .&& sAnd (fst <$> bPath) .&& differingResults - -- If there exists a pair of endstates where this is not the case, - -- the following constraint is satisfiable - constrain $ sOr differingEndStates +formatCex :: Expr Buf -> SMTCex -> Text +formatCex cd m@(SMTCex _ _ blockContext txContext) = T.unlines $ + [ "Calldata:" + , indent 2 cd' + , "" + ] + <> txCtx + <> blockCtx + where + -- we attempt to produce a model for calldata by substituting all variables + -- and buffers provided by the model into the original calldata expression. + -- If we have a concrete result then we diplay it, otherwise we diplay + -- `Any`. This is a little bit of a hack (and maybe unsound?), but we need + -- it for branches that do not refer to calldata at all (e.g. the top level + -- callvalue check inserted by solidity in contracts that don't have any + -- payable functions). + cd' = prettyBuf $ Expr.simplify $ subModel m cd - checkSat >>= \case - Unk -> return $ Timeout () - Sat -> return $ Cex preStateA - Unsat -> return $ Qed (leaves aVMs, leaves bVMs) - DSat _ -> error "unexpected DSAT" + txCtx :: [Text] + txCtx + | Map.null txContext = [] + | otherwise = + [ "Transaction Context:" + , indent 2 $ T.unlines $ Map.foldrWithKey (\key val acc -> (showTxCtx key <> ": " <> (T.pack $ show val)) : acc) mempty (filterSubCtx txContext) + , "" + ] -both' :: (a -> b) -> (a, a) -> (b, b) -both' f (x, y) = (f x, f y) + -- strips the frame arg from frame context vars to make them easier to read + showTxCtx :: Expr EWord -> Text + showTxCtx (CallValue _) = "CallValue" + showTxCtx (Caller _) = "Caller" + showTxCtx (Address _) = "Address" + showTxCtx x = T.pack $ show x -showCounterexample :: VM -> Maybe (Text, [AbiType]) -> Query () -showCounterexample vm maybesig = do - let (calldata', S _ cdlen) = view (EVM.state . EVM.calldata) vm - S _ cvalue = view (EVM.state . EVM.callvalue) vm - SAddr caller' = view (EVM.state . EVM.caller) vm - cdlen' <- num <$> getValue cdlen - calldatainput <- case calldata' of - SymbolicBuffer cd -> mapM (getValue.fromSized) (take cdlen' cd) >>= return . pack - ConcreteBuffer cd -> return $ BS.take cdlen' cd - callvalue' <- getValue cvalue - caller'' <- num <$> getValue caller' - io $ do - putStrLn "Calldata:" - print $ ByteStringS calldatainput + -- strips all frame context that doesn't come from the top frame + filterSubCtx :: Map (Expr EWord) W256 -> Map (Expr EWord) W256 + filterSubCtx = Map.filterWithKey go + where + go :: Expr EWord -> W256 -> Bool + go (CallValue x) _ = x == 0 + go (Caller x) _ = x == 0 + go (Address x) _ = x == 0 + go (Balance {}) _ = error "TODO: BALANCE" + go (SelfBalance {}) _ = error "TODO: SELFBALANCE" + go (Gas {}) _ = error "TODO: Gas" + go _ _ = False - -- pretty print calldata input if signature is available - case maybesig of - Just (name, types) -> putStrLn $ unpack (head (splitOn "(" name)) ++ - show (decodeAbiValue (AbiTupleType (fromList types)) $ Lazy.fromStrict (BS.drop 4 calldatainput)) - Nothing -> return () + blockCtx :: [Text] + blockCtx + | Map.null blockContext = [] + | otherwise = + [ "Block Context:" + , indent 2 $ T.unlines $ Map.foldrWithKey (\key val acc -> (T.pack $ show key <> ": " <> show val) : acc) mempty txContext + , "" + ] - putStrLn "Caller:" - print (Addr caller'') - putStrLn "Callvalue:" - print callvalue' + prettyBuf :: Expr Buf -> Text + prettyBuf (ConcreteBuf "") = "Empty" + prettyBuf (ConcreteBuf bs) = formatBinary bs + prettyBuf _ = "Any" + +-- | Takes a buffer and a Cex and replaces all abstract values in the buf with concrete ones from the Cex +subModel :: SMTCex -> Expr a -> Expr a +subModel c expr = subBufs (buffers c) . subVars (vars c) . subVars (blockContext c) . subVars (txContext c) $ expr + where + subVars model b = Map.foldlWithKey subVar b model + subVar :: Expr a -> Expr EWord -> W256 -> Expr a + subVar b var val = mapExpr go b + where + go :: Expr a -> Expr a + go = \case + v@(Var _) -> if v == var + then Lit val + else v + e -> e + + subBufs model b = Map.foldlWithKey subBuf b model + subBuf :: Expr a -> Expr Buf -> ByteString -> Expr a + subBuf b var val = mapExpr go b + where + go :: Expr a -> Expr a + go = \case + a@(AbstractBuf _) -> if a == var + then ConcreteBuf val + else a + e -> e diff --git a/src/EVM/Symbolic.hs b/src/EVM/Symbolic.hs deleted file mode 100644 --- a/src/EVM/Symbolic.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# Language NamedFieldPuns #-} -{-# Language DataKinds #-} -{-# Language OverloadedStrings #-} -{-# Language TypeApplications #-} -{-# Language ScopedTypeVariables #-} - -module EVM.Symbolic where - -import Prelude hiding (Word, LT, GT) -import qualified Data.ByteString as BS -import Data.ByteString (ByteString) -import Control.Lens hiding (op, (:<), (|>), (.>)) -import Data.Maybe (fromMaybe, fromJust) - -import EVM.Types -import qualified EVM.Concrete as Concrete -import qualified Data.ByteArray as BA -import Data.SBV hiding (runSMT, newArray_, addAxiom, Word) -import Data.SBV.Tools.Overflow -import Crypto.Hash (Digest, SHA256) -import qualified Crypto.Hash as Crypto - -litWord :: Word -> SymWord -litWord (C whiff a) = S whiff (literal $ toSizzle a) - -litAddr :: Addr -> SAddr -litAddr = SAddr . literal . toSizzle - -maybeLitAddr :: SAddr -> Maybe Addr -maybeLitAddr (SAddr a) = fmap fromSizzle (unliteral a) - -maybeLitBytes :: [SWord 8] -> Maybe ByteString -maybeLitBytes xs = fmap (\x -> BS.pack (fmap fromSized x)) (mapM unliteral xs) - --- | Note: the (force*) functions are crude and in general, --- the continuation passing style `forceConcrete` --- alternatives should be prefered for better error --- handling when used during EVM execution -forceLit :: SymWord -> Word -forceLit (S whiff a) = case unliteral a of - Just c -> C whiff (fromSizzle c) - Nothing -> error "unexpected symbolic argument" - -forceLitBytes :: [SWord 8] -> ByteString -forceLitBytes = BS.pack . fmap (fromSized . fromJust . unliteral) - -forceBuffer :: Buffer -> ByteString -forceBuffer (ConcreteBuffer b) = b -forceBuffer (SymbolicBuffer b) = forceLitBytes b - -sdiv :: SymWord -> SymWord -> SymWord -sdiv (S a x) (S b y) = let sx, sy :: SInt 256 - sx = sFromIntegral x - sy = sFromIntegral y - in S (Div a b) (sFromIntegral (sx `sQuot` sy)) - -smod :: SymWord -> SymWord -> SymWord -smod (S a x) (S b y) = let sx, sy :: SInt 256 - sx = sFromIntegral x - sy = sFromIntegral y - in S (Mod a b) $ ite (y .== 0) 0 (sFromIntegral (sx `sRem` sy)) - -addmod :: SymWord -> SymWord -> SymWord -> SymWord -addmod (S a x) (S b y) (S c z) = let to512 :: SWord 256 -> SWord 512 - to512 = sFromIntegral - in S (Todo "addmod" [a, b, c]) $ ite (z .== 0) 0 $ sFromIntegral $ ((to512 x) + (to512 y)) `sMod` (to512 z) - -mulmod :: SymWord -> SymWord -> SymWord -> SymWord -mulmod (S a x) (S b y) (S c z) = let to512 :: SWord 256 -> SWord 512 - to512 = sFromIntegral - in S (Todo "mulmod" [a, b, c]) $ ite (z .== 0) 0 $ sFromIntegral $ ((to512 x) * (to512 y)) `sMod` (to512 z) - --- | Signed less than -slt :: SymWord -> SymWord -> SymWord -slt (S xw x) (S yw y) = - iteWhiff (SLT xw yw) (sFromIntegral x .< (sFromIntegral y :: (SInt 256))) 1 0 - --- | Signed greater than -sgt :: SymWord -> SymWord -> SymWord -sgt (S xw x) (S yw y) = - iteWhiff (SGT xw yw) (sFromIntegral x .> (sFromIntegral y :: (SInt 256))) 1 0 - --- * Operations over symbolic memory (list of symbolic bytes) -swordAt :: Int -> [SWord 8] -> SymWord -swordAt i bs = let bs' = truncpad 32 $ drop i bs - in S (FromBytes (SymbolicBuffer bs')) (fromBytes bs') - -readByteOrZero' :: Int -> [SWord 8] -> SWord 8 -readByteOrZero' i bs = fromMaybe 0 (bs ^? ix i) - -sliceWithZero' :: Int -> Int -> [SWord 8] -> [SWord 8] -sliceWithZero' o s m = truncpad s $ drop o m - -writeMemory' :: [SWord 8] -> Word -> Word -> Word -> [SWord 8] -> [SWord 8] -writeMemory' bs1 (C _ n) (C _ src) (C _ dst) bs0 = - let - (a, b) = splitAt (num dst) bs0 - a' = replicate (num dst - length a) 0 - c = if src > num (length bs1) - then replicate (num n) 0 - else sliceWithZero' (num src) (num n) bs1 - b' = drop (num (n)) b - in - a <> a' <> c <> b' - -readMemoryWord' :: Word -> [SWord 8] -> SymWord -readMemoryWord' (C _ i) m = - let bs = truncpad 32 (drop (num i) m) - in S (FromBytes (SymbolicBuffer bs)) (fromBytes bs) - -readMemoryWord32' :: Word -> [SWord 8] -> SWord 32 -readMemoryWord32' (C _ i) m = fromBytes $ truncpad 4 (drop (num i) m) - -setMemoryWord' :: Word -> SymWord -> [SWord 8] -> [SWord 8] -setMemoryWord' (C _ i) (S _ x) = - writeMemory' (toBytes x) 32 0 (num i) - -setMemoryByte' :: Word -> SWord 8 -> [SWord 8] -> [SWord 8] -setMemoryByte' (C _ i) x = - writeMemory' [x] 1 0 (num i) - -readSWord' :: Word -> [SWord 8] -> SymWord -readSWord' (C _ i) x = - if i > num (length x) - then 0 - else swordAt (num i) x - - -select' :: (Ord b, Num b, SymVal b, Mergeable a) => [a] -> a -> SBV b -> a -select' xs err ind = walk xs ind err - where walk [] _ acc = acc - walk (e:es) i acc = walk es (i-1) (ite (i .== 0) e acc) - --- | Read 32 bytes from index from a bounded list of bytes. -readSWordWithBound :: SymWord -> Buffer -> SymWord -> SymWord -readSWordWithBound sind@(S _ ind) (SymbolicBuffer xs) (S _ bound) = case (num <$> maybeLitWord sind, num <$> fromSizzle <$> unliteral bound) of - (Just i, Just b) -> - let bs = truncpad 32 $ drop i (take b xs) - in S (FromBytes (SymbolicBuffer bs)) (fromBytes bs) - _ -> - -- Generates a ridiculously large set of constraints (roughly 25k) when - -- the index is symbolic, but it still seems (kind of) manageable - -- for the solvers. - - -- The proper solution here is to use smt arrays instead. - - let boundedList = [ite (i .<= bound) x' 0 | (x', i) <- zip xs [1..]] - res = [select' boundedList 0 (ind + j) | j <- [0..31]] - in S (FromBytes $ SymbolicBuffer res) $ fromBytes res - -readSWordWithBound sind (ConcreteBuffer xs) bound = - case maybeLitWord sind of - Nothing -> readSWordWithBound sind (SymbolicBuffer (litBytes xs)) bound - Just x' -> - -- INVARIANT: bound should always be length xs for concrete bytes - -- so we should be able to safely ignore it here - litWord $ Concrete.readMemoryWord x' xs - --- a whole foldable instance seems overkill, but length is always good to have! -len :: Buffer -> Int -len (SymbolicBuffer bs) = length bs -len (ConcreteBuffer bs) = BS.length bs - -readByteOrZero :: Int -> Buffer -> SWord 8 -readByteOrZero i (SymbolicBuffer bs) = readByteOrZero' i bs -readByteOrZero i (ConcreteBuffer bs) = num $ Concrete.readByteOrZero i bs - -sliceWithZero :: Int -> Int -> Buffer -> Buffer -sliceWithZero o s (SymbolicBuffer m) = SymbolicBuffer (sliceWithZero' o s m) -sliceWithZero o s (ConcreteBuffer m) = ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes o s m) - -writeMemory :: Buffer -> Word -> Word -> Word -> Buffer -> Buffer -writeMemory (ConcreteBuffer bs1) n src dst (ConcreteBuffer bs0) = - ConcreteBuffer (Concrete.writeMemory bs1 n src dst bs0) -writeMemory (ConcreteBuffer bs1) n src dst (SymbolicBuffer bs0) = - SymbolicBuffer (writeMemory' (litBytes bs1) n src dst bs0) -writeMemory (SymbolicBuffer bs1) n src dst (ConcreteBuffer bs0) = - SymbolicBuffer (writeMemory' bs1 n src dst (litBytes bs0)) -writeMemory (SymbolicBuffer bs1) n src dst (SymbolicBuffer bs0) = - SymbolicBuffer (writeMemory' bs1 n src dst bs0) - -readMemoryWord :: Word -> Buffer -> SymWord -readMemoryWord i (SymbolicBuffer m) = readMemoryWord' i m -readMemoryWord i (ConcreteBuffer m) = litWord $ Concrete.readMemoryWord i m - -readMemoryWord32 :: Word -> Buffer -> SWord 32 -readMemoryWord32 i (SymbolicBuffer m) = readMemoryWord32' i m -readMemoryWord32 i (ConcreteBuffer m) = num $ Concrete.readMemoryWord32 i m - -setMemoryWord :: Word -> SymWord -> Buffer -> Buffer -setMemoryWord i x (SymbolicBuffer z) = SymbolicBuffer $ setMemoryWord' i x z -setMemoryWord i x (ConcreteBuffer z) = case maybeLitWord x of - Just x' -> ConcreteBuffer $ Concrete.setMemoryWord i x' z - Nothing -> SymbolicBuffer $ setMemoryWord' i x (litBytes z) - -setMemoryByte :: Word -> SWord 8 -> Buffer -> Buffer -setMemoryByte i x (SymbolicBuffer m) = SymbolicBuffer $ setMemoryByte' i x m -setMemoryByte i x (ConcreteBuffer m) = case fromSized <$> unliteral x of - Nothing -> SymbolicBuffer $ setMemoryByte' i x (litBytes m) - Just x' -> ConcreteBuffer $ Concrete.setMemoryByte i x' m - -readSWord :: Word -> Buffer -> SymWord -readSWord i (SymbolicBuffer x) = readSWord' i x -readSWord i (ConcreteBuffer x) = num $ Concrete.readMemoryWord i x - -index :: Int -> Buffer -> SWord8 -index x (ConcreteBuffer b) = literal $ BS.index b x -index x (SymbolicBuffer b) = fromSized $ b !! x - --- * Uninterpreted functions - -symSHA256N :: SInteger -> SInteger -> SWord 256 -symSHA256N = uninterpret "sha256" - -symkeccakN :: SInteger -> SInteger -> SWord 256 -symkeccakN = uninterpret "keccak" - -toSInt :: [SWord 8] -> SInteger -toSInt bs = sum $ zipWith (\a (i :: Integer) -> sFromIntegral a * 256 ^ i) bs [0..] - - --- | Although we'd like to define this directly as an uninterpreted function, --- we cannot because [a] is not a symbolic type. We must convert the list into a suitable --- symbolic type first. The only important property of this conversion is that it is injective. --- We embedd the bytestring as a pair of symbolic integers, this is a fairly easy solution. -symkeccak' :: [SWord 8] -> SWord 256 -symkeccak' bytes = case length bytes of - 0 -> literal $ toSizzle $ keccak "" - n -> symkeccakN (num n) (toSInt bytes) - -symSHA256 :: [SWord 8] -> [SWord 8] -symSHA256 bytes = case length bytes of - 0 -> litBytes $ BS.pack $ BA.unpack $ (Crypto.hash BS.empty :: Digest SHA256) - n -> toBytes $ symSHA256N (num n) (toSInt bytes) - -rawVal :: SymWord -> SWord 256 -rawVal (S _ v) = v - --- | Reconstruct the smt/sbv value from a whiff --- Should satisfy (rawVal x .== whiffValue x) -whiffValue :: Whiff -> SWord 256 -whiffValue w = case w of - w'@(Todo _ _) -> error $ "unable to get value of " ++ show w' - And x y -> whiffValue x .&. whiffValue y - Or x y -> whiffValue x .|. whiffValue y - Eq x y -> ite (whiffValue x .== whiffValue y) 1 0 - LT x y -> ite (whiffValue x .< whiffValue y) 1 0 - GT x y -> ite (whiffValue x .> whiffValue y) 1 0 - ITE b x y -> ite (whiffValue b .== 1) (whiffValue x) (whiffValue y) - SLT x y -> rawVal $ slt (S x (whiffValue x)) (S y (whiffValue y)) - SGT x y -> rawVal $ sgt (S x (whiffValue x)) (S y (whiffValue y)) - IsZero x -> ite (whiffValue x .== 0) 1 0 - SHL x y -> sShiftLeft (whiffValue x) (whiffValue y) - SHR x y -> sShiftRight (whiffValue x) (whiffValue y) - SAR x y -> sSignedShiftArithRight (whiffValue x) (whiffValue y) - Add x y -> whiffValue x + whiffValue y - Sub x y -> whiffValue x - whiffValue y - Mul x y -> whiffValue x * whiffValue y - Div x y -> whiffValue x `sDiv` whiffValue y - Mod x y -> whiffValue x `sMod` whiffValue y - Exp x y -> whiffValue x .^ whiffValue y - Neg x -> complement $ whiffValue x - Var _ v -> v - FromKeccak (ConcreteBuffer bstr) -> literal $ num $ keccak bstr - FromKeccak (SymbolicBuffer buf) -> symkeccak' buf - Literal x -> literal $ num $ x - FromBytes buf -> rawVal $ readMemoryWord 0 buf - FromStorage ind arr -> readArray arr (whiffValue ind) - --- | Special cases that have proven useful in practice -simplifyCondition :: SBool -> Whiff -> SBool -simplifyCondition _ (IsZero (IsZero (IsZero a))) = whiffValue a .== 0 - - - --- | Overflow safe math can be difficult for smt solvers to deal with, --- especially for 256-bit words. When we recognize terms arising from --- overflow checks, we translate our queries into a more bespoke form, --- outlined in: --- Modular Bug-finding for Integer Overflows in the Large: --- Sound, Efficient, Bit-precise Static Analysis --- www.microsoft.com/en-us/research/wp-content/uploads/2016/02/z3prefix.pdf --- --- Addition overflow. --- Written as --- require (x <= (x + y)) --- or require (y <= (x + y)) --- or require (!(y < (x + y))) -simplifyCondition b (IsZero (IsZero (LT (Add x y) z))) = - let x' = whiffValue x - y' = whiffValue y - z' = whiffValue z - (_, overflow) = bvAddO x' y' - in - ite (x' .== z' .|| - y' .== z') - overflow - b - --- Multiplication overflow. --- Written as --- require (y == 0 || x * y / y == x) --- or require (y == 0 || x == x * y / y) - --- proveWith cvc4 $ \x y z -> ite (y .== (z :: SWord 8)) (((x * y) `sDiv` z ./= x) .<=> (snd (bvMulO x y) .|| (z .== 0 .&& x .> 0))) (sTrue) --- Q.E.D. -simplifyCondition b (IsZero (Eq x (Div (Mul y z) w))) = - simplifyCondition b (IsZero (Eq (Div (Mul y z) w) x)) -simplifyCondition b (IsZero (Eq (Div (Mul y z) w) x)) = - let x' = whiffValue x - y' = whiffValue y - z' = whiffValue z - w' = whiffValue w - (_, overflow) = bvMulO y' z' - in - ite - ((y' .== x' .&& z' .== w') .|| - (z' .== x' .&& y' .== w')) - (overflow .|| (w' .== 0 .&& x' ./= 0)) - b -simplifyCondition b _ = b diff --git a/src/EVM/TTY.hs b/src/EVM/TTY.hs --- a/src/EVM/TTY.hs +++ b/src/EVM/TTY.hs @@ -13,27 +13,30 @@ import EVM import EVM.ABI (abiTypeSolidity, decodeAbiValue, AbiType(..), emptyAbi) import EVM.SymExec (maxIterationsReached, symCalldata) +import EVM.Expr (simplify) import EVM.Dapp (DappInfo, dappInfo, Test, extractSig, Test(..), srcMap) import EVM.Dapp (dappUnitTests, unitTestMethods, dappSolcByName, dappSolcByHash, dappSources) import EVM.Dapp (dappAstSrcMap) import EVM.Debug import EVM.Format (showWordExact, showWordExplanation) -import EVM.Format (contractNamePart, contractPathPart, showTraceTree) +import EVM.Format (contractNamePart, contractPathPart, showTraceTree, prettyIfConcreteWord, formatExpr) import EVM.Hexdump (prettyHex) +import EVM.SMT (SolverGroup) import EVM.Op import EVM.Solidity hiding (storageLayout) import EVM.Types hiding (padRight) import EVM.UnitTest import EVM.StorageLayout +import Text.Wrap import EVM.Stepper (Stepper) import qualified EVM.Stepper as Stepper +import qualified EVM.Fetch as Fetch import qualified Control.Monad.Operational as Operational import EVM.Fetch (Fetcher) import Control.Lens hiding (List) -import Control.Monad.Trans.Reader import Control.Monad.State.Strict hiding (state) import Data.Aeson.Lens @@ -44,10 +47,9 @@ import Data.Text.Encoding (decodeUtf8) import Data.List (sort, find) import Data.Version (showVersion) -import Data.SBV hiding (solver) -import qualified Data.SBV.Internals as SBV import qualified Data.ByteString as BS +import qualified Data.Text as T import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.Vector as Vec @@ -228,17 +230,18 @@ V.setMode (V.outputIface vty) V.BracketedPaste True return vty -runFromVM :: Maybe Integer -> DappInfo -> (Query -> IO (EVM ())) -> VM -> IO VM -runFromVM maxIter' dappinfo oracle' vm = do +runFromVM :: SolverGroup -> Fetch.RpcInfo -> Maybe Integer -> DappInfo -> VM -> IO VM +runFromVM solvers rpcInfo maxIter' dappinfo vm = do let opts = UnitTestOptions - { oracle = oracle' + { solvers = solvers + , rpcInfo = rpcInfo , verbose = Nothing , maxIter = maxIter' , askSmtIters = Nothing , smtTimeout = Nothing - , smtState = Nothing + , smtDebug = False , solver = Nothing , maxDepth = Nothing , match = "" @@ -567,7 +570,7 @@ case listSelectedElement (view testPickerList s) of Nothing -> error "nothing selected" Just (_, x) -> do - initVm <- liftIO $ initialUiVmStateForTest (view testOpts s) x + let initVm = initialUiVmStateForTest (view testOpts s) x continue . ViewVm $ initVm -- UnitTest Picker: (main) - render list @@ -607,9 +610,9 @@ appEvent s _ = continue s app :: UnitTestOptions -> App UiState () Name -app opts = - let ?fetcher = oracle opts - ?maxIter = maxIter opts +app UnitTestOptions{..} = + let ?fetcher = Fetch.oracle solvers rpcInfo + ?maxIter = maxIter in App { appDraw = drawUi , appChooseCursor = neverShowCursor @@ -621,44 +624,41 @@ initialUiVmStateForTest :: UnitTestOptions -> (Text, Text) - -> IO UiVmState -initialUiVmStateForTest opts@UnitTestOptions{..} (theContractName, theTestName) = do - let state' = fromMaybe (error "Internal Error: missing smtState") smtState - (buf, len) <- case test of - SymbolicTest _ -> flip runReaderT state' $ SBV.runQueryT $ symCalldata theTestName types [] - _ -> return (error "unreachable", error "unreachable") - let script = do - Stepper.evm . pushTrace . EntryTrace $ - "test " <> theTestName <> " (" <> theContractName <> ")" - initializeUnitTest opts testContract - case test of - ConcreteTest _ -> do - let args = case replay of - Nothing -> emptyAbi - Just (sig, callData) -> - if theTestName == sig - then decodeAbiValue (AbiTupleType (Vec.fromList types)) callData - else emptyAbi - void (runUnitTest opts theTestName args) - SymbolicTest _ -> do - Stepper.evm $ modify symbolify - void (execSymTest opts theTestName (SymbolicBuffer buf, w256lit len)) - InvariantTest _ -> do - targets <- getTargetContracts opts - let randomRun = initialExplorationStepper opts theTestName [] targets (fromMaybe 20 maxDepth) - void $ case replay of - Nothing -> randomRun - Just (sig, cd) -> - if theTestName == sig - then initialExplorationStepper opts theTestName (decodeCalls cd) targets (length (decodeCalls cd)) - else randomRun - pure $ initUiVmState vm0 opts script + -> UiVmState +initialUiVmStateForTest opts@UnitTestOptions{..} (theContractName, theTestName) = initUiVmState vm0 opts script where + cd = case test of + SymbolicTest _ -> symCalldata theTestName types [] (AbstractBuf "txdata") + _ -> (error "unreachable", error "unreachable") Just (test, types) = find (\(test',_) -> extractSig test' == theTestName) $ unitTestMethods testContract Just testContract = view (dappSolcByName . at theContractName) dapp vm0 = initialUnitTestVm opts testContract + script = do + Stepper.evm . pushTrace . EntryTrace $ + "test " <> theTestName <> " (" <> theContractName <> ")" + initializeUnitTest opts testContract + case test of + ConcreteTest _ -> do + let args = case replay of + Nothing -> emptyAbi + Just (sig, callData) -> + if theTestName == sig + then decodeAbiValue (AbiTupleType (Vec.fromList types)) callData + else emptyAbi + void (runUnitTest opts theTestName args) + SymbolicTest _ -> do + void (execSymTest opts theTestName cd) + InvariantTest _ -> do + targets <- getTargetContracts opts + let randomRun = initialExplorationStepper opts theTestName [] targets (fromMaybe 20 maxDepth) + void $ case replay of + Nothing -> randomRun + Just (sig, cd') -> + if theTestName == sig + then initialExplorationStepper opts theTestName (decodeCalls cd') targets (length (decodeCalls cd')) + else randomRun myTheme :: [(AttrName, V.Attr)] myTheme = @@ -725,21 +725,21 @@ (\selected (k, c') -> withHighlight selected . txt . mconcat $ [ fromMaybe "" . flip preview dapp' $ - ( dappSolcByHash . ix (view codehash c') + ( dappSolcByHash . ix (maybeHash c') . _2 . contractName ) , "\n" , " ", pack (show k) ]) True (view browserContractList ui) - , case flip preview dapp' (dappSolcByHash . ix (view codehash c) . _2) of + , case flip preview dapp' (dappSolcByHash . ix (maybeHash c) . _2) of Nothing -> hBox [ borderWithLabel (txt "Contract information") . padBottom Max . padRight Max $ vBox [ txt ("Codehash: " <> pack (show (view codehash c))) , txt ("Nonce: " <> showWordExact (view nonce c)) , txt ("Balance: " <> showWordExact (view balance c)) - , txt ("Storage: " <> storageDisplay (view storage c)) + --, txt ("Storage: " <> storageDisplay (view storage c)) -- TODO: fix this ] ] Just sol -> @@ -754,18 +754,18 @@ , txt "Public methods:" , vBox . flip map (sort (Map.elems (view abiMap sol))) $ \method -> txt (" " <> view methodSignature method) - , txt ("Storage:" <> storageDisplay (view storage c)) + --, txt ("Storage:" <> storageDisplay (view storage c)) -- TODO: fix this ] , borderWithLabel (txt "Storage slots") . padBottom Max . padRight Max $ vBox (map txt (storageLayout dapp' sol)) ] ] ] - where storageDisplay (Concrete s) = pack ( show ( Map.toList s)) - storageDisplay (Symbolic v _) = pack $ show v - dapp' = dapp (view (browserVm . uiTestOpts) ui) - Just (_, (_, c)) = listSelectedElement (view browserContractList ui) + where + dapp' = dapp (view (browserVm . uiTestOpts) ui) + Just (_, (_, c)) = listSelectedElement (view browserContractList ui) -- currentContract = view (dappSolcByHash . ix ) dapp + maybeHash ch = fromJust (error "Internal error: cannot find concrete codehash for partially symbolic code") (maybeLitWord (view codehash ch)) drawVm :: UiVmState -> [UiWidget] drawVm ui = @@ -877,18 +877,18 @@ drawStackPane :: UiVmState -> UiWidget drawStackPane ui = let - gasText = showWordExact (view (uiVm . state . gas) ui) + gasText = showWordExact (num $ view (uiVm . state . gas) ui) labelText = txt ("Gas available: " <> gasText <> "; stack:") - stackList = list StackPane (Vec.fromList $ zip [(1 :: Int)..] (view (uiVm . state . stack) ui)) 2 + stackList = list StackPane (Vec.fromList $ zip [(1 :: Int)..] (fmap simplify $ view (uiVm . state . stack) ui)) 2 in hBorderWithLabel labelText <=> renderList - (\_ (i, x@(S _ w)) -> + (\_ (i, w) -> vBox [ withHighlight True (str ("#" ++ show i ++ " ")) - <+> str (show x) - , dim (txt (" " <> case unliteral w of + <+> ourWrap (Text.unpack $ prettyIfConcreteWord w) + , dim (txt (" " <> case unlit w of Nothing -> "" - Just u -> showWordExplanation (fromSizzle u) $ dapp (view uiTestOpts ui))) + Just u -> showWordExplanation u $ dapp (view uiTestOpts ui))) ]) False stackList @@ -896,12 +896,12 @@ message :: VM -> String message vm = case view result vm of - Just (VMSuccess (ConcreteBuffer msg)) -> + Just (VMSuccess (ConcreteBuf msg)) -> "VMSuccess: " <> (show $ ByteStringS msg) - Just (VMSuccess (SymbolicBuffer msg)) -> + Just (VMSuccess (msg)) -> "VMSuccess: " <> (show msg) - Just (VMFailure (Revert msg)) -> - "VMFailure: " <> (show . ByteStringS $ msg) + Just (VMFailure (EVM.Revert msg)) -> + "VMFailure: " <> (show msg) Just (VMFailure err) -> "VMFailure: " <> show err Nothing -> @@ -932,9 +932,9 @@ withHighlight False = withDefAttr dimAttr withHighlight True = withDefAttr boldAttr -prettyIfConcrete :: Buffer -> String -prettyIfConcrete (SymbolicBuffer x) = show x -prettyIfConcrete (ConcreteBuffer x) = prettyHex 40 x +prettyIfConcrete :: Expr Buf -> String +prettyIfConcrete (ConcreteBuf x) = prettyHex 40 x +prettyIfConcrete x = T.unpack $ formatExpr $ simplify x drawTracePane :: UiVmState -> UiWidget drawTracePane s = @@ -950,26 +950,35 @@ 1 in case view uiShowMemory s of - True -> - hBorderWithLabel (txt "Calldata") - <=> str (prettyIfConcrete $ fst (view (state . calldata) vm)) - <=> hBorderWithLabel (txt "Returndata") - <=> str (prettyIfConcrete (view (state . returndata) vm)) - <=> hBorderWithLabel (txt "Output") - <=> str (maybe "" show (view result vm)) - <=> hBorderWithLabel (txt "Cache") - <=> str (show (view (cache . path) vm)) - <=> hBorderWithLabel (txt "Path Conditions") - <=> (str $ show $ snd <$> view constraints vm) - <=> hBorderWithLabel (txt "Memory") - <=> viewport TracePane Vertical - (str (prettyIfConcrete (view (state . memory) vm))) + True -> viewport TracePane Vertical $ + hBorderWithLabel (txt "Calldata") + <=> ourWrap (prettyIfConcrete (view (state . calldata) vm)) + <=> hBorderWithLabel (txt "Returndata") + <=> ourWrap (prettyIfConcrete (view (state . returndata) vm)) + <=> hBorderWithLabel (txt "Output") + <=> ourWrap (maybe "" show (view result vm)) + <=> hBorderWithLabel (txt "Cache") + <=> ourWrap (show (view (cache . path) vm)) + <=> hBorderWithLabel (txt "Path Conditions") + <=> (ourWrap $ show $ view constraints vm) + <=> hBorderWithLabel (txt "Memory") + <=> (ourWrap (prettyIfConcrete (view (state . memory) vm))) False -> hBorderWithLabel (txt "Trace") <=> renderList (\_ x -> txt x) False (listMoveTo (length traceList) traceList) + +ourWrap :: String -> Widget n +ourWrap = strWrapWith settings + where + settings = WrapSettings + { preserveIndentation = True + , breakLongWords = True + , fillStrategy = NoFill + , fillScope = FillAfterFirst + } solidityList :: VM -> DappInfo -> List Name (Int, ByteString) solidityList vm dapp' = diff --git a/src/EVM/Transaction.hs b/src/EVM/Transaction.hs --- a/src/EVM/Transaction.hs +++ b/src/EVM/Transaction.hs @@ -7,20 +7,21 @@ import EVM.FeeSchedule import EVM.Precompiled (execute) import EVM.RLP -import EVM.Symbolic (forceLit) import EVM.Types +import EVM.Expr (litAddr) import Control.Lens import Data.Aeson (FromJSON (..)) import Data.ByteString (ByteString) import Data.Map (Map) -import Data.Maybe (fromMaybe, isNothing, isJust) +import Data.Maybe (fromMaybe, isNothing) import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON import qualified Data.ByteString as BS import qualified Data.Map as Map +import Data.Word (Word64) data AccessListEntry = AccessListEntry { accessAddress :: Addr, @@ -34,7 +35,7 @@ data Transaction = Transaction { txData :: ByteString, - txGasLimit :: W256, + txGasLimit :: Word64, txGasPrice :: Maybe W256, txNonce :: W256, txR :: W256, @@ -60,7 +61,7 @@ sender :: Int -> Transaction -> Maybe Addr sender chainId tx = ecrec v' (txR tx) (txS tx) hash - where hash = keccak (signingData chainId tx) + where hash = keccak' (signingData chainId tx) v = txV tx v' = if v == 27 || v == 28 then v else 27 + v @@ -87,13 +88,13 @@ ) accessList normalData = rlpList [rlpWord256 (txNonce tx), rlpWord256 gasPrice, - rlpWord256 (txGasLimit tx), + rlpWord256 (num $ txGasLimit tx), to', rlpWord256 (txValue tx), BS (txData tx)] eip155Data = rlpList [rlpWord256 (txNonce tx), rlpWord256 gasPrice, - rlpWord256 (txGasLimit tx), + rlpWord256 (num $ txGasLimit tx), to', rlpWord256 (txValue tx), BS (txData tx), @@ -105,7 +106,7 @@ rlpWord256 (txNonce tx), rlpWord256 maxPrio, rlpWord256 maxFee, - rlpWord256 (txGasLimit tx), + rlpWord256 (num $ txGasLimit tx), to', rlpWord256 (txValue tx), BS (txData tx), @@ -115,21 +116,21 @@ rlpWord256 (fromIntegral chainId), rlpWord256 (txNonce tx), rlpWord256 gasPrice, - rlpWord256 (txGasLimit tx), + rlpWord256 (num $ txGasLimit tx), to', rlpWord256 (txValue tx), BS (txData tx), rlpAccessList] -accessListPrice :: FeeSchedule Integer -> [AccessListEntry] -> Integer +accessListPrice :: FeeSchedule Word64 -> [AccessListEntry] -> Word64 accessListPrice fs al = sum (map (\ale -> g_access_list_address fs + - (g_access_list_storage_key fs * (toInteger . length) (accessStorageKeys ale))) + (g_access_list_storage_key fs * (fromIntegral . length) (accessStorageKeys ale))) al) -txGasCost :: FeeSchedule Integer -> Transaction -> Integer +txGasCost :: FeeSchedule Word64 -> Transaction -> Word64 txGasCost fs tx = let calldata = txData tx zeroBytes = BS.count 0 calldata @@ -152,7 +153,7 @@ instance FromJSON Transaction where parseJSON (JSON.Object val) = do tdata <- dataField val "data" - gasLimit <- wordField val "gasLimit" + gasLimit <- word64Field val "gasLimit" gasPrice <- fmap read <$> val JSON..:? "gasPrice" maxPrio <- fmap read <$> val JSON..:? "maxPriorityFeePerGas" maxFee <- fmap read <$> val JSON..:? "maxFeePerGas" @@ -186,9 +187,9 @@ newAccount = initialContract $ EVM.RuntimeCode mempty -- | Increments origin nonce and pays gas deposit -setupTx :: Addr -> Addr -> Word -> Word -> Map Addr EVM.Contract -> Map Addr EVM.Contract +setupTx :: Addr -> Addr -> W256 -> Word64 -> Map Addr EVM.Contract -> Map Addr EVM.Contract setupTx origin coinbase gasPrice gasLimit prestate = - let gasCost = gasPrice * gasLimit + let gasCost = gasPrice * (num gasLimit) in (Map.adjust ((over EVM.nonce (+ 1)) . (over balance (subtract gasCost))) origin) . touchAccount origin @@ -205,20 +206,27 @@ gasLimit = view (EVM.tx . EVM.txgaslimit) vm coinbase = view (EVM.block . EVM.coinbase) vm value = view (EVM.state . EVM.callvalue) vm - toContract = initialContract (EVM.InitCode (view (EVM.state . EVM.code) vm)) + toContract = initialContract (view (EVM.state . EVM.code) vm) preState = setupTx origin coinbase gasPrice gasLimit $ view (EVM.env . EVM.contracts) vm oldBalance = view (accountAt toAddr . balance) preState creation = view (EVM.tx . EVM.isCreate) vm - initState = - (if isJust (maybeLitWord value) - then (Map.adjust (over balance (subtract (forceLit value))) origin) - . (Map.adjust (over balance (+ (forceLit value))) toAddr) - else id) + initState = (case unlit value of + Just v -> ((Map.adjust (over balance (subtract v))) origin) + . (Map.adjust (over balance (+ v))) toAddr + Nothing -> id) . (if creation then Map.insert toAddr (toContract & balance .~ oldBalance) else touchAccount toAddr) $ preState + resetConcreteStore s = if creation then Map.insert (num toAddr) mempty s else s + + resetStore (ConcreteStore s) = ConcreteStore (resetConcreteStore s) + resetStore (SStore a@(Lit _) k v s) = if creation && a == (litAddr toAddr) then resetStore s else (SStore a k v (resetStore s)) + resetStore (SStore {}) = error "cannot reset storage if it contains symbolic addresses" + resetStore s = s in vm & EVM.env . EVM.contracts .~ initState & EVM.tx . EVM.txReversion .~ preState + & EVM.env . EVM.storage %~ resetStore + & EVM.env . EVM.origStorage %~ resetConcreteStore diff --git a/src/EVM/Traversals.hs b/src/EVM/Traversals.hs new file mode 100644 --- /dev/null +++ b/src/EVM/Traversals.hs @@ -0,0 +1,669 @@ +{-# Language DataKinds #-} + +{- | + Module: EVM.Traversals + Description: Generic traversal functions for Expr datatypes +-} +module EVM.Traversals where + +import Prelude hiding (Word, LT, GT) + +import Control.Monad.Identity + +import EVM.Types + +foldProp :: forall b . Monoid b => (forall a . Expr a -> b) -> b -> Prop -> b +foldProp f acc p = acc <> (go p) + where + go :: Prop -> b + go = \case + PBool _ -> mempty + PEq a b -> (foldExpr f mempty a) <> (foldExpr f mempty b) + PLT a b -> foldExpr f mempty a <> foldExpr f mempty b + PGT a b -> foldExpr f mempty a <> foldExpr f mempty b + PGEq a b -> foldExpr f mempty a <> foldExpr f mempty b + PLEq a b -> foldExpr f mempty a <> foldExpr f mempty b + PNeg a -> go a + PAnd a b -> go a <> go b + POr a b -> go a <> go b + +-- | Recursively folds a given function over a given expression +-- Recursion schemes do this & a lot more, but defining them over GADT's isn't worth the hassle +foldExpr :: forall b c . Monoid b => (forall a . Expr a -> b) -> b -> Expr c -> b +foldExpr f acc expr = acc <> (go expr) + where + go :: forall a . Expr a -> b + go = \case + + -- literals & variables + + e@(Lit _) -> f e + e@(LitByte _) -> f e + e@(Var _) -> f e + e@(GVar _) -> f e + + -- bytes + + e@(IndexWord a b) -> f e <> (go a) <> (go b) + e@(EqByte a b) -> f e <> (go a) <> (go b) + + e@(JoinBytes + zero one two three four five six seven + eight nine ten eleven twelve thirteen fourteen fifteen + sixteen seventeen eighteen nineteen twenty twentyone twentytwo twentythree + twentyfour twentyfive twentysix twentyseven twentyeight twentynine thirty thirtyone) + -> f e + <> (go zero) <> (go one) <> (go two) <> (go three) + <> (go four) <> (go five) <> (go six) <> (go seven) + <> (go eight) <> (go nine) <> (go ten) <> (go eleven) + <> (go twelve) <> (go thirteen) <> (go fourteen) + <> (go fifteen) <> (go sixteen) <> (go seventeen) + <> (go eighteen) <> (go nineteen) <> (go twenty) + <> (go twentyone) <> (go twentytwo) <> (go twentythree) + <> (go twentyfour) <> (go twentyfive) <> (go twentysix) + <> (go twentyseven) <> (go twentyeight) <> (go twentynine) + <> (go thirty) <> (go thirtyone) + + -- control flow + + e@(Invalid a) -> f e <> (foldl (foldProp f) mempty a) + e@(StackLimitExceeded a) -> f e <> (foldl (foldProp f) mempty a) + e@(InvalidMemoryAccess a) -> f e <> (foldl (foldProp f) mempty a) + e@(BadJumpDestination a) -> f e <> (foldl (foldProp f) mempty a) + e@(SelfDestruct a) -> f e <> (foldl (foldProp f) mempty a) + e@(IllegalOverflow a) -> f e <> (foldl (foldProp f) mempty a) + e@(Revert a b) -> f e <> (foldl (foldProp f) mempty a) <> (go b) + e@(Return a b c) -> f e <> (foldl (foldProp f) mempty a) <> (go b) <> (go c) + e@(ITE a b c) -> f e <> (go a) <> (go b) <> (go c) + e@(TmpErr a _) -> f e <> (foldl (foldProp f) mempty a) + + -- integers + + e@(Add a b) -> f e <> (go a) <> (go b) + e@(Sub a b) -> f e <> (go a) <> (go b) + e@(Mul a b) -> f e <> (go a) <> (go b) + e@(Div a b) -> f e <> (go a) <> (go b) + e@(SDiv a b) -> f e <> (go a) <> (go b) + e@(Mod a b) -> f e <> (go a) <> (go b) + e@(SMod a b) -> f e <> (go a) <> (go b) + e@(AddMod a b c) -> f e <> (go a) <> (go b) <> (go c) + e@(MulMod a b c) -> f e <> (go a) <> (go b) <> (go c) + e@(Exp a b) -> f e <> (go a) <> (go b) + e@(SEx a b) -> f e <> (go a) <> (go b) + e@(Min a b) -> f e <> (go a) <> (go b) + + -- booleans + + e@(LT a b) -> f e <> (go a) <> (go b) + e@(GT a b) -> f e <> (go a) <> (go b) + e@(LEq a b) -> f e <> (go a) <> (go b) + e@(GEq a b) -> f e <> (go a) <> (go b) + e@(SLT a b) -> f e <> (go a) <> (go b) + e@(SGT a b) -> f e <> (go a) <> (go b) + e@(Eq a b) -> f e <> (go a) <> (go b) + e@(IsZero a) -> f e <> (go a) + + -- bits + + e@(And a b) -> f e <> (go a) <> (go b) + e@(Or a b) -> f e <> (go a) <> (go b) + e@(Xor a b) -> f e <> (go a) <> (go b) + e@(Not a) -> f e <> (go a) + e@(SHL a b) -> f e <> (go a) <> (go b) + e@(SHR a b) -> f e <> (go a) <> (go b) + e@(SAR a b) -> f e <> (go a) <> (go b) + + -- Hashes + + e@(Keccak a) -> f e <> (go a) + e@(SHA256 a) -> f e <> (go a) + + -- block context + + e@(Origin) -> f e + e@(Coinbase) -> f e + e@(Timestamp) -> f e + e@(BlockNumber) -> f e + e@(PrevRandao) -> f e + e@(GasLimit) -> f e + e@(ChainId) -> f e + e@(BaseFee) -> f e + e@(BlockHash a) -> f e <> (go a) + + -- frame context + + e@(Caller _) -> f e + e@(CallValue _) -> f e + e@(Address _) -> f e + e@(SelfBalance _ _) -> f e + e@(Gas _ _) -> f e + e@(Balance {}) -> f e + + -- code + + e@(CodeSize a) -> f e <> (go a) + e@(ExtCodeHash a) -> f e <> (go a) + + -- logs + + e@(LogEntry a b c) -> f e <> (go a) <> (go b) <> (foldl (<>) mempty (fmap f c)) + + -- Contract Creation + + e@(Create a b c d g h) + -> f e + <> (go a) + <> (go b) + <> (go c) + <> (go d) + <> (foldl (<>) mempty (fmap go g)) + <> (go h) + e@(Create2 a b c d g h i) + -> f e + <> (go a) + <> (go b) + <> (go c) + <> (go d) + <> (go g) + <> (foldl (<>) mempty (fmap go h)) + <> (go i) + + -- Calls + + e@(Call a b c d g h i j k) + -> f e + <> (go a) + <> (maybe mempty (go) b) + <> (go c) + <> (go d) + <> (go g) + <> (go h) + <> (go i) + <> (foldl (<>) mempty (fmap go j)) + <> (go k) + + e@(CallCode a b c d g h i j k) + -> f e + <> (go a) + <> (go b) + <> (go c) + <> (go d) + <> (go g) + <> (go h) + <> (go i) + <> (foldl (<>) mempty (fmap go j)) + <> (go k) + + e@(DelegeateCall a b c d g h i j k) + -> f e + <> (go a) + <> (go b) + <> (go c) + <> (go d) + <> (go g) + <> (go h) + <> (go i) + <> (foldl (<>) mempty (fmap go j)) + <> (go k) + + -- storage + + e@(EmptyStore) -> f e + e@(ConcreteStore _) -> f e + e@(AbstractStore) -> f e + e@(SLoad a b c) -> f e <> (go a) <> (go b) <> (go c) + e@(SStore a b c d) -> f e <> (go a) <> (go b) <> (go c) <> (go d) + + -- buffers + + e@(ConcreteBuf _) -> f e + e@(AbstractBuf _) -> f e + e@(ReadWord a b) -> f e <> (go a) <> (go b) + e@(ReadByte a b) -> f e <> (go a) <> (go b) + e@(WriteWord a b c) -> f e <> (go a) <> (go b) <> (go c) + e@(WriteByte a b c) -> f e <> (go a) <> (go b) <> (go c) + + e@(CopySlice a b c d g) + -> f e + <> (go a) + <> (go b) + <> (go c) + <> (go d) + <> (go g) + e@(BufLength a) -> f e <> (go a) + +mapProp :: (forall a . Expr a -> Expr a) -> Prop -> Prop +mapProp f = \case + PBool b -> PBool b + PEq a b -> PEq (mapExpr f (f a)) (mapExpr f (f b)) + PLT a b -> PLT (mapExpr f (f a)) (mapExpr f (f b)) + PGT a b -> PGT (mapExpr f (f a)) (mapExpr f (f b)) + PLEq a b -> PLEq (mapExpr f (f a)) (mapExpr f (f b)) + PGEq a b -> PGEq (mapExpr f (f a)) (mapExpr f (f b)) + PNeg a -> PNeg (mapProp f a) + PAnd a b -> PAnd (mapProp f a) (mapProp f b) + POr a b -> POr (mapProp f a) (mapProp f b) + +-- | Recursively applies a given function to every node in a given expr instance +-- Recursion schemes do this & a lot more, but defining them over GADT's isn't worth the hassle +mapExpr :: (forall a . Expr a -> Expr a) -> Expr b -> Expr b +mapExpr f expr = runIdentity (mapExprM (Identity . f) expr) + + +mapExprM :: Monad m => (forall a . Expr a -> m (Expr a)) -> Expr b -> m (Expr b) +mapExprM f expr = case expr of + + -- literals & variables + + Lit a -> f (Lit a) + LitByte a -> f (LitByte a) + Var a -> f (Var a) + GVar s -> f (GVar s) + + -- bytes + + IndexWord a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (IndexWord a' b') + EqByte a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (EqByte a' b') + + JoinBytes zero one two three four five six seven eight nine + ten eleven twelve thirteen fourteen fifteen sixteen seventeen + eighteen nineteen twenty twentyone twentytwo twentythree twentyfour + twentyfive twentysix twentyseven twentyeight twentynine thirty thirtyone -> do + zero' <- mapExprM f zero + one' <- mapExprM f one + two' <- mapExprM f two + three' <- mapExprM f three + four' <- mapExprM f four + five' <- mapExprM f five + six' <- mapExprM f six + seven' <- mapExprM f seven + eight' <- mapExprM f eight + nine' <- mapExprM f nine + ten' <- mapExprM f ten + eleven' <- mapExprM f eleven + twelve' <- mapExprM f twelve + thirteen' <- mapExprM f thirteen + fourteen' <- mapExprM f fourteen + fifteen' <- mapExprM f fifteen + sixteen' <- mapExprM f sixteen + seventeen' <- mapExprM f seventeen + eighteen' <- mapExprM f eighteen + nineteen' <- mapExprM f nineteen + twenty' <- mapExprM f twenty + twentyone' <- mapExprM f twentyone + twentytwo' <- mapExprM f twentytwo + twentythree' <- mapExprM f twentythree + twentyfour' <- mapExprM f twentyfour + twentyfive' <- mapExprM f twentyfive + twentysix' <- mapExprM f twentysix + twentyseven' <- mapExprM f twentyseven + twentyeight' <- mapExprM f twentyeight + twentynine' <- mapExprM f twentynine + thirty' <- mapExprM f thirty + thirtyone' <- mapExprM f thirtyone + f (JoinBytes zero' one' two' three' four' five' six' seven' eight' nine' + ten' eleven' twelve' thirteen' fourteen' fifteen' sixteen' seventeen' + eighteen' nineteen' twenty' twentyone' twentytwo' twentythree' twentyfour' + twentyfive' twentysix' twentyseven' twentyeight' twentynine' thirty' thirtyone') + + -- control flow + + Invalid a -> do + a' <- mapM (mapPropM f) a + f (Invalid a') + SelfDestruct a -> do + a' <- mapM (mapPropM f) a + f (SelfDestruct a') + IllegalOverflow a -> do + a' <- mapM (mapPropM f) a + f (IllegalOverflow a') + InvalidMemoryAccess a -> do + a' <- mapM (mapPropM f) a + f (InvalidMemoryAccess a') + StackLimitExceeded a -> do + a' <- mapM (mapPropM f) a + f (StackLimitExceeded a') + BadJumpDestination a -> do + a' <- mapM (mapPropM f) a + f (BadJumpDestination a') + Revert a b -> do + a' <- mapM (mapPropM f) a + b' <- mapExprM f b + f (Revert a' b') + Return a b c -> do + a' <- mapM (mapPropM f) a + b' <- mapExprM f b + c' <- mapExprM f c + f (Return a' b' c') + + ITE a b c -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapExprM f c + f (ITE a' b' c') + + TmpErr a b -> do + a' <- mapM (mapPropM f) a + f (TmpErr a' b) + + -- integers + + Add a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (Add a' b') + Sub a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (Sub a' b') + Mul a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (Mul a' b') + Div a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (Div a' b') + SDiv a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (SDiv a' b') + Mod a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (Mod a' b') + SMod a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (SMod a' b') + AddMod a b c -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapExprM f c + f (AddMod a' b' c') + MulMod a b c -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapExprM f c + f (MulMod a' b' c') + Exp a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (Exp a' b') + SEx a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (SEx a' b') + Min a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (Min a' b') + + -- booleans + + LT a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (LT a' b') + GT a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (GT a' b') + LEq a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (LEq a' b') + GEq a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (GEq a' b') + SLT a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (SLT a' b') + SGT a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (SGT a' b') + Eq a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (Eq a' b') + IsZero a -> do + a' <- mapExprM f a + f (IsZero a') + + -- bits + + And a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (And a' b') + Or a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (Or a' b') + Xor a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (Xor a' b') + Not a -> do + a' <- mapExprM f a + f (Not a') + SHL a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (SHL a' b') + SHR a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (SHR a' b') + SAR a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (SAR a' b') + + + -- Hashes + + Keccak a -> do + a' <- mapExprM f a + f (Keccak a') + + SHA256 a -> do + a' <- mapExprM f a + f (SHA256 a') + + -- block context + + Origin -> f Origin + Coinbase -> f Coinbase + Timestamp -> f Timestamp + BlockNumber -> f BlockNumber + PrevRandao -> f PrevRandao + GasLimit -> f GasLimit + ChainId -> f ChainId + BaseFee -> f BaseFee + BlockHash a -> do + a' <- mapExprM f a + f (BlockHash a') + + -- frame context + + Caller a -> f (Caller a) + CallValue a -> f (CallValue a) + Address a -> f (Address a) + SelfBalance a b -> f (SelfBalance a b) + Gas a b -> f (Gas a b) + Balance a b c -> do + c' <- mapExprM f c + f (Balance a b c') + + -- code + + CodeSize a -> do + a' <- mapExprM f a + f (CodeSize a') + ExtCodeHash a -> do + a' <- mapExprM f a + f (ExtCodeHash a') + + -- logs + + LogEntry a b c -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapM (mapExprM f) c + f (LogEntry a' b' c') + + -- Contract Creation + + Create a b c d e g -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapExprM f c + d' <- mapExprM f d + e' <- mapM (mapExprM f) e + g' <- mapExprM f g + f (Create a' b' c' d' e' g') + Create2 a b c d e g h -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapExprM f c + d' <- mapExprM f d + e' <- mapExprM f e + g' <- mapM (mapExprM f) g + h' <- mapExprM f h + f (Create2 a' b' c' d' e' g' h') + + -- Calls + + Call a b c d e g h i j -> do + a' <- mapExprM f a + b' <- mapM (mapExprM f) b + c' <- mapExprM f c + d' <- mapExprM f d + e' <- mapExprM f e + g' <- mapExprM f g + h' <- mapExprM f h + i' <- mapM (mapExprM f) i + j' <- mapExprM f j + f (Call a' b' c' d' e' g' h' i' j') + CallCode a b c d e g h i j -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapExprM f c + d' <- mapExprM f d + e' <- mapExprM f e + g' <- mapExprM f g + h' <- mapExprM f h + i' <- mapM (mapExprM f) i + j' <- mapExprM f j + f (CallCode a' b' c' d' e' g' h' i' j') + DelegeateCall a b c d e g h i j -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapExprM f c + d' <- mapExprM f d + e' <- mapExprM f e + g' <- mapExprM f g + h' <- mapExprM f h + i' <- mapM (mapExprM f) i + j' <- mapExprM f j + f (DelegeateCall a' b' c' d' e' g' h' i' j') + + -- storage + + EmptyStore -> f EmptyStore + ConcreteStore a -> f (ConcreteStore a) + AbstractStore -> f AbstractStore + SLoad a b c -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapExprM f c + f (SLoad a' b' c') + SStore a b c d -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapExprM f c + d' <- mapExprM f d + f (SStore a' b' c' d') + + -- buffers + + ConcreteBuf a -> do + f (ConcreteBuf a) + AbstractBuf a -> do + f (AbstractBuf a) + ReadWord a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (ReadWord a' b') + ReadByte a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + f (ReadByte a' b') + WriteWord a b c -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapExprM f c + f (WriteWord a' b' c') + WriteByte a b c -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapExprM f c + f (WriteByte a' b' c') + + CopySlice a b c d e -> do + a' <- mapExprM f a + b' <- mapExprM f b + c' <- mapExprM f c + d' <- mapExprM f d + e' <- mapExprM f e + f (CopySlice a' b' c' d' e') + + BufLength a -> do + a' <- mapExprM f a + f (BufLength a') + + +mapPropM :: Monad m => (forall a . Expr a -> m (Expr a)) -> Prop -> m Prop +mapPropM f = \case + PBool b -> pure $ PBool b + PEq a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + pure $ PEq a' b' + PLT a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + pure $ PLT a' b' + PGT a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + pure $ PGT a' b' + PLEq a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + pure $ PLEq a' b' + PGEq a b -> do + a' <- mapExprM f a + b' <- mapExprM f b + pure $ PGEq a' b' + PNeg a -> do + a' <- mapPropM f a + pure $ PNeg a' + PAnd a b -> do + a' <- mapPropM f a + b' <- mapPropM f b + pure $ PAnd a' b' + POr a b -> do + a' <- mapPropM f a + b' <- mapPropM f b + pure $ POr a' b' diff --git a/src/EVM/Types.hs b/src/EVM/Types.hs --- a/src/EVM/Types.hs +++ b/src/EVM/Types.hs @@ -1,27 +1,27 @@ {-# Language CPP #-} {-# Language TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# Language TypeApplications #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} module EVM.Types where import Prelude hiding (Word, LT, GT) import Data.Aeson -import Crypto.Hash -import Data.SBV hiding (Word) -import Data.Kind +import Crypto.Hash hiding (SHA256) +import Data.Map (Map) import Data.Bifunctor (first) import Data.Char -import Data.List (intercalate) +import Data.List (isPrefixOf) import Data.ByteString (ByteString) import Data.ByteString.Base16 as BS16 import Data.ByteString.Builder (byteStringHex, toLazyByteString) import Data.ByteString.Lazy (toStrict) -import Control.Monad.State.Strict (liftM) import qualified Data.ByteString.Char8 as Char8 +import Data.Word (Word8, Word32, Word64) +import Data.Bits (Bits, FiniteBits, shiftR, shift, shiftL, (.&.), (.|.)) import Data.DoubleWord import Data.DoubleWord.TH import Data.Maybe (fromMaybe) @@ -42,302 +42,427 @@ -- Some stuff for "generic programming", needed to create Word512 import Data.Data +import qualified Data.Vector as V -- We need a 512-bit word for doing ADDMOD and MULMOD with full precision. mkUnpackedDoubleWord "Word512" ''Word256 "Int512" ''Int256 ''Word256 [''Typeable, ''Data, ''Generic] -data Buffer - = ConcreteBuffer ByteString - | SymbolicBuffer [SWord 8] - newtype W256 = W256 Word256 deriving - ( Num, Integral, Real, Ord, Enum, Eq - , Bits, FiniteBits, Bounded, Generic + ( Num, Integral, Real, Ord, Generic + , Bits , FiniteBits, Enum, Eq , Bounded ) -data Word = C Whiff W256 --maybe to remove completely in the future +{- | + Expr implements an abstract respresentation of an EVM program -instance Show Word where - show (C _ x) = show x + This type can give insight into the provenance of a term which is useful, + both for the aesthetic purpose of printing terms in a richer way, but also to + allow optimizations on the AST instead of letting the SMT solver do all the + heavy lifting. -instance Read Word where - readsPrec n s = - case readsPrec n s of - [(x, r)] -> [(C (Literal x) x, r)] - _ -> [] + Memory, calldata, and returndata are all represented as a Buf. Semantically + speaking a Buf is a byte array with of size 2^256. -w256 :: W256 -> Word -w256 w = C (Literal w) w + Bufs have two base constructors: + - AbstractBuf: all elements are fully abstract values + - ConcreteBuf bs: all elements past (length bs) are zero -instance Bits Word where - (C a x) .&. (C b y) = C (And a b) (x .&. y) - (C a x) .|. (C b y) = C (Or a b) (x .|. y) - (C a x) `xor` (C b y) = C (Todo "xor" [a, b]) (x `xor` y) - complement (C a x) = C (Neg a) (complement x) - shiftL (C a x) i = C (SHL a (Literal $ fromIntegral i)) (shiftL x i) - shiftR (C a x) i = C (SHR a (Literal $ fromIntegral i)) (shiftR x i) - rotate (C a x) i = C (Todo "rotate " [a]) (rotate x i) -- unused. - 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 + Bufs can be read from with: + - ReadByte idx buf: read the byte at idx from buf + - ReadWord idx buf: read the byte at idx from buf -instance FiniteBits Word where - finiteBitSize (C _ x) = finiteBitSize x - countLeadingZeros (C _ x) = countLeadingZeros x - countTrailingZeros (C _ x) = countTrailingZeros x + Bufs can be written to with: + - WriteByte idx val buf: write val to idx in buf + - WriteWord idx val buf: write val to idx in buf + - CopySlice srcOffset dstOffset size src dst: + overwrite dstOffset -> dstOffset + size in dst with srcOffset -> srcOffset + size from src -instance Bounded Word where - minBound = w256 minBound - maxBound = w256 maxBound + Note that the shared usage of `Buf` does allow for the construction of some + badly typed Expr instances (e.g. an MSTORE on top of the contents of calldata + instead of some previous instance of memory), we accept this for the + sake of simplifying pattern matches against a Buf expression. -instance Eq Word where - (C _ x) == (C _ y) = x == y + Storage expressions are similar, but instead of writing regions of bytes, we + write a word to a particular key in a given addresses storage. Note that as + with a Buf, writes can be sequenced on top of concrete, empty and fully + abstract starting states. -instance Enum Word where - toEnum i = w256 (toEnum i) - fromEnum (C _ x) = fromEnum x + One important principle is that of local context: e.g. each term representing + a write to a Buf / Storage / Logs will always contain a copy of the state + that is being added to, this ensures that all context relevant to a given + operation is contained within the term that represents that operation. -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 + When dealing with Expr instances we assume that concrete expressions have + been reduced to their smallest possible representation (i.e. a `Lit`, + `ConcreteBuf`, or `ConcreteStore`). Failure to adhere to this invariant will + result in your concrete term being treated as symbolic, and may produce + unexpected errors. In the future we may wish to consider encoding the + concreteness of a given term directly in the type of that term, since such + type level shenanigans tends to complicate implementation, we skip this for + now. +-} -instance Num Word where - (C a x) + (C b y) = C (Add a b) (x + y) - (C a x) * (C b y) = C (Mul a b) (x * y) - abs (C a x) = C (Todo "abs" [a]) (abs x) - signum (C a x) = C (Todo "signum" [a]) (signum x) - fromInteger x = C (Literal (fromInteger x)) (fromInteger x) - negate (C a x) = C (Sub (Literal 0) a) (negate x) +-- phantom type tags for AST construction +data EType + = Buf + | Storage + | Log + | EWord + | Byte + | End + deriving (Typeable) -instance Real Word where - toRational (C _ x) = toRational x +-- Variables refering to a global environment +data GVar (a :: EType) where + BufVar :: Int -> GVar Buf + StoreVar :: Int -> GVar Storage -instance Ord Word where - compare (C _ x) (C _ y) = compare x y +deriving instance Show (GVar a) +deriving instance Eq (GVar a) +deriving instance Ord (GVar a) -newtype ByteStringS = ByteStringS ByteString deriving (Eq) -instance Show ByteStringS where - show (ByteStringS x) = ("0x" ++) . Text.unpack . fromBinary $ x - where - fromBinary = - Text.decodeUtf8 . toStrict . toLazyByteString . byteStringHex +-- add type level list of constraints +data Expr (a :: EType) where -instance JSON.ToJSON ByteStringS where - toJSON = JSON.String . Text.pack . show + -- identifiers --- | Symbolic words of 256 bits, possibly annotated with additional --- "insightful" information -data SymWord = S Whiff (SWord 256) + Lit :: W256 -> Expr EWord + Var :: Text -> Expr EWord + GVar :: GVar a -> Expr a -instance Show SymWord where - show (S w _) = show w + -- bytes -var :: String -> SWord 256 -> SymWord -var name x = S (Var name x) x + LitByte :: Word8 -> Expr Byte + IndexWord :: Expr EWord -> Expr EWord -> Expr Byte + EqByte :: Expr Byte -> Expr Byte -> Expr EWord --- | Custom instances for SymWord, many of which have direct --- analogues for concrete words defined in Concrete.hs -instance EqSymbolic SymWord where - (.==) (S _ x) (S _ y) = x .== y + -- TODO: rm readWord in favour of this? + JoinBytes :: Expr Byte -> Expr Byte -> Expr Byte -> Expr Byte + -> Expr Byte -> Expr Byte -> Expr Byte -> Expr Byte + -> Expr Byte -> Expr Byte -> Expr Byte -> Expr Byte + -> Expr Byte -> Expr Byte -> Expr Byte -> Expr Byte + -> Expr Byte -> Expr Byte -> Expr Byte -> Expr Byte + -> Expr Byte -> Expr Byte -> Expr Byte -> Expr Byte + -> Expr Byte -> Expr Byte -> Expr Byte -> Expr Byte + -> Expr Byte -> Expr Byte -> Expr Byte -> Expr Byte + -> Expr EWord + -- control flow -instance Num SymWord where - (S a x) + (S b y) = S (Add a b) (x + y) - (S a x) * (S b y) = S (Mul a b) (x * y) - abs (S a x) = S (Todo "abs" [a]) (abs x) - signum (S a x) = S (Todo "signum" [a]) (signum x) - fromInteger x = S (Literal (fromInteger x)) (fromInteger x) - negate (S a x) = S (Neg a) (negate x) + Invalid :: [Prop] -> Expr End + IllegalOverflow :: [Prop] -> Expr End + SelfDestruct :: [Prop] -> Expr End + StackLimitExceeded :: [Prop] -> Expr End + InvalidMemoryAccess :: [Prop] -> Expr End + BadJumpDestination :: [Prop] -> Expr End + Revert :: [Prop] -> Expr Buf -> Expr End + Return :: [Prop] -> Expr Buf -> Expr Storage -> Expr End + ITE :: Expr EWord -> Expr End -> Expr End -> Expr End + TmpErr :: [Prop] -> String -> Expr End -- TODO this is a crutch to help us not deal with all EVM failure modes in Expr + -- should be removed once EVM failure modes are handled in Expr + -- integers -instance Bits SymWord where - (S a x) .&. (S b y) = S (And a b) (x .&. y) - (S a x) .|. (S b y) = S (Or a b) (x .|. y) - (S a x) `xor` (S b y) = S (Todo "xor" [a, b]) (x `xor` y) - complement (S a x) = S (Neg a) (complement x) - shiftL (S a x) i = S (SHL a (Literal $ fromIntegral i)) (shiftL x i) - shiftR (S a x) i = S (SHR a (Literal $ fromIntegral i)) (shiftR x i) - rotate (S a x) i = S (Todo "rotate " [a]) (rotate x i) -- unused. - bitSize (S _ x) = bitSize x - bitSizeMaybe (S _ x) = bitSizeMaybe x - isSigned (S _ x) = isSigned x - testBit (S _ x) i = testBit x i - bit i = w256lit (bit i) - popCount (S _ x) = popCount x + Add :: Expr EWord -> Expr EWord -> Expr EWord + Sub :: Expr EWord -> Expr EWord -> Expr EWord + Mul :: Expr EWord -> Expr EWord -> Expr EWord + Div :: Expr EWord -> Expr EWord -> Expr EWord + SDiv :: Expr EWord -> Expr EWord -> Expr EWord + Mod :: Expr EWord -> Expr EWord -> Expr EWord + SMod :: Expr EWord -> Expr EWord -> Expr EWord + AddMod :: Expr EWord -> Expr EWord -> Expr EWord -> Expr EWord + MulMod :: Expr EWord -> Expr EWord -> Expr EWord -> Expr EWord + Exp :: Expr EWord -> Expr EWord -> Expr EWord + SEx :: Expr EWord -> Expr EWord -> Expr EWord + Min :: Expr EWord -> Expr EWord -> Expr EWord --- sQuotRem and sDivMod are identical for SWord 256 --- prove $ \x y -> x `sQuotRem` (y :: SWord 256) .== x `sDivMod` y --- Q.E.D. -instance SDivisible SymWord where - sQuotRem (S x' x) (S y' y) = let (a, b) = x `sQuotRem` y - in (S (Div x' y') a, S (Mod x' y') b) - sDivMod = sQuotRem + -- booleans --- | Instead of supporting a Mergeable instance directly, --- we use one which carries the Whiff around: -iteWhiff :: Whiff -> SBool -> SWord 256 -> SWord 256 -> SymWord -iteWhiff w b x y = S w (ite b x y) + LT :: Expr EWord -> Expr EWord -> Expr EWord + GT :: Expr EWord -> Expr EWord -> Expr EWord + LEq :: Expr EWord -> Expr EWord -> Expr EWord + GEq :: Expr EWord -> Expr EWord -> Expr EWord + SLT :: Expr EWord -> Expr EWord -> Expr EWord + SGT :: Expr EWord -> Expr EWord -> Expr EWord + Eq :: Expr EWord -> Expr EWord -> Expr EWord + IsZero :: Expr EWord -> Expr EWord -instance Bounded SymWord where - minBound = w256lit minBound - maxBound = w256lit maxBound + -- bits -instance Eq SymWord where - (S _ x) == (S _ y) = x == y + And :: Expr EWord -> Expr EWord -> Expr EWord + Or :: Expr EWord -> Expr EWord -> Expr EWord + Xor :: Expr EWord -> Expr EWord -> Expr EWord + Not :: Expr EWord -> Expr EWord + SHL :: Expr EWord -> Expr EWord -> Expr EWord + SHR :: Expr EWord -> Expr EWord -> Expr EWord + SAR :: Expr EWord -> Expr EWord -> Expr EWord -instance Enum SymWord where - toEnum i = w256lit (toEnum i) - fromEnum (S _ x) = fromEnum x + -- Hashes --- | This type can give insight into the provenance of a term --- which is useful, both for the aesthetic purpose of printing --- terms in a richer way, but also do optimizations on the AST --- instead of letting the SMT solver do all the heavy lifting. -data Whiff = - Todo String [Whiff] - -- booleans / bits - | And Whiff Whiff - | Or Whiff Whiff - | Eq Whiff Whiff - | LT Whiff Whiff - | GT Whiff Whiff - | SLT Whiff Whiff - | SGT Whiff Whiff - | IsZero Whiff - | ITE Whiff Whiff Whiff - -- bits - | SHL Whiff Whiff - | SHR Whiff Whiff - | SAR Whiff Whiff + Keccak :: Expr Buf -> Expr EWord + SHA256 :: Expr Buf -> Expr EWord - -- integers - | Add Whiff Whiff - | Sub Whiff Whiff - | Mul Whiff Whiff - | Div Whiff Whiff - | Mod Whiff Whiff - | Exp Whiff Whiff - | Neg Whiff - | FromKeccak Buffer - | FromBytes Buffer - | FromStorage Whiff (SArray (WordN 256) (WordN 256)) - | Literal W256 - | Var String (SWord 256) + -- block context -instance Show Whiff where - show w = - let - infix' s x y = show x ++ s ++ show y - in case w of - Todo s args -> s ++ "(" ++ (intercalate "," (show <$> args)) ++ ")" - And x y -> infix' " and " x y - Or x y -> infix' " or " x y - ITE b x y -> "if " ++ show b ++ " then " ++ show x ++ " else " ++ show y - Eq x y -> infix' " == " x y - LT x y -> infix' " < " x y - GT x y -> infix' " > " x y - SLT x y -> infix' " s< " x y - SGT x y -> infix' " s> " x y - IsZero x -> "IsZero(" ++ show x ++ ")" - SHL x y -> infix' " << " x y - SHR x y -> infix' " >> " x y - SAR x y -> infix' " a>> " x y - Add x y -> infix' " + " x y - Sub x y -> infix' " - " x y - Mul x y -> infix' " * " x y - Div x y -> infix' " / " x y - Mod x y -> infix' " % " x y - Exp x y -> infix' " ** " x y - Neg x -> "not " ++ show x - Var v _ -> v - FromKeccak buf -> "keccak(" ++ show buf ++ ")" - Literal x -> show x - FromBytes buf -> "FromBuffer " ++ show buf - FromStorage l _ -> "SLOAD(" ++ show l ++ ")" + Origin :: Expr EWord + BlockHash :: Expr EWord -> Expr EWord + Coinbase :: Expr EWord + Timestamp :: Expr EWord + BlockNumber :: Expr EWord + PrevRandao :: Expr EWord + GasLimit :: Expr EWord + ChainId :: Expr EWord + BaseFee :: Expr EWord -newtype Addr = Addr { addressWord160 :: Word160 } - deriving (Num, Integral, Real, Ord, Enum, Eq, Bits, Generic) + -- frame context -newtype SAddr = SAddr { saddressWord160 :: SWord 160 } - deriving (Num) + CallValue :: Int -- frame idx + -> Expr EWord --- | Capture the correspondence between sized and fixed-sized BVs --- (This is blatant copypasta of `FromSized` from sbv, which just --- happens to be defined up to 64 bits) -type family FromSizzle (t :: Type) :: Type where - FromSizzle (WordN 256) = W256 - FromSizzle (WordN 160) = Addr + Caller :: Int -- frame idx + -> Expr EWord --- | Conversion from a sized BV to a fixed-sized bit-vector. -class FromSizzleBV a where - -- | Convert a sized bit-vector to the corresponding fixed-sized bit-vector, - -- for instance 'SWord 16' to 'SWord16'. See also 'toSized'. - fromSizzle :: a -> FromSizzle a + Address :: Int -- frame idx + -> Expr EWord - default fromSizzle :: (Num (FromSizzle a), Integral a) => a -> FromSizzle a - fromSizzle = fromIntegral + Balance :: Int -- frame idx + -> Int -- PC (in case we're checking the current contract) + -> Expr EWord -- address + -> Expr EWord + SelfBalance :: Int -- frame idx + -> Int -- PC + -> Expr EWord -maybeLitWord :: SymWord -> Maybe Word -maybeLitWord (S whiff a) = fmap (C whiff . fromSizzle) (unliteral a) + Gas :: Int -- frame idx + -> Int -- PC + -> Expr EWord --- | convert between (WordN 256) and Word256 -type family ToSizzle (t :: Type) :: Type where - ToSizzle W256 = (WordN 256) - ToSizzle Addr = (WordN 160) + -- code --- | Conversion from a fixed-sized BV to a sized bit-vector. -class ToSizzleBV a where - -- | Convert a fixed-sized bit-vector to the corresponding sized bit-vector, - toSizzle :: a -> ToSizzle a + CodeSize :: Expr EWord -- address + -> Expr EWord -- size - default toSizzle :: (Num (ToSizzle a), Integral a) => (a -> ToSizzle a) - toSizzle = fromIntegral + ExtCodeHash :: Expr EWord -- address + -> Expr EWord -- size + -- logs -instance (ToSizzleBV W256) -instance (FromSizzleBV (WordN 256)) -instance (ToSizzleBV Addr) -instance (FromSizzleBV (WordN 160)) + LogEntry :: Expr EWord -- address + -> Expr Buf -- data + -> [Expr EWord] -- topics + -> Expr Log -w256lit :: W256 -> SymWord -w256lit x = S (Literal x) $ literal $ toSizzle x + -- Contract Creation -litBytes :: ByteString -> [SWord 8] -litBytes bs = fmap (toSized . literal) (BS.unpack bs) + Create :: Expr EWord -- value + -> Expr EWord -- offset + -> Expr EWord -- size + -> Expr Buf -- memory + -> [Expr Log] -- logs + -> Expr Storage -- storage + -> Expr EWord -- address --- | Operations over buffers (concrete or symbolic) + Create2 :: Expr EWord -- value + -> Expr EWord -- offset + -> Expr EWord -- size + -> Expr EWord -- salt + -> Expr Buf -- memory + -> [Expr Log] -- logs + -> Expr Storage -- storage + -> Expr EWord -- address --- | A buffer is a list of bytes. For concrete execution, this is simply `ByteString`. --- In symbolic settings, it is a list of symbolic bitvectors of size 8. -instance Show Buffer where - show (ConcreteBuffer b) = show $ ByteStringS b - show (SymbolicBuffer b) = show (length b) ++ " bytes" + -- Calls + Call :: Expr EWord -- gas + -> Maybe (Expr EWord) -- target + -> Expr EWord -- value + -> Expr EWord -- args offset + -> Expr EWord -- args size + -> Expr EWord -- ret offset + -> Expr EWord -- ret size + -> [Expr Log] -- logs + -> Expr Storage -- storage + -> Expr EWord -- success -instance Semigroup Buffer where - ConcreteBuffer a <> ConcreteBuffer b = ConcreteBuffer (a <> b) - ConcreteBuffer a <> SymbolicBuffer b = SymbolicBuffer (litBytes a <> b) - SymbolicBuffer a <> ConcreteBuffer b = SymbolicBuffer (a <> litBytes b) - SymbolicBuffer a <> SymbolicBuffer b = SymbolicBuffer (a <> b) + CallCode :: Expr EWord -- gas + -> Expr EWord -- address + -> Expr EWord -- value + -> Expr EWord -- args offset + -> Expr EWord -- args size + -> Expr EWord -- ret offset + -> Expr EWord -- ret size + -> [Expr Log] -- logs + -> Expr Storage -- storage + -> Expr EWord -- success -instance Monoid Buffer where - mempty = ConcreteBuffer mempty + DelegeateCall :: Expr EWord -- gas + -> Expr EWord -- address + -> Expr EWord -- value + -> Expr EWord -- args offset + -> Expr EWord -- args size + -> Expr EWord -- ret offset + -> Expr EWord -- ret size + -> [Expr Log] -- logs + -> Expr Storage -- storage + -> Expr EWord -- success -instance EqSymbolic Buffer where - ConcreteBuffer a .== ConcreteBuffer b = literal (a == b) - ConcreteBuffer a .== SymbolicBuffer b = litBytes a .== b - SymbolicBuffer a .== ConcreteBuffer b = a .== litBytes b - SymbolicBuffer a .== SymbolicBuffer b = a .== b + -- storage + EmptyStore :: Expr Storage + ConcreteStore :: Map W256 (Map W256 W256) -> Expr Storage + AbstractStore :: Expr Storage + SLoad :: Expr EWord -- address + -> Expr EWord -- index + -> Expr Storage -- storage + -> Expr EWord -- result + + SStore :: Expr EWord -- address + -> Expr EWord -- index + -> Expr EWord -- value + -> Expr Storage -- old storage + -> Expr Storage -- new storae + + -- buffers + + ConcreteBuf :: ByteString -> Expr Buf + AbstractBuf :: Text -> Expr Buf + + ReadWord :: Expr EWord -- index + -> Expr Buf -- src + -> Expr EWord + + ReadByte :: Expr EWord -- index + -> Expr Buf -- src + -> Expr Byte + + WriteWord :: Expr EWord -- dst offset + -> Expr EWord -- value + -> Expr Buf -- prev + -> Expr Buf + + WriteByte :: Expr EWord -- dst offset + -> Expr Byte -- value + -> Expr Buf -- prev + -> Expr Buf + + CopySlice :: Expr EWord -- src offset + -> Expr EWord -- dst offset + -> Expr EWord -- size + -> Expr Buf -- src + -> Expr Buf -- dst + -> Expr Buf + + BufLength :: Expr Buf -> Expr EWord + +deriving instance Show (Expr a) +deriving instance Eq (Expr a) +deriving instance Ord (Expr a) + +-- The language of assertable expressions. +-- This is useful when generating SMT queries based on Expr instances, since +-- the translation of Eq and other boolean operators from Expr to SMT is an +-- (ite (eq a b) 1 0). We can use the boolean operators here to remove some +-- unescessary `ite` statements from our SMT encoding. +data Prop where + PEq :: forall a . Typeable a => Expr a -> Expr a -> Prop + PLT :: Expr EWord -> Expr EWord -> Prop + PGT :: Expr EWord -> Expr EWord -> Prop + PGEq :: Expr EWord -> Expr EWord -> Prop + PLEq :: Expr EWord -> Expr EWord -> Prop + PNeg :: Prop -> Prop + PAnd :: Prop -> Prop -> Prop + POr :: Prop -> Prop -> Prop + PBool :: Bool -> Prop +deriving instance (Show Prop) + +infixr 3 .&& +(.&&) :: Prop -> Prop -> Prop +x .&& y = PAnd x y + +infixr 2 .|| +(.||) :: Prop -> Prop -> Prop +x .|| y = POr x y + +infix 4 .<, .<=, .>, .>= +(.<) :: Expr EWord -> Expr EWord -> Prop +x .< y = PLT x y +(.<=) :: Expr EWord -> Expr EWord -> Prop +x .<= y = PLEq x y +(.>) :: Expr EWord -> Expr EWord -> Prop +x .> y = PGT x y +(.>=) :: Expr EWord -> Expr EWord -> Prop +x .>= y = PGEq x y + +infix 4 .==, ./= +(.==) :: (Typeable a) => Expr a -> Expr a -> Prop +x .== y = PEq x y +(./=) :: (Typeable a) => Expr a -> Expr a -> Prop +x ./= y = PNeg (PEq x y) + +instance Eq Prop where + PBool a == PBool b = a == b + PEq (a :: Expr x) (b :: Expr x) == PEq (c :: Expr y) (d :: Expr y) + = case eqT @x @y of + Just Refl -> a == c && b == d + Nothing -> False + PLT a b == PLT c d = a == c && b == d + PGT a b == PGT c d = a == c && b == d + PGEq a b == PGEq c d = a == c && b == d + PLEq a b == PLEq c d = a == c && b == d + PNeg a == PNeg b = a == b + PAnd a b == PAnd c d = a == c && b == d + POr a b == POr c d = a == c && b == d + _ == _ = False + +instance Ord Prop where + PBool a <= PBool b = a <= b + PEq (a :: Expr x) (b :: Expr x) <= PEq (c :: Expr y) (d :: Expr y) + = case eqT @x @y of + Just Refl -> a <= c && b <= d + Nothing -> False + PLT a b <= PLT c d = a <= c && b <= d + PGT a b <= PGT c d = a <= c && b <= d + PGEq a b <= PGEq c d = a <= c && b <= d + PLEq a b <= PLEq c d = a <= c && b <= d + PNeg a <= PNeg b = a <= b + PAnd a b <= PAnd c d = a <= c && b <= d + POr a b <= POr c d = a <= c && b <= d + _ <= _ = False + + +unlit :: Expr EWord -> Maybe W256 +unlit (Lit x) = Just x +unlit _ = Nothing + +unlitByte :: Expr Byte -> Maybe Word8 +unlitByte (LitByte x) = Just x +unlitByte _ = Nothing + +newtype ByteStringS = ByteStringS ByteString deriving (Eq) + +instance Show ByteStringS where + show (ByteStringS x) = ("0x" ++) . Text.unpack . fromBinary $ x + where + fromBinary = + Text.decodeUtf8 . toStrict . toLazyByteString . byteStringHex + +instance JSON.ToJSON ByteStringS where + toJSON = JSON.String . Text.pack . show + +newtype Addr = Addr { addressWord160 :: Word160 } + deriving + ( Num, Integral, Real, Ord, Enum + , Eq, Generic, Bits, FiniteBits + ) + +maybeLitWord :: Expr EWord -> Maybe W256 +maybeLitWord (Lit w) = Just w +maybeLitWord _ = Nothing + instance Read W256 where readsPrec _ "0x" = [(0, "")] readsPrec n s = first W256 <$> readsPrec n s @@ -348,9 +473,6 @@ instance JSON.ToJSON W256 where toJSON = JSON.String . Text.pack . show -instance JSON.ToJSON Word where - toJSON (C _ x) = toJSON x - instance Read Addr where readsPrec _ ('0':'x':s) = readHex s readsPrec _ s = readHex s @@ -361,11 +483,6 @@ str = replicate (40 - length hex) '0' ++ hex in "0x" ++ toChecksumAddress str ++ drop 40 str -instance Show SAddr where - show (SAddr a) = case unliteral a of - Nothing -> "" - Just c -> show $ fromSizzle c - -- https://eips.ethereum.org/EIPS/eip-55 toChecksumAddress :: String -> String toChecksumAddress addr = zipWith transform nibbles addr @@ -376,6 +493,9 @@ strip0x :: ByteString -> ByteString strip0x bs = if "0x" `Char8.isPrefixOf` bs then Char8.drop 2 bs else bs +strip0x' :: String -> String +strip0x' s = if "0x" `isPrefixOf` s then drop 2 s else s + instance FromJSON W256 where parseJSON v = do s <- Text.unpack <$> parseJSON v @@ -434,17 +554,21 @@ readNull :: Read a => a -> String -> a readNull x = fromMaybe x . Text.Read.readMaybe -wordField :: JSON.Object -> Text -> JSON.Parser W256 +wordField :: JSON.Object -> Key -> JSON.Parser W256 wordField x f = ((readNull 0) . Text.unpack) <$> (x .: f) -addrField :: JSON.Object -> Text -> JSON.Parser Addr +word64Field :: JSON.Object -> Key -> JSON.Parser Word64 +word64Field x f = ((readNull 0) . Text.unpack) + <$> (x .: f) + +addrField :: JSON.Object -> Key -> JSON.Parser Addr addrField x f = (read . Text.unpack) <$> (x .: f) -addrFieldMaybe :: JSON.Object -> Text -> JSON.Parser (Maybe Addr) +addrFieldMaybe :: JSON.Object -> Key -> JSON.Parser (Maybe Addr) addrFieldMaybe x f = (Text.Read.readMaybe . Text.unpack) <$> (x .: f) -dataField :: JSON.Object -> Text -> JSON.Parser ByteString +dataField :: JSON.Object -> Key -> JSON.Parser ByteString dataField x f = hexText <$> (x .: f) toWord512 :: W256 -> Word512 @@ -453,13 +577,15 @@ 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 +padLeftStr :: Int -> String -> String +padLeftStr n xs = replicate (n - length xs) '0' <> xs + padRight :: Int -> ByteString -> ByteString padRight n xs = xs <> BS.replicate (n - BS.length xs) 0 @@ -467,13 +593,13 @@ padRight' n xs = xs <> replicate (n - length xs) '0' -- | Right padding / truncating -truncpad :: Int -> [SWord 8] -> [SWord 8] -truncpad n xs = if m > n then take n xs - else mappend xs (replicate (n - m) 0) - where m = length xs +--truncpad :: Int -> [SWord 8] -> [SWord 8] +--truncpad n xs = if m > n then take n xs + --else mappend xs (replicate (n - m) 0) + --where m = length xs -padLeft' :: (Num a) => Int -> [a] -> [a] -padLeft' n xs = replicate (n - length xs) 0 <> xs +padLeft' :: Int -> V.Vector (Expr Byte) -> V.Vector (Expr Byte) +padLeft' n xs = V.replicate (n - length xs) (LitByte 0) <> xs word256 :: ByteString -> Word256 word256 xs = case Cereal.runGet m (padLeft 32 xs) of @@ -509,13 +635,12 @@ word160Bytes x = BS.pack [byteAt (addressWord160 x) (19 - i) | i <- [0..19]] newtype Nibble = Nibble Word8 - deriving ( Num, Integral, Real, Ord, Enum, Eq - , Bits, FiniteBits, Bounded, Generic) + deriving ( Num, Integral, Real, Ord, Enum, Eq, Bounded, Generic) instance Show Nibble where show = (:[]) . intToDigit . num ---Get first and second Nibble from byte +-- Get first and second Nibble from byte hi, lo :: Word8 -> Nibble hi b = Nibble $ b `shiftR` 4 lo b = Nibble $ b .&. 0x0f @@ -527,7 +652,7 @@ unpackNibbles bs = BS.unpack bs >>= unpackByte where unpackByte b = [hi b, lo b] ---Well-defined for even length lists only (plz dependent types) +-- Well-defined for even length lists only (plz dependent types) packNibbles :: [Nibble] -> ByteString packNibbles [] = mempty packNibbles (n1:n2:ns) = BS.singleton (toByte n1 n2) <> packNibbles ns @@ -538,19 +663,19 @@ keccakBytes :: ByteString -> ByteString keccakBytes = (hash :: ByteString -> Digest Keccak_256) - >>> BA.unpack - >>> BS.pack + >>> BA.convert word32 :: [Word8] -> Word32 word32 xs = sum [ fromIntegral x `shiftL` (8*n) | (n, x) <- zip [0..] (reverse xs) ] -keccak :: ByteString -> W256 -keccak = - keccakBytes - >>> BS.take 32 - >>> word +keccak :: Expr Buf -> Expr EWord +keccak (ConcreteBuf bs) = Lit $ keccak' bs +keccak buf = Keccak buf +keccak' :: ByteString -> W256 +keccak' = keccakBytes >>> BS.take 32 >>> word + abiKeccak :: ByteString -> Word32 abiKeccak = keccakBytes @@ -561,7 +686,7 @@ -- Utils concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM f xs = liftM concat (mapM f xs) +concatMapM f xs = fmap concat (mapM f xs) regexMatches :: Text -> Text -> Bool regexMatches regexSource = diff --git a/src/EVM/UnitTest.hs b/src/EVM/UnitTest.hs --- a/src/EVM/UnitTest.hs +++ b/src/EVM/UnitTest.hs @@ -1,4 +1,3 @@ -{-# Language LambdaCase #-} {-# Language DataKinds #-} {-# Language ImplicitParams #-} @@ -6,20 +5,25 @@ import Prelude hiding (Word) -import EVM +import EVM hiding (Unknown, path) import EVM.ABI -import EVM.Concrete hiding (readMemoryWord) -import EVM.Symbolic +import EVM.Concrete +import EVM.SMT import EVM.Dapp import EVM.Debug (srcMapCodePos) import EVM.Exec +import EVM.Expr (litAddr, readStorage', simplify) import EVM.Format import EVM.Solidity -import EVM.SymExec +import qualified EVM.SymExec as SymExec +import EVM.SymExec (defaultVeriOpts, symCalldata, verify, isQed, extractCex, runExpr, subModel, VeriOpts) import EVM.Types import EVM.Transaction (initTx) import EVM.RLP -import qualified EVM.Fetch +import qualified EVM.Facts as Facts +import qualified EVM.Facts.Git as Git +import qualified EVM.Fetch as Fetch +import qualified EVM.Expr as Expr import qualified EVM.FeeSchedule as FeeSchedule @@ -27,7 +31,7 @@ import qualified EVM.Stepper as Stepper import qualified Control.Monad.Operational as Operational -import Control.Lens hiding (Indexed, elements, List) +import Control.Lens hiding (Indexed, elements, List, passing) import Control.Monad.State.Strict hiding (state) import qualified Control.Monad.State.Strict as State @@ -35,26 +39,23 @@ import Control.Monad.Par.IO (runParIO) import qualified Data.ByteString.Lazy as BSLazy -import qualified Data.SBV.Trans.Control as SBV (Query, getValue, resetAssertions) -import qualified Data.SBV.Internals as SBV (State) import Data.Binary.Get (runGet) import Data.ByteString (ByteString) -import Data.SBV hiding (verbose) -import Data.SBV.Control (CheckSatResult(..), checkSat) import Data.Decimal (DecimalRaw(..)) -import Data.Either (isRight, lefts) +import Data.Either (isRight) import Data.Foldable (toList) import Data.Map (Map) import Data.Maybe (fromMaybe, catMaybes, fromJust, isJust, fromMaybe, mapMaybe, isNothing) import Data.Text (isPrefixOf, stripSuffix, intercalate, Text, pack, unpack) +import Data.Word (Word32, Word64) import Data.Text.Encoding (encodeUtf8) import System.Environment (lookupEnv) import System.IO (hFlush, stdout) +import GHC.Natural import qualified Control.Monad.Par.Class as Par import qualified Data.ByteString as BS import qualified Data.Map as Map -import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.IO as Text @@ -70,13 +71,14 @@ import Test.QuickCheck hiding (verbose) data UnitTestOptions = UnitTestOptions - { oracle :: EVM.Query -> IO (EVM ()) + { rpcInfo :: Fetch.RpcInfo + , solvers :: SolverGroup , verbose :: Maybe Int , maxIter :: Maybe Integer , askSmtIters :: Maybe Integer + , smtDebug :: Bool , maxDepth :: Maybe Int - , smtTimeout :: Maybe Integer - , smtState :: Maybe SBV.State + , smtTimeout :: Maybe Natural , solver :: Maybe Text , covMatch :: Maybe Text , match :: Text @@ -92,25 +94,25 @@ { testAddress :: Addr , testCaller :: Addr , testOrigin :: Addr - , testGasCreate :: W256 - , testGasCall :: W256 + , testGasCreate :: Word64 + , testGasCall :: Word64 , testBaseFee :: W256 , testPriorityFee :: W256 , testBalanceCreate :: W256 , testCoinbase :: Addr , testNumber :: W256 , testTimestamp :: W256 - , testGaslimit :: W256 + , testGaslimit :: Word64 , testGasprice :: W256 , testMaxCodeSize :: W256 - , testDifficulty :: W256 + , testPrevrandao :: W256 , testChainId :: W256 } -defaultGasForCreating :: W256 +defaultGasForCreating :: Word64 defaultGasForCreating = 0xffffffffffff -defaultGasForInvoking :: W256 +defaultGasForInvoking :: Word64 defaultGasForInvoking = 0xffffffffffff defaultBalanceForTestContract :: W256 @@ -121,6 +123,42 @@ type ABIMethod = Text + +-- | Generate VeriOpts from UnitTestOptions +makeVeriOpts :: UnitTestOptions -> VeriOpts +makeVeriOpts opts = + defaultVeriOpts { SymExec.debug = smtDebug opts + , SymExec.maxIter = maxIter opts + , SymExec.askSmtIters = askSmtIters opts + , SymExec.rpcInfo = rpcInfo opts + } + +-- | Top level CLI endpoint for dapp-test +dappTest :: UnitTestOptions -> String -> Maybe String -> IO Bool +dappTest opts solcFile cache' = do + out <- liftIO $ readSolc solcFile + case out of + Just (contractMap, _) -> do + let unitTests = findUnitTests (EVM.UnitTest.match opts) $ Map.elems contractMap + results <- concatMapM (runUnitTestContract opts contractMap) unitTests + let (passing, vms) = unzip results + case cache' of + Nothing -> + pure () + Just path -> + -- merge all of the post-vm caches and save into the state + let + evmcache = mconcat [view EVM.cache vm | vm <- vms] + in + liftIO $ Git.saveFacts (Git.RepoAt path) (Facts.cacheFacts evmcache) + + if and passing + then return True + else return False + Nothing -> + error ("Failed to read Solidity JSON for `" ++ solcFile ++ "'") + + -- | Assuming a constructor is loaded, this stepper will run the constructor -- to create the test contract, give it an initial balance, and run `setUp()'. initializeUnitTest :: UnitTestOptions -> SolcContract -> Stepper () @@ -139,7 +177,7 @@ Stepper.evm $ do -- Give a balance to the test target - env . contracts . ix addr . balance += w256 (testBalanceCreate testParams) + env . contracts . ix addr . balance += testBalanceCreate testParams -- call setUp(), if it exists, to initialize the test contract let theAbi = view abiMap theContract @@ -156,7 +194,6 @@ Left e -> pushTrace (ErrorTrace e) _ -> popTrace - -- | Assuming a test contract is loaded and initialized, this stepper -- will run the specified test method and return whether it succeeded. runUnitTest :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool @@ -186,14 +223,13 @@ let ?context = DappContext dapp cs this <- fromMaybe (error "unknown target") <$> (use (env . contracts . at (testAddress testParams))) let name = maybe "" (contractNamePart . view contractName) $ lookupCode (view contractcode this) dapp - pushTrace (EntryTrace (name <> "." <> sig <> "(" <> intercalate "," ((pack . show) <$> types) <> ")" <> showCall types (ConcreteBuffer bs))) + pushTrace (EntryTrace (name <> "." <> sig <> "(" <> intercalate "," ((pack . show) <$> types) <> ")" <> showCall types (ConcreteBuf bs))) -- Try running the test method Stepper.execFully >>= \case -- If we failed, put the error in the trace. Left e -> Stepper.evm (pushTrace (ErrorTrace e) >> popTrace) >> pure True _ -> pure False - checkFailures :: UnitTestOptions -> ABIMethod -> Bool -> Stepper Bool checkFailures UnitTestOptions { .. } method bailed = do -- Decide whether the test is supposed to fail or succeed @@ -207,16 +243,16 @@ abiCall testParams $ Left ("failed()", emptyAbi) res <- Stepper.execFully case res of - Right (ConcreteBuffer r) -> + Right (ConcreteBuf r) -> let AbiBool failed = decodeAbiValue AbiBoolType (BSLazy.fromStrict r) in pure (shouldFail == failed) - _ -> error "internal error: unexpected failure code" + c -> error $ "internal error: unexpected failure code: " <> show c -- | Randomly generates the calldata arguments and runs the test fuzzTest :: UnitTestOptions -> Text -> [AbiType] -> VM -> Property -fuzzTest opts sig types vm = forAllShow (genAbiValue (AbiTupleType $ Vector.fromList types)) (show . ByteStringS . encodeAbiValue) +fuzzTest opts@UnitTestOptions{..} sig types vm = forAllShow (genAbiValue (AbiTupleType $ Vector.fromList types)) (show . ByteStringS . encodeAbiValue) $ \args -> ioProperty $ - fst <$> runStateT (EVM.Stepper.interpret (oracle opts) (runUnitTest opts sig args)) vm + fst <$> runStateT (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) (runUnitTest opts sig args)) vm tick :: Text -> IO () tick x = Text.putStr x >> hFlush stdout @@ -269,7 +305,7 @@ :: UnitTestOptions -> Stepper a -> StateT CoverageState IO a -interpretWithCoverage opts = +interpretWithCoverage opts@UnitTestOptions{..} = eval . Operational.view where @@ -287,7 +323,7 @@ Stepper.Run -> runWithCoverage >>= interpretWithCoverage opts . k Stepper.Wait q -> - do m <- liftIO (oracle opts q) + do m <- liftIO ((Fetch.oracle solvers rpcInfo) q) zoom _1 (State.state (runState m)) >> interpretWithCoverage opts (k ()) Stepper.Ask _ -> error "cannot make choice in this interpreter" @@ -385,7 +421,7 @@ :: UnitTestOptions -> Map Text SolcContract -> (Text, [(Test, [AbiType])]) - -> SBV.Query [(Bool, VM)] + -> IO [(Bool, VM)] runUnitTestContract opts@(UnitTestOptions {..}) contractMap (name, testSigs) = do @@ -404,7 +440,7 @@ let vm0 = initialUnitTestVm opts theContract vm1 <- liftIO $ execStateT - (EVM.Stepper.interpret oracle + (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) (Stepper.enter name >> initializeUnitTest opts theContract)) vm0 @@ -413,16 +449,17 @@ Just (VMFailure _) -> liftIO $ do Text.putStrLn "\x1b[31m[BAIL]\x1b[0m setUp() " tick "\n" - tick $ failOutput vm1 opts "setUp()" + tick (Data.Text.pack $ show $ failOutput vm1 opts "setUp()") pure [(False, vm1)] Just (VMSuccess _) -> do let + runCache :: ([(Either Text Text, VM)], VM) -> (Test, [AbiType]) - -> SBV.Query ([(Either Text Text, VM)], VM) + -> IO ([(Either Text Text, VM)], VM) runCache (results, vm) (test, types) = do (t, r, vm') <- runTest opts vm (test, types) liftIO $ Text.putStrLn t - let vmCached = vm & set (cache . fetched) (view (cache . fetched) vm') + let vmCached = vm & set cache (view cache vm') pure (((r, vm'): results), vmCached) -- Run all the test cases and print their status updates, @@ -435,12 +472,12 @@ liftIO $ do tick "\n" tick (Text.unlines (filter (not . Text.null) running)) - tick (Text.unlines (filter (not . Text.null) bailing)) + tick (Text.unlines bailing) pure [(isRight r, vm) | (r, vm) <- details] -runTest :: UnitTestOptions -> VM -> (Test, [AbiType]) -> SBV.Query (Text, Either Text Text, VM) +runTest :: UnitTestOptions -> VM -> (Test, [AbiType]) -> IO (Text, Either Text Text, VM) runTest opts@UnitTestOptions{} vm (ConcreteTest testName, []) = liftIO $ runOne opts vm testName emptyAbi runTest opts@UnitTestOptions{..} vm (ConcreteTest testName, types) = liftIO $ case replay of Nothing -> @@ -450,7 +487,6 @@ then runOne opts vm testName $ decodeAbiValue (AbiTupleType (Vector.fromList types)) callData else fuzzRun opts vm testName types -runTest opts vm (SymbolicTest testName, types) = symRun opts vm testName types runTest opts@UnitTestOptions{..} vm (InvariantTest testName, []) = liftIO $ case replay of Nothing -> exploreRun opts vm testName [] Just (sig, cds) -> @@ -458,6 +494,7 @@ then exploreRun opts vm testName (decodeCalls cds) else exploreRun opts vm testName [] runTest _ _ (InvariantTest _, types) = error $ "invariant testing with arguments: " <> show types <> " is not implemented (yet!)" +runTest opts vm (SymbolicTest testName, types) = symRun opts vm testName types type ExploreTx = (Addr, Addr, ByteString, W256) @@ -486,7 +523,7 @@ vm <- get let cs = view (env . contracts) vm noCode c = case view contractcode c of - RuntimeCode c' -> len c' == 0 + RuntimeCode c' -> null c' _ -> False mutable m = view methodMutability m `elem` [NonPayable, Payable] knownAbis :: Map Addr SolcContract @@ -528,7 +565,7 @@ let opts' = opts { testParams = testParams {testAddress = target, testCaller = caller', testTimestamp = timestamp'}} thisCallRLP = List [BS $ word160Bytes caller', BS $ word160Bytes target, BS cd, BS $ word256Bytes timestamp'] -- set the timestamp - Stepper.evm $ assign (block . timestamp) (w256lit timestamp') + Stepper.evm $ assign (block . timestamp) (Lit timestamp') -- perform the call bailed <- exploreStep opts' cd Stepper.evm popTrace @@ -557,7 +594,7 @@ Stepper.evm $ abiCall testParams (Left ("targetContracts()", emptyAbi)) res <- Stepper.execFully case res of - Right (ConcreteBuffer r) -> + Right (ConcreteBuf r) -> let AbiTuple vs = decodeAbiValue (AbiTupleType (Vector.fromList [AbiArrayDynamicType AbiAddressType])) (BSLazy.fromStrict r) [AbiArrayDynamic AbiAddressType targets] = Vector.toList vs in return $ fmap (\(AbiAddress a) -> a) (Vector.toList targets) @@ -565,6 +602,7 @@ exploreRun :: UnitTestOptions -> VM -> ABIMethod -> [ExploreTx] -> IO (Text, Either Text Text, VM) exploreRun opts@UnitTestOptions{..} initialVm testName replayTxs = do + let oracle = Fetch.oracle solvers rpcInfo (targets, _) <- runStateT (EVM.Stepper.interpret oracle (getTargetContracts opts)) initialVm let depth = fromMaybe 20 maxDepth ((x, counterex), vm') <- @@ -588,7 +626,7 @@ execTest :: UnitTestOptions -> VM -> ABIMethod -> AbiValue -> IO (Bool, VM) execTest opts@UnitTestOptions{..} vm testName args = runStateT - (EVM.Stepper.interpret oracle (execTestStepper opts testName args)) + (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) (execTestStepper opts testName args)) vm -- | Define the thread spawner for normal test cases @@ -598,7 +636,7 @@ (bailed, vm') <- execTest opts vm testName args (success, vm'') <- runStateT - (EVM.Stepper.interpret oracle (checkFailures opts testName bailed)) vm' + (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) (checkFailures opts testName bailed)) vm' if success then let gasSpent = num (testGasCall testParams) - view (state . gas) vm' @@ -649,7 +687,7 @@ ppOutput = pack $ show abiValue in do -- Run the failing test again to get a proper trace - vm' <- execStateT (EVM.Stepper.interpret oracle (runUnitTest opts testName abiValue)) vm + vm' <- execStateT (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) (runUnitTest opts testName abiValue)) vm pure ("\x1b[31m[FAIL]\x1b[0m " <> testName <> ". Counterexample: " <> ppOutput <> "\nRun:\n dapp test --replay '(\"" <> testName <> "\",\"" @@ -665,114 +703,108 @@ ) -- | Define the thread spawner for symbolic tests --- TODO: return a list of VM's -symRun :: UnitTestOptions -> VM -> Text -> [AbiType] -> SBV.Query (Text, Either Text Text, VM) -symRun opts@UnitTestOptions{..} concreteVm testName types = do - SBV.resetAssertions - let vm = symbolify concreteVm - (cd, cdlen) <- symCalldata testName types [] - let cd' = (SymbolicBuffer cd, w256lit cdlen) +symRun :: UnitTestOptions -> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM) +symRun opts@UnitTestOptions{..} vm testName types = do + let cd = symCalldata testName types [] (AbstractBuf "txdata") shouldFail = "proveFail" `isPrefixOf` testName + testContract = view (state . contract) vm - -- get all posible postVMs for the test method - allPaths <- fst <$> runStateT - (EVM.SymExec.interpret oracle maxIter askSmtIters (execSymTest opts testName cd')) vm - let consistentPaths = flip filter allPaths $ - \(_, vm') -> case view result vm' of - Just (VMFailure DeadPath) -> False - _ -> True - results <- forM consistentPaths $ - -- If the vm execution succeeded, check if the vm is reachable, - -- and if any ds-test assertions were triggered - -- Report a failure depending on the prefix of the test name + -- define postcondition depending on `shouldFail` + -- We directly encode the failure conditions from failed() in ds-test since this is easier to encode than a call into failed() + -- we need to read from slot 0 in the test contract and mask it with 0x10 to get the value of _failed + -- we don't need to do this when reading the failed from the cheatcode address since we don't do any packing there + let failed store = (And (readStorage' (litAddr testContract) (Lit 0) store) (Lit 2) .== Lit 2) + .|| (readStorage' (litAddr cheatCode) (Lit 0x6661696c65640000000000000000000000000000000000000000000000000000) store .== Lit 1) + postcondition = curry $ case shouldFail of + True -> \(_, post) -> case post of + Return _ _ store -> failed store + _ -> PBool True + False -> \(_, post) -> case post of + Return _ _ store -> PNeg (failed store) + _ -> PBool False - -- If the vm execution failed, check if the vm is reachable, and if so, - -- report a failure unless the test is supposed to fail. + (_, vm') <- runStateT + (EVM.Stepper.interpret (Fetch.oracle solvers rpcInfo) (Stepper.evm $ do + popTrace + makeTxCall testParams cd + )) vm - \(bailed, vm') -> do - let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env . EVM.contracts } - SBV.resetAssertions - constrain $ sAnd (fst <$> view EVM.constraints vm') - unless bailed $ - case view result vm' of - Just (VMSuccess (SymbolicBuffer buf)) -> - constrain $ litBytes (encodeAbiValue $ AbiBool $ not shouldFail) .== buf - r -> error $ "unexpected return value: " ++ show r - checkSat >>= \case - Sat -> do - prettyCd <- prettyCalldata cd' testName types - let explorationFailed = case view result vm' of - Just (VMFailure e) -> case e of - NotUnique _ -> True - UnexpectedSymbolicArg -> True - _ -> False - _ -> False - return $ - if shouldFail && bailed && not explorationFailed - then Right () - else Left (vm', prettyCd) - Unsat -> return $ Right () - Unk -> return $ Left (vm', "SMT Query Timeout! Try setting a higher timeout with the --smttimeout flag or the DAPP_TEST_SMTTIMEOUT environment variable.") - DSat _ -> error "Unexpected DSat" + -- check postconditions against vm + (_, results) <- verify solvers (makeVeriOpts opts) vm' (Just postcondition) - if null $ lefts results - then + -- display results + if all isQed results + then do return ("\x1b[32m[PASS]\x1b[0m " <> testName, Right "", vm) - else - return ("\x1b[31m[FAIL]\x1b[0m " <> testName, Left $ symFailure opts testName (lefts results), vm) + else do + let x = mapMaybe extractCex results + let y = symFailure opts testName (fst cd) types x + return ("\x1b[31m[FAIL]\x1b[0m " <> testName, Left y, vm) -symFailure :: UnitTestOptions -> Text -> [(VM, Text)] -> Text -symFailure UnitTestOptions {..} testName failures' = mconcat - [ "Failure: " - , testName - , "\n\n" - , intercalate "\n" $ indentLines 2 . mkMsg <$> failures' - ] +symFailure :: UnitTestOptions -> Text -> Expr Buf -> [AbiType] -> [(Expr End, SMTCex)] -> Text +symFailure UnitTestOptions {..} testName cd types failures' = + mconcat + [ "Failure: " + , testName + , "\n\n" + , intercalate "\n" $ indentLines 2 . mkMsg <$> failures' + ] + where + ctx = DappContext { _contextInfo = dapp, _contextEnv = mempty } + showRes = \case + Return _ _ _ -> if "proveFail" `isPrefixOf` testName + then "Successful execution" + else "Failed: DSTest Assertion Violation" + res -> + --let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env . EVM.contracts} + let ?context = ctx + in Text.pack $ prettyvmresult res + mkMsg (leaf, cex) = Text.unlines + ["Counterexample:" + ,"" + ," result: " <> showRes leaf + ," calldata: " <> let ?context = ctx in prettyCalldata cex cd testName types + , case verbose of + --Just _ -> unlines + --[ "" + --, unpack $ indentLines 2 (showTraceTree dapp vm) + --] + _ -> "" + ] + +prettyCalldata :: (?context :: DappContext) => SMTCex -> Expr Buf -> Text -> [AbiType] -> Text +prettyCalldata cex buf sig types = head (Text.splitOn "(" sig) <> showCalldata cex types buf + +showCalldata :: (?context :: DappContext) => SMTCex -> [AbiType] -> Expr Buf -> Text +showCalldata cex tps buf = "(" <> intercalate "," (fmap showVal vals) <> ")" where - showRes vm = let Just res = view result vm in - case res of - VMFailure _ -> - let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env . EVM.contracts} - in prettyvmresult res - VMSuccess _ -> if "proveFail" `isPrefixOf` testName - then "Successful execution" - else "Failed: DSTest Assertion Violation" - mkMsg (vm, cd) = pack $ unlines - ["Counterexample:" - ,"" - ," result: " <> showRes vm - ," calldata: " <> unpack cd - , case verbose of - Just _ -> unlines - [ "" - , unpack $ indentLines 2 (showTraceTree dapp vm) - ] - _ -> "" - ] + argdata = Expr.drop 4 $ simplify $ subModel cex buf + vals = case decodeBuf tps argdata of + CAbi v -> v + _ -> error $ "Internal Error: unable to abi decode function arguments:\n" <> (Text.unpack $ formatExpr argdata) -prettyCalldata :: (?context :: DappContext) => (Buffer, SymWord) -> Text -> [AbiType]-> SBV.Query Text -prettyCalldata (buffer, S _ cdlen) sig types = do - cdlen' <- num <$> SBV.getValue cdlen - cd <- case buffer of - SymbolicBuffer cd -> mapM (SBV.getValue . fromSized) (take cdlen' cd) <&> BS.pack - ConcreteBuffer cd -> return $ BS.take cdlen' cd - pure $ (head (Text.splitOn "(" sig)) <> showCall types (ConcreteBuffer cd) +showVal :: AbiValue -> Text +showVal (AbiBytes _ bs) = formatBytes bs +showVal (AbiAddress addr) = Text.pack . show $ addr +showVal v = Text.pack . show $ v -execSymTest :: UnitTestOptions -> ABIMethod -> (Buffer, SymWord) -> Stepper (Bool, VM) -execSymTest opts@UnitTestOptions{ .. } method cd = do + +-- prettyCalldata :: (?context :: DappContext) => Expr Buf -> Text -> [AbiType]-> IO Text +-- prettyCalldata buf sig types = do +-- cdlen' <- num <$> SBV.getValue cdlen +-- cd <- case buf of +-- ConcreteBuf cd -> return $ BS.take cdlen' cd +-- cd -> mapM (SBV.getValue . fromSized) (take cdlen' cd) <&> BS.pack +-- pure $ (head (Text.splitOn "(" sig)) <> showCall types (ConcreteBuffer cd) + +execSymTest :: UnitTestOptions -> ABIMethod -> (Expr Buf, [Prop]) -> Stepper (Expr End) +execSymTest UnitTestOptions{ .. } method cd = do -- Set up the call to the test method Stepper.evm $ do makeTxCall testParams cd pushTrace (EntryTrace method) -- Try running the test method - Stepper.runFully >>= \vm' -> case view result vm' of - Just (VMFailure err) -> - -- If we failed, put the error in the trace. - Stepper.evm (pushTrace (ErrorTrace err)) >> (pure (True, vm')) - Just (VMSuccess _) -> do - postVm <- checkSymFailures opts - pure (False, postVm) - Nothing -> error "Internal Error: execSymTest: vm has not completed execution!" + runExpr checkSymFailures :: UnitTestOptions -> Stepper VM checkSymFailures UnitTestOptions { .. } = do @@ -802,6 +834,7 @@ ] else "" +-- TODO failOutput :: VM -> UnitTestOptions -> Text -> Text failOutput vm UnitTestOptions { .. } testName = let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env . EVM.contracts} @@ -816,7 +849,7 @@ , "\n" ] -formatTestLogs :: (?context :: DappContext) => Map W256 Event -> Seq.Seq Log -> Text +formatTestLogs :: (?context :: DappContext) => Map W256 Event -> [Expr Log] -> Text formatTestLogs events xs = case catMaybes (toList (fmap (formatTestLog events) xs)) of [] -> "\n" @@ -825,10 +858,11 @@ -- Here we catch and render some special logs emitted by ds-test, -- with the intent to then present them in a separate view to the -- regular trace output. -formatTestLog :: (?context :: DappContext) => Map W256 Event -> Log -> Maybe Text -formatTestLog _ (Log _ _ []) = Nothing -formatTestLog events (Log _ args (topic:_)) = - case maybeLitWord topic >>= \t1 -> (Map.lookup (wordValue t1) events) of +formatTestLog :: (?context :: DappContext) => Map W256 Event -> Expr Log -> Maybe Text +formatTestLog _ (LogEntry _ _ []) = Nothing +formatTestLog _ (GVar _) = error "unexpected global variable" +formatTestLog events (LogEntry _ args (topic:_)) = + case maybeLitWord topic >>= \t1 -> (Map.lookup t1 events) of Nothing -> Nothing Just (Event name _ types) -> case (name <> parenthesise (abiTypeSolidity <$> (unindexed types))) of @@ -875,14 +909,14 @@ pack $ show $ Decimal (num dec) val log_named_decimal = case args of - (ConcreteBuffer b) -> + (ConcreteBuf b) -> case toList $ runGet (getAbiSeq (length ts) ts) (BSLazy.fromStrict b) of [key, (AbiUInt 256 val), (AbiUInt 256 dec)] -> Just $ (unquote (showAbiValue key)) <> ": " <> showDecimal dec val [key, (AbiInt 256 val), (AbiUInt 256 dec)] -> Just $ (unquote (showAbiValue key)) <> ": " <> showDecimal dec val _ -> Nothing - (SymbolicBuffer _) -> Just "" + _ -> Just "" word32Bytes :: Word32 -> ByteString @@ -893,20 +927,20 @@ let cd = case args of Left (sig, args') -> abiMethod sig args' Right b -> b - l = num . BS.length $ cd - in makeTxCall params (ConcreteBuffer cd, litWord l) + in makeTxCall params (ConcreteBuf cd, []) -makeTxCall :: TestVMParams -> (Buffer, SymWord) -> EVM () -makeTxCall TestVMParams{..} cd = do +makeTxCall :: TestVMParams -> (Expr Buf, [Prop]) -> EVM () +makeTxCall TestVMParams{..} (cd, cdProps) = do resetState assign (tx . isCreate) False loadContract testAddress - assign (state . calldata) cd + assign (state . EVM.calldata) cd + constraints %= (<> cdProps) assign (state . caller) (litAddr testCaller) - assign (state . gas) (w256 testGasCall) + assign (state . gas) testGasCall origin' <- fromMaybe (initialContract (RuntimeCode mempty)) <$> use (env . contracts . at testOrigin) let originBal = view balance origin' - when (originBal < (w256 testGasprice) * (w256 testGasCall)) $ error "insufficient balance for gas cost" + when (originBal < testGasprice * (num testGasCall)) $ error "insufficient balance for gas cost" vm <- get put $ initTx vm @@ -915,9 +949,9 @@ let TestVMParams {..} = testParams vm = makeVm $ VMOpts - { vmoptContract = initialContract (InitCode (ConcreteBuffer (view creationCode theContract))) - , vmoptCalldata = (mempty, 0) - , vmoptValue = 0 + { vmoptContract = initialContract (InitCode (view creationCode theContract) mempty) + , vmoptCalldata = mempty + , vmoptValue = Lit 0 , vmoptAddress = testAddress , vmoptCaller = litAddr testCaller , vmoptOrigin = testOrigin @@ -925,61 +959,48 @@ , vmoptGaslimit = testGasCreate , vmoptCoinbase = testCoinbase , vmoptNumber = testNumber - , vmoptTimestamp = litWord $ w256 testTimestamp + , vmoptTimestamp = Lit testTimestamp , vmoptBlockGaslimit = testGaslimit , vmoptGasprice = testGasprice , vmoptBaseFee = testBaseFee , vmoptPriorityFee = testPriorityFee , vmoptMaxCodeSize = testMaxCodeSize - , vmoptDifficulty = testDifficulty + , vmoptPrevRandao = testPrevrandao , vmoptSchedule = FeeSchedule.berlin , vmoptChainId = testChainId , vmoptCreate = True - , vmoptStorageModel = ConcreteS -- TODO: support RPC + , vmoptStorageBase = Concrete , vmoptTxAccessList = mempty -- TODO: support unit test access lists??? , vmoptAllowFFI = ffiAllowed } creator = initialContract (RuntimeCode mempty) & set nonce 1 - & set balance (w256 testBalanceCreate) + & set balance testBalanceCreate in vm & set (env . contracts . at ethrunAddress) (Just creator) --- | takes a concrete VM and makes all storage symbolic -symbolify :: VM -> VM -symbolify vm = - vm & over (env . contracts . each . storage) mkSymStorage - & set (env . storageModel) InitialS - where - mkSymStorage :: Storage -> Storage - mkSymStorage (Symbolic _ _) = error "should not happen" - mkSymStorage (Concrete s) = - let - list = [(literal $ toSizzle k, v) | (C _ k, S _ v) <- Map.toList s] - symlist = [(litWord k, v) | (k, v) <- Map.toList s] - in Symbolic symlist $ sListArray 0 list - getParametersFromEnvironmentVariables :: Maybe Text -> IO TestVMParams getParametersFromEnvironmentVariables rpc = do - block' <- maybe EVM.Fetch.Latest (EVM.Fetch.BlockNumber . read) <$> (lookupEnv "DAPP_TEST_NUMBER") + block' <- maybe Fetch.Latest (Fetch.BlockNumber . read) <$> (lookupEnv "DAPP_TEST_NUMBER") - (miner,ts,blockNum,diff,limit,base) <- + (miner,ts,blockNum,ran,limit,base) <- case rpc of - Nothing -> return (0,0,0,0,0,0) - Just url -> EVM.Fetch.fetchBlockFrom block' url >>= \case + Nothing -> return (0,Lit 0,0,0,0,0) + Just url -> Fetch.fetchBlockFrom block' url >>= \case Nothing -> error "Could not fetch block" Just EVM.Block{..} -> return ( _coinbase - , wordValue $ forceLit _timestamp - , wordValue _number - , wordValue _difficulty - , wordValue _gaslimit - , wordValue _baseFee + , _timestamp + , _number + , _prevRandao + , _gaslimit + , _baseFee ) let getWord s def = maybe def read <$> lookupEnv s getAddr s def = maybe def read <$> lookupEnv s + ts' = fromMaybe (error "Internal Error: received unexpected symbolic timestamp via rpc") (maybeLitWord ts) TestVMParams <$> getAddr "DAPP_TEST_ADDRESS" (createAddress ethrunAddress 1) @@ -992,9 +1013,9 @@ <*> getWord "DAPP_TEST_BALANCE" defaultBalanceForTestContract <*> getAddr "DAPP_TEST_COINBASE" miner <*> getWord "DAPP_TEST_NUMBER" blockNum - <*> getWord "DAPP_TEST_TIMESTAMP" ts + <*> getWord "DAPP_TEST_TIMESTAMP" ts' <*> getWord "DAPP_TEST_GAS_LIMIT" limit <*> getWord "DAPP_TEST_GAS_PRICE" 0 <*> getWord "DAPP_TEST_MAXCODESIZE" defaultMaxCodeSize - <*> getWord "DAPP_TEST_DIFFICULTY" diff + <*> getWord "DAPP_TEST_PREVRANDAO" ran <*> getWord "DAPP_TEST_CHAINID" 99 diff --git a/src/EVM/VMTest.hs b/src/EVM/VMTest.hs --- a/src/EVM/VMTest.hs +++ b/src/EVM/VMTest.hs @@ -1,12 +1,12 @@ {-# Language CPP #-} -{-# Language TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} module EVM.VMTest ( Case , BlockchainCase -#if MIN_VERSION_aeson(1, 0, 0) + , parseBCSuite -#endif + , initTx , setupTx , vmForCase @@ -16,11 +16,11 @@ import Prelude hiding (Word) import qualified EVM -import EVM (contractcode, storage, origStorage, balance, nonce, Storage(..), initialContract) +import EVM (contractcode, storage, origStorage, balance, nonce, initialContract, StorageBase(..)) +import EVM.Expr (litCode, litAddr) import qualified EVM.Concrete as EVM import qualified EVM.FeeSchedule -import EVM.Symbolic import EVM.Transaction import EVM.Types @@ -31,7 +31,6 @@ import GHC.Stack import Data.Aeson ((.:), (.:?), FromJSON (..)) -import Data.Foldable (fold) import Data.Map (Map) import Data.Maybe (fromMaybe, isNothing) import Data.Witherable (Filterable, catMaybes) @@ -40,14 +39,17 @@ import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON import qualified Data.ByteString.Lazy as Lazy -import qualified Data.ByteString as BS +import qualified Data.Vector as V +import Data.Word (Word64) +type Storage = Map W256 W256 + data Which = Pre | Post data Block = Block { blockCoinbase :: Addr , blockDifficulty :: W256 - , blockGasLimit :: W256 + , blockGasLimit :: Word64 , blockBaseFee :: W256 , blockNumber :: W256 , blockTimestamp :: W256 @@ -56,14 +58,14 @@ data Case = Case { testVmOpts :: EVM.VMOpts - , checkContracts :: Map Addr EVM.Contract - , testExpectation :: Map Addr EVM.Contract + , checkContracts :: Map Addr (EVM.Contract, Storage) + , testExpectation :: Map Addr (EVM.Contract, Storage) } deriving Show data BlockchainCase = BlockchainCase { blockchainBlocks :: [Block] - , blockchainPre :: Map Addr EVM.Contract - , blockchainPost :: Map Addr EVM.Contract + , blockchainPre :: Map Addr (EVM.Contract, Storage) + , blockchainPost :: Map Addr (EVM.Contract, Storage) , blockchainNetwork :: String } deriving Show @@ -76,12 +78,12 @@ checkStateFail :: Bool -> Case -> EVM.VM -> (Bool, Bool, Bool, Bool, Bool) -> IO Bool checkStateFail diff x vm (okState, okMoney, okNonce, okData, okCode) = do let - printContracts :: Map Addr EVM.Contract -> IO () - printContracts cs = putStrLn $ Map.foldrWithKey (\k v acc -> + printContracts :: Map Addr (EVM.Contract, Storage) -> IO () + printContracts cs = putStrLn $ Map.foldrWithKey (\k (c, s) acc -> acc ++ show k ++ " : " - ++ (show . toInteger $ (view nonce v)) ++ " " - ++ (show . toInteger $ (view balance v)) ++ " " - ++ (printStorage $ (view storage v)) + ++ (show . toInteger $ (view nonce c)) ++ " " + ++ (show . toInteger $ (view balance c)) ++ " " + ++ (printStorage s) ++ "\n") "" cs reason = map fst (filter (not . snd) @@ -93,9 +95,8 @@ ]) check = checkContracts x expected = testExpectation x - actual = view (EVM.env . EVM.contracts . to (fmap (clearZeroStorage.clearOrigStorage))) vm - printStorage (EVM.Symbolic _ c) = show c - printStorage (EVM.Concrete c) = show $ Map.toList c + actual = Map.map (,mempty) $ view (EVM.env . EVM.contracts) vm -- . to (fmap (clearZeroStorage.clearOrigStorage))) vm + printStorage = show -- TODO: fixme putStr (unwords reason) when (diff && (not okState)) $ do @@ -110,75 +111,76 @@ checkExpectation :: HasCallStack => Bool -> Case -> EVM.VM -> IO Bool checkExpectation diff x vm = do let expectation = testExpectation x - (okState, b2, b3, b4, b5) = checkExpectedContracts vm $ expectation + (okState, b2, b3, b4, b5) = checkExpectedContracts vm expectation + putStrLn $ show expectation unless okState $ void $ checkStateFail diff x vm (okState, b2, b3, b4, b5) return okState -- quotient account state by nullness -(~=) :: Map Addr EVM.Contract -> Map Addr EVM.Contract -> Bool -(~=) cs cs' = +(~=) :: Map Addr (EVM.Contract, Storage) -> Map Addr (EVM.Contract, Storage) -> Bool +(~=) cs1 cs2 = let nullAccount = EVM.initialContract (EVM.RuntimeCode mempty) - padNewAccounts cs'' ks = (fold [Map.insertWith (\_ x -> x) k nullAccount | k <- ks]) cs'' - padded_cs' = padNewAccounts cs' (Map.keys cs) - padded_cs = padNewAccounts cs (Map.keys cs') - in and $ zipWith (===) (Map.elems padded_cs) (Map.elems padded_cs') + padNewAccounts cs ks = Map.union cs $ Map.fromList [(k, (nullAccount, mempty)) | k <- ks] + padded_cs1 = padNewAccounts cs1 (Map.keys cs2) + padded_cs2 = padNewAccounts cs2 (Map.keys cs1) + in and $ zipWith (===) (Map.elems padded_cs1) (Map.elems padded_cs2) -(===) :: EVM.Contract -> EVM.Contract -> Bool -a === b = codeEqual && storageEqual && (view balance a == view balance b) && (view nonce a == view nonce b) +(===) :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) -> Bool +(c1, s1) === (c2, s2) = + codeEqual && storageEqual && (c1 ^. balance == c2 ^. balance) && (c1 ^. nonce == c2 ^. nonce) where - storageEqual = view storage a == view storage b - codeEqual = case (view contractcode a, view contractcode b) of - (EVM.RuntimeCode (ConcreteBuffer a'), EVM.RuntimeCode (ConcreteBuffer b')) -> a' == b' + storageEqual = s1 == s2 + codeEqual = case (c1 ^. contractcode, c2 ^. contractcode) of + (EVM.RuntimeCode a', EVM.RuntimeCode b') -> a' == b' _ -> error "unexpected code" -checkExpectedContracts :: HasCallStack => EVM.VM -> Map Addr EVM.Contract -> (Bool, Bool, Bool, Bool, Bool) +checkExpectedContracts :: HasCallStack => EVM.VM -> Map Addr (EVM.Contract, Storage) -> (Bool, Bool, Bool, Bool, Bool) checkExpectedContracts vm expected = - let cs = vm ^. EVM.env . EVM.contracts . to (fmap (clearZeroStorage.clearOrigStorage)) - expectedCs = clearOrigStorage <$> expected + let cs = zipWithStorages $ vm ^. EVM.env . EVM.contracts -- . to (fmap (clearZeroStorage.clearOrigStorage)) + expectedCs = clearStorage <$> expected in ( (expectedCs ~= cs) , (clearBalance <$> expectedCs) ~= (clearBalance <$> cs) , (clearNonce <$> expectedCs) ~= (clearNonce <$> cs) , (clearStorage <$> expectedCs) ~= (clearStorage <$> cs) , (clearCode <$> expectedCs) ~= (clearCode <$> cs) ) + where + zipWithStorages = Map.mapWithKey (\addr c -> (c, lookupStorage addr)) + lookupStorage _ = + case vm ^. EVM.env . EVM.storage of + ConcreteStore _ -> mempty -- clearZeroStorage $ fromMaybe mempty $ Map.lookup (num addr) s + EmptyStore -> mempty + AbstractStore -> mempty -- error "AbstractStore, should this be handled?" + SStore {} -> mempty -- error "SStore, should this be handled?" + GVar _ -> error "unexpected global variable" -clearOrigStorage :: EVM.Contract -> EVM.Contract -clearOrigStorage = set origStorage mempty +clearStorage :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) +clearStorage (c, _) = (c, mempty) -clearZeroStorage :: EVM.Contract -> EVM.Contract -clearZeroStorage c = case view storage c of - EVM.Symbolic _ _ -> c - EVM.Concrete m -> let store = Map.filter (\x -> forceLit x /= 0) m - in set EVM.storage (EVM.Concrete store) c +clearBalance :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) +clearBalance (c, s) = (set balance 0 c, s) -clearStorage :: EVM.Contract -> EVM.Contract -clearStorage = set storage (EVM.Concrete mempty) +clearNonce :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) +clearNonce (c, s) = (set nonce 0 c, s) -clearBalance :: EVM.Contract -> EVM.Contract -clearBalance = set balance 0 +clearCode :: (EVM.Contract, Storage) -> (EVM.Contract, Storage) +clearCode (c, s) = (set contractcode (EVM.RuntimeCode mempty) c, s) -clearNonce :: EVM.Contract -> EVM.Contract -clearNonce = set nonce 0 -clearCode :: EVM.Contract -> EVM.Contract -clearCode = set contractcode (EVM.RuntimeCode mempty) -#if MIN_VERSION_aeson(1, 0, 0) +newtype ContractWithStorage = ContractWithStorage { unContractWithStorage :: (EVM.Contract, Storage) } -instance FromJSON EVM.Contract where +instance FromJSON ContractWithStorage where parseJSON (JSON.Object v) = do - code <- (EVM.RuntimeCode . ConcreteBuffer <$> (hexText <$> v .: "code")) - storage' <- Map.mapKeys w256 <$> v .: "storage" + code <- (EVM.RuntimeCode . V.fromList . litCode <$> (hexText <$> v .: "code")) + storage' <- v .: "storage" balance' <- v .: "balance" nonce' <- v .: "nonce" - return - $ - EVM.initialContract code - & balance .~ w256 balance' - & nonce .~ w256 nonce' - & storage .~ EVM.Concrete (fmap (litWord . w256) storage') - & origStorage .~ fmap w256 storage' + let c = EVM.initialContract code + & balance .~ balance' + & nonce .~ nonce' + return $ ContractWithStorage (c, storage') parseJSON invalid = JSON.typeMismatch "Contract" invalid @@ -198,7 +200,7 @@ txs <- v .: "transactions" coinbase <- addrField v' "coinbase" difficulty <- wordField v' "difficulty" - gasLimit <- wordField v' "gasLimit" + gasLimit <- word64Field v' "gasLimit" number <- wordField v' "number" baseFee <- fmap read <$> v' .:? "baseFeePerGas" timestamp <- wordField v' "timestamp" @@ -207,9 +209,9 @@ JSON.typeMismatch "Block" invalid parseContracts :: - Which -> JSON.Object -> JSON.Parser (Map Addr EVM.Contract) + Which -> JSON.Object -> JSON.Parser (Map Addr (EVM.Contract, Storage)) parseContracts w v = - v .: which >>= parseJSON + (Map.map unContractWithStorage) <$> (v .: which >>= parseJSON) where which = case w of Pre -> "pre" Post -> "postState" @@ -228,8 +230,8 @@ else if Map.size parsedCases == 0 then Left "No cases to check." else Right parsedCases -#endif + data BlockchainError = TooManyBlocks | TooManyTxs @@ -258,7 +260,7 @@ (_, _) -> Left TooManyBlocks fromBlockchainCase' :: Block -> Transaction - -> Map Addr EVM.Contract -> Map Addr EVM.Contract + -> Map Addr (EVM.Contract, Storage) -> Map Addr (EVM.Contract, Storage) -> Either BlockchainError Case fromBlockchainCase' block tx preState postState = let isCreate = isNothing (txToAddr tx) in @@ -268,26 +270,26 @@ (Just origin, Just checkState) -> Right $ Case (EVM.VMOpts { vmoptContract = EVM.initialContract theCode - , vmoptCalldata = cd - , vmoptValue = litWord (w256 $ txValue tx) + , vmoptCalldata = (cd, []) + , vmoptValue = Lit (txValue tx) , vmoptAddress = toAddr , vmoptCaller = litAddr origin + , vmoptStorageBase = Concrete , vmoptOrigin = origin , vmoptGas = txGasLimit tx - fromIntegral (txGasCost feeSchedule tx) , vmoptBaseFee = blockBaseFee block , vmoptPriorityFee = priorityFee tx (blockBaseFee block) , vmoptGaslimit = txGasLimit tx , vmoptNumber = blockNumber block - , vmoptTimestamp = litWord $ w256 $ blockTimestamp block + , vmoptTimestamp = Lit $ blockTimestamp block , vmoptCoinbase = blockCoinbase block - , vmoptDifficulty = blockDifficulty block + , vmoptPrevRandao = blockDifficulty block , vmoptMaxCodeSize = 24576 , vmoptBlockGaslimit = blockGasLimit block , vmoptGasprice = effectiveGasPrice , vmoptSchedule = feeSchedule , vmoptChainId = 1 , vmoptCreate = isCreate - , vmoptStorageModel = EVM.ConcreteS , vmoptTxAccessList = txAccessMap tx , vmoptAllowFFI = False }) @@ -295,17 +297,16 @@ postState where toAddr = fromMaybe (EVM.createAddress origin senderNonce) (txToAddr tx) - senderNonce = EVM.wordValue $ view (accountAt origin . nonce) preState + senderNonce = view (accountAt origin . nonce) (Map.map fst preState) feeSchedule = EVM.FeeSchedule.berlin toCode = Map.lookup toAddr preState theCode = if isCreate - then EVM.InitCode (ConcreteBuffer (txData tx)) - else maybe (EVM.RuntimeCode mempty) (view contractcode) toCode + then EVM.InitCode (txData tx) mempty + else maybe (EVM.RuntimeCode mempty) (view contractcode) (fst <$> toCode) effectiveGasPrice = effectiveprice tx (blockBaseFee block) cd = if isCreate - then (mempty, 0) - else let l = num . BS.length $ txData tx - in (ConcreteBuffer $ txData tx, litWord l) + then mempty + else ConcreteBuf $ txData tx effectiveprice :: Transaction -> W256 -> W256 effectiveprice tx baseFee = priorityFee tx baseFee + baseFee @@ -333,35 +334,41 @@ in gasPrice -validateTx :: Transaction -> Block -> Map Addr EVM.Contract -> Maybe () +validateTx :: Transaction -> Block -> Map Addr (EVM.Contract, Storage) -> Maybe () validateTx tx block cs = do + let cs' = Map.map fst cs origin <- sender 1 tx - originBalance <- (view balance) <$> view (at origin) cs - originNonce <- (view nonce) <$> view (at origin) cs - let gasDeposit = w256 $ (effectiveprice tx (blockBaseFee block)) * (txGasLimit tx) - if gasDeposit + (w256 $ txValue tx) <= originBalance - && (w256 $ txNonce tx) == originNonce && blockBaseFee block <= maxBaseFee tx + originBalance <- (view balance) <$> view (at origin) cs' + originNonce <- (view nonce) <$> view (at origin) cs' + let gasDeposit = (effectiveprice tx (blockBaseFee block)) * (num $ txGasLimit tx) + if gasDeposit + (txValue tx) <= originBalance + && txNonce tx == originNonce && blockBaseFee block <= maxBaseFee tx then Just () else Nothing -checkTx :: Transaction -> Block -> Map Addr EVM.Contract -> Maybe (Map Addr EVM.Contract) +checkTx :: Transaction -> Block -> Map Addr (EVM.Contract, Storage) -> Maybe (Map Addr (EVM.Contract, Storage)) checkTx tx block prestate = do origin <- sender 1 tx validateTx tx block prestate let isCreate = isNothing (txToAddr tx) - senderNonce = EVM.wordValue $ view (accountAt origin . nonce) prestate + senderNonce = view (accountAt origin . nonce) (Map.map fst prestate) toAddr = fromMaybe (EVM.createAddress origin senderNonce) (txToAddr tx) - prevCode = view (accountAt toAddr . contractcode) prestate - prevNonce = view (accountAt toAddr . nonce) prestate - if isCreate && ((case prevCode of {EVM.RuntimeCode b -> len b /= 0; _ -> True}) || (prevNonce /= 0)) + prevCode = view (accountAt toAddr . contractcode) (Map.map fst prestate) + prevNonce = view (accountAt toAddr . nonce) (Map.map fst prestate) + if isCreate && ((case prevCode of {EVM.RuntimeCode b -> not (null b); _ -> True}) || (prevNonce /= 0)) then mzero else - return $ prestate + return prestate vmForCase :: Case -> EVM.VM vmForCase x = let + a = checkContracts x + cs = Map.map fst a + st = Map.mapKeys num $ Map.map snd a vm = EVM.makeVm (testVmOpts x) - & set (EVM.env . EVM.contracts) (checkContracts x) + & set (EVM.env . EVM.contracts) cs + & set (EVM.env . EVM.storage) (ConcreteStore st) + & set (EVM.env . EVM.origStorage) st in initTx vm diff --git a/test/EVM/TestUtils.hs b/test/EVM/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/EVM/TestUtils.hs @@ -0,0 +1,136 @@ +{-# Language QuasiQuotes #-} + +module EVM.TestUtils where + +import Data.Text +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Paths_hevm as Paths +import Data.String.Here +import System.Directory +import System.IO.Temp +import GHC.IO.Handle (hClose) +import System.Process (readProcess) + +import EVM.Solidity +import EVM.SMT +import EVM.Dapp +import EVM.UnitTest +import EVM.Fetch (RpcInfo) +import qualified EVM.TTY as TTY + +runDappTestCustom :: FilePath -> Text -> Maybe Integer -> Bool -> RpcInfo -> IO Bool +runDappTestCustom testFile match maxIter ffiAllowed rpcinfo = do + root <- Paths.getDataDir + (json, _) <- compileWithDSTest testFile + --T.writeFile "output.json" json + withCurrentDirectory root $ do + withSystemTempFile "output.json" $ \file handle -> do + hClose handle + T.writeFile file json + withSolvers Z3 1 Nothing $ \solvers -> do + opts <- testOpts solvers root json match maxIter ffiAllowed rpcinfo + dappTest opts file Nothing + +runDappTest :: FilePath -> Text -> IO Bool +runDappTest testFile match = runDappTestCustom testFile match Nothing True Nothing + +debugDappTest :: FilePath -> RpcInfo -> IO () +debugDappTest testFile rpcinfo = do + root <- Paths.getDataDir + (json, _) <- compileWithDSTest testFile + --TIO.writeFile "output.json" json + withCurrentDirectory root $ do + withSystemTempFile "output.json" $ \file handle -> do + hClose handle + T.writeFile file json + withSolvers Z3 1 Nothing $ \solvers -> do + opts <- testOpts solvers root json ".*" Nothing True rpcinfo + TTY.main opts root file + +testOpts :: SolverGroup -> FilePath -> Text -> Text -> Maybe Integer -> Bool -> RpcInfo -> IO UnitTestOptions +testOpts solvers root solcJson match maxIter allowFFI rpcinfo = do + srcInfo <- case readJSON solcJson of + Nothing -> error "Could not read solc json" + Just (contractMap, asts, sources) -> do + sourceCache <- makeSourceCache sources asts + pure $ dappInfo root contractMap sourceCache + + params <- getParametersFromEnvironmentVariables Nothing + + pure UnitTestOptions + { solvers = solvers + , rpcInfo = rpcinfo + , maxIter = maxIter + , askSmtIters = Nothing + , smtDebug = False + , smtTimeout = Nothing + , solver = Nothing + , covMatch = Nothing + , verbose = Just 1 + , match = match + , maxDepth = Nothing + , fuzzRuns = 100 + , replay = Nothing + , vmModifier = id + , testParams = params + , dapp = srcInfo + , ffiAllowed = allowFFI + } + +compileWithDSTest :: FilePath -> IO (Text, Text) +compileWithDSTest src = + withSystemTempFile "input.json" $ \file handle -> do + hClose handle + dsTest <- readFile =<< Paths.getDataFileName "test/contracts/lib/test.sol" + erc20 <- readFile =<< Paths.getDataFileName "test/contracts/lib/erc20.sol" + testFilePath <- Paths.getDataFileName src + testFile <- readFile testFilePath + T.writeFile file + [i| + { + "language": "Solidity", + "sources": { + "ds-test/test.sol": { + "content": ${dsTest} + }, + "lib/erc20.sol": { + "content": ${erc20} + }, + "test.sol": { + "content": ${testFile} + } + }, + "settings": { + "metadata": { + "useLiteralContent": true + }, + "outputSelection": { + "*": { + "*": [ + "metadata", + "evm.bytecode", + "evm.deployedBytecode", + "abi", + "storageLayout", + "evm.bytecode.sourceMap", + "evm.bytecode.linkReferences", + "evm.bytecode.generatedSources", + "evm.deployedBytecode.sourceMap", + "evm.deployedBytecode.linkReferences", + "evm.deployedBytecode.generatedSources" + ], + "": [ + "ast" + ] + } + } + } + } + |] + x <- T.pack <$> + readProcess + "solc" + ["--allow-paths", file, "--standard-json", file] + "" + return (x, T.pack testFilePath) diff --git a/test/contracts/fail/cheatCodes.sol b/test/contracts/fail/cheatCodes.sol new file mode 100644 --- /dev/null +++ b/test/contracts/fail/cheatCodes.sol @@ -0,0 +1,24 @@ +import "ds-test/test.sol"; + +interface Hevm { + function warp(uint256) external; + function roll(uint256) external; + function load(address,bytes32) external returns (bytes32); + function store(address,bytes32,bytes32) external; + function sign(uint256,bytes32) external returns (uint8,bytes32,bytes32); + function addr(uint256) external returns (address); + function ffi(string[] calldata) external returns (bytes memory); +} + +contract TestFailCheatCodes is DSTest { + Hevm hevm = Hevm(HEVM_ADDRESS); + + function testBadFFI() public { + string[] memory inputs = new string[](2); + inputs[0] = "echo"; + inputs[1] = "acab"; + + // should revert if --ffi hasn't been passed to hevm... + hevm.ffi(inputs); + } +} diff --git a/test/contracts/fail/dsProveFail.sol b/test/contracts/fail/dsProveFail.sol new file mode 100644 --- /dev/null +++ b/test/contracts/fail/dsProveFail.sol @@ -0,0 +1,66 @@ +import "ds-test/test.sol"; +import "lib/erc20.sol"; + +contract SolidityTest is DSTest { + ERC20 token; + + function setUp() public { + token = new ERC20("TOKEN", "TKN", 18); + } + + function prove_trivial() public { + assert(false); + } + + function prove_add(uint x, uint y) public { + unchecked { + assertTrue(x + y >= x); + } + } + + //function proveFail_shouldFail(address usr) public { + //usr.call(""); + //} + + function prove_smtTimeout(uint x, uint y, uint z) public { + if ((x * y / z) * (x / y) / (x * y) == (x * x * x * y * z / x * z * y)) { + assertTrue(false); + } else { + assertTrue(true); + } + } + + function prove_multi(uint x) public { + if (x == 3) { + assertTrue(false); + } else if (x == 9) { + assertTrue(false); + } else if (x == 1023423194871904872390487213) { + assertTrue(false); + } else { + assertTrue(true); + } + } + + function prove_mul(uint136 x, uint128 y) public { + x * y; + } + + function prove_distributivity(uint120 x, uint120 y, uint120 z) public { + assertEq(x + (y * z), (x + y) * (x + z)); + } + + function prove_transfer(uint supply, address usr, uint amt) public { + token.mint(address(this), supply); + + uint prebal = token.balanceOf(usr); + token.transfer(usr, amt); + uint postbal = token.balanceOf(usr); + + uint expected = usr == address(this) + ? 0 // self transfer is a noop + : amt; // otherwise `amt` has been transfered to `usr` + assertEq(expected, postbal - prebal); + } +} + diff --git a/test/contracts/fail/invariantFail.sol b/test/contracts/fail/invariantFail.sol new file mode 100644 --- /dev/null +++ b/test/contracts/fail/invariantFail.sol @@ -0,0 +1,50 @@ +import "ds-test/test.sol"; + +contract Testdapp { + uint public x; + function f() public { + x++; + } + function g(uint y) public { + if (y % 2 == 0) x*=2; + } +} + + +contract TestdappTest is DSTest { + Testdapp testdapp; + + function setUp() public { + testdapp = new Testdapp(); + } + + function invariantFirst() public { + assertLt(testdapp.x(), 100); + } +} + +contract InvariantCount is DSTest { + BrokenAtStart count; + address[] targetContracts_; + + function targetContracts() public returns (address[] memory) { + return targetContracts_; + } + function setUp() public { + count = new BrokenAtStart(); + targetContracts_.push(address(count)); + } + + // this can only fail if we call the invariant method before calling any other method in the target contracts + function invariantCount() public { + assertGt(count.count(), 0); + } +} + +contract BrokenAtStart { + uint public count; + + function inc() public { + count++; + } +} diff --git a/test/contracts/fail/trivial.sol b/test/contracts/fail/trivial.sol new file mode 100644 --- /dev/null +++ b/test/contracts/fail/trivial.sol @@ -0,0 +1,9 @@ +import {DSTest} from "ds-test/test.sol"; + +// should run and pass +contract Trivial is DSTest { + function testFalse() public { + assertTrue(false); + } +} + diff --git a/test/contracts/lib/erc20.sol b/test/contracts/lib/erc20.sol new file mode 100644 --- /dev/null +++ b/test/contracts/lib/erc20.sol @@ -0,0 +1,201 @@ +// modified from solmate erc20 +// https://github.com/transmissions11/solmate/blob/c2594bf4635ad773a8f4763e20b7e79582e41535/src/tokens/ERC20.sol + +/// @notice Modern and gas efficient ERC20 + EIP-2612 implementation. +/// @author Solmate (https://github.com/transmissions11/solmate/blob/main/src/tokens/ERC20.sol) +/// @author Modified from Uniswap (https://github.com/Uniswap/uniswap-v2-core/blob/master/contracts/UniswapV2ERC20.sol) +/// @dev Do not manually set balances without updating totalSupply, as the sum of all user balances must not exceed it. +contract ERC20 { + + // --- events --- + + event Transfer(address indexed from, address indexed to, uint256 amount); + event Approval(address indexed owner, address indexed spender, uint256 amount); + + // --- metadata --- + + string public name; + string public symbol; + uint8 public immutable decimals; + + // --- erc20 data --- + + uint256 public totalSupply; + mapping(address => uint256) public balanceOf; + mapping(address => mapping(address => uint256)) public allowance; + + // --- eip2612 data --- + + uint256 internal immutable INITIAL_CHAIN_ID; + bytes32 internal immutable INITIAL_DOMAIN_SEPARATOR; + mapping(address => uint256) public nonces; + + // --- admin --- + + address public owner; + modifier auth { require(owner == msg.sender, "not-authorized"); _; } + + // --- init --- + + constructor( + string memory _name, + string memory _symbol, + uint8 _decimals + ) { + name = _name; + symbol = _symbol; + decimals = _decimals; + + INITIAL_CHAIN_ID = block.chainid; + INITIAL_DOMAIN_SEPARATOR = computeDomainSeparator(); + + owner = msg.sender; + } + + // --- erc20 logic --- + + function approve(address spender, uint256 amount) public returns (bool) { + allowance[msg.sender][spender] = amount; + + emit Approval(msg.sender, spender, amount); + + return true; + } + + function transfer(address to, uint256 amount) public returns (bool) { + balanceOf[msg.sender] -= amount; + + // Cannot overflow because the sum of all user + // balances can't exceed the max uint256 value. + unchecked { + balanceOf[to] += amount; + } + + emit Transfer(msg.sender, to, amount); + + return true; + } + + function transferFrom( + address from, + address to, + uint256 amount + ) public returns (bool) { + uint256 allowed = allowance[from][msg.sender]; // Saves gas for limited approvals. + + if (allowed != type(uint256).max) allowance[from][msg.sender] = allowed - amount; + + balanceOf[from] -= amount; + + // Cannot overflow because the sum of all user + // balances can't exceed the max uint256 value. + unchecked { + balanceOf[to] += amount; + } + + emit Transfer(from, to, amount); + + return true; + } + + // --- mint / burn logic --- + + function mint(address to, uint256 amount) public auth { + _mint(to, amount); + } + + function burn(address from, uint256 amount) public auth { + _burn(from, amount); + } + + // --- eip2612 logic --- + + function permit( + address owner, + address spender, + uint256 value, + uint256 deadline, + uint8 v, + bytes32 r, + bytes32 s + ) public { + require(deadline >= block.timestamp, "PERMIT_DEADLINE_EXPIRED"); + + // Unchecked because the only math done is incrementing + // the owner's nonce which cannot realistically overflow. + unchecked { + address recoveredAddress = ecrecover( + keccak256( + abi.encodePacked( + "\x19\x01", + DOMAIN_SEPARATOR(), + keccak256( + abi.encode( + keccak256( + "Permit(address owner,address spender,uint256 value,uint256 nonce,uint256 deadline)" + ), + owner, + spender, + value, + nonces[owner]++, + deadline + ) + ) + ) + ), + v, + r, + s + ); + + require(recoveredAddress != address(0) && recoveredAddress == owner, "INVALID_SIGNER"); + + allowance[recoveredAddress][spender] = value; + } + + emit Approval(owner, spender, value); + } + + function DOMAIN_SEPARATOR() public view returns (bytes32) { + return block.chainid == INITIAL_CHAIN_ID ? INITIAL_DOMAIN_SEPARATOR : computeDomainSeparator(); + } + + function computeDomainSeparator() internal view returns (bytes32) { + return + keccak256( + abi.encode( + keccak256("EIP712Domain(string name,string version,uint256 chainId,address verifyingContract)"), + keccak256(bytes(name)), + keccak256("1"), + block.chainid, + address(this) + ) + ); + } + + // --- internal mint / burn logic --- + + function _mint(address to, uint256 amount) internal { + totalSupply += amount; + + // Cannot overflow because the sum of all user + // balances can't exceed the max uint256 value. + unchecked { + balanceOf[to] += amount; + } + + emit Transfer(address(0), to, amount); + } + + function _burn(address from, uint256 amount) internal { + balanceOf[from] -= amount; + + // Cannot underflow because a user's balance + // will never be larger than the total supply. + unchecked { + totalSupply -= amount; + } + + emit Transfer(from, address(0), amount); + } +} diff --git a/test/contracts/lib/test.sol b/test/contracts/lib/test.sol new file mode 100644 --- /dev/null +++ b/test/contracts/lib/test.sol @@ -0,0 +1,469 @@ +// SPDX-License-Identifier: GPL-3.0-or-later + +// This program is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. + +// This program is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. + +// You should have received a copy of the GNU General Public License +// along with this program. If not, see . + +pragma solidity >=0.5.0; + +contract DSTest { + event log (string); + event logs (bytes); + + event log_address (address); + event log_bytes32 (bytes32); + event log_int (int); + event log_uint (uint); + event log_bytes (bytes); + event log_string (string); + + event log_named_address (string key, address val); + event log_named_bytes32 (string key, bytes32 val); + event log_named_decimal_int (string key, int val, uint decimals); + event log_named_decimal_uint (string key, uint val, uint decimals); + event log_named_int (string key, int val); + event log_named_uint (string key, uint val); + event log_named_bytes (string key, bytes val); + event log_named_string (string key, string val); + + bool public IS_TEST = true; + bool private _failed; + + address constant HEVM_ADDRESS = + address(bytes20(uint160(uint256(keccak256('hevm cheat code'))))); + + modifier mayRevert() { _; } + modifier testopts(string memory) { _; } + + function failed() public returns (bool) { + if (_failed) { + return _failed; + } else { + bool globalFailed = false; + if (hasHEVMContext()) { + (, bytes memory retdata) = HEVM_ADDRESS.call( + abi.encodePacked( + bytes4(keccak256("load(address,bytes32)")), + abi.encode(HEVM_ADDRESS, bytes32("failed")) + ) + ); + globalFailed = abi.decode(retdata, (bool)); + } + return globalFailed; + } + } + + function fail() internal { + if (hasHEVMContext()) { + (bool status, ) = HEVM_ADDRESS.call( + abi.encodePacked( + bytes4(keccak256("store(address,bytes32,bytes32)")), + abi.encode(HEVM_ADDRESS, bytes32("failed"), bytes32(uint256(0x01))) + ) + ); + status; // Silence compiler warnings + } + _failed = true; + } + + function hasHEVMContext() internal view returns (bool) { + uint256 hevmCodeSize = 0; + assembly { + hevmCodeSize := extcodesize(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D) + } + return hevmCodeSize > 0; + } + + modifier logs_gas() { + uint startGas = gasleft(); + _; + uint endGas = gasleft(); + emit log_named_uint("gas", startGas - endGas); + } + + function assertTrue(bool condition) internal { + if (!condition) { + emit log("Error: Assertion Failed"); + fail(); + } + } + + function assertTrue(bool condition, string memory err) internal { + if (!condition) { + emit log_named_string("Error", err); + assertTrue(condition); + } + } + + function assertEq(address a, address b) internal { + if (a != b) { + emit log("Error: a == b not satisfied [address]"); + emit log_named_address(" Expected", b); + emit log_named_address(" Actual", a); + fail(); + } + } + function assertEq(address a, address b, string memory err) internal { + if (a != b) { + emit log_named_string ("Error", err); + assertEq(a, b); + } + } + + function assertEq(bytes32 a, bytes32 b) internal { + if (a != b) { + emit log("Error: a == b not satisfied [bytes32]"); + emit log_named_bytes32(" Expected", b); + emit log_named_bytes32(" Actual", a); + fail(); + } + } + function assertEq(bytes32 a, bytes32 b, string memory err) internal { + if (a != b) { + emit log_named_string ("Error", err); + assertEq(a, b); + } + } + function assertEq32(bytes32 a, bytes32 b) internal { + assertEq(a, b); + } + function assertEq32(bytes32 a, bytes32 b, string memory err) internal { + assertEq(a, b, err); + } + + function assertEq(int a, int b) internal { + if (a != b) { + emit log("Error: a == b not satisfied [int]"); + emit log_named_int(" Expected", b); + emit log_named_int(" Actual", a); + fail(); + } + } + function assertEq(int a, int b, string memory err) internal { + if (a != b) { + emit log_named_string("Error", err); + assertEq(a, b); + } + } + function assertEq(uint a, uint b) internal { + if (a != b) { + emit log("Error: a == b not satisfied [uint]"); + emit log_named_uint(" Expected", b); + emit log_named_uint(" Actual", a); + fail(); + } + } + function assertEq(uint a, uint b, string memory err) internal { + if (a != b) { + emit log_named_string("Error", err); + assertEq(a, b); + } + } + function assertEqDecimal(int a, int b, uint decimals) internal { + if (a != b) { + emit log("Error: a == b not satisfied [decimal int]"); + emit log_named_decimal_int(" Expected", b, decimals); + emit log_named_decimal_int(" Actual", a, decimals); + fail(); + } + } + function assertEqDecimal(int a, int b, uint decimals, string memory err) internal { + if (a != b) { + emit log_named_string("Error", err); + assertEqDecimal(a, b, decimals); + } + } + function assertEqDecimal(uint a, uint b, uint decimals) internal { + if (a != b) { + emit log("Error: a == b not satisfied [decimal uint]"); + emit log_named_decimal_uint(" Expected", b, decimals); + emit log_named_decimal_uint(" Actual", a, decimals); + fail(); + } + } + function assertEqDecimal(uint a, uint b, uint decimals, string memory err) internal { + if (a != b) { + emit log_named_string("Error", err); + assertEqDecimal(a, b, decimals); + } + } + + function assertGt(uint a, uint b) internal { + if (a <= b) { + emit log("Error: a > b not satisfied [uint]"); + emit log_named_uint(" Value a", a); + emit log_named_uint(" Value b", b); + fail(); + } + } + function assertGt(uint a, uint b, string memory err) internal { + if (a <= b) { + emit log_named_string("Error", err); + assertGt(a, b); + } + } + function assertGt(int a, int b) internal { + if (a <= b) { + emit log("Error: a > b not satisfied [int]"); + emit log_named_int(" Value a", a); + emit log_named_int(" Value b", b); + fail(); + } + } + function assertGt(int a, int b, string memory err) internal { + if (a <= b) { + emit log_named_string("Error", err); + assertGt(a, b); + } + } + function assertGtDecimal(int a, int b, uint decimals) internal { + if (a <= b) { + emit log("Error: a > b not satisfied [decimal int]"); + emit log_named_decimal_int(" Value a", a, decimals); + emit log_named_decimal_int(" Value b", b, decimals); + fail(); + } + } + function assertGtDecimal(int a, int b, uint decimals, string memory err) internal { + if (a <= b) { + emit log_named_string("Error", err); + assertGtDecimal(a, b, decimals); + } + } + function assertGtDecimal(uint a, uint b, uint decimals) internal { + if (a <= b) { + emit log("Error: a > b not satisfied [decimal uint]"); + emit log_named_decimal_uint(" Value a", a, decimals); + emit log_named_decimal_uint(" Value b", b, decimals); + fail(); + } + } + function assertGtDecimal(uint a, uint b, uint decimals, string memory err) internal { + if (a <= b) { + emit log_named_string("Error", err); + assertGtDecimal(a, b, decimals); + } + } + + function assertGe(uint a, uint b) internal { + if (a < b) { + emit log("Error: a >= b not satisfied [uint]"); + emit log_named_uint(" Value a", a); + emit log_named_uint(" Value b", b); + fail(); + } + } + function assertGe(uint a, uint b, string memory err) internal { + if (a < b) { + emit log_named_string("Error", err); + assertGe(a, b); + } + } + function assertGe(int a, int b) internal { + if (a < b) { + emit log("Error: a >= b not satisfied [int]"); + emit log_named_int(" Value a", a); + emit log_named_int(" Value b", b); + fail(); + } + } + function assertGe(int a, int b, string memory err) internal { + if (a < b) { + emit log_named_string("Error", err); + assertGe(a, b); + } + } + function assertGeDecimal(int a, int b, uint decimals) internal { + if (a < b) { + emit log("Error: a >= b not satisfied [decimal int]"); + emit log_named_decimal_int(" Value a", a, decimals); + emit log_named_decimal_int(" Value b", b, decimals); + fail(); + } + } + function assertGeDecimal(int a, int b, uint decimals, string memory err) internal { + if (a < b) { + emit log_named_string("Error", err); + assertGeDecimal(a, b, decimals); + } + } + function assertGeDecimal(uint a, uint b, uint decimals) internal { + if (a < b) { + emit log("Error: a >= b not satisfied [decimal uint]"); + emit log_named_decimal_uint(" Value a", a, decimals); + emit log_named_decimal_uint(" Value b", b, decimals); + fail(); + } + } + function assertGeDecimal(uint a, uint b, uint decimals, string memory err) internal { + if (a < b) { + emit log_named_string("Error", err); + assertGeDecimal(a, b, decimals); + } + } + + function assertLt(uint a, uint b) internal { + if (a >= b) { + emit log("Error: a < b not satisfied [uint]"); + emit log_named_uint(" Value a", a); + emit log_named_uint(" Value b", b); + fail(); + } + } + function assertLt(uint a, uint b, string memory err) internal { + if (a >= b) { + emit log_named_string("Error", err); + assertLt(a, b); + } + } + function assertLt(int a, int b) internal { + if (a >= b) { + emit log("Error: a < b not satisfied [int]"); + emit log_named_int(" Value a", a); + emit log_named_int(" Value b", b); + fail(); + } + } + function assertLt(int a, int b, string memory err) internal { + if (a >= b) { + emit log_named_string("Error", err); + assertLt(a, b); + } + } + function assertLtDecimal(int a, int b, uint decimals) internal { + if (a >= b) { + emit log("Error: a < b not satisfied [decimal int]"); + emit log_named_decimal_int(" Value a", a, decimals); + emit log_named_decimal_int(" Value b", b, decimals); + fail(); + } + } + function assertLtDecimal(int a, int b, uint decimals, string memory err) internal { + if (a >= b) { + emit log_named_string("Error", err); + assertLtDecimal(a, b, decimals); + } + } + function assertLtDecimal(uint a, uint b, uint decimals) internal { + if (a >= b) { + emit log("Error: a < b not satisfied [decimal uint]"); + emit log_named_decimal_uint(" Value a", a, decimals); + emit log_named_decimal_uint(" Value b", b, decimals); + fail(); + } + } + function assertLtDecimal(uint a, uint b, uint decimals, string memory err) internal { + if (a >= b) { + emit log_named_string("Error", err); + assertLtDecimal(a, b, decimals); + } + } + + function assertLe(uint a, uint b) internal { + if (a > b) { + emit log("Error: a <= b not satisfied [uint]"); + emit log_named_uint(" Value a", a); + emit log_named_uint(" Value b", b); + fail(); + } + } + function assertLe(uint a, uint b, string memory err) internal { + if (a > b) { + emit log_named_string("Error", err); + assertLe(a, b); + } + } + function assertLe(int a, int b) internal { + if (a > b) { + emit log("Error: a <= b not satisfied [int]"); + emit log_named_int(" Value a", a); + emit log_named_int(" Value b", b); + fail(); + } + } + function assertLe(int a, int b, string memory err) internal { + if (a > b) { + emit log_named_string("Error", err); + assertLe(a, b); + } + } + function assertLeDecimal(int a, int b, uint decimals) internal { + if (a > b) { + emit log("Error: a <= b not satisfied [decimal int]"); + emit log_named_decimal_int(" Value a", a, decimals); + emit log_named_decimal_int(" Value b", b, decimals); + fail(); + } + } + function assertLeDecimal(int a, int b, uint decimals, string memory err) internal { + if (a > b) { + emit log_named_string("Error", err); + assertLeDecimal(a, b, decimals); + } + } + function assertLeDecimal(uint a, uint b, uint decimals) internal { + if (a > b) { + emit log("Error: a <= b not satisfied [decimal uint]"); + emit log_named_decimal_uint(" Value a", a, decimals); + emit log_named_decimal_uint(" Value b", b, decimals); + fail(); + } + } + function assertLeDecimal(uint a, uint b, uint decimals, string memory err) internal { + if (a > b) { + emit log_named_string("Error", err); + assertGeDecimal(a, b, decimals); + } + } + + function assertEq(string memory a, string memory b) internal { + if (keccak256(abi.encodePacked(a)) != keccak256(abi.encodePacked(b))) { + emit log("Error: a == b not satisfied [string]"); + emit log_named_string(" Value a", a); + emit log_named_string(" Value b", b); + fail(); + } + } + function assertEq(string memory a, string memory b, string memory err) internal { + if (keccak256(abi.encodePacked(a)) != keccak256(abi.encodePacked(b))) { + emit log_named_string("Error", err); + assertEq(a, b); + } + } + + function checkEq0(bytes memory a, bytes memory b) internal pure returns (bool ok) { + ok = true; + if (a.length == b.length) { + for (uint i = 0; i < a.length; i++) { + if (a[i] != b[i]) { + ok = false; + } + } + } else { + ok = false; + } + } + function assertEq0(bytes memory a, bytes memory b) internal { + if (!checkEq0(a, b)) { + emit log("Error: a == b not satisfied [bytes]"); + emit log_named_bytes(" Expected", a); + emit log_named_bytes(" Actual", b); + fail(); + } + } + function assertEq0(bytes memory a, bytes memory b, string memory err) internal { + if (!checkEq0(a, b)) { + emit log_named_string("Error", err); + assertEq0(a, b); + } + } +} diff --git a/test/contracts/pass/abstract.sol b/test/contracts/pass/abstract.sol new file mode 100644 --- /dev/null +++ b/test/contracts/pass/abstract.sol @@ -0,0 +1,15 @@ +import {DSTest} from "ds-test/test.sol"; + +// should not be run (no code) +abstract contract MyTest is DSTest { + function testAbstract() public { + assertTrue(true); + } +} + +// should run and pass +contract TestMy is MyTest { + function testTrue() public { + assertTrue(true); + } +} diff --git a/test/contracts/pass/cheatCodes.sol b/test/contracts/pass/cheatCodes.sol new file mode 100644 --- /dev/null +++ b/test/contracts/pass/cheatCodes.sol @@ -0,0 +1,89 @@ +pragma experimental ABIEncoderV2; + +import "ds-test/test.sol"; + +interface Hevm { + function warp(uint256) external; + function roll(uint256) external; + function load(address,bytes32) external returns (bytes32); + function store(address,bytes32,bytes32) external; + function sign(uint256,bytes32) external returns (uint8,bytes32,bytes32); + function addr(uint256) external returns (address); + function ffi(string[] calldata) external returns (bytes memory); +} + +contract HasStorage { + uint slot0 = 10; +} + +contract CheatCodes is DSTest { + address store = address(new HasStorage()); + Hevm hevm = Hevm(HEVM_ADDRESS); + + function test_warp_concrete(uint128 jump) public { + uint pre = block.timestamp; + hevm.warp(block.timestamp + jump); + assertEq(block.timestamp, pre + jump); + } + + function prove_warp_symbolic(uint128 jump) public { + test_warp_concrete(jump); + } + + function test_roll_concrete(uint64 jump) public { + uint pre = block.number; + hevm.roll(block.number + jump); + assertEq(block.number, pre + jump); + } + + function test_store_load_concrete(uint x) public { + uint ten = uint(hevm.load(store, bytes32(0))); + assertEq(ten, 10); + + hevm.store(store, bytes32(0), bytes32(x)); + uint val = uint(hevm.load(store, bytes32(0))); + assertEq(val, x); + } + + function prove_store_load_symbolic(uint x) public { + test_store_load_concrete(x); + } + + function test_sign_addr_digest(uint sk, bytes32 digest) public { + if (sk == 0) return; // invalid key + + (uint8 v, bytes32 r, bytes32 s) = hevm.sign(sk, digest); + address expected = hevm.addr(sk); + address actual = ecrecover(digest, v, r, s); + + assertEq(actual, expected); + } + + function test_sign_addr_message(uint sk, bytes memory message) public { + test_sign_addr_digest(sk, keccak256(message)); + } + + function testFail_sign_addr(uint sk, bytes32 digest) public { + uint badKey = sk + 1; + + (uint8 v, bytes32 r, bytes32 s) = hevm.sign(badKey, digest); + address expected = hevm.addr(sk); + address actual = ecrecover(digest, v, r, s); + + assertEq(actual, expected); + } + + function testFail_addr_zero_sk() public { + hevm.addr(0); + } + + function testFFI() public { + string[] memory inputs = new string[](3); + inputs[0] = "echo"; + inputs[1] = "-n"; + inputs[2] = "0x000000000000000000000000000000000000000000000000000000000000002000000000000000000000000000000000000000000000000000000000000000046163616200000000000000000000000000000000000000000000000000000000"; + + (string memory output) = abi.decode(hevm.ffi(inputs), (string)); + assertEq(output, "acab"); + } +} diff --git a/test/contracts/pass/constantinople.sol b/test/contracts/pass/constantinople.sol new file mode 100644 --- /dev/null +++ b/test/contracts/pass/constantinople.sol @@ -0,0 +1,331 @@ +import "ds-test/test.sol"; + +contract DeadCode{ + function dummy() external returns (uint256) {} +} + +contract ConstantinopleTests is DSTest { + DeadCode notmuch; + function setUp() public { + notmuch = new DeadCode(); + } + + // this 5 byte-long initcode simply returns nothing + // PUSH1 00 PUSH1 00 RETURN + // 60 00 60 00 f3 + bytes32 zerocode = 0x60006000f3000000000000000000000000000000000000000000000000000000; + // this 13 byte-long initcode simply returns 0xdeadbeef: + // PUSH4 de ad be ef PUSH1 00 MSTORE PUSH1 32 PUSH1 00 RETURN + // 63 de ad be ef 60 00 52 60 20 60 00 f3 + bytes32 deadcode = 0x63deadbeef60005260206000f300000000000000000000000000000000000000; + // this 25 byte-long initcode returns deadcode (but without the padding) + // PUSH1 0d PUSH1 0c PUSH1 00 CODECO PUSH1 0d PUSH1 00 RETURN deadcode + // 60 0d 60 0c 60 00 39 60 0d 60 00 f3 + bytes32 deploysdeadcode = 0x600d600c600039600d6000f363deadbeef60005260206000f300000000000000; + + // EXTCODEHASH of non-existent account is 0 + function test_extcodehash_1() public { + uint256 h; + assembly { + h := extcodehash(0x10) + } + assertEq(h, 0); + } + // EXTCODEHASH of account with no code is keccak256("") + function test_extcodehash_2() public { + address a; + uint256 h; + assembly { + let top := mload(0x40) + mstore(top, sload(zerocode.slot)) + a := create(0, top, 5) + h := extcodehash(a) + } + assertEq(h, 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470); + } + // EXTCODEHASH of account with code 0xdeadbeef is keccak256(0xdeadbeef) + function test_extcodehash_3() public { + address a; + uint256 h; + + assembly { + let top := mload(0x40) + mstore(top, sload(deadcode.slot)) + a := create(0, top, 13) + h := extcodehash(a) + } + + uint256 expected_h; + assembly { + let top := mload(0x40) + mstore(top, 0xdeadbeef) + expected_h := keccak256(top, 32) + } + assertEq(h, expected_h); + } + // EXTCODEHASH of the notmuch contract should be same as + // doing EXTCODECOPY and then keccak256 + function test_extcodehash_4() public { + address a = address(notmuch); + uint256 h; + + assembly { + h := extcodehash(a) + } + + uint256 expected_h; + assembly { + let top := mload(0x40) + let size := extcodesize(a) + extcodecopy(a, top, 0, size) + expected_h := keccak256(top, size) + } + assertEq(h, expected_h); + } + + // address of account created by CREATE2 is + // keccak256(0xff + address + salt + keccak256(init_code))[12:] + function test_create2_1() public { + address a; + uint256 salt = 0xfacefeed; + assembly { + let top := mload(0x40) + mstore(top, sload(deadcode.slot)) + a := create2(0, top, 13, salt) + } + + address expected_a; + + assembly { + let top := mload(0x40) + mstore(top, sload(deadcode.slot)) + let inithash := keccak256(top, 13) + mstore(sub(top, 11), address()) + mstore8(top, 0xff) + mstore(add(top, 21), salt) + mstore(add(top, 53), inithash) + expected_a := and(keccak256(top, 85), 0x000000000000000000000000ffffffffffffffffffffffffffffffffffffffff) + } + + assertEq(a, expected_a); + } + // calling a CREATE2 contract works as expected + function test_create2_2() public { + address a; + uint256 salt = 0xfacefeed; + assembly { + let top := mload(0x40) + mstore(top, sload(deploysdeadcode.slot)) + a := create2(0, top, 25, salt) + } + + assertEq(DeadCode(a).dummy(), 0xdeadbeef); + } + // TODO: test some SELFDESTRUCT properties of CREATE2 + // TODO: test EXTCODEHASH on self-destructed contract + // TODO: test EXTCODEHASH on precompiled contracts + + // SHL, SHR and SAR tests taken from + // https://github.com/ethereum/EIPs/blob/fde32dfd6b24bac7bfabf6c1ebe3f5a603d5ff4c/EIPS/eip-145.md + function test_shl() public { + uint z; + + assembly { + z := shl(0x00, 0x0000000000000000000000000000000000000000000000000000000000000001) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000001); + + assembly { + z := shl(0x01, 0x0000000000000000000000000000000000000000000000000000000000000001) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000002); + + assembly { + z := shl(0xff, 0x0000000000000000000000000000000000000000000000000000000000000001) + } + assertEq(z, 0x8000000000000000000000000000000000000000000000000000000000000000); + + assembly { + z := shl(0x0100, 0x0000000000000000000000000000000000000000000000000000000000000001) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); + + assembly { + z := shl(0x0101, 0x0000000000000000000000000000000000000000000000000000000000000001) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); + + assembly { + z := shl(0x00, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(z, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff); + + assembly { + z := shl(0x01, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(z, 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe); + + assembly { + z := shl(0xff, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(z, 0x8000000000000000000000000000000000000000000000000000000000000000); + + assembly { + z := shl(0x0100, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); + + assembly { + z := shl(0x01, 0x0000000000000000000000000000000000000000000000000000000000000000) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); + + assembly { + z := shl(0x01, 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(z, 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe); + } + + function test_shr() public { + uint z; + + assembly { + z := shr(0x00, 0x0000000000000000000000000000000000000000000000000000000000000001) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000001); + + assembly { + z := shr(0x01, 0x0000000000000000000000000000000000000000000000000000000000000001) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); + + assembly { + z := shr(0x01, 0x8000000000000000000000000000000000000000000000000000000000000000) + } + assertEq(z, 0x4000000000000000000000000000000000000000000000000000000000000000); + + assembly { + z := shr(0xff, 0x8000000000000000000000000000000000000000000000000000000000000000) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000001); + + assembly { + z := shr(0x0100, 0x8000000000000000000000000000000000000000000000000000000000000000) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); + + assembly { + z := shr(0x0101, 0x8000000000000000000000000000000000000000000000000000000000000000) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); + + assembly { + z := shr(0x00, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(z, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff); + + assembly { + z := shr(0x01, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(z, 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff); + + assembly { + z := shr(0xff, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000001); + + assembly { + z := shr(0x0100, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); + + assembly { + z := shr(0x01, 0x0000000000000000000000000000000000000000000000000000000000000000) + } + assertEq(z, 0x0000000000000000000000000000000000000000000000000000000000000000); + } + + function test_sar() public { + uint z; + + assembly { + z := sar(0x00, 0x0000000000000000000000000000000000000000000000000000000000000001) + } + assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000001)); + + assembly { + z := sar(0x01, 0x0000000000000000000000000000000000000000000000000000000000000001) + } + assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000000)); + + assembly { + z := sar(0x01, 0x8000000000000000000000000000000000000000000000000000000000000000) + } + assertEq(bytes32(z), bytes32(0xc000000000000000000000000000000000000000000000000000000000000000)); + + assembly { + z := sar(0xff, 0x8000000000000000000000000000000000000000000000000000000000000000) + } + assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); + + assembly { + z := sar(0x0100, 0x8000000000000000000000000000000000000000000000000000000000000000) + } + assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); + + assembly { + z := sar(0x0101, 0x8000000000000000000000000000000000000000000000000000000000000000) + } + assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); + + assembly { + z := sar(0x00, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); + + assembly { + z := sar(0x01, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); + + assembly { + z := sar(0xff, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); + + assembly { + z := sar(0x0100, 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(bytes32(z), bytes32(0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)); + + assembly { + z := sar(0x01, 0x0000000000000000000000000000000000000000000000000000000000000000) + } + assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000000)); + + assembly { + z := sar(0xfe, 0x4000000000000000000000000000000000000000000000000000000000000000) + } + assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000001)); + + assembly { + z := sar(0xf8, 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(bytes32(z), bytes32(0x000000000000000000000000000000000000000000000000000000000000007f)); + + assembly { + z := sar(0xfe, 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000001)); + + assembly { + z := sar(0xff, 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000000)); + + assembly { + z := sar(0x0100, 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) + } + assertEq(bytes32(z), bytes32(0x0000000000000000000000000000000000000000000000000000000000000000)); + } +} diff --git a/test/contracts/pass/dsProvePass.sol b/test/contracts/pass/dsProvePass.sol new file mode 100644 --- /dev/null +++ b/test/contracts/pass/dsProvePass.sol @@ -0,0 +1,82 @@ +import "ds-test/test.sol"; +import "lib/erc20.sol"; + +contract ConstructorArg { + address immutable public a; + constructor(address _a) public { + a = _a; + } +} + +contract SolidityTest is DSTest { + ERC20 token; + + function setUp() public { + token = new ERC20("Token", "TKN", 18); + } + + function prove_trivial() public { + assertTrue(true); + } + + function prove_easy(uint v) public { + if (v != 100) return; + assertEq(v, 100); + } + + function prove_add(uint x, uint y) public { + unchecked { + if (x + y < x) return; // no overflow + assertTrue(x + y >= x); + } + } + + function prove_balance(address usr, uint amt) public { + assertEq(0, token.balanceOf(usr)); + token.mint(usr, amt); + assertEq(amt, token.balanceOf(usr)); + } + + function prove_supply(uint supply) public { + token.mint(address(this), supply); + uint actual = token.totalSupply(); + assertEq(supply, actual); + } + + function prove_constructorArgs(address b) public { + ConstructorArg c = new ConstructorArg(b); + assertEq(b, c.a()); + } + + function proveFail_revertSmoke() public { + require(false); + } + + function proveFail_assertSmoke() public { + assertTrue(false); + } + + function prove_transfer(uint supply, address usr, uint amt) public { + if (amt > supply) return; // no underflow + + token.mint(address(this), supply); + + uint prebal = token.balanceOf(usr); + token.transfer(usr, amt); + uint postbal = token.balanceOf(usr); + + uint expected = usr == address(this) + ? 0 // self transfer is a noop + : amt; // otherwise `amt` has been transfered to `usr` + assertEq(expected, postbal - prebal); + } + + function prove_burn(uint supply, uint amt) public { + if (amt > supply) return; // no undeflow + + token.mint(address(this), supply); + token.burn(address(this), amt); + + assertEq(supply - amt, token.totalSupply()); + } +} diff --git a/test/contracts/pass/invariants.sol b/test/contracts/pass/invariants.sol new file mode 100644 --- /dev/null +++ b/test/contracts/pass/invariants.sol @@ -0,0 +1,41 @@ +import "ds-test/test.sol"; +import "lib/erc20.sol"; + +contract InvariantTest is DSTest { + ERC20 token; + User user; + address[] targetContracts_; + + function targetContracts() public returns (address[] memory) { + return targetContracts_; + } + + function setUp() public { + token = new ERC20("TOKEN", "TKN", 18); + user = new User(token); + token.mint(address(user), type(uint).max); + targetContracts_.push(address(user)); + } + + function invariantTestThisBal() public { + assertLe(token.balanceOf(address(user)), type(uint).max); + } + function invariantTotSupply() public { + assertEq(token.totalSupply(), type(uint).max); + } +} + +contract User { + ERC20 token; + constructor(ERC20 token_) public { + token = token_; + } + + function doTransfer(address to, uint amount) public { + token.transfer(to, amount); + } + + function doSelfTransfer(uint amount) public { + token.transfer(address(this), amount); + } +} diff --git a/test/contracts/pass/libraries.sol b/test/contracts/pass/libraries.sol new file mode 100644 --- /dev/null +++ b/test/contracts/pass/libraries.sol @@ -0,0 +1,18 @@ +import "ds-test/test.sol"; + +library A { + function f(uint128 x) public returns (uint256) { + return uint(x) * 2; + } +} + +contract B is DSTest { + using A for uint128; + function test_f(uint128 x) public { + assertEq(uint(x) * 2, x.f()); + } + + function testFail_f() public { + assertEq(1, uint128(1).f()); + } +} diff --git a/test/contracts/pass/loops.sol b/test/contracts/pass/loops.sol new file mode 100644 --- /dev/null +++ b/test/contracts/pass/loops.sol @@ -0,0 +1,12 @@ +import "ds-test/test.sol"; + +contract Loops is DSTest { + + function prove_loop(uint n) public { + uint counter = 0; + for (uint i = 0; i < n; i++) { + counter++; + } + assertTrue(counter < 100); + } +} diff --git a/test/contracts/pass/rpc.sol b/test/contracts/pass/rpc.sol new file mode 100644 --- /dev/null +++ b/test/contracts/pass/rpc.sol @@ -0,0 +1,16 @@ +import {DSTest} from "ds-test/test.sol"; +import {ERC20} from "lib/erc20.sol"; + +contract C is DSTest { + // BAL: https://etherscan.io/address/0xba100000625a3754423978a60c9317c58a424e3D#code + ERC20 bal = ERC20(0xba100000625a3754423978a60c9317c58a424e3D); + + function test_trivial() public { + uint ub = bal.balanceOf(0xBA12222222228d8Ba445958a75a0704d566BF2C8); + assertEq(ub, 27099516537379438397130892); + } + + function prove_trivial() public { + test_trivial(); + } +} diff --git a/test/contracts/pass/trivial.sol b/test/contracts/pass/trivial.sol new file mode 100644 --- /dev/null +++ b/test/contracts/pass/trivial.sol @@ -0,0 +1,9 @@ +import {DSTest} from "ds-test/test.sol"; + +// should run and pass +contract Trivial is DSTest { + function testTrue() public { + assertTrue(true); + } +} + diff --git a/test/rpc.hs b/test/rpc.hs new file mode 100644 --- /dev/null +++ b/test/rpc.hs @@ -0,0 +1,149 @@ +{-# Language GADTs #-} +{-# Language DataKinds #-} + +module Main where + +import Control.Lens +import Test.Tasty +import Test.Tasty.HUnit +import Data.Text (Text) +import Control.Monad.State.Strict (execStateT) +import Data.Functor +import Data.Maybe +import qualified Data.Map as Map +import qualified Data.Vector as V + +import EVM +import EVM.ABI +import EVM.SMT +import EVM.Fetch +import EVM.SymExec +import EVM.TestUtils +import qualified EVM.Stepper as Stepper +import qualified EVM.Fetch as Fetch +import EVM.Types hiding (BlockNumber) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "rpc" + [ testGroup "Block Parsing Tests" + [ testCase "pre-merge-block" $ do + let block' = BlockNumber 15537392 + (cb, numb, basefee, prevRan) <- fetchBlockFrom block' testRpc >>= \case + Nothing -> error "Could not fetch block" + Just EVM.Block{..} -> return (_coinbase + , _number + , _baseFee + , _prevRandao + ) + + assertEqual "coinbase" (Addr 0xea674fdde714fd979de3edf0f56aa9716b898ec8) cb + assertEqual "number" (BlockNumber numb) block' + assertEqual "basefee" 38572377838 basefee + assertEqual "prevRan" 11049842297455506 prevRan + , testCase "post-merge-block" $ do + let block' = BlockNumber 16184420 + (cb, numb, basefee, prevRan) <- fetchBlockFrom block' testRpc >>= \case + Nothing -> error "Could not fetch block" + Just EVM.Block{..} -> return (_coinbase + , _number + , _baseFee + , _prevRandao + ) + + assertEqual "coinbase" (Addr 0x690b9a9e9aa1c9db991c7721a92d351db4fac990) cb + assertEqual "number" (BlockNumber numb) block' + assertEqual "basefee" 22163046690 basefee + assertEqual "prevRan" 0x2267531ab030ed32fd5f2ef51f81427332d0becbd74fe7f4cd5684ddf4b287e0 prevRan + ] + , testGroup "execution with remote state" + -- execute against remote state from a ds-test harness + [ testCase "dapp-test" $ do + let testFile = "test/contracts/pass/rpc.sol" + runDappTestCustom testFile ".*" Nothing False testRpcInfo >>= assertEqual "test result" True + + -- concretely exec "transfer" on WETH9 using remote rpc + -- https://etherscan.io/token/0xc02aaa39b223fe8d0a0e5c4f27ead9083c756cc2#code + , testCase "weth-conc" $ do + let + blockNum = 16198552 + wad = 0x999999999999999999 + calldata' = ConcreteBuf $ abiMethod "transfer(address,uint256)" (AbiTuple (V.fromList [AbiAddress (Addr 0xdead), AbiUInt 256 wad])) + vm <- weth9VM blockNum (calldata', []) + postVm <- withSolvers Z3 1 Nothing $ \solvers -> + execStateT (Stepper.interpret (Fetch.oracle solvers (Just (BlockNumber blockNum, testRpc))) . void $ Stepper.execFully) vm + let + (ConcreteStore postStore) = view (env . storage) postVm + wethStore = fromJust $ Map.lookup 0xC02aaA39b223FE8D0A0e5C4F27eAD9083C756Cc2 postStore + receiverBal = fromJust $ Map.lookup (keccak' (word256Bytes 0xdead <> word256Bytes 0x3)) wethStore + (Just (VMSuccess msg)) = view result postVm + assertEqual "should succeed" msg (ConcreteBuf $ word256Bytes 0x1) + assertEqual "should revert" receiverBal (W256 $ 2595433725034301 + wad) + + -- symbolically exec "transfer" on WETH9 using remote rpc + -- https://etherscan.io/token/0xc02aaa39b223fe8d0a0e5c4f27ead9083c756cc2#code + , testCase "weth-sym" $ do + let + blockNum = 16198552 + calldata' = symCalldata "transfer(address,uint256)" [AbiAddressType, AbiUIntType 256] ["0xdead"] (AbstractBuf "txdata") + postc _ (EVM.Types.Revert _ _) = PBool False + postc _ _ = PBool True + vm <- weth9VM blockNum calldata' + (_, [Cex (_, model)]) <- withSolvers Z3 1 Nothing $ \solvers -> + verify solvers (rpcVeriOpts (BlockNumber blockNum, testRpc)) vm (Just postc) + assertBool "model should exceed caller balance" (getVar model "arg2" >= 695836005599316055372648) + ] + ] + +-- call into WETH9 from 0xf04a... (a large holder) +weth9VM :: W256 -> (Expr Buf, [Prop]) -> IO (EVM.VM) +weth9VM blockNum calldata' = do + let + caller' = Lit 0xf04a5cc80b1e94c69b48f5ee68a08cd2f09a7c3e + weth9 = Addr 0xC02aaA39b223FE8D0A0e5C4F27eAD9083C756Cc2 + callvalue' = Lit 0 + vmFromRpc blockNum calldata' callvalue' caller' weth9 + +vmFromRpc :: W256 -> (Expr Buf, [Prop]) -> Expr EWord -> Expr EWord -> Addr -> IO (EVM.VM) +vmFromRpc blockNum calldata' callvalue' caller' address' = do + ctrct <- fetchContractFrom (BlockNumber blockNum) testRpc address' >>= \case + Nothing -> error $ "contract not found: " <> show address' + Just contract' -> return contract' + + blk <- fetchBlockFrom (BlockNumber blockNum) testRpc >>= \case + Nothing -> error "could not fetch block" + Just b -> pure b + + pure $ EVM.makeVm $ EVM.VMOpts + { EVM.vmoptContract = ctrct + , EVM.vmoptCalldata = calldata' + , EVM.vmoptValue = callvalue' + , EVM.vmoptAddress = address' + , EVM.vmoptCaller = caller' + , EVM.vmoptOrigin = 0xacab + , EVM.vmoptGas = 0xffffffffffffffff + , EVM.vmoptGaslimit = 0xffffffffffffffff + , EVM.vmoptBaseFee = view baseFee blk + , EVM.vmoptPriorityFee = 0 + , EVM.vmoptCoinbase = view coinbase blk + , EVM.vmoptNumber = view number blk + , EVM.vmoptTimestamp = view timestamp blk + , EVM.vmoptBlockGaslimit = view gaslimit blk + , EVM.vmoptGasprice = 0 + , EVM.vmoptMaxCodeSize = view maxCodeSize blk + , EVM.vmoptPrevRandao = view prevRandao blk + , EVM.vmoptSchedule = view schedule blk + , EVM.vmoptChainId = 1 + , EVM.vmoptCreate = False + , EVM.vmoptStorageBase = EVM.Concrete + , EVM.vmoptTxAccessList = mempty + , EVM.vmoptAllowFFI = False + } + +testRpc :: Text +testRpc = "https://eth-mainnet.alchemyapi.io/v2/vpeKFsEF6PHifHzdtcwXSDbhV3ym5Ro4" + +testRpcInfo :: RpcInfo +testRpcInfo = Just (BlockNumber 16198552, testRpc) diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,788 +1,2471 @@ -{-# Language OverloadedStrings #-} -{-# Language ViewPatterns #-} -{-# Language ScopedTypeVariables #-} -{-# Language LambdaCase #-} -{-# Language QuasiQuotes #-} -{-# Language FlexibleInstances #-} -{-# Language GeneralizedNewtypeDeriving #-} -{-# Language DataKinds #-} -{-# Language StandaloneDeriving #-} - -module Main where - -import Data.Text (Text) -import Data.ByteString (ByteString) - -import Prelude hiding (fail) - -import qualified Data.Text as Text -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BS (fromStrict) -import qualified Data.ByteString.Base16 as Hex -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.Tasty.HUnit -import Test.Tasty.Runners - -import Control.Monad.State.Strict (execState, runState) -import Control.Lens hiding (List, pre, (.>)) - -import qualified Data.Vector as Vector -import Data.String.Here - -import Control.Monad.Fail - -import Data.Binary.Put (runPut) -import Data.SBV hiding ((===), forAll, sList) -import Data.SBV.Control -import qualified Data.Map as Map -import Data.Binary.Get (runGetOrFail) - -import EVM hiding (Query) -import EVM.SymExec -import EVM.ABI -import EVM.Exec -import qualified EVM.Patricia as Patricia -import EVM.Precompiled -import EVM.RLP -import EVM.Solidity -import EVM.Types - -instance MonadFail Query where - fail = io . fail - -main :: IO () -main = defaultMain tests - --- | run a subset of tests in the repl. p is a tasty pattern: --- https://github.com/UnkindPartition/tasty/tree/ee6fe7136fbcc6312da51d7f1b396e1a2d16b98a#patterns -runSubSet :: String -> IO () -runSubSet p = defaultMain . applyPattern p $ tests - -tests :: TestTree -tests = testGroup "hevm" - [ testGroup "ABI" - [ testProperty "Put/get inverse" $ \x -> - case runGetOrFail (getAbi (abiValueType x)) (runPut (putAbi x)) of - Right ("", _, x') -> x' == x - _ -> False - ] - , testGroup "Solidity expressions" - [ testCase "Trivial" $ - SolidityCall "x = 3;" [] - ===> AbiUInt 256 3 - - , testCase "Arithmetic" $ do - SolidityCall "x = a + 1;" - [AbiUInt 256 1] ===> AbiUInt 256 2 - SolidityCall "unchecked { x = a - 1; }" - [AbiUInt 8 0] ===> AbiUInt 8 255 - - , testCase "keccak256()" $ - SolidityCall "x = uint(keccak256(abi.encodePacked(a)));" - [AbiString ""] ===> AbiUInt 256 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470 - - , testProperty "abi encoding vs. solidity" $ withMaxSuccess 20 $ forAll (arbitrary >>= genAbiValue) $ - \y -> ioProperty $ do - -- traceM ("encoding: " ++ (show y) ++ " : " ++ show (abiValueType y)) - Just encoded <- runStatements [i| x = abi.encode(a);|] - [y] AbiBytesDynamicType - let AbiTuple (Vector.toList -> [solidityEncoded]) = decodeAbiValue (AbiTupleType $ Vector.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) - let hevmEncoded = encodeAbiValue (AbiTuple $ Vector.fromList [y]) - -- traceM ("encoded (solidity): " ++ show solidityEncoded) - -- traceM ("encoded (hevm): " ++ show (AbiBytesDynamic hevmEncoded)) - assertEqual "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) - - , testProperty "abi encoding vs. solidity (2 args)" $ withMaxSuccess 20 $ forAll (arbitrary >>= bothM genAbiValue) $ - \(x', y') -> ioProperty $ do - -- traceM ("encoding: " ++ (show x') ++ ", " ++ (show y') ++ " : " ++ show (abiValueType x') ++ ", " ++ show (abiValueType y')) - Just encoded <- runStatements [i| x = abi.encode(a, b);|] - [x', y'] AbiBytesDynamicType - let AbiTuple (Vector.toList -> [solidityEncoded]) = decodeAbiValue (AbiTupleType $ Vector.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) - let hevmEncoded = encodeAbiValue (AbiTuple $ Vector.fromList [x',y']) - -- traceM ("encoded (solidity): " ++ show solidityEncoded) - -- traceM ("encoded (hevm): " ++ show (AbiBytesDynamic hevmEncoded)) - assertEqual "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) - ] - - , testGroup "Precompiled contracts" - [ testGroup "Example (reverse)" - [ testCase "success" $ - assertEqual "example contract reverses" - (execute 0xdeadbeef "foobar" 6) (Just "raboof") - , testCase "failure" $ - assertEqual "example contract fails on length mismatch" - (execute 0xdeadbeef "foobar" 5) Nothing - ] - - , testGroup "ECRECOVER" - [ testCase "success" $ do - let - r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4732" - s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" - v = hex "000000000000000000000000000000000000000000000000000000000000001c" - h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31" - a = hex "0000000000000000000000002d5e56d45c63150d937f2182538a0f18510cb11f" - assertEqual "successful recovery" - (Just a) - (execute 1 (h <> v <> r <> s) 32) - , testCase "fail on made up values" $ do - let - r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4731" - s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" - v = hex "000000000000000000000000000000000000000000000000000000000000001c" - h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31" - assertEqual "fail because bit flip" - Nothing - (execute 1 (h <> v <> r <> s) 32) - ] - ] - , testGroup "Byte/word manipulations" - [ testProperty "padLeft length" $ \n (Bytes bs) -> - BS.length (padLeft n bs) == max n (BS.length bs) - , testProperty "padLeft identity" $ \(Bytes bs) -> - padLeft (BS.length bs) bs == bs - , testProperty "padRight length" $ \n (Bytes bs) -> - BS.length (padLeft n bs) == max n (BS.length bs) - , testProperty "padRight identity" $ \(Bytes bs) -> - padLeft (BS.length bs) bs == bs - , testProperty "padLeft zeroing" $ \(NonNegative n) (Bytes bs) -> - let x = BS.take n (padLeft (BS.length bs + n) bs) - y = BS.replicate n 0 - in x == y - ] - - , testGroup "Unresolved link detection" - [ testCase "holes detected" $ do - let code' = "608060405234801561001057600080fd5b5060405161040f38038061040f83398181016040528101906100329190610172565b73__$f3cbc3eb14e5bd0705af404abcf6f741ec$__63ab5c1ffe826040518263ffffffff1660e01b81526004016100699190610217565b60206040518083038186803b15801561008157600080fd5b505af4158015610095573d6000803e3d6000fd5b505050506040513d601f19601f820116820180604052508101906100b99190610145565b50506103c2565b60006100d36100ce84610271565b61024c565b9050828152602081018484840111156100ef576100ee610362565b5b6100fa8482856102ca565b509392505050565b600081519050610111816103ab565b92915050565b600082601f83011261012c5761012b61035d565b5b815161013c8482602086016100c0565b91505092915050565b60006020828403121561015b5761015a61036c565b5b600061016984828501610102565b91505092915050565b6000602082840312156101885761018761036c565b5b600082015167ffffffffffffffff8111156101a6576101a5610367565b5b6101b284828501610117565b91505092915050565b60006101c6826102a2565b6101d081856102ad565b93506101e08185602086016102ca565b6101e981610371565b840191505092915050565b60006102016003836102ad565b915061020c82610382565b602082019050919050565b6000604082019050818103600083015261023181846101bb565b90508181036020830152610244816101f4565b905092915050565b6000610256610267565b905061026282826102fd565b919050565b6000604051905090565b600067ffffffffffffffff82111561028c5761028b61032e565b5b61029582610371565b9050602081019050919050565b600081519050919050565b600082825260208201905092915050565b60008115159050919050565b60005b838110156102e85780820151818401526020810190506102cd565b838111156102f7576000848401525b50505050565b61030682610371565b810181811067ffffffffffffffff821117156103255761032461032e565b5b80604052505050565b7f4e487b7100000000000000000000000000000000000000000000000000000000600052604160045260246000fd5b600080fd5b600080fd5b600080fd5b600080fd5b6000601f19601f8301169050919050565b7f6261720000000000000000000000000000000000000000000000000000000000600082015250565b6103b4816102be565b81146103bf57600080fd5b50565b603f806103d06000396000f3fe6080604052600080fdfea26469706673582212207d03b26e43dc3d116b0021ddc9817bde3762a3b14315351f11fc4be384fd14a664736f6c63430008060033" - assertBool "linker hole not detected" (containsLinkerHole code'), - testCase "no false positives" $ do - let code' = "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fea265627a7a723158205d775f914dcb471365a430b5f5b2cfe819e615cbbb5b2f1ccc7da1fd802e43c364736f6c634300050b0032" - assertBool "false positive" (not . containsLinkerHole $ code') - ] - - , testGroup "metadata stripper" - [ testCase "it strips the metadata for solc => 0.6" $ do - let code' = hexText "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fea265627a7a723158205d775f914dcb471365a430b5f5b2cfe819e615cbbb5b2f1ccc7da1fd802e43c364736f6c634300050b0032" - stripped = stripBytecodeMetadata code' - assertEqual "failed to strip metadata" (show (ByteStringS stripped)) "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fe" - , - testCase "it strips the metadata and constructor args" $ do - let srccode = - [i| - contract A { - uint y; - constructor(uint x) public { - y = x; - } - } - |] - - (json, path') <- solidity' srccode - let Just (solc', _, _) = readJSON json - initCode :: ByteString - Just initCode = solc' ^? ix (path' <> ":A") . creationCode - -- add constructor arguments - assertEqual "constructor args screwed up metadata stripping" (stripBytecodeMetadata (initCode <> encodeAbiValue (AbiUInt 256 1))) (stripBytecodeMetadata initCode) - ] - - , testGroup "RLP encodings" - [ testProperty "rlp decode is a retraction (bytes)" $ \(Bytes bs) -> --- withMaxSuccess 100000 $ - rlpdecode (rlpencode (BS bs)) == Just (BS bs) - , testProperty "rlp encode is a partial inverse (bytes)" $ \(Bytes bs) -> --- withMaxSuccess 100000 $ - case rlpdecode bs of - Just r -> rlpencode r == bs - Nothing -> True - , testProperty "rlp decode is a retraction (RLP)" $ \(RLPData r) -> --- withMaxSuccess 100000 $ - rlpdecode (rlpencode r) == Just r - ] - , testGroup "Merkle Patricia Trie" - [ testProperty "update followed by delete is id" $ \(Bytes r, Bytes s, Bytes t) -> - whenFail - (putStrLn ("r:" <> (show (ByteStringS r))) >> - putStrLn ("s:" <> (show (ByteStringS s))) >> - putStrLn ("t:" <> (show (ByteStringS t)))) $ --- withMaxSuccess 100000 $ - Patricia.insertValues [(r, BS.pack[1]), (s, BS.pack[2]), (t, BS.pack[3]), - (r, mempty), (s, mempty), (t, mempty)] - === (Just $ Patricia.Literal Patricia.Empty) - ] - - , testGroup "Symbolic execution" - [ - -- Somewhat tautological since we are asserting the precondition - -- on the same form as the actual "requires" clause. - testCase "SafeAdd success case" $ do - Just safeAdd <- solcRuntime "SafeAdd" - [i| - contract SafeAdd { - function add(uint x, uint y) public pure returns (uint z) { - require((z = x + y) >= x); - } - } - |] - let pre preVM = let [x, y] = getStaticAbiArgs preVM - in x .<= x + y - .&& view (state . callvalue) preVM .== 0 - post = Just $ \(prestate, poststate) -> - let [x, y] = getStaticAbiArgs prestate - in case view result poststate of - Just (VMSuccess (SymbolicBuffer out)) -> (fromBytes out) .== x + y - _ -> sFalse - (Qed res, _) <- runSMT $ query $ verifyContract safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre post - putStrLn $ "successfully explored: " <> show (length res) <> " paths" - , - - testCase "x == y => x + y == 2 * y" $ do - Just safeAdd <- solcRuntime "SafeAdd" - [i| - contract SafeAdd { - function add(uint x, uint y) public pure returns (uint z) { - require((z = x + y) >= x); - } - } - |] - let pre preVM = let [x, y] = getStaticAbiArgs preVM - in (x .<= x + y) - .&& (x .== y) - .&& view (state . callvalue) preVM .== 0 - post (prestate, poststate) = - let [_, y] = getStaticAbiArgs prestate - in case view result poststate of - Just (VMSuccess (SymbolicBuffer out)) -> fromBytes out .== 2 * y - _ -> sFalse - (Qed res, _) <- runSMTWith z3 $ query $ - verifyContract safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre (Just post) - putStrLn $ "successfully explored: " <> show (length res) <> " paths" - , - testCase "summary storage writes" $ do - Just c <- solcRuntime "A" - [i| - contract A { - uint x; - function f(uint256 y) public { - unchecked { - x += y; - x += y; - } - } - } - |] - let pre vm = 0 .== view (state . callvalue) vm - post = Just $ \(prestate, poststate) -> - let [y] = getStaticAbiArgs prestate - this = view (state . codeContract) prestate - Just preC = view (env.contracts . at this) prestate - Just postC = view (env.contracts . at this) poststate - Symbolic _ prestore = _storage preC - Symbolic _ poststore = _storage postC - prex = readArray prestore 0 - postx = readArray poststore 0 - in case view result poststate of - Just (VMSuccess _) -> prex + 2 * y .== postx - _ -> sFalse - (Qed res, _) <- runSMT $ query $ verifyContract c (Just ("f(uint256)", [AbiUIntType 256])) [] SymbolicS pre post - putStrLn $ "successfully explored: " <> show (length res) <> " paths" - , - -- tests how whiffValue handles Neg via application of the triple IsZero simplification rule - -- regression test for: https://github.com/dapphub/dapptools/pull/698 - testCase "Neg" $ do - let src = - [i| - object "Neg" { - code { - // Deploy the contract - datacopy(0, dataoffset("runtime"), datasize("runtime")) - return(0, datasize("runtime")) - } - object "runtime" { - code { - let v := calldataload(4) - if iszero(iszero(and(v, not(0xffffffffffffffffffffffffffffffffffffffff)))) { - invalid() - } - } - } - } - |] - Just c <- yulRuntime "Neg" src - (Qed res, _) <- runSMTWith cvc4 $ query $ checkAssert defaultPanicCodes c (Just ("hello(address)", [AbiAddressType])) [] - putStrLn $ "successfully explored: " <> show (length res) <> " paths" - , - - -- Inspired by these `msg.sender == to` token bugs - -- which break linearity of totalSupply. - testCase "catch storage collisions" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y) public { - assembly { - let newx := sub(sload(x), 1) - let newy := add(sload(y), 1) - sstore(x,newx) - sstore(y,newy) - } - } - } - |] - let pre vm = 0 .== view (state . callvalue) vm - post (prestate, poststate) = - let [x,y] = getStaticAbiArgs prestate - this = view (state . codeContract) prestate - (Just preC, Just postC) = both' (view (env.contracts . at this)) (prestate, poststate) - --Just postC = view (env.contracts . at this) poststate - (Symbolic _ prestore, Symbolic _ poststore) = both' (view storage) (preC, postC) - (prex, prey) = both' (readArray prestore) (x, y) - (postx, posty) = both' (readArray poststore) (x, y) - in case view result poststate of - Just (VMSuccess _) -> prex + prey .== postx + (posty :: SWord 256) - _ -> sFalse - bs <- runSMT $ query $ do - (Cex _, vm) <- verifyContract c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre (Just post) - case view (state . calldata . _1) vm of - SymbolicBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs - ConcreteBuffer _ -> error "unexpected" - - let [AbiUInt 256 x, AbiUInt 256 y] = decodeAbiValues [AbiUIntType 256, AbiUIntType 256] bs - assertEqual "Catch storage collisions" x y - , - testCase "Deposit contract loop (z3)" $ do - Just c <- solcRuntime "Deposit" - [i| - contract Deposit { - function deposit(uint256 deposit_count) external pure { - require(deposit_count < 2**32 - 1); - ++deposit_count; - bool found = false; - for (uint height = 0; height < 32; height++) { - if ((deposit_count & 1) == 1) { - found = true; - break; - } - deposit_count = deposit_count >> 1; - } - assert(found); - } - } - |] - (Qed res, _) <- runSMTWith z3 $ query $ checkAssert defaultPanicCodes c (Just ("deposit(uint256)", [AbiUIntType 256])) [] - putStrLn $ "successfully explored: " <> show (length res) <> " paths" - , - testCase "Deposit contract loop (cvc4)" $ do - Just c <- solcRuntime "Deposit" - [i| - contract Deposit { - function deposit(uint256 deposit_count) external pure { - require(deposit_count < 2**32 - 1); - ++deposit_count; - bool found = false; - for (uint height = 0; height < 32; height++) { - if ((deposit_count & 1) == 1) { - found = true; - break; - } - deposit_count = deposit_count >> 1; - } - assert(found); - } - } - |] - (Qed res, _) <- runSMTWith cvc4 $ query $ checkAssert defaultPanicCodes c (Just ("deposit(uint256)", [AbiUIntType 256])) [] - putStrLn $ "successfully explored: " <> show (length res) <> " paths" - , - testCase "Deposit contract loop (error version)" $ do - Just c <- solcRuntime "Deposit" - [i| - contract Deposit { - function deposit(uint8 deposit_count) external pure { - require(deposit_count < 2**32 - 1); - ++deposit_count; - bool found = false; - for (uint height = 0; height < 32; height++) { - if ((deposit_count & 1) == 1) { - found = true; - break; - } - deposit_count = deposit_count >> 1; - } - assert(found); - } - } - |] - bs <- runSMT $ query $ do - (Cex _, vm) <- checkAssert allPanicCodes c (Just ("deposit(uint8)", [AbiUIntType 8])) [] - case view (state . calldata . _1) vm of - SymbolicBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs - ConcreteBuffer _ -> error "unexpected" - - let [deposit] = decodeAbiValues [AbiUIntType 8] bs - assertEqual "overflowing uint8" deposit (AbiUInt 8 255) - , - testCase "explore function dispatch" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x) public pure returns (uint) { - return x; - } - } - |] - (Qed res, _) <- runSMTWith z3 $ do - setTimeOut 5000 - query $ checkAssert defaultPanicCodes c Nothing [] - putStrLn $ "successfully explored: " <> show (length res) <> " paths" - , - - testCase "injectivity of keccak (32 bytes)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y) public pure { - if (keccak256(abi.encodePacked(x)) == keccak256(abi.encodePacked(y))) assert(x == y); - } - } - |] - (Qed res, _) <- runSMTWith cvc4 $ query $ checkAssert defaultPanicCodes c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] - putStrLn $ "successfully explored: " <> show (length res) <> " paths" - , - testCase "injectivity of keccak (32 bytes)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y) public pure { - if (keccak256(abi.encodePacked(x)) == keccak256(abi.encodePacked(y))) assert(x == y); - } - } - |] - (Qed res, _) <- runSMTWith z3 $ query $ checkAssert defaultPanicCodes c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] - putStrLn $ "successfully explored: " <> show (length res) <> " paths" - , - - testCase "injectivity of keccak (64 bytes)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f(uint x, uint y, uint w, uint z) public pure { - assert (keccak256(abi.encodePacked(x,y)) != keccak256(abi.encodePacked(w,z))); - } - } - |] - bs <- runSMTWith z3 $ query $ do - (Cex _, vm) <- checkAssert defaultPanicCodes c (Just ("f(uint256,uint256,uint256,uint256)", replicate 4 (AbiUIntType 256))) [] - case view (state . calldata . _1) vm of - SymbolicBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs - ConcreteBuffer _ -> error "unexpected" - - let [AbiUInt 256 x, - AbiUInt 256 y, - AbiUInt 256 w, - AbiUInt 256 z] = decodeAbiValues [AbiUIntType 256, - AbiUIntType 256, - AbiUIntType 256, - AbiUIntType 256] bs - assertEqual "x == w" x w - assertEqual "y == z" y z - , - - testCase "calldata beyond calldatasize is 0 (z3)" $ do - Just c <- solcRuntime "A" - [i| - contract A { - function f() public pure { - uint y; - assembly { - let x := calldatasize() - y := calldataload(x) - } - assert(y == 0); - } - } - |] - Qed res <- runSMTWith z3 $ do - setTimeOut 5000 - query $ fst <$> checkAssert defaultPanicCodes c Nothing [] - putStrLn $ "successfully explored: " <> show (length res) <> " paths" - - , - - testCase "keccak soundness" $ do - Just c <- solcRuntime "C" - [i| - contract C { - mapping (uint => mapping (uint => uint)) maps; - - function f(uint x, uint y) public view { - assert(maps[y][0] == maps[x][0]); - } - } - |] - -- should find a counterexample - Cex _ <- runSMTWith cvc4 $ query $ fst <$> checkAssert defaultPanicCodes c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] - putStrLn "found counterexample:" - - - , - testCase "multiple contracts" $ do - let code' = - [i| - contract C { - uint x; - A constant a = A(0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B); - - function call_A() public view { - // should fail since a.x() can be anything - assert(a.x() == x); - } - } - contract A { - uint public x; - } - |] - aAddr = Addr 0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B - Just c <- solcRuntime "C" code' - Just a <- solcRuntime "A" code' - Cex _ <- runSMT $ query $ do - vm0 <- abstractVM (Just ("call_A()", [])) [] c SymbolicS - store <- freshArray (show aAddr) Nothing - let vm = vm0 - & set (state . callvalue) 0 - & over (env . contracts) - (Map.insert aAddr (initialContract (RuntimeCode $ ConcreteBuffer a) & - set EVM.storage (EVM.Symbolic [] store))) - verify vm Nothing Nothing Nothing (Just $ checkAssertions defaultPanicCodes) - putStrLn "found counterexample:" - , - testCase "calling unique contracts (read from storage)" $ do - let code' = - [i| - contract C { - uint x; - A a; - - function call_A() public { - a = new A(); - // should fail since x can be anything - assert(a.x() == x); - } - } - contract A { - uint public x; - } - |] - Just c <- solcRuntime "C" code' - Cex _ <- runSMT $ query $ do - vm0 <- abstractVM (Just ("call_A()", [])) [] c SymbolicS - let vm = vm0 & set (state . callvalue) 0 - verify vm Nothing Nothing Nothing (Just $ checkAssertions defaultPanicCodes) - putStrLn "found counterexample:" - , - - testCase "keccak concrete and sym agree" $ do - let code' = - [i| - contract C { - function kecc(uint x) public pure { - if (x == 0) { - assert(keccak256(abi.encode(x)) == keccak256(abi.encode(0))); - } - } - } - |] - Just c <- solcRuntime "C" code' - Qed _ <- runSMT $ query $ do - vm0 <- abstractVM (Just ("kecc(uint256)", [AbiUIntType 256])) [] c SymbolicS - let vm = vm0 & set (state . callvalue) 0 - verify vm Nothing Nothing Nothing (Just $ checkAssertions defaultPanicCodes) - putStrLn "found counterexample:" - - , testCase "safemath distributivity (yul)" $ do - Qed _ <- runSMTWith cvc4 $ query $ do - let yulsafeDistributivity = hex "6355a79a6260003560e01c14156016576015601f565b5b60006000fd60a1565b603d602d604435600435607c565b6039602435600435607c565b605d565b6052604b604435602435605d565b600435607c565b141515605a57fe5b5b565b6000828201821115151560705760006000fd5b82820190505b92915050565b6000818384048302146000841417151560955760006000fd5b82820290505b92915050565b" - vm <- abstractVM (Just ("distributivity(uint256,uint256,uint256)", [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] yulsafeDistributivity SymbolicS - verify vm Nothing Nothing Nothing (Just $ checkAssertions defaultPanicCodes) - putStrLn "Proven" - - , testCase "safemath distributivity (sol)" $ do - let code' = - [i| - contract C { - function distributivity(uint x, uint y, uint z) public { - assert(mul(x, add(y, z)) == add(mul(x, y), mul(x, z))); - } - - function add(uint x, uint y) internal pure returns (uint z) { - unchecked { - require((z = x + y) >= x, "ds-math-add-overflow"); - } - } - function mul(uint x, uint y) internal pure returns (uint z) { - unchecked { - require(y == 0 || (z = x * y) / y == x, "ds-math-mul-overflow"); - } - } - } - |] - Just c <- solcRuntime "C" code' - - Qed _ <- runSMTWith cvc4 $ query $ do - vm <- abstractVM (Just ("distributivity(uint256,uint256,uint256)", [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] c SymbolicS - verify vm Nothing Nothing Nothing (Just $ checkAssertions defaultPanicCodes) - putStrLn "Proven" - - ] - , testGroup "Equivalence checking" - [ - testCase "yul optimized" $ do - -- These yul programs are not equivalent: (try --calldata $(seth --to-uint256 2) for example) - Just aPrgm <- yul "" - [i| - { - calldatacopy(0, 0, 32) - switch mload(0) - case 0 { } - case 1 { } - default { invalid() } - } - |] - Just bPrgm <- yul "" - [i| - { - calldatacopy(0, 0, 32) - switch mload(0) - case 0 { } - case 2 { } - default { invalid() } - } - |] - runSMTWith z3 $ query $ do - Cex _ <- equivalenceCheck aPrgm bPrgm Nothing Nothing Nothing - return () - ] - ] - where - (===>) = assertSolidityComputation - - -runSimpleVM :: ByteString -> ByteString -> Maybe ByteString -runSimpleVM x ins = case loadVM x of - Nothing -> Nothing - Just vm -> let calldata' = (ConcreteBuffer ins, w256lit $ num $ BS.length ins) - in case runState (assign (state.calldata) calldata' >> exec) vm of - (VMSuccess (ConcreteBuffer bs), _) -> Just bs - _ -> Nothing - -loadVM :: ByteString -> Maybe VM -loadVM x = - case runState exec (vmForEthrunCreation x) of - (VMSuccess (ConcreteBuffer targetCode), vm1) -> do - let target = view (state . contract) vm1 - vm2 = execState (replaceCodeOfSelf (RuntimeCode (ConcreteBuffer targetCode))) vm1 - return $ snd $ flip runState vm2 - (do resetState - assign (state . gas) 0xffffffffffffffff -- kludge - loadContract target) - _ -> Nothing - -hex :: ByteString -> ByteString -hex s = - case Hex.decode s of - Right x -> x - Left e -> error e - -singleContract :: Text -> Text -> IO (Maybe ByteString) -singleContract x s = - solidity x [i| - pragma experimental ABIEncoderV2; - contract ${x} { ${s} } - |] - -defaultDataLocation :: AbiType -> Text -defaultDataLocation t = - if (case t of - AbiBytesDynamicType -> True - AbiStringType -> True - AbiArrayDynamicType _ -> True - AbiArrayType _ _ -> True - _ -> False) - then "memory" - else "" - -runFunction :: Text -> ByteString -> IO (Maybe ByteString) -runFunction c input = do - Just x <- singleContract "X" c - return $ runSimpleVM x input - -runStatements - :: Text -> [AbiValue] -> AbiType - -> IO (Maybe ByteString) -runStatements stmts args t = do - let params = - Text.intercalate ", " - (map (\(x, c) -> abiTypeSolidity (abiValueType x) - <> " " <> defaultDataLocation (abiValueType x) - <> " " <> Text.pack [c]) - (zip args "abcdefg")) - s = - "foo(" <> Text.intercalate "," - (map (abiTypeSolidity . abiValueType) args) <> ")" - - runFunction [i| - function foo(${params}) public pure returns (${abiTypeSolidity t} ${defaultDataLocation t} x) { - ${stmts} - } - |] (abiMethod s (AbiTuple $ Vector.fromList args)) - -getStaticAbiArgs :: VM -> [SWord 256] -getStaticAbiArgs vm = - let cd = view (state . calldata . _1) vm - bs = case cd of - ConcreteBuffer bs' -> ConcreteBuffer $ BS.drop 4 bs' - SymbolicBuffer bs' -> SymbolicBuffer $ drop 4 bs' - args = decodeStaticArgs bs - in fmap (\(S _ v) -> v) args - --- includes shaving off 4 byte function sig -decodeAbiValues :: [AbiType] -> ByteString -> [AbiValue] -decodeAbiValues types bs = - let AbiTuple xy = decodeAbiValue (AbiTupleType $ Vector.fromList types) (BS.fromStrict (BS.drop 4 bs)) - in Vector.toList xy - -newtype Bytes = Bytes ByteString - deriving Eq - -instance Show Bytes where - showsPrec _ (Bytes x) _ = show (BS.unpack x) - -instance Arbitrary Bytes where - arbitrary = fmap (Bytes . BS.pack) arbitrary - -newtype RLPData = RLPData RLP - deriving (Eq, Show) - --- bias towards bytestring to try to avoid infinite recursion -instance Arbitrary RLPData where - arbitrary = frequency - [(5, do - Bytes bytes <- arbitrary - return $ RLPData $ BS bytes) - , (1, do - k <- choose (0,10) - ls <- vectorOf k arbitrary - return $ RLPData $ List [r | RLPData r <- ls]) - ] - -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) +{-# Language GADTs #-} +{-# Language NumericUnderscores #-} +{-# Language QuasiQuotes #-} +{-# Language DataKinds #-} + +module Main where + +import Data.Text (Text) +import Data.ByteString (ByteString) +import Data.Bits +import System.Directory +import GHC.Natural +import Control.Monad +import Text.RE.TDFA.String +import Text.RE.Replace +import Data.Time +import System.Environment + +import Prelude hiding (fail, LT, GT) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS (fromStrict) +import qualified Data.ByteString.Base16 as Hex +import Data.Maybe +import Data.Typeable +import Data.List (elemIndex) +import Data.DoubleWord +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.QuickCheck.Instances.Text() +import Test.QuickCheck.Instances.Natural() +import Test.QuickCheck.Instances.ByteString() +import Test.Tasty.HUnit +import Test.Tasty.Runners +import Test.Tasty.ExpectedFailure + +import Control.Monad.State.Strict (execState, runState) +import Control.Lens hiding (List, pre, (.>), re) + +import qualified Data.Vector as Vector +import Data.String.Here +import qualified Data.Map.Strict as Map + +import Data.Binary.Put (runPut) +import Data.Binary.Get (runGetOrFail) + +import EVM hiding (Query, allowFFI) +import EVM.SymExec +import EVM.ABI +import EVM.Exec +import qualified EVM.Patricia as Patricia +import EVM.Precompiled +import EVM.RLP +import EVM.Solidity +import EVM.Types +import EVM.Traversals +import EVM.SMT hiding (one) +import qualified EVM.Expr as Expr +import qualified Data.Text as T +import Data.List (isSubsequenceOf) +import EVM.TestUtils + +main :: IO () +main = defaultMain tests + +-- | run a subset of tests in the repl. p is a tasty pattern: +-- https://github.com/UnkindPartition/tasty/tree/ee6fe7136fbcc6312da51d7f1b396e1a2d16b98a#patterns +runSubSet :: String -> IO () +runSubSet p = defaultMain . applyPattern p $ tests + +tests :: TestTree +tests = testGroup "hevm" + [ testGroup "StorageTests" + [ testCase "read-from-sstore" $ assertEqual "" + (Lit 0xab) + (Expr.readStorage' (Lit 0x0) (Lit 0x0) (SStore (Lit 0x0) (Lit 0x0) (Lit 0xab) AbstractStore)) + , testCase "read-from-concrete" $ assertEqual "" + (Lit 0xab) + (Expr.readStorage' (Lit 0x0) (Lit 0x0) (ConcreteStore $ Map.fromList [(0x0, Map.fromList [(0x0, 0xab)])])) + , testCase "read-past-abstract-writes-to-different-address" $ assertEqual "" + (Lit 0xab) + (Expr.readStorage' (Lit 0x0) (Lit 0x0) (SStore (Lit 0x1) (Var "a") (Var "b") (ConcreteStore $ Map.fromList [(0x0, Map.fromList [(0x0, 0xab)])]))) + , testCase "abstract-slots-block-reads-for-same-address" $ assertEqual "" + (SLoad (Lit 0x0) (Lit 0x0) (SStore (Lit 0x0) (Var "b") (Var "c") (ConcreteStore $ Map.fromList [(0x0, Map.fromList [(0x0, 0xab)])]))) + (Expr.readStorage' (Lit 0x0) (Lit 0x0) + (SStore (Lit 0x1) (Var "1312") (Var "acab") (SStore (Lit 0x0) (Var "b") (Var "c") (ConcreteStore $ Map.fromList [(0x0, Map.fromList [(0x0, 0xab)])])))) + , testCase "abstract-addrs-block-reads" $ assertEqual "" + (SLoad (Lit 0x0) (Lit 0x0) (SStore (Var "1312") (Lit 0x0) (Lit 0x0) (ConcreteStore $ Map.fromList [(0x0, Map.fromList [(0x0, 0xab)])]))) + (Expr.readStorage' (Lit 0x0) (Lit 0x0) + (SStore (Lit 0xacab) (Lit 0xdead) (Lit 0x0) (SStore (Var "1312") (Lit 0x0) (Lit 0x0) (ConcreteStore $ Map.fromList [(0x0, Map.fromList [(0x0, 0xab)])])))) + ] + -- These tests fuzz the simplifier by generating a random expression, + -- applying some simplification rules, and then using the smt encoding to + -- check that the simplified version is semantically equivalent to the + -- unsimplified one + , testGroup "SimplifierTests" + [ testProperty "buffer-simplification" $ \(expr :: Expr Buf) -> ioProperty $ do + let simplified = Expr.simplify expr + checkEquiv expr simplified + , testProperty "store-simplification" $ \(expr :: Expr Storage) -> ioProperty $ do + let simplified = Expr.simplify expr + checkEquiv expr simplified + , testProperty "byte-simplification" $ \(expr :: Expr Byte) -> ioProperty $ do + let simplified = Expr.simplify expr + checkEquiv expr simplified + , testProperty "word-simplification" $ \(_ :: Int) -> ioProperty $ do + expr <- generate . sized $ genWord 0 -- we want a lower frequency of lits for this test + let simplified = Expr.simplify expr + checkEquiv expr simplified + , testProperty "readStorage-equivalance" $ \(store, addr, slot) -> ioProperty $ do + let simplified = Expr.readStorage' addr slot store + full = SLoad addr slot store + checkEquiv simplified full + , testProperty "writeStorage-equivalance" $ \(addr, slot, val) -> ioProperty $ do + let mkStore = oneof + [ pure EmptyStore + , fmap ConcreteStore arbitrary + , do + -- generate some write chains where we know that at least one + -- write matches either the input addr, or both the input + -- addr and slot + let matchAddr = liftM2 (SStore addr) arbitrary arbitrary + matchBoth = fmap (SStore addr slot) arbitrary + addWrites :: Expr Storage -> Int -> Gen (Expr Storage) + addWrites b 0 = pure b + addWrites b n = liftM4 SStore arbitrary arbitrary arbitrary (addWrites b (n - 1)) + s <- arbitrary + addMatch <- oneof [ matchAddr, matchBoth ] + let withMatch = addMatch s + newWrites <- oneof [ pure 0, pure 1, fmap (`mod` 5) arbitrary ] + addWrites withMatch newWrites + , arbitrary + ] + store <- generate mkStore + let simplified = Expr.writeStorage addr slot val store + full = SStore addr slot val store + checkEquiv simplified full + , testProperty "readWord-equivalance" $ \(buf, idx) -> ioProperty $ do + let simplified = Expr.readWord idx buf + full = ReadWord idx buf + checkEquiv simplified full + , testProperty "writeWord-equivalance" $ \(idx, val) -> ioProperty $ do + let mkBuf = oneof + [ pure $ ConcreteBuf "" -- empty + , fmap ConcreteBuf arbitrary -- concrete + , sized (genBuf 100) -- overlapping writes + , arbitrary -- sparse writes + ] + buf <- generate mkBuf + let simplified = Expr.writeWord idx val buf + full = WriteWord idx val buf + checkEquiv simplified full + , testProperty "readByte-equivalance" $ \(buf, idx) -> ioProperty $ do + let simplified = Expr.readByte idx buf + full = ReadByte idx buf + checkEquiv simplified full + -- we currently only simplify concrete writes over concrete buffers so that's what we test here + , testProperty "writeByte-equivalance" $ \(LitOnly val, LitOnly buf) -> ioProperty $ do + idx <- generate $ frequency + [ (10, genLit (fromIntegral (1_000_000 :: Int))) -- can never overflow an Int + , (1, fmap Lit arbitrary) -- can overflow an Int + ] + let simplified = Expr.writeByte idx val buf + full = WriteByte idx val buf + checkEquiv simplified full + , testProperty "copySlice-equivalance" $ \(srcOff) -> ioProperty $ do + -- we bias buffers to be concrete more often than not + let mkBuf = oneof + [ pure $ ConcreteBuf "" + , fmap ConcreteBuf arbitrary + , arbitrary + ] + src <- generate mkBuf + dst <- generate mkBuf + size <- generate (genLit 300) + dstOff <- generate (maybeBoundedLit 100_000) + let simplified = Expr.copySlice srcOff dstOff size src dst + full = CopySlice srcOff dstOff size src dst + checkEquiv simplified full + , testProperty "indexWord-equivalence" $ \(src) -> ioProperty $ do + idx <- generate (genLit 50) + let simplified = Expr.indexWord idx src + full = IndexWord idx src + checkEquiv simplified full + , testProperty "indexWord-mask-equivalence" $ \(src :: Expr EWord) -> ioProperty $ do + idx <- generate (genLit 35) + mask <- generate $ do + pow <- arbitrary :: Gen Int + frequency + [ (1, pure $ Lit $ (shiftL 1 (pow `mod` 256)) - 1) -- potentially non byte aligned + , (1, pure $ Lit $ (shiftL 1 ((pow * 8) `mod` 256)) - 1) -- byte aligned + ] + let + input = And mask src + simplified = Expr.indexWord idx input + full = IndexWord idx input + checkEquiv simplified full + , testProperty "toList-equivalance" $ \buf -> ioProperty $ do + let + -- transforms the input buffer to give it a known length + fixLength :: Expr Buf -> Gen (Expr Buf) + fixLength = mapExprM go + where + go :: Expr a -> Gen (Expr a) + go = \case + WriteWord _ val b -> liftM3 WriteWord idx (pure val) (pure b) + WriteByte _ val b -> liftM3 WriteByte idx (pure val) (pure b) + CopySlice so _ sz src dst -> liftM5 CopySlice (pure so) idx (pure sz) (pure src) (pure dst) + AbstractBuf _ -> cbuf + e -> pure e + cbuf = do + bs <- arbitrary + pure $ ConcreteBuf bs + idx = do + w <- arbitrary + -- we use 100_000 as an upper bound for indices to keep tests reasonably fast here + pure $ Lit (w `mod` 100_000) + + input <- generate $ fixLength buf + case Expr.toList input of + Nothing -> do + putStrLn "skip" + pure True -- ignore cases where the buf cannot be represented as a list + Just asList -> do + let asBuf = Expr.fromList asList + checkEquiv asBuf input + ] + , testGroup "MemoryTests" + [ testCase "read-write-same-byte" $ assertEqual "" + (LitByte 0x12) + (Expr.readByte (Lit 0x20) (WriteByte (Lit 0x20) (LitByte 0x12) mempty)) + , testCase "read-write-same-word" $ assertEqual "" + (Lit 0x12) + (Expr.readWord (Lit 0x20) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) + , testCase "read-byte-write-word" $ assertEqual "" + -- reading at byte 31 a word that's been written should return LSB + (LitByte 0x12) + (Expr.readByte (Lit 0x1f) (WriteWord (Lit 0x0) (Lit 0x12) mempty)) + , testCase "read-byte-write-word2" $ assertEqual "" + -- Same as above, but offset not 0 + (LitByte 0x12) + (Expr.readByte (Lit 0x20) (WriteWord (Lit 0x1) (Lit 0x12) mempty)) + ,testCase "read-write-with-offset" $ assertEqual "" + -- 0x3F = 63 decimal, 0x20 = 32. 0x12 = 18 + -- We write 128bits (32 Bytes), representing 18 at offset 32. + -- Hence, when reading out the 63rd byte, we should read out the LSB 8 bits + -- which is 0x12 + (LitByte 0x12) + (Expr.readByte (Lit 0x3F) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) + ,testCase "read-write-with-offset2" $ assertEqual "" + -- 0x20 = 32, 0x3D = 61 + -- we write 128 bits (32 Bytes) representing 0x10012, at offset 32. + -- we then read out a byte at offset 61. + -- So, at 63 we'd read 0x12, at 62 we'd read 0x00, at 61 we should read 0x1 + (LitByte 0x1) + (Expr.readByte (Lit 0x3D) (WriteWord (Lit 0x20) (Lit 0x10012) mempty)) + , testCase "read-write-with-extension-to-zero" $ assertEqual "" + -- write word and read it at the same place (i.e. 0 offset) + (Lit 0x12) + (Expr.readWord (Lit 0x0) (WriteWord (Lit 0x0) (Lit 0x12) mempty)) + , testCase "read-write-with-extension-to-zero-with-offset" $ assertEqual "" + -- write word and read it at the same offset of 4 + (Lit 0x12) + (Expr.readWord (Lit 0x4) (WriteWord (Lit 0x4) (Lit 0x12) mempty)) + , testCase "read-write-with-extension-to-zero-with-offset2" $ assertEqual "" + -- write word and read it at the same offset of 16 + (Lit 0x12) + (Expr.readWord (Lit 0x20) (WriteWord (Lit 0x20) (Lit 0x12) mempty)) + , testCase "read-word-copySlice-overlap" $ assertEqual "" + -- we should not recurse into a copySlice if the read index + 32 overlaps the sliced region + (ReadWord (Lit 40) (CopySlice (Lit 0) (Lit 30) (Lit 12) (WriteWord (Lit 10) (Lit 0x64) (AbstractBuf "hi")) (AbstractBuf "hi"))) + (Expr.readWord (Lit 40) (CopySlice (Lit 0) (Lit 30) (Lit 12) (WriteWord (Lit 10) (Lit 0x64) (AbstractBuf "hi")) (AbstractBuf "hi"))) + , testCase "indexword-MSB" $ assertEqual "" + -- 31st is the LSB byte (of 32) + (LitByte 0x78) + (Expr.indexWord (Lit 31) (Lit 0x12345678)) + , testCase "indexword-LSB" $ assertEqual "" + -- 0th is the MSB byte (of 32), Lit 0xff22bb... is exactly 32 Bytes. + (LitByte 0xff) + (Expr.indexWord (Lit 0) (Lit 0xff22bb4455667788990011223344556677889900112233445566778899001122)) + , testCase "indexword-LSB2" $ assertEqual "" + -- same as above, but with offset 2 + (LitByte 0xbb) + (Expr.indexWord (Lit 2) (Lit 0xff22bb4455667788990011223344556677889900112233445566778899001122)) + , testCase "encodeConcreteStore-overwrite" $ + let + w :: Int -> W256 + w x = W256 $ EVM.Types.word256 $ BS.pack [fromIntegral x] + in + assertEqual "" + (EVM.SMT.encodeConcreteStore $ + Map.fromList [(w 1, (Map.fromList [(w 2, w 99), (w 2, w 100)]))]) + "(sstore (_ bv1 256) (_ bv2 256) (_ bv100 256) emptyStore)" + , testCase "indexword-oob-sym" $ assertEqual "" + -- indexWord should return 0 for oob access + (LitByte 0x0) + (Expr.indexWord (Lit 100) (JoinBytes + (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) + (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) + (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) + (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0))) + , testCase "stripbytes-concrete-bug" $ assertEqual "" + (Expr.simplifyReads (ReadByte (Lit 0) (ConcreteBuf "5"))) + (LitByte 53) + ] + , testGroup "ABI" + [ testProperty "Put/get inverse" $ \x -> + case runGetOrFail (getAbi (abiValueType x)) (runPut (putAbi x)) of + Right ("", _, x') -> x' == x + _ -> False + ] + , testGroup "Solidity expressions" + [ testCase "Trivial" $ + SolidityCall "x = 3;" [] + ===> AbiUInt 256 3 + + , testCase "Arithmetic" $ do + SolidityCall "x = a + 1;" + [AbiUInt 256 1] ===> AbiUInt 256 2 + SolidityCall "unchecked { x = a - 1; }" + [AbiUInt 8 0] ===> AbiUInt 8 255 + + , testCase "keccak256()" $ + SolidityCall "x = uint(keccak256(abi.encodePacked(a)));" + [AbiString ""] ===> AbiUInt 256 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470 + + , testProperty "abi encoding vs. solidity" $ withMaxSuccess 20 $ forAll (arbitrary >>= genAbiValue) $ + \y -> ioProperty $ do + -- traceM ("encoding: " ++ (show y) ++ " : " ++ show (abiValueType y)) + Just encoded <- runStatements [i| x = abi.encode(a);|] + [y] AbiBytesDynamicType + let AbiTuple (Vector.toList -> [solidityEncoded]) = decodeAbiValue (AbiTupleType $ Vector.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) + let hevmEncoded = encodeAbiValue (AbiTuple $ Vector.fromList [y]) + -- traceM ("encoded (solidity): " ++ show solidityEncoded) + -- traceM ("encoded (hevm): " ++ show (AbiBytesDynamic hevmEncoded)) + assertEqual "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) + + , testProperty "abi encoding vs. solidity (2 args)" $ withMaxSuccess 20 $ forAll (arbitrary >>= bothM genAbiValue) $ + \(x', y') -> ioProperty $ do + -- traceM ("encoding: " ++ (show x') ++ ", " ++ (show y') ++ " : " ++ show (abiValueType x') ++ ", " ++ show (abiValueType y')) + Just encoded <- runStatements [i| x = abi.encode(a, b);|] + [x', y'] AbiBytesDynamicType + let AbiTuple (Vector.toList -> [solidityEncoded]) = decodeAbiValue (AbiTupleType $ Vector.fromList [AbiBytesDynamicType]) (BS.fromStrict encoded) + let hevmEncoded = encodeAbiValue (AbiTuple $ Vector.fromList [x',y']) + -- traceM ("encoded (solidity): " ++ show solidityEncoded) + -- traceM ("encoded (hevm): " ++ show (AbiBytesDynamic hevmEncoded)) + assertEqual "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) + ] + + , testGroup "Precompiled contracts" + [ testGroup "Example (reverse)" + [ testCase "success" $ + assertEqual "example contract reverses" + (execute 0xdeadbeef "foobar" 6) (Just "raboof") + , testCase "failure" $ + assertEqual "example contract fails on length mismatch" + (execute 0xdeadbeef "foobar" 5) Nothing + ] + + , testGroup "ECRECOVER" + [ testCase "success" $ do + let + r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4732" + s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" + v = hex "000000000000000000000000000000000000000000000000000000000000001c" + h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31" + a = hex "0000000000000000000000002d5e56d45c63150d937f2182538a0f18510cb11f" + assertEqual "successful recovery" + (Just a) + (execute 1 (h <> v <> r <> s) 32) + , testCase "fail on made up values" $ do + let + r = hex "c84e55cee2032ea541a32bf6749e10c8b9344c92061724c4e751600f886f4731" + s = hex "1542b6457e91098682138856165381453b3d0acae2470286fd8c8a09914b1b5d" + v = hex "000000000000000000000000000000000000000000000000000000000000001c" + h = hex "513954cf30af6638cb8f626bd3f8c39183c26784ce826084d9d267868a18fb31" + assertEqual "fail because bit flip" + Nothing + (execute 1 (h <> v <> r <> s) 32) + ] + ] + , testGroup "Byte/word manipulations" + [ testProperty "padLeft length" $ \n (Bytes bs) -> + BS.length (padLeft n bs) == max n (BS.length bs) + , testProperty "padLeft identity" $ \(Bytes bs) -> + padLeft (BS.length bs) bs == bs + , testProperty "padRight length" $ \n (Bytes bs) -> + BS.length (padLeft n bs) == max n (BS.length bs) + , testProperty "padRight identity" $ \(Bytes bs) -> + padLeft (BS.length bs) bs == bs + , testProperty "padLeft zeroing" $ \(NonNegative n) (Bytes bs) -> + let x = BS.take n (padLeft (BS.length bs + n) bs) + y = BS.replicate n 0 + in x == y + ] + + , testGroup "Unresolved link detection" + [ testCase "holes detected" $ do + let code' = "608060405234801561001057600080fd5b5060405161040f38038061040f83398181016040528101906100329190610172565b73__$f3cbc3eb14e5bd0705af404abcf6f741ec$__63ab5c1ffe826040518263ffffffff1660e01b81526004016100699190610217565b60206040518083038186803b15801561008157600080fd5b505af4158015610095573d6000803e3d6000fd5b505050506040513d601f19601f820116820180604052508101906100b99190610145565b50506103c2565b60006100d36100ce84610271565b61024c565b9050828152602081018484840111156100ef576100ee610362565b5b6100fa8482856102ca565b509392505050565b600081519050610111816103ab565b92915050565b600082601f83011261012c5761012b61035d565b5b815161013c8482602086016100c0565b91505092915050565b60006020828403121561015b5761015a61036c565b5b600061016984828501610102565b91505092915050565b6000602082840312156101885761018761036c565b5b600082015167ffffffffffffffff8111156101a6576101a5610367565b5b6101b284828501610117565b91505092915050565b60006101c6826102a2565b6101d081856102ad565b93506101e08185602086016102ca565b6101e981610371565b840191505092915050565b60006102016003836102ad565b915061020c82610382565b602082019050919050565b6000604082019050818103600083015261023181846101bb565b90508181036020830152610244816101f4565b905092915050565b6000610256610267565b905061026282826102fd565b919050565b6000604051905090565b600067ffffffffffffffff82111561028c5761028b61032e565b5b61029582610371565b9050602081019050919050565b600081519050919050565b600082825260208201905092915050565b60008115159050919050565b60005b838110156102e85780820151818401526020810190506102cd565b838111156102f7576000848401525b50505050565b61030682610371565b810181811067ffffffffffffffff821117156103255761032461032e565b5b80604052505050565b7f4e487b7100000000000000000000000000000000000000000000000000000000600052604160045260246000fd5b600080fd5b600080fd5b600080fd5b600080fd5b6000601f19601f8301169050919050565b7f6261720000000000000000000000000000000000000000000000000000000000600082015250565b6103b4816102be565b81146103bf57600080fd5b50565b603f806103d06000396000f3fe6080604052600080fdfea26469706673582212207d03b26e43dc3d116b0021ddc9817bde3762a3b14315351f11fc4be384fd14a664736f6c63430008060033" + assertBool "linker hole not detected" (containsLinkerHole code'), + testCase "no false positives" $ do + let code' = "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fea265627a7a723158205d775f914dcb471365a430b5f5b2cfe819e615cbbb5b2f1ccc7da1fd802e43c364736f6c634300050b0032" + assertBool "false positive" (not . containsLinkerHole $ code') + ] + + , testGroup "metadata stripper" + [ testCase "it strips the metadata for solc => 0.6" $ do + let code' = hexText "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fea265627a7a723158205d775f914dcb471365a430b5f5b2cfe819e615cbbb5b2f1ccc7da1fd802e43c364736f6c634300050b0032" + stripped = stripBytecodeMetadata code' + assertEqual "failed to strip metadata" (show (ByteStringS stripped)) "0x608060405234801561001057600080fd5b50600436106100365760003560e01c806317bf8bac1461003b578063acffee6b1461005d575b600080fd5b610043610067565b604051808215151515815260200191505060405180910390f35b610065610073565b005b60008060015414905090565b6000809054906101000a900473ffffffffffffffffffffffffffffffffffffffff1673ffffffffffffffffffffffffffffffffffffffff1663f8a8fd6d6040518163ffffffff1660e01b815260040160206040518083038186803b1580156100da57600080fd5b505afa1580156100ee573d6000803e3d6000fd5b505050506040513d602081101561010457600080fd5b810190808051906020019092919050505060018190555056fe" + , + testCase "it strips the metadata and constructor args" $ do + let srccode = + [i| + contract A { + uint y; + constructor(uint x) public { + y = x; + } + } + |] + + (json, path') <- solidity' srccode + let Just (solc', _, _) = readJSON json + initCode :: ByteString + Just initCode = solc' ^? ix (path' <> ":A") . creationCode + -- add constructor arguments + assertEqual "constructor args screwed up metadata stripping" (stripBytecodeMetadata (initCode <> encodeAbiValue (AbiUInt 256 1))) (stripBytecodeMetadata initCode) + ] + + , testGroup "RLP encodings" + [ testProperty "rlp decode is a retraction (bytes)" $ \(Bytes bs) -> +-- withMaxSuccess 100000 $ + rlpdecode (rlpencode (BS bs)) == Just (BS bs) + , testProperty "rlp encode is a partial inverse (bytes)" $ \(Bytes bs) -> +-- withMaxSuccess 100000 $ + case rlpdecode bs of + Just r -> rlpencode r == bs + Nothing -> True + , testProperty "rlp decode is a retraction (RLP)" $ \(RLPData r) -> +-- withMaxSuccess 100000 $ + rlpdecode (rlpencode r) == Just r + ] + , testGroup "Merkle Patricia Trie" + [ testProperty "update followed by delete is id" $ \(Bytes r, Bytes s, Bytes t) -> + whenFail + (putStrLn ("r:" <> (show (ByteStringS r))) >> + putStrLn ("s:" <> (show (ByteStringS s))) >> + putStrLn ("t:" <> (show (ByteStringS t)))) $ +-- withMaxSuccess 100000 $ + Patricia.insertValues [(r, BS.pack[1]), (s, BS.pack[2]), (t, BS.pack[3]), + (r, mempty), (s, mempty), (t, mempty)] + === (Just $ Patricia.Literal Patricia.Empty) + ] + , testGroup "Remote State Tests" + [ + ] + , testGroup "Panic code tests via symbolic execution" + [ + testCase "assert-fail" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a) external pure { + assert(a != 0); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x01] c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + assertEqual "Must be 0" 0 $ getVar ctr "arg1" + putStrLn $ "expected counterexample found, and it's correct: " <> (show $ getVar ctr "arg1") + , + testCase "safeAdd-fail" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure returns (uint256 c) { + c = a+b; + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x11] c (Just ("fun(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + let x = getVar ctr "arg1" + let y = getVar ctr "arg2" + + let maxUint = 2 ^ (256 :: Integer) :: Integer + assertBool "Overflow must occur" (toInteger x + toInteger y >= maxUint) + putStrLn "expected counterexample found" + , + testCase "div-by-zero-fail" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure returns (uint256 c) { + c = a/b; + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x12] c (Just ("fun(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + assertEqual "Division by 0 needs b=0" (getVar ctr "arg2") 0 + putStrLn "expected counterexample found" + , + testCase "enum-conversion-fail" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + enum MyEnum { ONE, TWO } + function fun(uint256 a) external pure returns (MyEnum b) { + b = MyEnum(a); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x21] c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + assertBool "Enum is only defined for 0 and 1" $ (getVar ctr "arg1") > 1 + putStrLn "expected counterexample found" + , + -- TODO 0x22 is missing: "0x22: If you access a storage byte array that is incorrectly encoded." + -- TODO below should NOT fail + -- TODO this has a loop that depends on a symbolic value and currently causes interpret to loop + ignoreTest $ testCase "pop-empty-array" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] private arr; + function fun(uint8 a) external { + arr.push(1); + arr.push(2); + for (uint i = 0; i < a; i++) { + arr.pop(); + } + } + } + |] + a <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x31] c (Just ("fun(uint8)", [AbiUIntType 8])) [] defaultVeriOpts + print $ length a + print $ show a + putStrLn "expected counterexample found" + , + testCase "access-out-of-bounds-array" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + uint[] private arr; + function fun(uint8 a) external returns (uint x){ + arr.push(1); + arr.push(2); + x = arr[a]; + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x32] c (Just ("fun(uint8)", [AbiUIntType 8])) [] defaultVeriOpts + assertBool "Access must be beyond element 2" $ (getVar ctr "arg1") > 1 + putStrLn "expected counterexample found" + , + -- TODO the system currently does not allow for symbolic array size allocation + expectFail $ testCase "alloc-too-much" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a) external { + uint[] memory arr = new uint[](a); + } + } + |] + (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x41] c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "expected counterexample found" + , + -- TODO the system currently does not allow for symbolic JUMP + expectFail $ testCase "call-zero-inited-var-thats-a-function" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function (uint256) internal returns (uint) funvar; + function fun2(uint256 a) internal returns (uint){ + return a; + } + function fun(uint256 a) external returns (uint) { + if (a != 44) { + funvar = fun2; + } + return funvar(a); + } + } + |] + (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s [0x51] c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "expected counterexample found" + ] + + , testGroup "Dapp Tests" + [ testCase "Trivial-Pass" $ do + let testFile = "test/contracts/pass/trivial.sol" + runDappTest testFile ".*" >>= assertEqual "test result" True + , testCase "Trivial-Fail" $ do + let testFile = "test/contracts/fail/trivial.sol" + runDappTest testFile "testFalse" >>= assertEqual "test result" False + , testCase "Abstract" $ do + let testFile = "test/contracts/pass/abstract.sol" + runDappTest testFile ".*" >>= assertEqual "test result" True + , testCase "Constantinople" $ do + let testFile = "test/contracts/pass/constantinople.sol" + runDappTest testFile ".*" >>= assertEqual "test result" True + , testCase "Prove-Tests-Pass" $ do + let testFile = "test/contracts/pass/dsProvePass.sol" + runDappTest testFile ".*" >>= assertEqual "test result" True + , testCase "Prove-Tests-Fail" $ do + let testFile = "test/contracts/fail/dsProveFail.sol" + runDappTest testFile "prove_trivial" >>= assertEqual "test result" False + runDappTest testFile "prove_add" >>= assertEqual "test result" False + --runDappTest testFile "prove_smtTimeout" >>= assertEqual "test result" False + runDappTest testFile "prove_multi" >>= assertEqual "test result" False + runDappTest testFile "prove_mul" >>= assertEqual "test result" False + -- TODO: implement overflow checking optimizations and enable, currently this runs forever + --runDappTest testFile "prove_distributivity" >>= assertEqual "test result" False + runDappTest testFile "prove_transfer" >>= assertEqual "test result" False + , testCase "Loop-Tests" $ do + let testFile = "test/contracts/pass/loops.sol" + runDappTestCustom testFile "prove_loop" (Just 10) False Nothing >>= assertEqual "test result" True + runDappTestCustom testFile "prove_loop" (Just 100) False Nothing >>= assertEqual "test result" False + , testCase "Invariant-Tests-Pass" $ do + let testFile = "test/contracts/pass/invariants.sol" + runDappTest testFile ".*" >>= assertEqual "test result" True + , testCase "Invariant-Tests-Fail" $ do + let testFile = "test/contracts/fail/invariantFail.sol" + runDappTest testFile "invariantFirst" >>= assertEqual "test result" False + runDappTest testFile "invariantCount" >>= assertEqual "test result" False + , testCase "Cheat-Codes-Pass" $ do + let testFile = "test/contracts/pass/cheatCodes.sol" + runDappTest testFile ".*" >>= assertEqual "test result" True + , testCase "Cheat-Codes-Fail" $ do + let testFile = "test/contracts/fail/cheatCodes.sol" + runDappTestCustom testFile "testBadFFI" Nothing False Nothing >>= assertEqual "test result" False + ] + , testGroup "Symbolic execution" + [ + testCase "require-test" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 a) external pure { + require(a <= 0); + assert (a <= 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(int256)", [AbiIntType 256])) [] defaultVeriOpts + putStrLn "Require works as expected" + , + testCase "ITE-with-bitwise-AND" $ do + --- using ignore to suppress huge output + Just c <- solcRuntime "C" + [i| + contract C { + function f(uint256 x) public pure { + require(x > 0); + uint256 a = (x & 8); + bool w; + // assembly is needed here, because solidity doesn't allow uint->bool conversion + assembly { + w:=a + } + if (!w) assert(false); //we should get a CEX: when x has a 0 at bit 3 + } + } + |] + -- should find a counterexample + (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("f(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "expected counterexample found" + , + testCase "ITE-with-bitwise-OR" $ do + --- using ignore to suppress huge output + Just c <- solcRuntime "C" + [i| + contract C { + function f(uint256 x) public pure { + uint256 a = (x | 8); + bool w; + // assembly is needed here, because solidity doesn't allow uint->bool conversion + assembly { + w:=a + } + assert(w); // due to bitwise OR with positive value, this must always be true + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("f(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "this should always be true, due to bitwise OR with positive value" + , + -- CopySlice check + -- uses identity precompiled contract (0x4) to copy memory + -- checks 9af114613075a2cd350633940475f8b6699064de (readByte + CopySlice had src/dest mixed up) + -- without 9af114613 it dies with: `Exception: UnexpectedSymbolicArg 296 "MSTORE index"` + -- TODO: check 9e734b9da90e3e0765128b1f20ce1371f3a66085 (bufLength + copySlice was off by 1) + testCase "copyslice-check" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function checkval(uint8 a) public { + bytes memory data = new bytes(5); + for(uint i = 0; i < 5; i++) data[i] = bytes1(a); + bytes memory ret = new bytes(data.length); + assembly { + let len := mload(data) + if iszero(call(0xff, 0x04, 0, add(data, 0x20), len, add(ret,0x20), len)) { + invalid() + } + } + for(uint i = 0; i < 5; i++) assert(ret[i] == data[i]); + } + } + |] + let + opts = VeriOpts + { simp = False + , debug = False + , maxIter = Nothing + , askSmtIters = Nothing + , rpcInfo = Nothing + } + calldata' = Just ("checkval(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256]) + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> + checkAssert s defaultPanicCodes c calldata' [] opts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + -- TODO look at tests here for SAR: https://github.com/dapphub/dapptools/blob/01ef8ea418c3fe49089a44d56013d8fcc34a1ec2/src/dapp-tests/pass/constantinople.sol#L250 + testCase "opcode-sar-neg" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 shift_by, int256 val) external pure returns (int256 out) { + require(shift_by >= 0); + require(val <= 0); + assembly { + out := sar(shift_by,val) + } + assert (out <= 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(int256,int256)", [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLn "SAR works as expected" + , + testCase "opcode-sar-pos" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 shift_by, int256 val) external pure returns (int256 out) { + require(shift_by >= 0); + require(val >= 0); + assembly { + out := sar(shift_by,val) + } + assert (out >= 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(int256,int256)", [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLn "SAR works as expected" + , + testCase "opcode-sar-fixedval-pos" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 shift_by, int256 val) external pure returns (int256 out) { + require(shift_by == 1); + require(val == 64); + assembly { + out := sar(shift_by,val) + } + assert (out == 32); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(int256,int256)", [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLn "SAR works as expected" + , + testCase "opcode-sar-fixedval-neg" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(int256 shift_by, int256 val) external pure returns (int256 out) { + require(shift_by == 1); + require(val == -64); + assembly { + out := sar(shift_by,val) + } + assert (out == -32); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(int256,int256)", [AbiIntType 256, AbiIntType 256])) [] defaultVeriOpts + putStrLn "SAR works as expected" + , + testCase "opcode-div-zero-1" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val) external pure { + uint out; + assembly { + out := div(val, 0) + } + assert(out == 0); + + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "sdiv works as expected" + , + testCase "opcode-div-zero-2" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val) external pure { + uint out; + assembly { + out := div(0, val) + } + assert(out == 0); + + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "sdiv works as expected" + , + testCase "opcode-sdiv-zero-1" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val) external pure { + uint out; + assembly { + out := sdiv(val, 0) + } + assert(out == 0); + + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "sdiv works as expected" + , + testCase "opcode-sdiv-zero-2" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val) external pure { + uint out; + assembly { + out := sdiv(0, val) + } + assert(out == 0); + + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "sdiv works as expected" + , + testCase "opcode-signextend-neg" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val, uint8 b) external pure { + require(b <= 31); + require(b >= 0); + require(val < (1 <<(b*8))); + require(val & (1 <<(b*8-1)) != 0); // MSbit set, i.e. negative + uint256 out; + assembly { + out := signextend(b, val) + } + if (b == 31) assert(out == val); + else assert(out > val); + assert(out & (1<<254) != 0); // MSbit set, i.e. negative + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("foo(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "signextend works as expected" + , + testCase "opcode-signextend-pos-nochop" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val, uint8 b) external pure { + require(val < (1 <<(b*8))); + require(val & (1 <<(b*8-1)) == 0); // MSbit not set, i.e. positive + uint256 out; + assembly { + out := signextend(b, val) + } + assert (out == val); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256,uint8)", [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts + putStrLn "signextend works as expected" + , + testCase "opcode-signextend-pos-chopped" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val, uint8 b) external pure { + require(b == 0); // 1-byte + require(val == 514); // but we set higher bits + uint256 out; + assembly { + out := signextend(b, val) + } + assert (out == 2); // chopped + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256,uint8)", [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts + putStrLn "signextend works as expected" + , + -- when b is too large, value is unchanged + testCase "opcode-signextend-pos-b-toolarge" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 val, uint8 b) external pure { + require(b >= 31); + uint256 out; + assembly { + out := signextend(b, val) + } + assert (out == val); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256,uint8)", [AbiUIntType 256, AbiUIntType 8])) [] defaultVeriOpts + putStrLn "signextend works as expected" + , + testCase "opcode-shl" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 shift_by, uint256 val) external pure { + require(val < (1<<16)); + require(shift_by < 16); + uint256 out; + assembly { + out := shl(shift_by,val) + } + assert (out >= val); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn "SAR works as expected" + , + testCase "opcode-xor-cancel" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure { + require(a == b); + uint256 c; + assembly { + c := xor(a,b) + } + assert (c == 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn "XOR works as expected" + , + testCase "opcode-xor-reimplement" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint256 a, uint256 b) external pure { + uint256 c; + assembly { + c := xor(a,b) + } + assert (c == (~(a & b)) & (a | b)); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn "XOR works as expected" + , + testCase "opcode-mulmod-no-overflow" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint8 a, uint8 b, uint8 c) external pure { + require(a < 4); + require(b < 4); + require(c < 4); + uint16 r1; + uint16 r2; + uint16 g2; + assembly { + r1 := mul(a,b) + r2 := mod(r1, c) + g2 := mulmod (a, b, c) + } + assert (r2 == g2); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint8,uint8,uint8)", [AbiUIntType 8, AbiUIntType 8, AbiUIntType 8])) [] defaultVeriOpts + putStrLn "MULMOD is fine on NON overflow values" + , + testCase "opcode-div-res-zero-on-div-by-zero" $ do + Just c <- solcRuntime "MyContract" + [i| + contract MyContract { + function fun(uint16 a) external pure { + uint16 b = 0; + uint16 res; + assembly { + res := div(a,b) + } + assert (res == 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint16)", [AbiUIntType 16])) [] defaultVeriOpts + putStrLn "DIV by zero is zero" + , + -- Somewhat tautological since we are asserting the precondition + -- on the same form as the actual "requires" clause. + testCase "SafeAdd success case" $ do + Just safeAdd <- solcRuntime "SafeAdd" + [i| + contract SafeAdd { + function add(uint x, uint y) public pure returns (uint z) { + require((z = x + y) >= x); + } + } + |] + let pre preVM = let [x, y] = getStaticAbiArgs 2 preVM + in (x .<= Expr.add x y) + .&& view (state . callvalue) preVM .== Lit 0 + post prestate leaf = + let [x, y] = getStaticAbiArgs 2 prestate + in case leaf of + Return _ b _ -> (ReadWord (Lit 0) b) .== (Add x y) + _ -> PBool True + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts SymbolicS (Just pre) (Just post) + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + + testCase "x == y => x + y == 2 * y" $ do + Just safeAdd <- solcRuntime "SafeAdd" + [i| + contract SafeAdd { + function add(uint x, uint y) public pure returns (uint z) { + require((z = x + y) >= x); + } + } + |] + let pre preVM = let [x, y] = getStaticAbiArgs 2 preVM + in (x .<= Expr.add x y) + .&& (x .== y) + .&& view (state . callvalue) preVM .== Lit 0 + post prestate leaf = + let [_, y] = getStaticAbiArgs 2 prestate + in case leaf of + Return _ b _ -> (ReadWord (Lit 0) b) .== (Mul (Lit 2) y) + _ -> PBool True + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> + verifyContract s safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts SymbolicS (Just pre) (Just post) + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "summary storage writes" $ do + Just c <- solcRuntime "A" + [i| + contract A { + uint x; + function f(uint256 y) public { + unchecked { + x += y; + x += y; + } + } + } + |] + let pre vm = Lit 0 .== view (state . callvalue) vm + post prestate leaf = + let [y] = getStaticAbiArgs 1 prestate + this = Expr.litAddr $ view (state . codeContract) prestate + prex = Expr.readStorage' this (Lit 0) (view (env . storage) prestate) + in case leaf of + Return _ _ postStore -> Expr.add prex (Expr.mul (Lit 2) y) .== (Expr.readStorage' this (Lit 0) postStore) + _ -> PBool True + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just ("f(uint256)", [AbiUIntType 256])) [] defaultVeriOpts SymbolicS (Just pre) (Just post) + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + -- tests how whiffValue handles Neg via application of the triple IsZero simplification rule + -- regression test for: https://github.com/dapphub/dapptools/pull/698 + testCase "Neg" $ do + let src = + [i| + object "Neg" { + code { + // Deploy the contract + datacopy(0, dataoffset("runtime"), datasize("runtime")) + return(0, datasize("runtime")) + } + object "runtime" { + code { + let v := calldataload(4) + if iszero(iszero(and(v, not(0xffffffffffffffffffffffffffffffffffffffff)))) { + invalid() + } + } + } + } + |] + Just c <- yulRuntime "Neg" src + (res, [Qed _]) <- withSolvers Z3 4 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("hello(address)", [AbiAddressType])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "catch-storage-collisions-noproblem" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y) public { + if (x != y) { + assembly { + let newx := sub(sload(x), 1) + let newy := add(sload(y), 1) + sstore(x,newx) + sstore(y,newy) + } + } + } + } + |] + let pre vm = (Lit 0) .== view (state . callvalue) vm + post prestate poststate = + let [x,y] = getStaticAbiArgs 2 prestate + this = Expr.litAddr $ view (state . codeContract) prestate + prestore = view (env . storage) prestate + prex = Expr.readStorage' this x prestore + prey = Expr.readStorage' this y prestore + in case poststate of + Return _ _ poststore -> let + postx = Expr.readStorage' this x poststore + posty = Expr.readStorage' this y poststore + in Expr.add prex prey .== Expr.add postx posty + _ -> PBool True + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts SymbolicS (Just pre) (Just post) + putStrLn "Correct, this can never fail" + , + -- Inspired by these `msg.sender == to` token bugs + -- which break linearity of totalSupply. + testCase "catch-storage-collisions-good" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y) public { + assembly { + let newx := sub(sload(x), 1) + let newy := add(sload(y), 1) + sstore(x,newx) + sstore(y,newy) + } + } + } + |] + let pre vm = (Lit 0) .== view (state . callvalue) vm + post prestate poststate = + let [x,y] = getStaticAbiArgs 2 prestate + this = Expr.litAddr $ view (state . codeContract) prestate + prestore = view (env . storage) prestate + prex = Expr.readStorage' this x prestore + prey = Expr.readStorage' this y prestore + in case poststate of + Return _ _ poststore -> let + postx = Expr.readStorage' this x poststore + posty = Expr.readStorage' this y poststore + in Expr.add prex prey .== Expr.add postx posty + _ -> PBool True + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> verifyContract s c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts SymbolicS (Just pre) (Just post) + let x = getVar ctr "arg1" + let y = getVar ctr "arg2" + putStrLn $ "y:" <> show y + putStrLn $ "x:" <> show x + assertEqual "Catch storage collisions" x y + putStrLn "expected counterexample found" + , + testCase "Simple Assert" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo() external pure { + assert(false); + } + } + |] + (_, [Cex (l, _)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("foo()", [])) [] defaultVeriOpts + assertEqual "incorrect revert msg" l (EVM.Types.Revert [] (ConcreteBuf $ panicMsg 0x01)) + , + testCase "simple-assert-2" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + assert(x != 10); + } + } + |] + (_, [(Cex (_, ctr))]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("foo(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + assertEqual "Must be 10" 10 $ getVar ctr "arg1" + putStrLn "Got 10 Cex, as expected" + , + testCase "assert-fail-equal" $ do + Just c <- solcRuntime "AssertFailEqual" + [i| + contract AssertFailEqual { + function fun(uint256 deposit_count) external pure { + assert(deposit_count == 0); + assert(deposit_count == 11); + } + } + |] + (_, [Cex (_, a), Cex (_, b)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + let ints = map (flip getVar "arg1") [a,b] + assertBool "0 must be one of the Cex-es" $ isJust $ elemIndex 0 ints + putStrLn "expected 2 counterexamples found, one Cex is the 0 value" + , + testCase "assert-fail-notequal" $ do + Just c <- solcRuntime "AssertFailNotEqual" + [i| + contract AssertFailNotEqual { + function fun(uint256 deposit_count) external pure { + assert(deposit_count != 0); + assert(deposit_count != 11); + } + } + |] + (_, [Cex (_, a), Cex (_, b)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + let x = getVar a "arg1" + let y = getVar b "arg1" + assertBool "At least one has to be 0, to go through the first assert" (x == 0 || y == 0) + putStrLn "expected 2 counterexamples found." + , + testCase "assert-fail-twoargs" $ do + Just c <- solcRuntime "AssertFailTwoParams" + [i| + contract AssertFailTwoParams { + function fun(uint256 deposit_count1, uint256 deposit_count2) external pure { + assert(deposit_count1 != 0); + assert(deposit_count2 != 11); + } + } + |] + (_, [Cex _, Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn "expected 2 counterexamples found" + , + testCase "assert-2nd-arg" $ do + Just c <- solcRuntime "AssertFailTwoParams" + [i| + contract AssertFailTwoParams { + function fun(uint256 deposit_count1, uint256 deposit_count2) external pure { + assert(deposit_count2 != 666); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("fun(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + assertEqual "Must be 666" 666 $ getVar ctr "arg2" + putStrLn "Found arg2 Ctx to be 666" + , + -- LSB is zeroed out, byte(31,x) takes LSB, so y==0 always holds + testCase "check-lsb-msb1" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + x &= 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff00; + uint8 y; + assembly { y := byte(31,x) } + assert(y == 0); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("foo(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + -- We zero out everything but the LSB byte. However, byte(31,x) takes the LSB byte + -- so there is a counterexamle, where LSB of x is not zero + testCase "check-lsb-msb2" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + x &= 0x00000000000000000000000000000000000000000000000000000000000000ff; + uint8 y; + assembly { y := byte(31,x) } + assert(y == 0); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("foo(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + assertBool "last byte must be non-zero" $ ((Data.Bits..&.) (getVar ctr "arg1") 0xff) > 0 + putStrLn "Expected counterexample found" + , + -- We zero out everything but the 2nd LSB byte. However, byte(31,x) takes the 2nd LSB byte + -- so there is a counterexamle, where 2nd LSB of x is not zero + testCase "check-lsb-msb3 -- 2nd byte" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + x &= 0x000000000000000000000000000000000000000000000000000000000000ff00; + uint8 y; + assembly { y := byte(30,x) } + assert(y == 0); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("foo(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + assertBool "second to last byte must be non-zero" $ ((Data.Bits..&.) (getVar ctr "arg1") 0xff00) > 0 + putStrLn "Expected counterexample found" + , + -- Reverse of thest above + testCase "check-lsb-msb4 2nd byte rev" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + x &= 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff00ff; + uint8 y; + assembly { + y := byte(30,x) + } + assert(y == 0); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("foo(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + -- Bitwise OR operation test + testCase "opcode-bitwise-or-full-1s" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + uint256 y; + uint256 z = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff; + assembly { y := or(x, z) } + assert(y == 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("foo(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "When OR-ing with full 1's we should get back full 1's" + , + -- Bitwise OR operation test + testCase "opcode-bitwise-or-byte-of-1s" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x) external pure { + uint256 y; + uint256 z = 0x000000000000000000000000000000000000000000000000000000000000ff00; + assembly { y := or(x, z) } + assert((y & 0x000000000000000000000000000000000000000000000000000000000000ff00) == + 0x000000000000000000000000000000000000000000000000000000000000ff00); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("foo(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "When OR-ing with a byte of 1's, we should get 1's back there" + , + testCase "Deposit contract loop (z3)" $ do + Just c <- solcRuntime "Deposit" + [i| + contract Deposit { + function deposit(uint256 deposit_count) external pure { + require(deposit_count < 2**32 - 1); + ++deposit_count; + bool found = false; + for (uint height = 0; height < 32; height++) { + if ((deposit_count & 1) == 1) { + found = true; + break; + } + deposit_count = deposit_count >> 1; + } + assert(found); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("deposit(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "Deposit-contract-loop-error-version" $ do + Just c <- solcRuntime "Deposit" + [i| + contract Deposit { + function deposit(uint8 deposit_count) external pure { + require(deposit_count < 2**32 - 1); + ++deposit_count; + bool found = false; + for (uint height = 0; height < 32; height++) { + if ((deposit_count & 1) == 1) { + found = true; + break; + } + deposit_count = deposit_count >> 1; + } + assert(found); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s allPanicCodes c (Just ("deposit(uint8)", [AbiUIntType 8])) [] defaultVeriOpts + assertEqual "Must be 255" 255 $ getVar ctr "arg1" + putStrLn $ "expected counterexample found, and it's correct: " <> (show $ getVar ctr "arg1") + , + testCase "explore function dispatch" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x) public pure returns (uint) { + return x; + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "check-asm-byte-in-bounds" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 idx, uint256 val) external pure { + uint256 actual; + uint256 expected; + require(idx < 32); + assembly { + actual := byte(idx,val) + expected := shr(248, shl(mul(idx, 8), val)) + } + assert(actual == expected); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLn "in bounds byte reads return the expected value" + , + testCase "check-div-mod-sdiv-smod-by-zero-constant-prop" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 e) external pure { + uint x = 0; + uint y = 55; + uint z; + assembly { z := div(y,x) } + assert(z == 0); + assembly { z := div(x,y) } + assert(z == 0); + assembly { z := sdiv(y,x) } + assert(z == 0); + assembly { z := sdiv(x,y) } + assert(z == 0); + assembly { z := mod(y,x) } + assert(z == 0); + assembly { z := mod(x,y) } + assert(z == 0); + assembly { z := smod(y,x) } + assert(z == 0); + assembly { z := smod(x,y) } + assert(z == 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("foo(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn "div/mod/sdiv/smod by zero works as expected during constant propagation" + , + testCase "check-asm-byte-oob" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function foo(uint256 x, uint256 y) external pure { + uint256 z; + require(x >= 32); + assembly { z := byte(x,y) } + assert(z == 0); + } + } + |] + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLn "oob byte reads always return 0" + , + testCase "injectivity of keccak (32 bytes)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y) public pure { + if (keccak256(abi.encodePacked(x)) == keccak256(abi.encodePacked(y))) assert(x == y); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "injectivity of keccak all pairs (32 bytes)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y, uint z) public pure { + bytes32 w; bytes32 u; bytes32 v; + w = keccak256(abi.encode(x)); + u = keccak256(abi.encode(y)); + v = keccak256(abi.encode(z)); + if (w == u) assert(x==y); + if (w == v) assert(x==z); + if (u == v) assert(y==z); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("f(uint256,uint256,uint256)", [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "injectivity of keccak contrapositive (32 bytes)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y) public pure { + require (x != y); + assert (keccak256(abi.encodePacked(x)) != keccak256(abi.encodePacked(y))); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "injectivity of keccak (64 bytes)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x, uint y, uint w, uint z) public pure { + assert (keccak256(abi.encodePacked(x,y)) != keccak256(abi.encodePacked(w,z))); + } + } + |] + (_, [Cex (_, ctr)]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("f(uint256,uint256,uint256,uint256)", replicate 4 (AbiUIntType 256))) [] defaultVeriOpts + let x = getVar ctr "arg1" + let y = getVar ctr "arg2" + let w = getVar ctr "arg3" + let z = getVar ctr "arg4" + assertEqual "x==y for hash collision" x y + assertEqual "w==z for hash collision" w z + putStrLn "expected counterexample found" + , + expectFail $ testCase "calldata beyond calldatasize is 0 (z3)" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f() public pure { + uint y; + assembly { + let x := calldatasize() + y := calldataload(x) + } + assert(y == 0); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c Nothing [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + ignoreTest $ testCase "keccak soundness" $ do + --- using ignore to suppress huge output + Just c <- solcRuntime "C" + [i| + contract C { + mapping (uint => mapping (uint => uint)) maps; + + function f(uint x, uint y) public view { + assert(maps[y][0] == maps[x][0]); + } + } + |] + + -- should find a counterexample + (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn "expected counterexample found" + , + testCase "multiple-contracts" $ do + let code' = + [i| + contract C { + uint x; + A constant a = A(0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B); + + function call_A() public view { + // should fail since a.x() can be anything + assert(a.x() == x); + } + } + contract A { + uint public x; + } + |] + aAddr = Addr 0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B + Just c <- solcRuntime "C" code' + Just a <- solcRuntime "A" code' + (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> do + let vm0 = abstractVM (Just ("call_A()", [])) [] c Nothing SymbolicS + let vm = vm0 + & set (state . callvalue) (Lit 0) + & over (env . contracts) + (Map.insert aAddr (initialContract (RuntimeCode (fromJust $ Expr.toList $ ConcreteBuf a)))) + -- NOTE: this used to as follows, but there is no _storage field in Contract record + -- (Map.insert aAddr (initialContract (RuntimeCode $ ConcreteBuffer a) & + -- set EVM.storage (EVM.Symbolic [] store))) + verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) + putStrLn "found counterexample:" + , + expectFail $ testCase "calling unique contracts (read from storage)" $ do + Just c <- solcRuntime "C" + [i| + contract C { + uint x; + A a; + + function call_A() public { + a = new A(); + // should fail since x can be anything + assert(a.x() == x); + } + } + contract A { + uint public x; + } + |] + (_, [Cex _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("call_A()", [])) [] defaultVeriOpts + putStrLn "expected counterexample found" + , + testCase "keccak concrete and sym agree" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function kecc(uint x) public pure { + if (x == 0) { + assert(keccak256(abi.encode(x)) == keccak256(abi.encode(0))); + } + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("kecc(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + testCase "keccak concrete and sym injectivity" $ do + Just c <- solcRuntime "A" + [i| + contract A { + function f(uint x) public pure { + if (x !=3) assert(keccak256(abi.encode(x)) != keccak256(abi.encode(3))); + } + } + |] + (res, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("f(uint256)", [AbiUIntType 256])) [] defaultVeriOpts + putStrLn $ "successfully explored: " <> show (Expr.numBranches res) <> " paths" + , + ignoreTest $ testCase "safemath distributivity (yul)" $ do + let yulsafeDistributivity = hex "6355a79a6260003560e01c14156016576015601f565b5b60006000fd60a1565b603d602d604435600435607c565b6039602435600435607c565b605d565b6052604b604435602435605d565b600435607c565b141515605a57fe5b5b565b6000828201821115151560705760006000fd5b82820190505b92915050565b6000818384048302146000841417151560955760006000fd5b82820290505b92915050565b" + let vm = abstractVM (Just ("distributivity(uint256,uint256,uint256)", [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] yulsafeDistributivity Nothing SymbolicS + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> verify s defaultVeriOpts vm (Just $ checkAssertions defaultPanicCodes) + putStrLn "Proven" + , + testCase "safemath distributivity (sol)" $ do + Just c <- solcRuntime "C" + [i| + contract C { + function distributivity(uint x, uint y, uint z) public { + assert(mul(x, add(y, z)) == add(mul(x, y), mul(x, z))); + } + + function add(uint x, uint y) internal pure returns (uint z) { + unchecked { + require((z = x + y) >= x, "ds-math-add-overflow"); + } + } + + function mul(uint x, uint y) internal pure returns (uint z) { + unchecked { + require(y == 0 || (z = x * y) / y == x, "ds-math-mul-overflow"); + } + } + } + |] + + (_, [Qed _]) <- withSolvers Z3 1 Nothing $ \s -> checkAssert s defaultPanicCodes c (Just ("distributivity(uint256,uint256,uint256)", [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] defaultVeriOpts + putStrLn "Proven" + ] + , testGroup "Equivalence checking" + [ + testCase "eq-yul-simple-cex" $ do + Just aPrgm <- yul "" + [i| + { + calldatacopy(0, 0, 32) + switch mload(0) + case 0 { } + case 1 { } + default { invalid() } + } + |] + Just bPrgm <- yul "" + [i| + { + calldatacopy(0, 0, 32) + switch mload(0) + case 0 { } + case 2 { } + default { invalid() } + } + |] + withSolvers Z3 3 Nothing $ \s -> do + a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts Nothing + assertBool "Must have a difference" (not (null a)) + , + testCase "eq-sol-exp-qed" $ do + Just aPrgm <- solcRuntime "C" + [i| + contract C { + function a(uint8 x) public returns (uint8 b) { + unchecked { + b = x*2; + } + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract C { + function a(uint8 x) public returns (uint8 b) { + unchecked { + b = x<<1; + } + } + } + |] + withSolvers Z3 3 Nothing $ \s -> do + a <- equivalenceCheck s aPrgm bPrgm defaultVeriOpts Nothing + assertEqual "Must have no difference" [] a + return () + , + testCase "eq-sol-exp-cex" $ do + -- These yul programs are not equivalent: (try --calldata $(seth --to-uint256 2) for example) + Just aPrgm <- solcRuntime "C" + [i| + contract C { + function a(uint8 x) public returns (uint8 b) { + unchecked { + b = x*2+1; + } + } + } + |] + Just bPrgm <- solcRuntime "C" + [i| + contract C { + function a(uint8 x) public returns (uint8 b) { + unchecked { + b = x<<1; + } + } + } + |] + withSolvers Z3 3 Nothing $ \s -> do + let myVeriOpts = VeriOpts{ simp = True, debug = False, maxIter = Just 2, askSmtIters = Just 2, rpcInfo = Nothing} + a <- equivalenceCheck s aPrgm bPrgm myVeriOpts Nothing + assertEqual "Must be different" (containsA (Cex ()) a) True + return () + , testCase "eq-all-yul-optimization-tests" $ do + let myVeriOpts = VeriOpts{ simp = True, debug = False, maxIter = Just 5, askSmtIters = Just 20, rpcInfo = Nothing } + ignoredTests = [ + "controlFlowSimplifier/terminating_for_nested.yul" + , "controlFlowSimplifier/terminating_for_nested_reversed.yul" + + -- unbounded loop -- + , "commonSubexpressionEliminator/branches_for.yul" + , "commonSubexpressionEliminator/loop.yul" + , "conditionalSimplifier/clear_after_if_continue.yul" + , "conditionalSimplifier/no_opt_if_break_is_not_last.yul" + , "conditionalUnsimplifier/clear_after_if_continue.yul" + , "conditionalUnsimplifier/no_opt_if_break_is_not_last.yul" + , "expressionSimplifier/inside_for.yul" + , "forLoopConditionIntoBody/cond_types.yul" + , "forLoopConditionIntoBody/simple.yul" + , "fullSimplify/inside_for.yul" + , "fullSuite/devcon_example.yul" + , "fullSuite/loopInvariantCodeMotion.yul" + , "fullSuite/no_move_loop_orig.yul" + , "loadResolver/loop.yul" + , "loopInvariantCodeMotion/multi.yul" + , "loopInvariantCodeMotion/recursive.yul" + , "loopInvariantCodeMotion/simple.yul" + , "redundantAssignEliminator/for_branch.yul" + , "redundantAssignEliminator/for_break.yul" + , "redundantAssignEliminator/for_continue.yul" + , "redundantAssignEliminator/for_decl_inside_break_continue.yul" + , "redundantAssignEliminator/for_deep_noremove.yul" + , "redundantAssignEliminator/for_deep_simple.yul" + , "redundantAssignEliminator/for_multi_break.yul" + , "redundantAssignEliminator/for_nested.yul" + , "redundantAssignEliminator/for_rerun.yul" + , "redundantAssignEliminator/for_stmnts_after_break_continue.yul" + , "rematerialiser/branches_for1.yul" + , "rematerialiser/branches_for2.yul" + , "rematerialiser/for_break.yul" + , "rematerialiser/for_continue.yul" + , "rematerialiser/for_continue_2.yul" + , "rematerialiser/for_continue_with_assignment_in_post.yul" + , "rematerialiser/no_remat_in_loop.yul" + , "ssaTransform/for_reassign_body.yul" + , "ssaTransform/for_reassign_init.yul" + , "ssaTransform/for_reassign_post.yul" + , "ssaTransform/for_simple.yul" + , "loopInvariantCodeMotion/nonMovable.yul" + , "unusedAssignEliminator/for_rerun.yul" + , "unusedAssignEliminator/for_continue_3.yul" + , "unusedAssignEliminator/for_deep_simple.yul" + , "ssaTransform/for_def_in_init.yul" + , "rematerialiser/many_refs_small_cost_loop.yul" + , "loopInvariantCodeMotion/no_move_state_loop.yul" + , "loopInvariantCodeMotion/dependOnVarInLoop.yul" + , "forLoopInitRewriter/empty_pre.yul" + , "loadResolver/keccak_crash.yul" + , "blockFlattener/for_stmt.yul" -- symb input can loop it forever + , "unusedAssignEliminator/for.yul" -- not infinite, just 2**256-3 + , "loopInvariantCodeMotion/no_move_state.yul" -- not infinite, but rollaround on a large int + , "loopInvariantCodeMotion/non-ssavar.yul" -- same as above + , "forLoopInitRewriter/complex_pre.yul" + , "rematerialiser/some_refs_small_cost_loop.yul" -- not infinite but 100 long + , "forLoopInitRewriter/simple.yul" + , "loopInvariantCodeMotion/no_move_loop.yul" + + -- unexpected symbolic arg -- + + -- OpCreate2 + , "expressionSimplifier/create2_and_mask.yul" + + -- OpCreate + , "expressionSimplifier/create_and_mask.yul" + , "expressionSimplifier/large_byte_access.yul" + + -- OpMload + , "yulOptimizerTests/expressionSplitter/inside_function.yul" + , "fullInliner/double_inline.yul" + , "fullInliner/inside_condition.yul" + , "fullInliner/large_function_multi_use.yul" + , "fullInliner/large_function_single_use.yul" + , "fullInliner/no_inline_into_big_global_context.yul" + , "fullSimplify/invariant.yul" + , "fullSuite/abi_example1.yul" + , "ssaAndBack/for_loop.yul" + , "ssaAndBack/multi_assign_multi_var_if.yul" + , "ssaAndBack/multi_assign_multi_var_switch.yul" + , "ssaAndBack/two_vars.yul" + , "ssaTransform/multi_assign.yul" + , "ssaTransform/multi_decl.yul" + , "expressionSplitter/inside_function.yul" + , "fullSuite/ssaReverseComplex.yul" + + -- OpMstore + , "commonSubexpressionEliminator/function_scopes.yul" + , "commonSubexpressionEliminator/variable_for_variable.yul" + , "expressionSplitter/trivial.yul" + , "fullInliner/multi_return.yul" + , "fullSimplify/constant_propagation.yul" + , "fullSimplify/identity_rules_complex.yul" + , "fullSuite/medium.yul" + , "loadResolver/memory_with_msize.yul" + , "loadResolver/merge_known_write.yul" + , "loadResolver/merge_known_write_with_distance.yul" + , "loadResolver/merge_unknown_write.yul" + , "loadResolver/reassign_value_expression.yul" + , "loadResolver/second_mstore_with_delta.yul" + , "loadResolver/second_store_with_delta.yul" + , "loadResolver/simple.yul" + , "loadResolver/simple_memory.yul" + , "fullSuite/ssaReverse.yul" + , "rematerialiser/cheap_caller.yul" + , "rematerialiser/non_movable_instruction.yul" + , "ssaAndBack/multi_assign.yul" + , "ssaAndBack/multi_assign_if.yul" + , "ssaAndBack/multi_assign_switch.yul" + , "ssaAndBack/simple.yul" + , "ssaReverser/simple.yul" + + -- OpMstore8 + , "loadResolver/memory_with_different_kinds_of_invalidation.yul" + + -- OpRevert + , "ssaAndBack/ssaReverse.yul" + , "redundantAssignEliminator/for_continue_3.yul" + , "controlFlowSimplifier/terminating_for_revert.yul" + + -- invalid test -- + -- https://github.com/ethereum/solidity/issues/9500 + , "commonSubexpressionEliminator/object_access.yul" + , "expressionSplitter/object_access.yul" + , "fullSuite/stack_compressor_msize.yul" + , "varNameCleaner/function_names.yul" + + -- stack too deep -- + , "fullSuite/abi2.yul" + , "fullSuite/aztec.yul" + , "stackCompressor/inlineInBlock.yul" + , "stackCompressor/inlineInFunction.yul" + , "stackCompressor/unusedPrunerWithMSize.yul" + , "wordSizeTransform/function_call.yul" + , "fullInliner/no_inline_into_big_function.yul" + , "controlFlowSimplifier/switch_only_default.yul" + , "stackLimitEvader" -- all that are in this subdirectory + + -- wrong number of args -- + , "wordSizeTransform/functional_instruction.yul" + , "wordSizeTransform/if.yul" + , "wordSizeTransform/or_bool_renamed.yul" + , "wordSizeTransform/switch_1.yul" + , "wordSizeTransform/switch_2.yul" + , "wordSizeTransform/switch_3.yul" + , "wordSizeTransform/switch_4.yul" + , "wordSizeTransform/switch_5.yul" + , "unusedFunctionParameterPruner/too_many_arguments.yul" + + -- typed yul -- + , "conditionalSimplifier/add_correct_type_wasm.yul" + , "conditionalSimplifier/add_correct_type.yul" + , "disambiguator/for_statement.yul" + , "disambiguator/funtion_call.yul" + , "disambiguator/if_statement.yul" + , "disambiguator/long_names.yul" + , "disambiguator/switch_statement.yul" + , "disambiguator/variables_clash.yul" + , "disambiguator/variables_inside_functions.yul" + , "disambiguator/variables.yul" + , "expressionInliner/simple.yul" + , "expressionInliner/with_args.yul" + , "expressionSplitter/typed.yul" + , "fullInliner/multi_return_typed.yul" + , "functionGrouper/empty_block.yul" + , "functionGrouper/multi_fun_mixed.yul" + , "functionGrouper/nested_fun.yul" + , "functionGrouper/single_fun.yul" + , "functionHoister/empty_block.yul" + , "functionHoister/multi_mixed.yul" + , "functionHoister/nested.yul" + , "functionHoister/single.yul" + , "mainFunction/empty_block.yul" + , "mainFunction/multi_fun_mixed.yul" + , "mainFunction/nested_fun.yul" + , "mainFunction/single_fun.yul" + , "ssaTransform/typed_for.yul" + , "ssaTransform/typed_switch.yul" + , "ssaTransform/typed.yul" + , "varDeclInitializer/typed.yul" + + -- New: symbolic index on MSTORE/MLOAD/CopySlice/CallDataCopy/ExtCodeCopy/Revert, + -- or exponent is symbolic (requires symbolic gas) + -- or SHA3 offset symbolic + , "blockFlattener/basic.yul" + , "commonSubexpressionEliminator/case2.yul" + , "equalStoreEliminator/indirect_inferrence.yul" + , "expressionJoiner/reassignment.yul" + , "expressionSimplifier/exp_simplifications.yul" + , "expressionSimplifier/zero_length_read.yul" + , "expressionSimplifier/side_effects_in_for_condition.yul" + , "fullSuite/create_and_mask.yul" + , "fullSuite/unusedFunctionParameterPruner_return.yul" + , "fullSuite/unusedFunctionParameterPruner_simple.yul" + , "fullSuite/unusedFunctionParameterPruner.yul" + , "loadResolver/double_mload_with_other_reassignment.yul" + , "loadResolver/double_mload_with_reassignment.yul" + , "loadResolver/double_mload.yul" + , "loadResolver/keccak_reuse_basic.yul" + , "loadResolver/keccak_reuse_expr_mstore.yul" + , "loadResolver/keccak_reuse_msize.yul" + , "loadResolver/keccak_reuse_mstore.yul" + , "loadResolver/keccak_reuse_reassigned_branch.yul" + , "loadResolver/keccak_reuse_reassigned_value.yul" + , "loadResolver/keccak_symbolic_memory.yul" + , "loadResolver/merge_mload_with_known_distance.yul" + , "loadResolver/mload_self.yul" + , "loadResolver/keccak_reuse_in_expression.yul" + , "loopInvariantCodeMotion/complex_move.yul" + , "loopInvariantCodeMotion/move_memory_function.yul" + , "loopInvariantCodeMotion/move_state_function.yul" + , "loopInvariantCodeMotion/no_move_memory.yul" + , "loopInvariantCodeMotion/no_move_storage.yul" + , "loopInvariantCodeMotion/not_first.yul" + , "ssaAndBack/single_assign_if.yul" + , "ssaAndBack/single_assign_switch.yul" + , "structuralSimplifier/switch_inline_no_match.yul" + , "unusedFunctionParameterPruner/simple.yul" + , "unusedStoreEliminator/covering_calldatacopy.yul" + , "unusedStoreEliminator/remove_before_revert.yul" + , "unusedStoreEliminator/unknown_length2.yul" + , "unusedStoreEliminator/unrelated_relative.yul" + + -- Takes too long, would timeout on most test setups. + -- We could probably fix these by "bunching together" queries + , "fullSuite/clear_after_if_continue.yul" + , "reasoningBasedSimplifier/smod.yul" + , "reasoningBasedSimplifier/mulmod.yul" + + -- TODO check what's wrong with these! + , "unusedStoreEliminator/create_inside_function.yul" + , "fullSimplify/not_applied_removes_non_constant_and_not_movable.yul" -- create bug? + , "unusedStoreEliminator/create.yul" -- create bug? + , "fullSuite/extcodelength.yul" -- extcodecopy bug? + , "loadResolver/keccak_short.yul" -- keccak bug + , "reasoningBasedSimplifier/signed_division.yul" -- ACTUAL bug, SDIV I think? + ] + + solcRepo <- fromMaybe (error "cannot find solidity repo") <$> (lookupEnv "HEVM_SOLIDITY_REPO") + let testDir = solcRepo <> "/test/libyul/yulOptimizerTests" + dircontents <- System.Directory.listDirectory testDir + let + fullpaths = map ((testDir ++ "/") ++) dircontents + recursiveList :: [FilePath] -> [FilePath] -> IO [FilePath] + recursiveList (a:ax) b = do + isdir <- doesDirectoryExist a + case isdir of + True -> do + fs <- System.Directory.listDirectory a + let fs2 = map ((a ++ "/") ++) fs + recursiveList (ax++fs2) b + False -> recursiveList ax (a:b) + recursiveList [] b = pure b + files <- recursiveList fullpaths [] + -- + let filesFiltered = filter (\file -> not $ any (\filt -> Data.List.isSubsequenceOf filt file) ignoredTests) files + -- + -- Takes one file which follows the Solidity Yul optimizer unit tests format, + -- extracts both the nonoptimized and the optimized versions, and checks equivalence. + forM_ filesFiltered (\f-> do + origcont <- readFile f + let + onlyAfter pattern (a:ax) = if a =~ pattern then (a:ax) else onlyAfter pattern ax + onlyAfter _ [] = [] + replaceOnce pat repl inp = go inp [] where + go (a:ax) b = if a =~ pat then let a2 = replaceAll repl $ a *=~ pat in b ++ a2:ax + else go ax (b ++ [a]) + go [] b = b + + -- takes a yul program and ensures memory is symbolic by prepending + -- `calldatacopy(0,0,1024)`. (calldata is symbolic, but memory starts empty). + -- This forces the exploration of more branches, and makes the test vectors a + -- little more thorough. + symbolicMem (a:ax) = if a =~ [re|"^ *object"|] then + let a2 = replaceAll "a calldatacopy(0,0,1024)" $ a *=~ [re|code {|] + in (a2:ax) + else replaceOnce [re|^ *{|] "{\ncalldatacopy(0,0,1024)" $ onlyAfter [re|^ *{|] (a:ax) + symbolicMem _ = error "Program too short" + + unfiltered = lines origcont + filteredASym = symbolicMem [ x | x <- unfiltered, (not $ x =~ [re|^//|]) && (not $ x =~ [re|^$|]) ] + filteredBSym = symbolicMem [ replaceAll "" $ x *=~[re|^//|] | x <- onlyAfter [re|^// step:|] unfiltered, not $ x =~ [re|^$|] ] + start <- getCurrentTime + putStrLn $ "Checking file: " <> f + when (debug myVeriOpts) $ do + putStrLn "-------------Original Below-----------------" + mapM_ putStrLn unfiltered + putStrLn "------------- Filtered A + Symb below-----------------" + mapM_ putStrLn filteredASym + putStrLn "------------- Filtered B + Symb below-----------------" + mapM_ putStrLn filteredBSym + putStrLn "------------- END -----------------" + Just aPrgm <- yul "" $ T.pack $ unlines filteredASym + Just bPrgm <- yul "" $ T.pack $ unlines filteredBSym + withSolvers CVC5 6 (Just 3) $ \s -> do + res <- equivalenceCheck s aPrgm bPrgm myVeriOpts Nothing + end <- getCurrentTime + case containsA (Cex()) res of + False -> do + print $ "OK. Took " <> (show $ diffUTCTime end start) <> " seconds" + let timeouts = filter (\(_, _, c) -> c == EVM.SymExec.Timeout()) res + unless (null timeouts) $ putStrLn $ "But " <> (show $ length timeouts) <> " timeout(s) occurred" + True -> do + putStrLn $ "Not OK: " <> show f <> " Got: " <> show res + error "Was NOT equivalent, error" + ) + ] + ] + where + (===>) = assertSolidityComputation + + +checkEquiv :: (Typeable a) => Expr a -> Expr a -> IO Bool +checkEquiv l r = withSolvers Z3 1 (Just 100) $ \solvers -> do + if l == r + then do + putStrLn "skip" + pure True + else do + let smt = assertProps [l ./= r] + res <- checkSat solvers smt + print res + pure $ case res of + Unsat -> True + EVM.SMT.Unknown -> True + Sat _ -> False + Error _ -> False + + +runSimpleVM :: ByteString -> ByteString -> Maybe ByteString +runSimpleVM x ins = case loadVM x of + Nothing -> Nothing + Just vm -> let calldata' = (ConcreteBuf ins) + in case runState (assign (state.calldata) calldata' >> exec) vm of + (VMSuccess (ConcreteBuf bs), _) -> Just bs + _ -> Nothing + +loadVM :: ByteString -> Maybe VM +loadVM x = + case runState exec (vmForEthrunCreation x) of + (VMSuccess (ConcreteBuf targetCode), vm1) -> do + let target = view (state . contract) vm1 + vm2 = execState (replaceCodeOfSelf (RuntimeCode (fromJust $ Expr.toList $ ConcreteBuf targetCode))) vm1 + return $ snd $ flip runState vm2 + (do resetState + assign (state . gas) 0xffffffffffffffff -- kludge + loadContract target) + _ -> Nothing + +hex :: ByteString -> ByteString +hex s = + case Hex.decode s of + Right x -> x + Left e -> error e + +singleContract :: Text -> Text -> IO (Maybe ByteString) +singleContract x s = + solidity x [i| + pragma experimental ABIEncoderV2; + contract ${x} { ${s} } + |] + +defaultDataLocation :: AbiType -> Text +defaultDataLocation t = + if (case t of + AbiBytesDynamicType -> True + AbiStringType -> True + AbiArrayDynamicType _ -> True + AbiArrayType _ _ -> True + _ -> False) + then "memory" + else "" + +runFunction :: Text -> ByteString -> IO (Maybe ByteString) +runFunction c input = do + Just x <- singleContract "X" c + return $ runSimpleVM x input + +runStatements + :: Text -> [AbiValue] -> AbiType + -> IO (Maybe ByteString) +runStatements stmts args t = do + let params = + T.intercalate ", " + (map (\(x, c) -> abiTypeSolidity (abiValueType x) + <> " " <> defaultDataLocation (abiValueType x) + <> " " <> T.pack [c]) + (zip args "abcdefg")) + s = + "foo(" <> T.intercalate "," + (map (abiTypeSolidity . abiValueType) args) <> ")" + + runFunction [i| + function foo(${params}) public pure returns (${abiTypeSolidity t} ${defaultDataLocation t} x) { + ${stmts} + } + |] (abiMethod s (AbiTuple $ Vector.fromList args)) + +getStaticAbiArgs :: Int -> VM -> [Expr EWord] +getStaticAbiArgs n vm = + let cd = view (state . calldata) vm + in decodeStaticArgs 4 n cd + +-- includes shaving off 4 byte function sig +decodeAbiValues :: [AbiType] -> ByteString -> [AbiValue] +decodeAbiValues types bs = + let AbiTuple xy = decodeAbiValue (AbiTupleType $ Vector.fromList types) (BS.fromStrict (BS.drop 4 bs)) + in Vector.toList xy + +newtype Bytes = Bytes ByteString + deriving Eq + +instance Show Bytes where + showsPrec _ (Bytes x) _ = show (BS.unpack x) + +instance Arbitrary Bytes where + arbitrary = fmap (Bytes . BS.pack) arbitrary + +newtype RLPData = RLPData RLP + deriving (Eq, Show) + +-- bias towards bytestring to try to avoid infinite recursion +instance Arbitrary RLPData where + arbitrary = frequency + [(5, do + Bytes bytes <- arbitrary + return $ RLPData $ BS bytes) + , (1, do + k <- choose (0,10) + ls <- vectorOf k arbitrary + return $ RLPData $ List [r | RLPData r <- ls]) + ] + +instance Arbitrary Word128 where + arbitrary = liftM2 fromHiAndLo arbitrary arbitrary + +instance Arbitrary Word256 where + arbitrary = liftM2 fromHiAndLo arbitrary arbitrary + +instance Arbitrary W256 where + arbitrary = fmap W256 arbitrary + +instance Arbitrary (Expr Storage) where + arbitrary = sized genStorage + +instance Arbitrary (Expr EWord) where + arbitrary = sized defaultWord + +instance Arbitrary (Expr Byte) where + arbitrary = sized genByte + +instance Arbitrary (Expr Buf) where + arbitrary = sized defaultBuf + +instance Arbitrary (Expr End) where + arbitrary = sized genEnd + +newtype LitOnly a = LitOnly a + deriving (Show, Eq) + +instance Arbitrary (LitOnly (Expr Byte)) where + arbitrary = LitOnly . LitByte <$> arbitrary + +instance Arbitrary (LitOnly (Expr EWord)) where + arbitrary = LitOnly . Lit <$> arbitrary + +instance Arbitrary (LitOnly (Expr Buf)) where + arbitrary = LitOnly . ConcreteBuf <$> arbitrary + +genByte :: Int -> Gen (Expr Byte) +genByte 0 = fmap LitByte arbitrary +genByte sz = oneof + [ liftM2 IndexWord subWord subWord + , liftM2 ReadByte subWord subBuf + ] + where + subWord = defaultWord (sz `div` 10) + subBuf = defaultBuf (sz `div` 10) + +genLit :: W256 -> Gen (Expr EWord) +genLit bound = do + w <- arbitrary + pure $ Lit (w `mod` bound) + +genNat :: Gen Int +genNat = fmap fromIntegral (arbitrary :: Gen Natural) + +genName :: Gen Text +genName = fmap T.pack $ listOf1 (oneof . (fmap pure) $ ['a'..'z'] <> ['A'..'Z']) + +genEnd :: Int -> Gen (Expr End) +genEnd 0 = oneof + [ pure $ Invalid [] + , pure $ EVM.Types.IllegalOverflow [] + , pure $ SelfDestruct [] + ] +genEnd sz = oneof + [ fmap (EVM.Types.Revert []) subBuf + , liftM3 Return (return []) subBuf subStore + , liftM3 ITE subWord subEnd subEnd + ] + where + subBuf = defaultBuf (sz `div` 2) + subStore = genStorage (sz `div` 2) + subWord = defaultWord (sz `div` 2) + subEnd = genEnd (sz `div` 2) + +genWord :: Int -> Int -> Gen (Expr EWord) +genWord litFreq 0 = frequency + [ (litFreq, do + val <- frequency + [ (10, fmap (`mod` 100) arbitrary) + , (1, arbitrary) + ] + pure $ Lit val + ) + , (1, oneof + [ pure Origin + , pure Coinbase + , pure Timestamp + , pure BlockNumber + , pure PrevRandao + , pure GasLimit + , pure ChainId + , pure BaseFee + , fmap CallValue genNat + , fmap Caller genNat + , fmap Address genNat + --, liftM2 SelfBalance arbitrary arbitrary + --, liftM2 Gas arbitrary arbitrary + , fmap Lit arbitrary + , fmap Var genName + ] + ) + ] +genWord litFreq sz = frequency + [ (litFreq, do + val <- frequency + [ (10, fmap (`mod` 100) arbitrary) + , (1, arbitrary) + ] + pure $ Lit val + ) + , (1, oneof + [ liftM2 Add subWord subWord + , liftM2 Sub subWord subWord + , liftM2 Mul subWord subWord + , liftM2 Div subWord subWord + , liftM2 SDiv subWord subWord + , liftM2 Mod subWord subWord + , liftM2 SMod subWord subWord + --, liftM3 AddMod subWord subWord subWord + --, liftM3 MulMod subWord subWord subWord -- it works, but it's VERY SLOW + --, liftM2 Exp subWord litWord + , liftM2 SEx subWord subWord + , liftM2 Min subWord subWord + , liftM2 LT subWord subWord + , liftM2 GT subWord subWord + , liftM2 LEq subWord subWord + , liftM2 GEq subWord subWord + , liftM2 SLT subWord subWord + --, liftM2 SGT subWord subWord + , liftM2 Eq subWord subWord + , fmap IsZero subWord + , liftM2 And subWord subWord + , liftM2 Or subWord subWord + , liftM2 Xor subWord subWord + , fmap Not subWord + , liftM2 SHL subWord subWord + , liftM2 SHR subWord subWord + , liftM2 SAR subWord subWord + , fmap BlockHash subWord + --, liftM3 Balance arbitrary arbitrary subWord + --, fmap CodeSize subWord + --, fmap ExtCodeHash subWord + , fmap Keccak subBuf + , fmap SHA256 subBuf + , liftM3 SLoad subWord subWord subStore + , liftM2 ReadWord subWord subBuf + , fmap BufLength subBuf + , do + one <- subByte + two <- subByte + three <- subByte + four <- subByte + five <- subByte + six <- subByte + seven <- subByte + eight <- subByte + nine <- subByte + ten <- subByte + eleven <- subByte + twelve <- subByte + thirteen <- subByte + fourteen <- subByte + fifteen <- subByte + sixteen <- subByte + seventeen <- subByte + eighteen <- subByte + nineteen <- subByte + twenty <- subByte + twentyone <- subByte + twentytwo <- subByte + twentythree <- subByte + twentyfour <- subByte + twentyfive <- subByte + twentysix <- subByte + twentyseven <- subByte + twentyeight <- subByte + twentynine <- subByte + thirty <- subByte + thirtyone <- subByte + thirtytwo <- subByte + pure $ JoinBytes + one two three four five six seven eight nine ten + eleven twelve thirteen fourteen fifteen sixteen + seventeen eighteen nineteen twenty twentyone + twentytwo twentythree twentyfour twentyfive + twentysix twentyseven twentyeight twentynine + thirty thirtyone thirtytwo + ]) + ] + where + subWord = genWord litFreq (sz `div` 5) + subBuf = defaultBuf (sz `div` 10) + subStore = genStorage (sz `div` 10) + subByte = genByte (sz `div` 10) + +defaultBuf :: Int -> Gen (Expr Buf) +defaultBuf = genBuf (4_000_000) + +defaultWord :: Int -> Gen (Expr EWord) +defaultWord = genWord 10 + +maybeBoundedLit :: W256 -> Gen (Expr EWord) +maybeBoundedLit bound = do + o <- (arbitrary :: Gen (Expr EWord)) + pure $ case o of + Lit w -> Lit $ w `mod` bound + _ -> o + +genBuf :: W256 -> Int -> Gen (Expr Buf) +genBuf _ 0 = oneof + [ fmap AbstractBuf genName + , fmap ConcreteBuf arbitrary + ] +genBuf bound sz = oneof + [ liftM3 WriteWord (maybeBoundedLit bound) subWord subBuf + , liftM3 WriteByte (maybeBoundedLit bound) subByte subBuf + -- we don't generate copyslice instances where: + -- - size is abstract + -- - size > 100 (due to unrolling in SMT.hs) + -- - literal dstOffsets are > 4,000,000 (due to unrolling in SMT.hs) + -- n.b. that 4,000,000 is the theoretical maximum memory size given a 30,000,000 block gas limit + , liftM5 CopySlice subWord (maybeBoundedLit bound) smolLitWord subBuf subBuf + ] + where + -- copySlice gets unrolled in the generated SMT so we can't go too crazy here + smolLitWord = do + w <- arbitrary + pure $ Lit (w `mod` 100) + subWord = defaultWord (sz `div` 5) + subByte = genByte (sz `div` 10) + subBuf = genBuf bound (sz `div` 10) + +genStorage :: Int -> Gen (Expr Storage) +genStorage 0 = oneof + [ pure AbstractStore + , pure EmptyStore + --, fmap ConcreteStore arbitrary + ] +genStorage sz = liftM4 SStore subWord subWord subWord subStore + where + subStore = genStorage (sz `div` 10) + subWord = defaultWord (sz `div` 5) + +data Invocation + = SolidityCall Text [AbiValue] + deriving Show + +assertSolidityComputation :: Invocation -> AbiValue -> IO () +assertSolidityComputation (SolidityCall s args) x = + do y <- runStatements s args (abiValueType x) + assertEqual (T.unpack s) (fmap Bytes (Just (encodeAbiValue x))) (fmap Bytes y)