erebos-tester (empty) → 0.2.1
raw patch · 25 files changed
+3599/−0 lines, 25 filesdep +Globdep +HsYAMLdep +basesetup-changed
Dependencies added: Glob, HsYAML, base, bytestring, containers, directory, filepath, generic-deriving, haskeline, lens, linux-namespaces, megaparsec, mtl, parser-combinators, process, regex-tdfa, scientific, stm, template-haskell, text, th-compat, unix
Files
- CHANGELOG.md +24/−0
- LICENSE +674/−0
- Setup.hs +2/−0
- erebos-tester.cabal +124/−0
- src/Config.hs +66/−0
- src/GDB.hs +275/−0
- src/GDB.hs-boot +8/−0
- src/Main.hs +140/−0
- src/Network.hs +203/−0
- src/Network.hs-boot +5/−0
- src/Network/Ip.hs +220/−0
- src/Output.hs +122/−0
- src/Parser.hs +42/−0
- src/Parser/Core.hs +86/−0
- src/Parser/Expr.hs +315/−0
- src/Parser/Statement.hs +367/−0
- src/Process.hs +152/−0
- src/Process.hs-boot +4/−0
- src/Run.hs +323/−0
- src/Run/Monad.hs +118/−0
- src/Test.hs +212/−0
- src/Util.hs +17/−0
- src/Version.hs +23/−0
- src/Version/Git.hs +32/−0
- src/Wrapper.hs +45/−0
+ CHANGELOG.md view
@@ -0,0 +1,24 @@+# Revision history for erebos-tester++## 0.2.1 -- 2024-05-14++* Selection of test from test file path on command line using ':' charater+* Added --repeat option to run the tests multiple times+* Added --wait option to wait at the end of each test+* Added 'flush' command+* Show record selectors in failure reports+* Compatibility with GHC up to 9.8++## 0.2.0 -- 2023-04-26++* Lists and "for" statement.+* Subnets of networks.+* Commands to disconnect nodes or networks.++## 0.1.1 -- 2023-02-04++* GDB improvements and fixes.++## 0.1.0 -- 2023-01-08++* First version.
+ LICENSE view
@@ -0,0 +1,674 @@+ GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU General Public License is a free, copyleft license for+software and other kinds of works.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+the GNU General Public License is 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. We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors. You can apply it to+your programs, too.++ 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.++ To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights. Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received. You must make sure that they, too, receive+or can get the source code. And you must show them these terms so they+know their rights.++ Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++ For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software. For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++ Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so. This is fundamentally incompatible with the aim of+protecting users' freedom to change the software. The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable. Therefore, we+have designed this version of the GPL to prohibit the practice for those+products. If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++ Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary. To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++ 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 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. Use with the GNU Affero General Public License.++ 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 Affero 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 special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU 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 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 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 General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU 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 <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++ <program> Copyright (C) <year> <name of author>+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++ 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 GPL, see+<http://www.gnu.org/licenses/>.++ The GNU General Public License does not permit incorporating your program+into proprietary programs. If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License. But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ erebos-tester.cabal view
@@ -0,0 +1,124 @@+cabal-version: 2.2++name: erebos-tester+version: 0.2.1+synopsis: Test framework with virtual network using Linux namespaces+description:+ This framework is intended mainly for networking libraries/applications and+ can run multiple concurrent instances of the tested application on+ different nodes, possibly within separate subnets, on the virtual network.+ Each instance can receive its own commands and produce output to be checked+ via standard input/output, as defined using custom script language.+homepage: https://erebosprotocol.net/tester+-- bug-reports:+license: GPL-3.0-only+license-file: LICENSE+author: Roman Smrž+maintainer: roman.smrz@seznam.cz+-- copyright:+category: Testing+extra-doc-files:+ CHANGELOG.md++flag ci+ description: Options for CI testing+ default: False+ manual: True++source-repository head+ type: git+ location: git://erebosprotocol.net/tester++common common+ ghc-options:+ -Wall+ -fdefer-typed-holes++ if flag(ci)+ ghc-options:+ -Werror+ -- sometimes needed for backward/forward compatibility:+ -Wno-error=unused-imports++executable erebos-tester+ import: common++ main-is: Wrapper.hs+ -- other-modules:+ -- other-extensions:+ build-depends: base >=4.13 && <5,+ directory >=1.3 && <1.4,+ filepath ^>=1.4.2.1,+ linux-namespaces ^>=0.1.3,+ process ^>=1.6.9,+ unix >=2.7 && <2.9,+ hs-source-dirs: src+ default-language: Haskell2010++executable erebos-tester-core+ import: common+ ghc-options:+ -threaded++ main-is: Main.hs++ other-modules: Config+ GDB+ Network+ Network.Ip+ Output+ Parser+ Parser.Core+ Parser.Expr+ Parser.Statement+ Paths_erebos_tester+ Process+ Run+ Run.Monad+ Test+ Util+ Version+ Version.Git++ autogen-modules: Paths_erebos_tester++ other-extensions: TemplateHaskell+ default-extensions: ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ GADTs+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ LambdaCase+ MultiParamTypeClasses+ OverloadedStrings+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ build-depends: base >=4.13 && <5,+ bytestring >=0.10 && <0.12,+ containers ^>=0.6.2.1,+ directory ^>=1.3.6.0,+ filepath ^>=1.4.2.1,+ generic-deriving >=1.14 && <1.15,+ Glob >=0.10 && <0.11,+ haskeline >=0.8 && <0.9,+ HsYAML >=0.2 && <0.3,+ lens >=5.0 && <5.3,+ megaparsec >=9.0 && <10,+ mtl >=2.2 && <2.4,+ parser-combinators >=1.3 && <1.4,+ process ^>=1.6.9,+ regex-tdfa ^>=1.3.1.0,+ scientific >=0.3 && < 0.4,+ stm ^>=2.5.0.1,+ template-haskell >=2.17 && <2.22,+ text >=1.2 && <2.1,+ th-compat >=0.1 && <0.2,+ unix >=2.7 && <2.9,+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Config.hs view
@@ -0,0 +1,66 @@+module Config (+ Config(..),+ findConfig,+ parseConfig,+) where++import Control.Monad.Combinators++import Data.ByteString.Lazy qualified as BS+import Data.Text qualified as T+import Data.YAML++import System.Directory+import System.Exit+import System.FilePath+import System.FilePath.Glob++data Config = Config+ { configTool :: Maybe FilePath+ , configTests :: [Pattern]+ }+ deriving (Show)++instance Semigroup Config where+ a <> b = Config+ { configTool = maybe (configTool b) Just (configTool a)+ , configTests = configTests a ++ configTests b+ }++instance Monoid Config where+ mempty = Config+ { configTool = Nothing+ , configTests = []+ }++instance FromYAML Config where+ parseYAML = withMap "Config" $ \m -> Config+ <$> (fmap T.unpack <$> m .:? "tool")+ <*> (map (compile . T.unpack) <$> foldr1 (<|>)+ [ fmap (:[]) (m .: "tests") -- single pattern+ , m .:? "tests" .!= [] -- list of patterns+ ]+ )++findConfig :: IO (Maybe FilePath)+findConfig = go "."+ where+ name = "erebos-tester.yaml"+ go path = do+ doesFileExist (path </> name) >>= \case+ True -> return $ Just $ path </> name+ False -> doesDirectoryExist (path </> "..") >>= \case+ True -> do+ parent <- canonicalizePath $ path </> ".."+ if parent /= path then go parent+ else return Nothing+ False -> return Nothing++parseConfig :: FilePath -> IO Config+parseConfig path = do+ contents <- BS.readFile path+ case decode1 contents of+ Left (pos, err) -> do+ putStr $ prettyPosWithSource pos contents err+ exitFailure+ Right conf -> return conf
+ src/GDB.hs view
@@ -0,0 +1,275 @@+module GDB (+ GDB, gdbProcess,+ gdbStart,+ addInferior,+ gdbSession,+) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Identity+import Control.Monad.Reader++import Data.Char+import Data.List+import Data.Text (Text)+import Data.Text qualified as T+import Data.Void++import Text.Megaparsec hiding (State)+import Text.Megaparsec.Char++import System.Console.Haskeline.Completion+import System.Process++import Output+import Process++data GDB = GDB+ { gdbProcess_ :: Process+ , gdbResult :: MVar (ResultClass, [(Text, MiValue)])+ , gdbInferiors :: MVar [Inferior]+ , gdbThreadGroups :: TChan Text+ , gdbOnCrash :: Process -> IO ()+ }++gdbProcess :: GDB -> Process+gdbProcess = gdbProcess_++data Inferior = Inferior+ { infProcess :: Process+ , infPid :: Pid+ , infThreadGroup :: Text+ , infThreads :: [Text]+ }++data MiRecord = ResultRecord ResultClass [(Text, MiValue)]+ | ExecAsyncOutput Text [(Text, MiValue)]+ | StatusAsyncOutput Text [(Text, MiValue)]+ | NotifyAsyncOutput Text [(Text, MiValue)]+ | ConsoleStreamOutput Text+ | TargetStreamOutput Text+ | LogStreamOutput Text+ deriving (Show)++data ResultClass = Done | Connected | Error | Exit+ deriving (Show)++data MiValue = MiString Text+ | MiTuple [(Text, MiValue)]+ | MiList [MiValue]+ deriving (Show)+++gdbCmd :: String+gdbCmd = "gdb --quiet --interpreter=mi3"++gdbStart :: (MonadOutput m, MonadFail m) => (Process -> IO ()) -> m GDB+gdbStart onCrash = do+ (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell gdbCmd)+ { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe+ }+ pout <- liftIO $ newTVarIO []++ let process = Process+ { procName = ProcNameGDB+ , procHandle = handle+ , procStdin = hin+ , procOutput = pout+ , procKillWith = Nothing+ , procNode = undefined+ }+ gdb <- GDB+ <$> pure process+ <*> liftIO newEmptyMVar+ <*> liftIO (newMVar [])+ <*> liftIO newTChanIO+ <*> pure onCrash++ out <- getOutput+ liftIO $ void $ forkIO $ flip runReaderT out $+ lineReadingLoop process hout $ gdbLine gdb+ liftIO $ void $ forkIO $ flip runReaderT out $+ lineReadingLoop process herr $ outProc OutputChildStderr process++ gdbCommand gdb "-gdb-set schedule-multiple on"+ gdbCommand gdb "-gdb-set mi-async on"+ gdbCommand gdb "-gdb-set non-stop on"+ gdbCommand gdb "-gdb-set print symbol-loading off"++ return gdb++gdbLine :: GDB -> Text -> ReaderT Output IO ()+gdbLine _ "(gdb)" = return ()+gdbLine _ "(gdb) " = return ()+gdbLine gdb rline = either (outProc OutputError (gdbProcess gdb) . T.pack . errorBundlePretty) go $+ runParser miOutputRecord "" rline+ where+ go = \case+ ResultRecord cls params -> liftIO $ putMVar (gdbResult gdb) (cls, params)+ ExecAsyncOutput cls params -> (cls,) <$> liftIO (readMVar (gdbInferiors gdb)) >>= \case+ ("stopped", infs)+ | Just (MiString "signal-received") <- lookup "reason" params+ , Just (MiString tid) <- lookup "thread-id" params+ , Just inf <- find (elem tid . infThreads) infs+ -> do+ -- It is needed to switch thread manually in non-stop mode,+ -- fork to avoid blocking further input and reply processing.+ out <- getOutput+ void $ liftIO $ forkIO $ do+ flip runReaderT out $ do+ gdbCommand gdb $ "-thread-select " <> tid+ gdbOnCrash gdb $ infProcess inf+ _ -> return ()+ StatusAsyncOutput cls params -> outProc OutputChildInfo (gdbProcess gdb) $ "status: " <> cls <> " " <> T.pack (show params)+ NotifyAsyncOutput cls params -> case cls of+ "thread-group-added" | Just (MiString tgid) <- lookup "id" params -> do+ liftIO $ atomically $ writeTChan (gdbThreadGroups gdb) tgid+ "thread-group-exited" | Just (MiString tgid) <- lookup "id" params -> do+ liftIO $ modifyMVar_ (gdbInferiors gdb) $ return . filter ((/=tgid) . infThreadGroup)+ "thread-created"+ | Just (MiString tid) <- lookup "id" params+ , Just (MiString tgid) <- lookup "group-id" params+ -> liftIO $ modifyMVar_ (gdbInferiors gdb) $ return . map (\inf -> if infThreadGroup inf == tgid then inf { infThreads = tid : infThreads inf } else inf)+ "thread-exited"+ | Just (MiString tid) <- lookup "id" params+ , Just (MiString tgid) <- lookup "group-id" params+ -> liftIO $ modifyMVar_ (gdbInferiors gdb) $ return . map (\inf -> if infThreadGroup inf == tgid then inf { infThreads = filter (/=tid) $ infThreads inf } else inf)+ _ -> return ()+ ConsoleStreamOutput line -> mapM_ (outLine OutputAlways Nothing) (T.lines line)+ TargetStreamOutput line -> mapM_ (outProc OutputChildStderr (gdbProcess gdb) . ("target-stream: " <>)) (T.lines line)+ LogStreamOutput line -> mapM_ (outProc OutputChildInfo (gdbProcess gdb) . ("log: " <>)) (T.lines line)++addInferior :: MonadOutput m => GDB -> Process -> m ()+addInferior gdb process = do+ liftIO (getPid $ procHandle process) >>= \case+ Nothing -> outProc OutputError process $ "failed to get PID"+ Just pid -> do+ tgid <- liftIO (atomically $ tryReadTChan $ gdbThreadGroups gdb) >>= \case+ Just tgid -> return tgid+ Nothing -> do+ gdbCommand gdb $ "-add-inferior"+ liftIO $ atomically $ readTChan $ gdbThreadGroups gdb++ liftIO $ modifyMVar_ (gdbInferiors gdb) $ return . (:) Inferior+ { infProcess = process+ , infPid = pid+ , infThreadGroup = tgid+ , infThreads = []+ }++ gdbCommand gdb $ "-target-attach --thread-group " <> tgid <> " " <> T.pack (show pid)+ gdbCommand gdb $ "-exec-continue --thread-group " <> tgid++gdbCommandRes :: MonadIO m => GDB -> Text -> m (ResultClass, [(Text, MiValue)])+gdbCommandRes gdb cmd = do+ send (gdbProcess gdb) cmd+ liftIO (takeMVar (gdbResult gdb))++gdbCommand :: MonadOutput m => GDB -> Text -> m ()+gdbCommand gdb cmd = do+ gdbCommandRes gdb cmd >>= \case+ (Done, _) -> return ()+ (Connected, _) -> outProc OutputChildInfo (gdbProcess gdb) "result connected"+ (Error, _) -> outProc OutputError (gdbProcess gdb) $ "command error: " <> cmd+ (Exit, _) -> outProc OutputError (gdbProcess gdb) "result exit"++gdbSession :: MonadOutput m => GDB -> m ()+gdbSession gdb = loop ""+ where+ loop prev = outPromptGetLineCompletion (gdbCompletion gdb) "gdb> " >>= \case+ Just line -> do+ let cmd = if T.null line then prev else line+ gdbCommand gdb ("-interpreter-exec console \"" <> cmd <> "\"")+ loop cmd+ Nothing -> return ()++gdbCompletion :: GDB -> CompletionFunc IO+gdbCompletion gdb (revcmd, _) = do+ gdbCommandRes gdb ("-complete " <> T.pack (show (reverse revcmd))) >>= \case+ (Done, resp)+ | Just (MiList matches) <- lookup "matches" resp -> do+ return ("", concatMap (\case MiString m -> [Completion (T.unpack m) (T.unpack m) False]; _ -> []) matches)+ _ -> return ("", [])+++type MiParser = ParsecT Void MiStream Identity++type MiStream = Text++miOutputRecord :: MiParser MiRecord+miOutputRecord = choice+ [ miResultRecord+ , miExecAsync+ , miStatusAsync+ , miNotifyAsync+ , miConsoleStream+ , miTargetStream+ , miLogStream+ ]++miResultRecord :: MiParser MiRecord+miResultRecord = char '^' >> ResultRecord <$> resultClass <*> many (char ',' *> result)++miExecAsync, miStatusAsync, miNotifyAsync :: MiParser MiRecord+miExecAsync = char '*' >> ExecAsyncOutput <$> miString <*> many (char ',' *> result)+miStatusAsync = char '+' >> StatusAsyncOutput <$> miString <*> many (char ',' *> result)+miNotifyAsync = char '=' >> NotifyAsyncOutput <$> miString <*> many (char ',' *> result)++miConsoleStream, miTargetStream, miLogStream :: MiParser MiRecord+miConsoleStream = char '~' >> ConsoleStreamOutput <$> miCString+miTargetStream = char '@' >> TargetStreamOutput <$> miCString+miLogStream = char '&' >> LogStreamOutput <$> miCString++resultClass :: MiParser ResultClass+resultClass = label "result-class" $ choice+ [ return Done <* string "done"+ , return Done <* string "running" -- equivalent to "done" per documentation+ , return Connected <* string "connected"+ , return Error <* string "error"+ , return Exit <* string "exit"+ ]++result :: MiParser (Text, MiValue)+result = (,) <$> miString <* char '=' <*> miValue++miString :: MiParser Text+miString = label "string" $ takeWhile1P Nothing (\x -> isAlphaNum x || x == '_' || x == '-')++miCString :: MiParser Text+miCString = label "c-string" $ do+ void $ char '"'+ let go = choice+ [ char '"' >> return []+ , takeWhile1P Nothing (`notElem` ['\"', '\\']) >>= \s -> (s:) <$> go+ ,do void $ char '\\'+ c <- choice+ [ char '\\' >> return '\\'+ , char '"' >> return '"'+ , char 'n' >> return '\n'+ , char 'r' >> return '\r'+ , char 't' >> return '\t'+ ]+ ((T.singleton c) :) <$> go+ ]+ T.concat <$> go++listOf :: MiParser a -> MiParser [a]+listOf item = do+ x <- item+ (x:) <$> choice [ char ',' >> listOf item, return [] ]++miTuple :: MiParser [(Text, MiValue)]+miTuple = between (char '{') (char '}') $ listOf result <|> return []++miList :: MiParser [MiValue]+miList = between (char '[') (char ']') $ listOf miValue <|> return []++miValue :: MiParser MiValue+miValue = choice+ [ MiString <$> miCString+ , MiTuple <$> miTuple+ , MiList <$> miList+ ]
+ src/GDB.hs-boot view
@@ -0,0 +1,8 @@+module GDB where++import Output+import {-# SOURCE #-} Process++data GDB+gdbSession :: MonadOutput m => GDB -> m ()+addInferior :: MonadOutput m => GDB -> Process -> m ()
+ src/Main.hs view
@@ -0,0 +1,140 @@+module Main (main) where++import Control.Monad++import Data.Maybe+import qualified Data.Text as T++import Text.Read (readMaybe)++import System.Console.GetOpt+import System.Directory+import System.Environment+import System.Exit+import System.FilePath+import System.FilePath.Glob+import System.IO++import Config+import Output+import Parser+import Process+import Run+import Test+import Util+import Version++data CmdlineOptions = CmdlineOptions+ { optTest :: TestOptions+ , optRepeat :: Int+ , optVerbose :: Bool+ , optShowHelp :: Bool+ , optShowVersion :: Bool+ }++defaultCmdlineOptions :: CmdlineOptions+defaultCmdlineOptions = CmdlineOptions+ { optTest = defaultTestOptions+ , optRepeat = 1+ , optVerbose = False+ , optShowHelp = False+ , optShowVersion = False+ }++options :: [OptDescr (CmdlineOptions -> CmdlineOptions)]+options =+ [ Option ['T'] ["tool"]+ (ReqArg (\str -> to $ \opts -> case break (==':') str of+ (path, []) -> opts { optDefaultTool = path }+ (pname, (_:path)) -> opts { optProcTools = (ProcName (T.pack pname), path) : optProcTools opts }+ ) "PATH")+ "test tool to be used"+ , Option ['v'] ["verbose"]+ (NoArg (\opts -> opts { optVerbose = True }))+ "show output of processes and successful tests"+ , Option ['t'] ["timeout"]+ (ReqArg (\str -> to $ \opts -> case readMaybe str of+ Just timeout -> opts { optTimeout = timeout }+ Nothing -> error "timeout must be a number") "SECONDS")+ "default timeout in seconds with microsecond precision"+ , Option ['g'] ["gdb"]+ (NoArg $ to $ \opts -> opts { optGDB = True })+ "run GDB and attach spawned processes"+ , Option ['f'] ["force"]+ (NoArg $ to $ \opts -> opts { optForce = True })+ "remove test directory if it already exists instead of stopping"+ , Option ['k'] ["keep"]+ (NoArg $ to $ \opts -> opts { optKeep = True })+ "keep test directory even if all tests succeed"+ , Option ['r'] ["repeat"]+ (ReqArg (\str opts -> opts { optRepeat = read str }) "COUNT")+ "number of times to repeat the test(s)"+ , Option [] ["wait"]+ (NoArg $ to $ \opts -> opts { optWait = True })+ "wait at the end of each test"+ , Option ['h'] ["help"]+ (NoArg $ \opts -> opts { optShowHelp = True })+ "show this help and exit"+ , Option ['V'] ["version"]+ (NoArg $ \opts -> opts { optShowVersion = True })+ "show version and exit"+ ]+ where+ to f opts = opts { optTest = f (optTest opts) }++main :: IO ()+main = do+ configPath <- findConfig+ config <- mapM parseConfig configPath+ let baseDir = maybe "." dropFileName configPath++ envtool <- lookupEnv "EREBOS_TEST_TOOL" >>= \mbtool ->+ return $ fromMaybe (error "No test tool defined") $ mbtool `mplus` (return . (baseDir </>) =<< configTool =<< config)++ let initOpts = defaultCmdlineOptions+ { optTest = defaultTestOptions+ { optDefaultTool = envtool+ , optTestDir = normalise $ baseDir </> optTestDir defaultTestOptions+ }+ }++ args <- getArgs+ (opts, ofiles) <- case getOpt Permute options args of+ (o, files, []) -> return (foldl (flip id) initOpts o, files)+ (_, _, errs) -> do+ hPutStrLn stderr $ concat errs <> "Try `erebos-tester --help' for more information."+ exitFailure++ when (optShowHelp opts) $ do+ let header = "Usage: erebos-tester [OPTION...]"+ putStrLn $ usageInfo header options+ exitSuccess++ when (optShowVersion opts) $ do+ putStrLn versionLine+ exitSuccess++ getPermissions (head $ words $ optDefaultTool $ optTest opts) >>= \perms -> do+ when (not $ executable perms) $ do+ fail $ optDefaultTool (optTest opts) <> " is not executable"++ files <- if not (null ofiles)+ then return $ flip map ofiles $ \ofile ->+ case span (/= ':') ofile of+ (path, ':':test) -> (path, Just $ T.pack test)+ (path, _) -> (path, Nothing)+ else map (, Nothing) . concat <$> mapM (flip globDir1 baseDir) (maybe [] configTests config)++ when (null files) $ fail $ "No test files"++ out <- startOutput $ optVerbose opts++ tests <- forM files $ \(path, mbTestName) -> do+ fileTests <- parseTestFile path+ return $ case mbTestName of+ Nothing -> fileTests+ Just name -> filter ((==name) . testName) fileTests++ ok <- allM (runTest out $ optTest opts) $+ concat $ replicate (optRepeat opts) $ concat tests+ when (not ok) exitFailure
+ src/Network.hs view
@@ -0,0 +1,203 @@+module Network (+ Internet(..),+ Network(..),+ Node(..),+ NodeName(..), textNodeName, unpackNodeName,+ nextNodeName,++ newInternet, delInternet,+ newSubnet,+ newNode,+) where++import Control.Arrow+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Writer++import Data.Text (Text)+import Data.Text qualified as T+import Data.Word++import System.Directory+import System.FilePath+import System.Process++import Network.Ip+import Test++{-+NETWORK STRUCTURE+=================++Local network (namespace "s<PREFIX>", e.g. "s1_2"):++ (upstream, if any) (to subnets, if any and prefix length < 24)+ ↑ veth_s1 (IP: prefix.1(.0)*.254)+ veth0 veth_s2 (IP: prefix.2(.0)*.254) → veth0 in subnet namespace+ | veth_s3 (IP: prefix.3(.0)*.254)+ br0 (IP: prefix(.0)*.1/24) ...+ / | \+ veth2 ... veth253+ ↓ ↓ ↓+ (to nodes)++Node (namespace "s<PREFIX>:<NODE>", e.g. "s1_2:p0"):++ (upstream)+ ↑+ veth0 (IP: prefix.N/24)+-}++data Internet = Internet+ { inetDir :: FilePath+ , inetRoot :: Network+ }++data Network = Network+ { netPrefix :: IpPrefix+ , netNetns :: NetworkNamespace+ , netBridge :: Link Bridge+ , netUpstream :: Maybe (Link VEth)+ , netNodes :: TVar [Node]+ , netSubnets :: TVar [(Word8, Network)]+ , netDir :: FilePath+ }++textNetworkName :: IpPrefix -> Text+textNetworkName (IpPrefix prefix) = T.intercalate "_" (map (T.pack . show) prefix)++data Node = Node+ { nodeIp :: IpAddress+ , nodeName :: NodeName+ , nodeNetns :: NetworkNamespace+ , nodeUpstream :: Link VEth+ , nodeNetwork :: Network+ , nodeDir :: FilePath+ }++data NodeName = NodeName Text Word+ deriving (Eq, Ord)++textNodeName :: NodeName -> Text+textNodeName (NodeName name 0) = name+textNodeName (NodeName name num) = name <> T.pack "~" <> T.pack (show num)++unpackNodeName :: NodeName -> String+unpackNodeName = T.unpack . textNodeName++nextNodeName :: VarName -> [NodeName] -> NodeName+nextNodeName (VarName tname) = go 0+ where+ go n [] = NodeName tname n+ go n (NodeName tname' m : ns) | tname == tname' = go (max n m + 1) ns+ | otherwise = go n ns+++instance HasNetns Network where getNetns = netNetns+instance HasNetns Node where getNetns = nodeNetns++instance ExprType Network where+ textExprType _ = T.pack "network"+ textExprValue n = "s:" <> textNetworkName (netPrefix n)+ emptyVarValue = Network (IpPrefix []) undefined undefined undefined undefined undefined undefined++instance ExprType Node where+ textExprType _ = T.pack "node"+ textExprValue n = T.pack "n:" <> textNodeName (nodeName n)+ emptyVarValue = Node (IpAddress (IpPrefix []) 0) (NodeName T.empty 0) undefined undefined undefined undefined++ recordMembers = map (first T.pack)+ [ ("ip", RecordSelector $ textIpAddress . nodeIp)+ ]+++nextPrefix :: IpPrefix -> [Word8] -> Word8+nextPrefix _ used = maximum (0 : used) + 1++newInternet :: MonadIO m => FilePath -> m Internet+newInternet dir = do+ atomicallyWithIO $ do+ Internet+ <$> pure dir+ <*> newNetwork (IpPrefix [1]) dir++delInternet :: MonadIO m => Internet -> m ()+delInternet _ = liftIO $ do+ callCommand $ "ip -all netns delete"++newSubnet :: MonadIO m => Network -> Maybe VarName -> m Network+newSubnet net vname = atomicallyWithIO $ do+ idx <- lift $ nextPrefix (netPrefix net) . map fst <$> readTVar (netSubnets net)+ sub <- newNetwork+ (ipSubnet idx (netPrefix net))+ (netDir net </> maybe (T.unpack $ textNetnsName $ getNetns net) (("sub_"++) . unpackVarName) vname)+ lift $ modifyTVar (netSubnets net) ((idx, sub) :)++ let lan = lanSubnet $ netPrefix sub+ lanIp = IpAddress lan+ bridge = lanIp 1+ router = lanIp 254++ (vethNet, vethSub) <- addVEth (net, "veth_s" <> T.pack (show idx)) (sub, "veth0")+ addAddress vethNet router+ setMaster vethSub (netBridge sub) -- this end needs to go up first, otherwise it+ linkUp vethSub -- sometimes gets stuck with NO-CARRIER for a while.+ linkUp vethNet++ -- If the new subnet can be split further, routing rule for the whole prefix is needed+ when (allowsSubnets (netPrefix sub)) $ do+ addRoute (netPrefix sub) bridge vethNet router+ addRoute (IpPrefix []) router (netBridge sub) bridge+ return sub { netUpstream = Just vethSub }++newNetwork :: IpPrefix -> FilePath -> WriterT [IO ()] STM Network+newNetwork prefix dir = do+ postpone $ createDirectoryIfMissing True dir++ netns <- addNetworkNamespace ("s" <> textNetworkName prefix)+ bridge <- addBridge netns "br0"++ addAddress bridge $ IpAddress (lanSubnet prefix) 1+ linkUp $ bridge+ linkUp $ loopback netns++ Network+ <$> pure prefix+ <*> pure netns+ <*> pure bridge+ <*> pure Nothing+ <*> lift (newTVar [])+ <*> lift (newTVar [])+ <*> pure dir++newNode :: MonadIO m => Network -> VarName -> m Node+newNode nodeNetwork vname = atomicallyWithIO $ do+ let lan = lanSubnet $ netPrefix nodeNetwork+ lanIp = IpAddress lan++ nodes <- lift $ readTVar (netNodes nodeNetwork)+ let nodeName = nextNodeName vname $ map Network.nodeName nodes+ idx = fromIntegral $ 2 + length nodes+ nodeIp = lanIp idx+ nodeDir = netDir nodeNetwork </> ("node_" ++ unpackNodeName nodeName)+ nodeNetns <- addNetworkNamespace $ textNetnsName (getNetns nodeNetwork) <> ":" <> textNodeName nodeName+ (vethNet, nodeUpstream) <- addVEth (nodeNetwork, "veth" <> T.pack (show idx)) (nodeNetns, "veth0")++ postpone $ do+ exists <- doesPathExist nodeDir+ when exists $ ioError $ userError $ nodeDir ++ " exists"+ createDirectoryIfMissing True nodeDir++ let node = Node {..}+ lift $ writeTVar (netNodes nodeNetwork) (node : nodes)++ setMaster vethNet $ netBridge nodeNetwork+ linkUp vethNet+ addAddress nodeUpstream $ nodeIp+ linkUp $ nodeUpstream+ linkUp $ loopback node+ addRoute (IpPrefix []) (lanIp 1) nodeUpstream nodeIp++ return node
+ src/Network.hs-boot view
@@ -0,0 +1,5 @@+module Network where++data Network+data Node+data NodeName
+ src/Network/Ip.hs view
@@ -0,0 +1,220 @@+module Network.Ip (+ IpPrefix(..),+ textIpNetwork,++ IpAddress(..),+ textIpAddress,+ textIpAddressCidr,++ allowsSubnets,+ ipSubnet,+ lanSubnet,++ MonadPIO(..),+ MonadSTM(..),+ atomicallyWithIO,++ NetworkNamespace,+ HasNetns(..),+ addNetworkNamespace,+ textNetnsName,+ callOn,++ Link(..),+ Loopback, loopback,+ VEth, addVEth,+ Bridge, addBridge,+ addAddress,+ setMaster,+ linkUp, linkDown,++ Route(..),+ addRoute,+) where++import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Writer++import Data.Function+import Data.Text (Text)+import Data.Text qualified as T+import Data.Typeable+import Data.Word++import System.Process++newtype IpPrefix = IpPrefix [Word8]+ deriving (Eq, Ord)++textIpNetwork :: IpPrefix -> Text+textIpNetwork (IpPrefix prefix) =+ T.intercalate "." (map (T.pack . show) $ prefix ++ replicate (4 - length prefix) 0)+ <> "/" <> T.pack (show (8 * length prefix))++data IpAddress = IpAddress IpPrefix Word8+ deriving (Eq, Ord)++textIpAddress :: IpAddress -> Text+textIpAddress (IpAddress (IpPrefix prefix) num) =+ T.intercalate "." $ map (T.pack . show) $ prefix ++ replicate (3 - length prefix) 0 ++ [num]++textIpAddressCidr :: IpAddress -> Text+textIpAddressCidr ip@(IpAddress (IpPrefix prefix) _) =+ textIpAddress ip <> "/" <> T.pack (show (8 * length prefix))++allowsSubnets :: IpPrefix -> Bool+allowsSubnets (IpPrefix prefix) = length prefix < 3++ipSubnet :: Word8 -> IpPrefix -> IpPrefix+ipSubnet num (IpPrefix prefix) = IpPrefix (prefix ++ [num])++lanSubnet :: IpPrefix -> IpPrefix+lanSubnet (IpPrefix prefix) = IpPrefix (take 3 $ prefix ++ repeat 0)+++class Monad m => MonadPIO m where+ postpone :: IO () -> m ()++instance MonadPIO IO where+ postpone = id++instance Monad m => MonadPIO (WriterT [IO ()] m) where+ postpone = tell . (:[])+++class Monad m => MonadSTM m where+ liftSTM :: STM a -> m a++instance MonadSTM STM where+ liftSTM = id++instance MonadSTM m => MonadSTM (WriterT [IO ()] m) where+ liftSTM = lift . liftSTM+++atomicallyWithIO :: MonadIO m => WriterT [IO ()] STM a -> m a+atomicallyWithIO act = liftIO $ do+ (x, fin) <- atomically $ runWriterT act+ sequence_ fin+ return x+++data NetworkNamespace = NetworkNamespace+ { netnsName :: Text+ , netnsRoutesConfigured :: TVar [Route]+ , netnsRoutesActive :: TVar [Route]+ }++instance Eq NetworkNamespace where+ (==) = (==) `on` netnsName++instance Ord NetworkNamespace where+ compare = compare `on` netnsName++class HasNetns a where getNetns :: a -> NetworkNamespace+instance HasNetns NetworkNamespace where getNetns = id++addNetworkNamespace :: (MonadPIO m, MonadSTM m) => Text -> m NetworkNamespace+addNetworkNamespace netnsName = do+ postpone $ callCommand $ T.unpack $ "ip netns add \"" <> netnsName <> "\""+ netnsRoutesConfigured <- liftSTM $ newTVar []+ netnsRoutesActive <- liftSTM $ newTVar []+ return $ NetworkNamespace {..}++textNetnsName :: NetworkNamespace -> Text+textNetnsName = netnsName++callOn :: HasNetns a => a -> Text -> IO ()+callOn n cmd = callCommand $ T.unpack $ "ip netns exec \"" <> ns <> "\" " <> cmd+ where ns = textNetnsName $ getNetns n+++data Link a = Link+ { linkName :: Text+ , linkNetns :: NetworkNamespace+ }+ deriving (Eq)++data SomeLink = forall a. Typeable a => SomeLink (Link a)++instance Eq SomeLink where+ SomeLink a == SomeLink b+ | Just b' <- cast b = a == b'+ | otherwise = False++liftSomeLink :: (forall a. Link a -> b) -> SomeLink -> b+liftSomeLink f (SomeLink x) = f x++instance HasNetns (Link a) where getNetns = linkNetns+instance HasNetns SomeLink where getNetns = liftSomeLink linkNetns++data Loopback++loopback :: HasNetns n => n -> Link Loopback+loopback = Link "lo" . getNetns++data VEth++addVEth :: (HasNetns n, HasNetns n', MonadPIO m) => (n, Text) -> (n', Text) -> m (Link VEth, Link VEth)+addVEth (netns, name) (netns', name') = do+ postpone $ callOn netns $ "ip link add \"" <> name <> "\" type veth peer name \"" <> name' <> "\" netns \"" <> textNetnsName (getNetns netns') <> "\""+ return $ (,)+ (Link name $ getNetns netns )+ (Link name' $ getNetns netns')++data Bridge++addBridge :: (HasNetns n, MonadPIO m) => n -> Text -> m (Link Bridge)+addBridge netns name = do+ postpone $ callOn netns $ "ip link add name \"" <> name <> "\" type bridge"+ return $ Link name $ getNetns netns++addAddress :: MonadPIO m => Link a -> IpAddress -> m ()+addAddress link addr@(IpAddress prefix _) = do+ let bcast = IpAddress prefix 255+ postpone $ callOn link $ "ip addr add " <> textIpAddressCidr addr <> " broadcast " <> textIpAddress bcast <> " dev \"" <> linkName link <> "\""++setMaster :: MonadPIO m => Link a -> Link Bridge -> m ()+setMaster link bridge = postpone $ do+ when (getNetns link /= getNetns bridge) $ fail "link and bridge in different network namespaces"+ callOn link $ "ip link set dev \"" <> linkName link <> "\" master \"" <> linkName bridge <> "\""++linkUp :: (Typeable a, MonadPIO m, MonadSTM m) => Link a -> m ()+linkUp link = do+ routes <- liftSTM $ filter ((== SomeLink link) . routeDev) <$> readTVar (netnsRoutesConfigured (getNetns link))+ liftSTM $ modifyTVar (netnsRoutesActive (getNetns link)) $ (routes ++)+ postpone $ do+ callOn link $ "ip link set dev \"" <> linkName link <> "\" up"+ -- add back routes that were automatically removed by kernel when the link went down+ mapM_ applyRoute routes++linkDown :: (Typeable a, MonadPIO m, MonadSTM m) => Link a -> m ()+linkDown link = do+ -- routes using this device will be automatically removed by kernel+ liftSTM $ modifyTVar (netnsRoutesActive (getNetns link)) $ filter ((/= SomeLink link) . routeDev)+ postpone $ callOn link $ "ip link set dev \"" <> linkName link <> "\" down"+++data Route = Route+ { routePrefix :: IpPrefix+ , routeVia :: IpAddress+ , routeDev :: SomeLink+ , routeSrc :: IpAddress+ }++addRoute :: Typeable a => IpPrefix -> IpAddress -> Link a -> IpAddress -> WriterT [IO ()] STM ()+addRoute routePrefix routeVia link routeSrc = do+ let routeDev = SomeLink link+ route = Route {..}+ lift $ do+ modifyTVar (netnsRoutesConfigured (getNetns link)) (route:)+ modifyTVar (netnsRoutesActive (getNetns link)) (route:)+ postpone $ applyRoute route++applyRoute :: Route -> IO ()+applyRoute route = callOn (routeDev route) $ "ip route add "+ <> textIpNetwork (routePrefix route)+ <> " via " <> textIpAddress (routeVia route)+ <> " dev " <> linkName `liftSomeLink` (routeDev route)+ <> " src " <> textIpAddress (routeSrc route)
+ src/Output.hs view
@@ -0,0 +1,122 @@+module Output (+ Output, OutputType(..),+ MonadOutput(..),+ startOutput,+ outLine,+ outPromptGetLine,+ outPromptGetLineCompletion,+) where++import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader++import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.IO qualified as TL++import System.Console.Haskeline+import System.Console.Haskeline.History++data Output = Output+ { outState :: MVar OutputState+ , outConfig :: OutputConfig+ }++data OutputConfig = OutputConfig+ { outVerbose :: Bool+ }++data OutputState = OutputState+ { outPrint :: TL.Text -> IO ()+ , outHistory :: History+ }++data OutputType = OutputChildStdout+ | OutputChildStderr+ | OutputChildStdin+ | OutputChildInfo+ | OutputChildFail+ | OutputMatch+ | OutputMatchFail+ | OutputError+ | OutputAlways++class MonadIO m => MonadOutput m where+ getOutput :: m Output++instance MonadIO m => MonadOutput (ReaderT Output m) where+ getOutput = ask++startOutput :: Bool -> IO Output+startOutput verbose = Output+ <$> newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory }+ <*> pure OutputConfig { outVerbose = verbose }++outColor :: OutputType -> Text+outColor OutputChildStdout = T.pack "0"+outColor OutputChildStderr = T.pack "31"+outColor OutputChildStdin = T.pack "0"+outColor OutputChildInfo = T.pack "0"+outColor OutputChildFail = T.pack "31"+outColor OutputMatch = T.pack "32"+outColor OutputMatchFail = T.pack "31"+outColor OutputError = T.pack "31"+outColor OutputAlways = "0"++outSign :: OutputType -> Text+outSign OutputChildStdout = T.empty+outSign OutputChildStderr = T.pack "!"+outSign OutputChildStdin = T.empty+outSign OutputChildInfo = T.pack "."+outSign OutputChildFail = T.pack "!!"+outSign OutputMatch = T.pack "+"+outSign OutputMatchFail = T.pack "/"+outSign OutputError = T.pack "!!"+outSign OutputAlways = T.empty++outArr :: OutputType -> Text+outArr OutputChildStdin = "<"+outArr _ = ">"++printWhenQuiet :: OutputType -> Bool+printWhenQuiet = \case+ OutputChildStderr -> True+ OutputChildFail -> True+ OutputMatchFail -> True+ OutputError -> True+ OutputAlways -> True+ _ -> False++ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a+ioWithOutput act = liftIO . act =<< getOutput++outLine :: MonadOutput m => OutputType -> Maybe Text -> Text -> m ()+outLine otype prompt line = ioWithOutput $ \out ->+ when (outVerbose (outConfig out) || printWhenQuiet otype) $ do+ withMVar (outState out) $ \st -> do+ outPrint st $ TL.fromChunks+ [ T.pack "\ESC[", outColor otype, T.pack "m"+ , maybe "" (<> outSign otype <> outArr otype <> " ") prompt+ , line+ , T.pack "\ESC[0m"+ ]++outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text)+outPromptGetLine = outPromptGetLineCompletion noCompletion++outPromptGetLineCompletion :: MonadOutput m => CompletionFunc IO -> Text -> m (Maybe Text)+outPromptGetLineCompletion compl prompt = ioWithOutput $ \out -> do+ st <- takeMVar (outState out)+ (x, st') <- runInputT (setComplete compl defaultSettings) $ do+ p <- getExternalPrint+ putHistory $ outHistory st+ liftIO $ putMVar (outState out) st { outPrint = p . TL.unpack . (<>"\n") }+ x <- getInputLine $ T.unpack prompt+ st' <- liftIO $ takeMVar (outState out)+ hist' <- getHistory+ return (x, st' { outPrint = outPrint st, outHistory = hist' })+ putMVar (outState out) st'+ return $ fmap T.pack x
+ src/Parser.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Parser (+ parseTestFile,+) where++import Control.Monad.State++import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.IO as TL++import Text.Megaparsec hiding (State)++import System.Exit++import Parser.Core+import Parser.Statement+import Test++parseTestDefinition :: TestParser Test+parseTestDefinition = label "test definition" $ toplevel $ do+ block (\name steps -> return $ Test name $ concat steps) header testStep+ where header = do+ wsymbol "test"+ lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':')++parseTestDefinitions :: TestParser [Test]+parseTestDefinitions = do+ tests <- many parseTestDefinition+ eof+ return tests++parseTestFile :: FilePath -> IO [Test]+parseTestFile path = do+ content <- TL.readFile path+ let initState = TestParserState+ { testVars = []+ , testContext = SomeExpr RootNetwork+ }+ case evalState (runParserT parseTestDefinitions path content) initState of+ Left err -> putStr (errorBundlePretty err) >> exitFailure+ Right tests -> return tests
+ src/Parser/Core.hs view
@@ -0,0 +1,86 @@+module Parser.Core where++import Control.Monad+import Control.Monad.State++import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import Data.Typeable+import Data.Void++import Text.Megaparsec hiding (State)+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L++import Network ()+import Test++type TestParser = ParsecT Void TestStream (State TestParserState)++type TestStream = TL.Text++data TestParserState = TestParserState+ { testVars :: [(VarName, SomeExprType)]+ , testContext :: SomeExpr+ }++data SomeExpr = forall a. ExprType a => SomeExpr (Expr a)+data SomeExprType = forall a. ExprType a => SomeExprType (Proxy a)++someEmptyVar :: SomeExprType -> SomeVarValue+someEmptyVar (SomeExprType (Proxy :: Proxy a)) = SomeVarValue $ emptyVarValue @a++textSomeExprType :: SomeExprType -> Text+textSomeExprType (SomeExprType p) = textExprType p++instance MonadEval TestParser where+ lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") (return . someEmptyVar) =<< gets (lookup name . testVars)+ rootNetwork = return emptyVarValue++skipLineComment :: TestParser ()+skipLineComment = L.skipLineComment $ TL.pack "#"++scn :: TestParser ()+scn = L.space space1 skipLineComment empty++sc :: TestParser ()+sc = L.space hspace1 skipLineComment empty++wordChar :: TestParser (Token TestStream)+wordChar = alphaNumChar <|> char '_'++lexeme :: TestParser a -> TestParser a+lexeme = L.lexeme sc++symbol, osymbol, wsymbol :: String -> TestParser ()+symbol str = void $ (string (TL.pack str)) <* sc+osymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy operatorChar) <* sc+wsymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy wordChar) <* sc++operatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s)+operatorChar = satisfy $ (`elem` ['.', '+', '-', '*', '/', '='])+{-# INLINE operatorChar #-}++localState :: TestParser a -> TestParser a+localState inner = do+ s <- get+ x <- inner+ put s+ return x++toplevel :: TestParser a -> TestParser a+toplevel = L.nonIndented scn++block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c+block merge header item = L.indentBlock scn $ do+ h <- header+ choice+ [ do symbol ":"+ return $ L.IndentSome Nothing (merge h) item+ , L.IndentNone <$> merge h []+ ]++listOf :: TestParser a -> TestParser [a]+listOf item = do+ x <- item+ (x:) <$> choice [ symbol "," >> listOf item, return [] ]
+ src/Parser/Expr.hs view
@@ -0,0 +1,315 @@+module Parser.Expr (+ varName,+ newVarName,+ addVarName,++ someExpr,+ typedExpr,+) where++import Control.Applicative (liftA2)+import Control.Monad.Combinators.Expr+import Control.Monad+import Control.Monad.State++import Data.Char+import Data.Maybe+import Data.Scientific+import qualified Data.Set as S+import Data.Text (Text)+import Data.Text qualified as T+import qualified Data.Text.Lazy as TL+import Data.Typeable+import Data.Void++import Text.Megaparsec hiding (State)+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L++import Parser.Core+import Test++identifier :: TestParser Text+identifier = do+ lexeme $ TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')++varName :: TestParser VarName+varName = VarName <$> identifier++newVarName :: forall a. ExprType a => TestParser (TypedVarName a)+newVarName = do+ off <- stateOffset <$> getParserState+ name <- TypedVarName <$> varName+ addVarName off name+ return name++addVarName :: forall a. ExprType a => Int -> TypedVarName a -> TestParser ()+addVarName off (TypedVarName name) = do+ gets (lookup name . testVars) >>= \case+ Just _ -> parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $+ T.pack "variable '" <> textVarName name <> T.pack "' already exists"+ Nothing -> return ()+ modify $ \s -> s { testVars = (name, SomeExprType @a Proxy) : testVars s }++someExpansion :: TestParser SomeExpr+someExpansion = do+ void $ char '$'+ choice+ [do name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')+ SomeVarValue (_ :: a) <- lookupVar name+ return $ SomeExpr $ Variable @a name+ , between (char '{') (char '}') someExpr+ ]++stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a)+stringExpansion tname conv = do+ off <- stateOffset <$> getParserState+ SomeExpr e <- someExpansion+ let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat+ [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ]++ maybe err return $ listToMaybe $ catMaybes $ conv e++numberLiteral :: TestParser SomeExpr+numberLiteral = label "number" $ lexeme $ do+ x <- L.scientific+ choice+ [ return (SomeExpr $ Pure (x / 100)) <* void (char ('%'))+ , if base10Exponent x == 0+ then return $ SomeExpr $ Pure (coefficient x)+ else return $ SomeExpr $ Pure x+ ]++quotedString :: TestParser (Expr Text)+quotedString = label "string" $ lexeme $ do+ void $ char '"'+ let inner = choice+ [ char '"' >> return []+ , takeWhile1P Nothing (`notElem` ['\"', '\\', '$']) >>= \s -> (Pure (TL.toStrict s):) <$> inner+ ,do void $ char '\\'+ c <- choice+ [ char '\\' >> return '\\'+ , char '"' >> return '"'+ , char '$' >> return '$'+ , char 'n' >> return '\n'+ , char 'r' >> return '\r'+ , char 't' >> return '\t'+ ]+ (Pure (T.singleton c) :) <$> inner+ ,do e <- stringExpansion (T.pack "string") $ \e ->+ [ cast e+ , fmap (T.pack . show @Integer) <$> cast e+ , fmap (T.pack . show @Scientific) <$> cast e+ ]+ (e:) <$> inner+ ]+ Concat <$> inner++regex :: TestParser (Expr Regex)+regex = label "regular expression" $ lexeme $ do+ void $ char '/'+ let inner = choice+ [ char '/' >> return []+ , takeWhile1P Nothing (`notElem` ['/', '\\', '$']) >>= \s -> (Pure (RegexPart (TL.toStrict s)) :) <$> inner+ ,do void $ char '\\'+ s <- choice+ [ char '/' >> return (Pure $ RegexPart $ T.singleton '/')+ , anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c])+ ]+ (s:) <$> inner+ ,do e <- stringExpansion (T.pack "regex") $ \e ->+ [ cast e+ , fmap RegexString <$> cast e+ , fmap (RegexString . T.pack . show @Integer) <$> cast e+ , fmap (RegexString . T.pack . show @Scientific) <$> cast e+ ]+ (e:) <$> inner+ ]+ expr <- Regex <$> inner+ _ <- eval expr -- test regex parsing with empty variables+ return expr++list :: TestParser SomeExpr+list = label "list" $ do+ symbol "["+ SomeExpr x <- someExpr++ let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $+ "list range enumeration not defined for '" <> textExprType x <> "'"+ let exprList = foldr (liftA2 (:)) (Pure [])+ SomeExpr <$> choice+ [do symbol "]"+ return $ exprList [x]++ ,do off <- stateOffset <$> getParserState+ osymbol ".."+ ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x+ y <- typedExpr+ symbol "]"+ return $ fromTo <$> x <*> y++ ,do symbol ","+ y <- typedExpr++ choice+ [do symbol "]"+ return $ exprList [x, y]++ ,do off <- stateOffset <$> getParserState+ osymbol ".."+ ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x+ z <- typedExpr+ symbol "]"+ return $ fromThenTo <$> x <*> y <*> z++ ,do symbol ","+ xs <- listOf typedExpr+ symbol "]"+ return $ exprList (x:y:xs)+ ]+ ]++data SomeUnOp = forall a b. (ExprType a, ExprType b) => SomeUnOp (a -> b)++applyUnOp :: forall a b sa.+ (ExprType a, ExprType b, ExprType sa) =>+ (a -> b) -> Expr sa -> Maybe (Expr b)+applyUnOp op x = do+ Refl :: a :~: sa <- eqT+ return $ op <$> x++data SomeBinOp = forall a b c. (ExprType a, ExprType b, ExprType c) => SomeBinOp (a -> b -> c)++applyBinOp :: forall a b c sa sb.+ (ExprType a, ExprType b, ExprType c, ExprType sa, ExprType sb) =>+ (a -> b -> c) -> Expr sa -> Expr sb -> Maybe (Expr c)+applyBinOp op x y = do+ Refl :: a :~: sa <- eqT+ Refl :: b :~: sb <- eqT+ return $ op <$> x <*> y++someExpr :: TestParser SomeExpr+someExpr = join inner <?> "expression"+ where+ inner = makeExprParser term table++ parens = between (symbol "(") (symbol ")")++ term = parens inner <|> literal <|> variable <?> "term"++ table = [ [ recordSelector+ ]+ , [ prefix "-" $ [ SomeUnOp (negate @Integer)+ , SomeUnOp (negate @Scientific)+ ]+ ]+ , [ binary "*" $ [ SomeBinOp ((*) @Integer)+ , SomeBinOp ((*) @Scientific)+ ]+ {- TODO: parsing issues with regular expressions+ , binary "/" $ [ SomeBinOp (div @Integer)+ , SomeBinOp ((/) @Scientific)+ ]+ -}+ ]+ , [ binary "+" $ [ SomeBinOp ((+) @Integer)+ , SomeBinOp ((+) @Scientific)+ ]+ , binary "-" $ [ SomeBinOp ((-) @Integer)+ , SomeBinOp ((-) @Scientific)+ ]+ ]+ , [ binary' "==" (\op xs ys -> length xs == length ys && and (zipWith op xs ys)) $+ [ SomeBinOp ((==) @Integer)+ , SomeBinOp ((==) @Scientific)+ , SomeBinOp ((==) @Text)+ ]+ , binary' "/=" (\op xs ys -> length xs /= length ys || or (zipWith op xs ys)) $+ [ SomeBinOp ((/=) @Integer)+ , SomeBinOp ((/=) @Scientific)+ , SomeBinOp ((/=) @Text)+ ]+ ]+ ]++ prefix :: String -> [SomeUnOp] -> Operator TestParser (TestParser SomeExpr)+ prefix name ops = Prefix $ do+ off <- stateOffset <$> getParserState+ void $ osymbol name+ return $ \p -> do+ SomeExpr e <- p+ let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat+ [T.pack "operator '", T.pack name, T.pack "' not defined for '", textExprType e, T.pack "'"]+ maybe err return $ listToMaybe $ catMaybes $ map (\(SomeUnOp op) -> SomeExpr <$> applyUnOp op e) ops++ binary :: String -> [SomeBinOp] -> Operator TestParser (TestParser SomeExpr)+ binary name = binary' name (undefined :: forall a b. (a -> b -> Void) -> [a] -> [b] -> Integer)+ -- use 'Void' that can never match actually used type to disable recursion++ binary' :: forall c c'. (Typeable c, ExprType c')+ => String+ -> (forall a b. (a -> b -> c) -> [a] -> [b] -> c')+ -> [SomeBinOp]+ -> Operator TestParser (TestParser SomeExpr)+ binary' name listmap ops = InfixL $ do+ off <- stateOffset <$> getParserState+ void $ osymbol name++ return $ \p q -> do+ SomeExpr e <- p+ SomeExpr f <- q++ let eqT' :: forall r s t. (Typeable r, Typeable s, Typeable t) => (r -> s -> t) -> Maybe ((r -> s -> t) :~: (r -> s -> c))+ eqT' _ = eqT++ let proxyOf :: proxy a -> Proxy a+ proxyOf _ = Proxy++ let tryop :: forall a b d sa sb.+ (ExprType a, ExprType b, ExprType d, ExprType sa, ExprType sb) =>+ (a -> b -> d) -> Proxy sa -> Proxy sb -> Maybe SomeExpr+ tryop op pe pf = msum+ [ SomeExpr <$> applyBinOp op e f+ , do Refl <- eqT' op+ ExprListUnpacker _ une <- exprListUnpacker pe+ ExprListUnpacker _ unf <- exprListUnpacker pf+ tryop (listmap op) (une pe) (unf pf)+ ]++ let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat+ [T.pack "operator '", T.pack name, T.pack "' not defined for '", textExprType e, T.pack "' and '", textExprType f, T.pack "'"]+ maybe err return $ listToMaybe $ catMaybes $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops++ recordSelector :: Operator TestParser (TestParser SomeExpr)+ recordSelector = Postfix $ fmap (foldl1 (flip (.))) $ some $ do+ void $ osymbol "."+ off <- stateOffset <$> getParserState+ m <- identifier+ return $ \p -> do+ SomeExpr e <- p+ let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat+ [ T.pack "value of type ", textExprType e, T.pack " does not have member '", m, T.pack "'" ]+ maybe err return $ applyRecordSelector m e <$> lookup m recordMembers++ applyRecordSelector :: ExprType a => Text -> Expr a -> RecordSelector a -> SomeExpr+ applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e++ literal = label "literal" $ choice+ [ return <$> numberLiteral+ , return . SomeExpr <$> quotedString+ , return . SomeExpr <$> regex+ , return <$> list+ ]++ variable = label "variable" $ do+ name <- varName+ SomeVarValue (_ :: a) <- lookupVar name+ return $ return $ SomeExpr $ Variable @a name++typedExpr :: forall a. ExprType a => TestParser (Expr a)+typedExpr = do+ off <- stateOffset <$> getParserState+ SomeExpr e <- someExpr+ let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat+ [ T.pack "expected '", textExprType @a Proxy, T.pack "', expression has type '", textExprType e, T.pack "'" ]+ maybe err return $ cast e
+ src/Parser/Statement.hs view
@@ -0,0 +1,367 @@+module Parser.Statement (+ testStep,+) where++import Control.Monad+import Control.Monad.Identity+import Control.Monad.State++import Data.Kind+import Data.Maybe+import qualified Data.Set as S+import Data.Text qualified as T+import qualified Data.Text.Lazy as TL+import Data.Typeable++import Text.Megaparsec hiding (State)+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L++import Network (Network, Node)+import Parser.Core+import Parser.Expr+import Process (Process)+import Test+import Util++getSourceLine :: TestParser SourceLine+getSourceLine = do+ pstate <- statePosState <$> getParserState+ return $ SourceLine $ T.concat+ [ T.pack $ sourcePosPretty $ pstateSourcePos pstate+ , T.pack ": "+ , TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate+ ]+++letStatement :: TestParser [TestStep]+letStatement = do+ line <- getSourceLine+ indent <- L.indentLevel+ wsymbol "let"+ off <- stateOffset <$> getParserState+ name <- varName+ osymbol "="+ SomeExpr e <- someExpr++ localState $ do+ let tname = TypedVarName name+ addVarName off tname+ void $ eol+ body <- testBlock indent+ return [Let line tname e body]++forStatement :: TestParser [TestStep]+forStatement = do+ line <- getSourceLine+ ref <- L.indentLevel+ wsymbol "for"+ voff <- stateOffset <$> getParserState+ name <- varName++ wsymbol "in"+ loff <- stateOffset <$> getParserState+ SomeExpr e <- someExpr+ let err = parseError $ FancyError loff $ S.singleton $ ErrorFail $ T.unpack $+ "expected a list, expression has type '" <> textExprType e <> "'"+ ExprListUnpacker unpack _ <- maybe err return $ exprListUnpacker e++ symbol ":"+ scn+ indent <- L.indentGuard scn GT ref+ localState $ do+ let tname = TypedVarName name+ addVarName voff tname+ body <- testBlock indent+ return [For line tname (unpack <$> e) body]++class (Typeable a, Typeable (ParamRep a)) => ParamType a where+ type ParamRep a :: Type+ type ParamRep a = a++ parseParam :: proxy a -> TestParser (ParamRep a)+ showParamType :: proxy a -> String++ paramDefault :: proxy a -> TestParser (ParamRep a)+ paramDefault _ = mzero++ paramFromSomeExpr :: proxy a -> SomeExpr -> Maybe (ParamRep a)+ paramFromSomeExpr _ (SomeExpr e) = cast e++instance ParamType SourceLine where+ parseParam _ = mzero+ showParamType _ = "<source line>"++instance ExprType a => ParamType (TypedVarName a) where+ parseParam _ = newVarName+ showParamType _ = "<variable>"++instance ExprType a => ParamType (Expr a) where+ parseParam _ = typedExpr+ showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">"++instance ParamType a => ParamType [a] where+ type ParamRep [a] = [ParamRep a]+ parseParam _ = listOf (parseParam @a Proxy)+ showParamType _ = showParamType @a Proxy ++ " [, " ++ showParamType @a Proxy ++ " ...]"+ paramDefault _ = return []+ paramFromSomeExpr _ se@(SomeExpr e) = cast e <|> ((:[]) <$> paramFromSomeExpr @a Proxy se)++instance ParamType a => ParamType (Maybe a) where+ type ParamRep (Maybe a) = Maybe (ParamRep a)+ parseParam _ = Just <$> parseParam @a Proxy+ showParamType _ = showParamType @a Proxy+ paramDefault _ = return Nothing+ paramFromSomeExpr _ se = Just <$> paramFromSomeExpr @a Proxy se++instance (ParamType a, ParamType b) => ParamType (Either a b) where+ type ParamRep (Either a b) = Either (ParamRep a) (ParamRep b)+ parseParam _ = try (Left <$> parseParam @a Proxy) <|> (Right <$> parseParam @b Proxy)+ showParamType _ = showParamType @a Proxy ++ " or " ++ showParamType @b Proxy+ paramFromSomeExpr _ se = (Left <$> paramFromSomeExpr @a Proxy se) <|> (Right <$> paramFromSomeExpr @b Proxy se)++data SomeParam f = forall a. ParamType a => SomeParam (Proxy a) (f (ParamRep a))++data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> a)++instance Functor CommandDef where+ fmap f (CommandDef types ctor) = CommandDef types (f . ctor)++instance Applicative CommandDef where+ pure x = CommandDef [] (\case [] -> x; _ -> error "command arguments mismatch")+ CommandDef types1 ctor1 <*> CommandDef types2 ctor2 =+ CommandDef (types1 ++ types2) $ \params ->+ let (params1, params2) = splitAt (length types1) params+ in ctor1 params1 $ ctor2 params2++param :: forall a. ParamType a => String -> CommandDef a+param name = CommandDef [(name, SomeParam (Proxy @a) Proxy)] $ \case+ [SomeParam Proxy (Identity x)] -> fromJust $ cast x+ _ -> error "command arguments mismatch"++data ParamOrContext a++instance ParamType a => ParamType (ParamOrContext a) where+ type ParamRep (ParamOrContext a) = ParamRep a+ parseParam _ = parseParam @a Proxy+ showParamType _ = showParamType @a Proxy+ paramDefault _ = gets testContext >>= \case+ se@(SomeExpr ctx)+ | Just e <- paramFromSomeExpr @a Proxy se -> return e+ | otherwise -> fail $ showParamType @a Proxy <> " not available from context type '" <> T.unpack (textExprType ctx) <> "'"++paramOrContext :: forall a. ParamType a => String -> CommandDef a+paramOrContext name = CommandDef [(name, SomeParam (Proxy @(ParamOrContext a)) Proxy)] $ \case+ [SomeParam Proxy (Identity x)] -> fromJust $ cast x+ _ -> error "command arguments mismatch"++cmdLine :: CommandDef SourceLine+cmdLine = param ""++data InnerBlock++instance ParamType InnerBlock where+ type ParamRep InnerBlock = [TestStep]+ parseParam _ = mzero+ showParamType _ = "<code block>"++instance ParamType TestStep where+ parseParam _ = mzero+ showParamType _ = "<code line>"++innerBlock :: CommandDef [TestStep]+innerBlock = CommandDef [("", SomeParam (Proxy @InnerBlock) Proxy)] $ \case+ [SomeParam Proxy (Identity x)] -> fromJust $ cast x+ _ -> error "command arguments mismatch"++command :: String -> CommandDef TestStep -> TestParser [TestStep]+command name (CommandDef types ctor) = do+ indent <- L.indentLevel+ line <- getSourceLine+ wsymbol name+ localState $ do+ restOfLine indent [] line $ map (fmap $ \(SomeParam p@(_ :: Proxy p) Proxy) -> SomeParam p $ Nothing @(ParamRep p)) types+ where+ restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser [TestStep]+ restOfLine cmdi partials line params = choice+ [do void $ lookAhead eol+ iparams <- forM params $ \case+ (_, SomeParam (p :: Proxy p) Nothing)+ | Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam p $ Identity line+ | Just (Refl :: p :~: InnerBlock) <- eqT -> SomeParam p . Identity <$> restOfParts cmdi partials+ (sym, SomeParam p Nothing) -> choice+ [ SomeParam p . Identity <$> paramDefault p+ , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p+ ]+ (_, SomeParam (p :: Proxy p) (Just x)) -> return $ SomeParam p $ Identity x+ return [ctor iparams]++ ,do symbol ":"+ scn+ indent <- L.indentLevel+ restOfParts cmdi ((indent, params) : partials)++ ,do tryParams cmdi partials line [] params+ ]++ restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser [TestStep]+ restOfParts cmdi [] = testBlock cmdi+ restOfParts cmdi partials@((partIndent, params) : rest) = do+ scn+ pos <- L.indentLevel+ line <- getSourceLine+ optional eof >>= \case+ Just _ -> return []+ _ | pos < partIndent -> restOfParts cmdi rest+ | pos == partIndent -> (++) <$> restOfLine cmdi partials line params <*> restOfParts cmdi partials+ | otherwise -> L.incorrectIndent EQ partIndent pos++ tryParam sym (SomeParam (p :: Proxy p) cur) = do+ when (not $ null sym) $ wsymbol sym+ when (isJust cur) $ do+ fail $ "multiple " ++ (if null sym then "unnamed" else "'" ++ sym ++ "'") ++ " parameters"+ SomeParam p . Just <$> parseParam @p Proxy++ tryParams cmdi partIndent line prev ((sym, p) : ps) = choice $+ (if null sym then reverse else id) {- try unnamed parameter as last option -} $+ [do p' <- tryParam sym p+ restOfLine cmdi partIndent line $ concat [reverse prev, [(sym, p')], ps]+ ,do tryParams cmdi partIndent line ((sym, p) : prev) ps+ ]+ tryParams _ _ _ _ [] = mzero++testLocal :: TestParser [TestStep]+testLocal = do+ ref <- L.indentLevel+ wsymbol "local"+ symbol ":"+ void $ eol++ indent <- L.indentGuard scn GT ref+ localState $ testBlock indent++testWith :: TestParser [TestStep]+testWith = do+ ref <- L.indentLevel+ wsymbol "with"++ off <- stateOffset <$> getParserState+ ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr+ let expected =+ [ SomeExprType @Network Proxy+ , SomeExprType @Node Proxy+ , SomeExprType @Process Proxy+ ]+ notAllowed <- flip allM expected $ \case+ SomeExprType (Proxy :: Proxy a) | Just (Refl :: ctxe :~: a) <- eqT -> return False+ _ -> return True+ when notAllowed $ parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $+ "expected " <> T.intercalate ", " (map (("'"<>) . (<>"'") . textSomeExprType) expected) <> ", expression has type '" <> textExprType @ctxe Proxy <> "'"++ symbol ":"+ void $ eol++ indent <- L.indentGuard scn GT ref+ localState $ do+ modify $ \s -> s { testContext = ctx }+ testBlock indent++testSubnet :: TestParser [TestStep]+testSubnet = command "subnet" $ Subnet+ <$> param ""+ <*> paramOrContext "of"+ <*> innerBlock++testNode :: TestParser [TestStep]+testNode = command "node" $ DeclNode+ <$> param ""+ <*> paramOrContext "on"+ <*> innerBlock++testSpawn :: TestParser [TestStep]+testSpawn = command "spawn" $ Spawn+ <$> param "as"+ <*> paramOrContext "on"+ <*> innerBlock++testSend :: TestParser [TestStep]+testSend = command "send" $ Send+ <$> paramOrContext "to"+ <*> param ""++testExpect :: TestParser [TestStep]+testExpect = command "expect" $ Expect+ <$> cmdLine+ <*> paramOrContext "from"+ <*> param ""+ <*> param "capture"+ <*> innerBlock++testFlush :: TestParser [TestStep]+testFlush = command "flush" $ Flush+ <$> paramOrContext "from"+ <*> param ""++testGuard :: TestParser [TestStep]+testGuard = command "guard" $ Guard+ <$> cmdLine+ <*> param ""++testDisconnectNode :: TestParser [TestStep]+testDisconnectNode = command "disconnect_node" $ DisconnectNode+ <$> paramOrContext ""+ <*> innerBlock++testDisconnectNodes :: TestParser [TestStep]+testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes+ <$> paramOrContext ""+ <*> innerBlock++testDisconnectUpstream :: TestParser [TestStep]+testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream+ <$> paramOrContext ""+ <*> innerBlock++testPacketLoss :: TestParser [TestStep]+testPacketLoss = command "packet_loss" $ PacketLoss+ <$> param ""+ <*> paramOrContext "on"+ <*> innerBlock+++testWait :: TestParser [TestStep]+testWait = do+ wsymbol "wait"+ return [Wait]++testBlock :: Pos -> TestParser [TestStep]+testBlock indent = concat <$> go+ where+ go = do+ scn+ pos <- L.indentLevel+ optional eof >>= \case+ Just _ -> return []+ _ | pos < indent -> return []+ | pos == indent -> (:) <$> testStep <*> go+ | otherwise -> L.incorrectIndent EQ indent pos++testStep :: TestParser [TestStep]+testStep = choice+ [ letStatement+ , forStatement+ , testLocal+ , testWith+ , testSubnet+ , testNode+ , testSpawn+ , testSend+ , testExpect+ , testFlush+ , testGuard+ , testDisconnectNode+ , testDisconnectNodes+ , testDisconnectUpstream+ , testPacketLoss+ , testWait+ ]
+ src/Process.hs view
@@ -0,0 +1,152 @@+module Process (+ Process(..),+ ProcName(..),+ textProcName, unpackProcName,+ send,+ outProc,+ lineReadingLoop,+ spawnOn,+ closeProcess,+ withProcess,+) where++import Control.Arrow+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader++import Data.Function+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T++import System.Exit+import System.IO+import System.IO.Error+import System.Posix.Signals+import System.Process++import {-# SOURCE #-} GDB+import Network+import Network.Ip+import Output+import Run.Monad+import Test++data Process = Process+ { procName :: ProcName+ , procHandle :: ProcessHandle+ , procStdin :: Handle+ , procOutput :: TVar [Text]+ , procKillWith :: Maybe Signal+ , procNode :: Node+ }++instance Eq Process where+ (==) = (==) `on` procStdin++instance ExprType Process where+ textExprType _ = T.pack "proc"+ textExprValue n = T.pack "p:" <> textProcName (procName n)+ emptyVarValue = Process (ProcName T.empty) undefined undefined undefined undefined emptyVarValue++ recordMembers = map (first T.pack)+ [ ("node", RecordSelector $ procNode)+ ]+++data ProcName = ProcName Text+ | ProcNameTcpdump+ | ProcNameGDB+ deriving (Eq, Ord)++textProcName :: ProcName -> Text+textProcName (ProcName name) = name+textProcName ProcNameTcpdump = T.pack "tcpdump"+textProcName ProcNameGDB = T.pack "gdb"++unpackProcName :: ProcName -> String+unpackProcName = T.unpack . textProcName++send :: MonadIO m => Process -> Text -> m ()+send p line = liftIO $ do+ T.hPutStrLn (procStdin p) line+ hFlush (procStdin p)++outProc :: MonadOutput m => OutputType -> Process -> Text -> m ()+outProc otype p line = outLine otype (Just $ textProcName $ procName p) line++lineReadingLoop :: MonadOutput m => Process -> Handle -> (Text -> m ()) -> m ()+lineReadingLoop process h act =+ liftIO (tryIOError (T.hGetLine h)) >>= \case+ Left err+ | isEOFError err -> return ()+ | otherwise -> outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err+ Right line -> do+ act line+ lineReadingLoop process h act++spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process+spawnOn target pname killWith cmd = do+ let netns = either getNetns getNetns target+ let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" "+ (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell $ prefix ++ cmd)+ { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe+ , env = Just [("EREBOS_DIR", either netDir nodeDir target)]+ }+ pout <- liftIO $ newTVarIO []++ let process = Process+ { procName = pname+ , procHandle = handle+ , procStdin = hin+ , procOutput = pout+ , procKillWith = killWith+ , procNode = either (const undefined) id target+ }++ forkTest $ lineReadingLoop process hout $ \line -> do+ outProc OutputChildStdout process line+ liftIO $ atomically $ modifyTVar pout (++[line])+ forkTest $ lineReadingLoop process herr $ \line -> do+ case pname of+ ProcNameTcpdump -> return ()+ _ -> outProc OutputChildStderr process line++ asks (teGDB . fst) >>= maybe (return Nothing) (liftIO . tryReadMVar) >>= \case+ Just gdb | ProcName _ <- pname -> addInferior gdb process+ _ -> return ()++ return process++closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Process -> m ()+closeProcess p = do+ liftIO $ hClose $ procStdin p+ case procKillWith p of+ Nothing -> return ()+ Just sig -> liftIO $ getPid (procHandle p) >>= \case+ Nothing -> return ()+ Just pid -> signalProcess sig pid++ liftIO $ void $ forkIO $ do+ threadDelay 1000000+ terminateProcess $ procHandle p+ liftIO (waitForProcess (procHandle p)) >>= \case+ ExitSuccess -> return ()+ ExitFailure code -> do+ outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code+ throwError Failed++withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a+withProcess target pname killWith cmd inner = do+ procVar <- asks $ teProcesses . fst++ process <- spawnOn target pname killWith cmd+ liftIO $ modifyMVar_ procVar $ return . (process:)++ inner process `finally` do+ ps <- liftIO $ takeMVar procVar+ closeProcess process `finally` do+ liftIO $ putMVar procVar $ filter (/=process) ps
+ src/Process.hs-boot view
@@ -0,0 +1,4 @@+module Process where++data Process+data ProcName
+ src/Run.hs view
@@ -0,0 +1,323 @@+module Run (+ module Run.Monad,+ runTest,+) where++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader++import Data.Either+import Data.Map qualified as M+import Data.Maybe+import Data.Set qualified as S+import Data.Scientific+import Data.Text (Text)+import qualified Data.Text as T++import System.Directory+import System.Exit+import System.IO.Error+import System.Posix.Process+import System.Posix.Signals+import System.Process++import GDB+import Network+import Network.Ip+import Output+import Process+import Run.Monad+import Test++runTest :: Output -> TestOptions -> Test -> IO Bool+runTest out opts test = do+ let testDir = optTestDir opts+ when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e ->+ if isDoesNotExistError e then return () else ioError e+ exists <- doesPathExist testDir+ when exists $ ioError $ userError $ testDir ++ " exists"+ createDirectoryIfMissing True testDir++ failedVar <- newTVarIO Nothing+ procVar <- newMVar []++ mgdb <- if optGDB opts+ then flip runReaderT out $ do+ gdb <- gdbStart $ atomically . writeTVar failedVar . Just . ProcessCrashed+ Just . (, gdbProcess gdb) <$> liftIO (newMVar gdb)+ else return Nothing++ let tenv = TestEnv+ { teOutput = out+ , teFailed = failedVar+ , teOptions = opts+ , teProcesses = procVar+ , teGDB = fst <$> mgdb+ }+ tstate = TestState+ { tsNetwork = error "network not initialized"+ , tsVars = []+ , tsNodePacketLoss = M.empty+ , tsDisconnectedUp = S.empty+ , tsDisconnectedBridge = S.empty+ }++ let sigHandler SignalInfo { siginfoSpecific = chld } = do+ processes <- readMVar procVar+ forM_ processes $ \p -> do+ mbpid <- getPid (procHandle p)+ when (mbpid == Just (siginfoPid chld)) $ flip runReaderT out $ do+ let err detail = outProc OutputChildFail p detail+ case siginfoStatus chld of+ Exited ExitSuccess -> outProc OutputChildInfo p $ T.pack $ "child exited successfully"+ Exited (ExitFailure code) -> do+ err $ T.pack $ "child process exited with status " ++ show code+ liftIO $ atomically $ writeTVar (teFailed tenv) $ Just Failed+ Terminated sig _ -> do+ err $ T.pack $ "child terminated with signal " ++ show sig+ liftIO $ atomically $ writeTVar (teFailed tenv) $ Just $ ProcessCrashed p+ Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig+ oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing++ res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do+ withInternet $ \_ -> do+ evalSteps (testSteps test)+ when (optWait opts) $ do+ void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..."++ void $ installHandler processStatusChanged oldHandler Nothing++ Right () <- runExceptT $ flip runReaderT out $ do+ maybe (return ()) (closeProcess . snd) mgdb+ [] <- readMVar procVar++ failed <- atomically $ readTVar (teFailed tenv)+ case (res, failed) of+ (Right (), Nothing) -> do+ when (not $ optKeep opts) $ removeDirectoryRecursive testDir+ return True+ _ -> return False++evalSteps :: [TestStep] -> TestRun ()+evalSteps = mapM_ $ \case+ Let (SourceLine sline) (TypedVarName name) expr inner -> do+ cur <- asks (lookup name . tsVars . snd)+ when (isJust cur) $ do+ outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline+ throwError Failed+ value <- eval expr+ withVar name value $ evalSteps inner++ For (SourceLine sline) (TypedVarName name) expr inner -> do+ cur <- asks (lookup name . tsVars . snd)+ when (isJust cur) $ do+ outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline+ throwError Failed+ value <- eval expr+ forM_ value $ \i -> do+ withVar name i $ evalSteps inner++ Subnet name@(TypedVarName vname) parentExpr inner -> do+ parent <- eval parentExpr+ withSubnet parent (Just name) $ \net -> do+ withVar vname net $ evalSteps inner++ DeclNode name@(TypedVarName vname) net inner -> do+ withNode net (Left name) $ \node -> do+ withVar vname node $ evalSteps inner++ Spawn tvname@(TypedVarName vname@(VarName tname)) target inner -> do+ case target of+ Left net -> withNode net (Right tvname) go+ Right node -> go =<< eval node+ where+ go node = do+ opts <- asks $ teOptions . fst+ let pname = ProcName tname+ tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)+ withProcess (Right node) pname Nothing tool $ \p -> do+ withVar vname p (evalSteps inner)++ Send pname expr -> do+ p <- eval pname+ line <- eval expr+ outProc OutputChildStdin p line+ send p line++ Expect line pname expr captures inner -> do+ p <- eval pname+ expect line p expr captures $ evalSteps inner++ Flush pname expr -> do+ p <- eval pname+ flush p expr++ Guard line expr -> do+ testStepGuard line expr++ DisconnectNode node inner -> do+ n <- eval node+ withDisconnectedUp (nodeUpstream n) $ evalSteps inner++ DisconnectNodes net inner -> do+ n <- eval net+ withDisconnectedBridge (netBridge n) $ evalSteps inner++ DisconnectUpstream net inner -> do+ n <- eval net+ case netUpstream n of+ Just link -> withDisconnectedUp link $ evalSteps inner+ Nothing -> evalSteps inner++ PacketLoss loss node inner -> do+ l <- eval loss+ n <- eval node+ withNodePacketLoss n l $ evalSteps inner++ Wait -> do+ void $ outPromptGetLine "Waiting..."+++withVar :: ExprType e => VarName -> e -> TestRun a -> TestRun a+withVar name value = local (fmap $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s })++withInternet :: (Network -> TestRun a) -> TestRun a+withInternet inner = do+ testDir <- asks $ optTestDir . teOptions . fst+ inet <- newInternet testDir+ res <- withNetwork (inetRoot inet) $ \net -> do+ local (fmap $ \s -> s { tsNetwork = net }) $ inner net+ delInternet inet+ return res++withSubnet :: Network -> Maybe (TypedVarName Network) -> (Network -> TestRun a) -> TestRun a+withSubnet parent tvname inner = do+ net <- newSubnet parent (fromTypedVarName <$> tvname)+ withNetwork net inner++withNetwork :: Network -> (Network -> TestRun a) -> TestRun a+withNetwork net inner = do+ tcpdump <- liftIO (findExecutable "tcpdump") >>= return . \case+ Just path -> withProcess (Left net) ProcNameTcpdump (Just softwareTermination)+ (path ++ " -i br0 -w '" ++ netDir net ++ "/br0.pcap' -U -Z root") . const+ Nothing -> id++ tcpdump $ inner net++withNode :: Expr Network -> Either (TypedVarName Node) (TypedVarName Process) -> (Node -> TestRun a) -> TestRun a+withNode netexpr tvname inner = do+ net <- eval netexpr+ node <- newNode net (either fromTypedVarName fromTypedVarName tvname)+ either (flip withVar node . fromTypedVarName) (const id) tvname $ inner node++withDisconnectedUp :: Link VEth -> TestRun a -> TestRun a+withDisconnectedUp link inner = do+ let netns = getNetns link+ disconnected <- asks $ S.member netns . tsDisconnectedUp . snd+ if disconnected+ then inner+ else do+ local (fmap $ \s -> s { tsDisconnectedUp = S.insert netns $ tsDisconnectedUp s }) $ do+ atomicallyWithIO $ linkDown link+ x <- inner+ atomicallyWithIO $ linkUp link+ return x++withDisconnectedBridge :: Link Bridge -> TestRun a -> TestRun a+withDisconnectedBridge bridge inner = do+ let netns = getNetns bridge+ disconnected <- asks $ S.member netns . tsDisconnectedBridge . snd+ if disconnected+ then inner+ else do+ local (fmap $ \s -> s { tsDisconnectedBridge = S.insert netns $ tsDisconnectedBridge s }) $ do+ atomicallyWithIO $ linkDown bridge+ x <- inner+ atomicallyWithIO $ linkUp bridge+ return x++withNodePacketLoss :: Node -> Scientific -> TestRun a -> TestRun a+withNodePacketLoss node loss inner = do+ x <- local (fmap $ \s -> s { tsNodePacketLoss = M.insertWith (\l l' -> 1 - (1 - l) * (1 - l')) (getNetns node) loss $ tsNodePacketLoss s }) $ do+ resetLoss+ inner+ resetLoss+ return x+ where+ resetLoss = do+ tl <- asks $ fromMaybe 0 . M.lookup (getNetns node) . tsNodePacketLoss . snd+ liftIO $ callOn node $ "tc qdisc replace dev veth0 root netem loss " <> T.pack (show (tl * 100)) <> "%"+++atomicallyTest :: STM a -> TestRun a+atomicallyTest act = do+ failedVar <- asks $ teFailed . fst+ res <- liftIO $ atomically $ do+ readTVar failedVar >>= \case+ Just e -> return $ Left e+ Nothing -> Right <$> act+ case res of+ Left e -> throwError e+ Right x -> return x++tryMatch :: Regex -> [Text] -> Maybe ((Text, [Text]), [Text])+tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just ((x, capture), xs)+ | otherwise = fmap (x:) <$> tryMatch re xs+tryMatch _ [] = Nothing++exprFailed :: Text -> SourceLine -> Maybe ProcName -> Expr a -> TestRun ()+exprFailed desc (SourceLine sline) pname expr = do+ let prompt = maybe T.empty textProcName pname+ exprVars <- gatherVars expr+ outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", sline]+ forM_ exprVars $ \((name, sel), value) ->+ outLine OutputMatchFail (Just prompt) $ T.concat [" ", textVarName name, T.concat (map ("."<>) sel), " = ", textSomeVarValue value]+ throwError Failed++expect :: SourceLine -> Process -> Expr Regex -> [TypedVarName Text] -> TestRun () -> TestRun ()+expect (SourceLine sline) p expr tvars inner = do+ re <- eval expr+ timeout <- asks $ optTimeout . teOptions . fst+ delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout+ mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do+ line <- readTVar (procOutput p)+ case tryMatch re line of+ Nothing -> retry+ Just (m, out') -> do+ writeTVar (procOutput p) out'+ return $ Just m+ case mbmatch of+ Just (line, capture) -> do+ let vars = map (\(TypedVarName n) -> n) tvars++ when (length vars /= length capture) $ do+ outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` sline+ throwError Failed++ forM_ vars $ \name -> do+ cur <- asks (lookup name . tsVars . snd)+ when (isJust cur) $ do+ outProc OutputError p $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline+ throwError Failed++ outProc OutputMatch p line+ local (fmap $ \s -> s { tsVars = zip vars (map SomeVarValue capture) ++ tsVars s }) inner++ Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) expr++flush :: Process -> Maybe (Expr Regex) -> TestRun ()+flush p mbexpr = do+ mbre <- sequence $ fmap eval mbexpr+ atomicallyTest $ do+ writeTVar (procOutput p) =<< case mbre of+ Nothing -> return []+ Just re -> filter (isLeft . regexMatch re) <$> readTVar (procOutput p)++testStepGuard :: SourceLine -> Expr Bool -> TestRun ()+testStepGuard sline expr = do+ x <- eval expr+ when (not x) $ exprFailed (T.pack "guard") sline Nothing expr
+ src/Run/Monad.hs view
@@ -0,0 +1,118 @@+module Run.Monad (+ TestRun(..),+ TestEnv(..),+ TestState(..),+ TestOptions(..), defaultTestOptions,+ Failed(..),++ finally,+ forkTest,+) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader++import Data.Map (Map)+import Data.Set (Set)+import Data.Scientific+import qualified Data.Text as T++import {-# SOURCE #-} GDB+import {-# SOURCE #-} Network+import Network.Ip+import Output+import {-# SOURCE #-} Process+import Test++newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a }+ deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO)++data TestEnv = TestEnv+ { teOutput :: Output+ , teFailed :: TVar (Maybe Failed)+ , teOptions :: TestOptions+ , teProcesses :: MVar [Process]+ , teGDB :: Maybe (MVar GDB)+ }++data TestState = TestState+ { tsNetwork :: Network+ , tsVars :: [(VarName, SomeVarValue)]+ , tsDisconnectedUp :: Set NetworkNamespace+ , tsDisconnectedBridge :: Set NetworkNamespace+ , tsNodePacketLoss :: Map NetworkNamespace Scientific+ }++data TestOptions = TestOptions+ { optDefaultTool :: String+ , optProcTools :: [(ProcName, String)]+ , optTestDir :: FilePath+ , optTimeout :: Scientific+ , optGDB :: Bool+ , optForce :: Bool+ , optKeep :: Bool+ , optWait :: Bool+ }++defaultTestOptions :: TestOptions+defaultTestOptions = TestOptions+ { optDefaultTool = ""+ , optProcTools = []+ , optTestDir = ".test"+ , optTimeout = 1+ , optGDB = False+ , optForce = False+ , optKeep = False+ , optWait = False+ }++data Failed = Failed+ | ProcessCrashed Process++instance MonadFail TestRun where+ fail str = do+ outLine OutputError Nothing $ T.pack str+ throwError Failed++instance MonadError Failed TestRun where+ throwError failed = do+ failedVar <- asks $ teFailed . fst+ liftIO $ atomically $ modifyTVar failedVar (`mplus` Just failed)++ te <- asks fst+ case failed of+ ProcessCrashed _ | Just mgdb <- teGDB te -> do+ maybe (return ()) gdbSession =<< liftIO (tryTakeMVar mgdb)+ _ -> return ()++ TestRun $ throwError failed++ catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler++instance MonadEval TestRun where+ lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< asks (lookup name . tsVars . snd)+ rootNetwork = asks $ tsNetwork . snd++instance MonadOutput TestRun where+ getOutput = asks $ teOutput . fst++instance MonadPIO TestRun where+ postpone = liftIO+++finally :: MonadError e m => m a -> m b -> m a+finally act handler = do+ x <- act `catchError` \e -> handler >> throwError e+ void handler+ return x++forkTest :: TestRun () -> TestRun ()+forkTest act = do+ tenv <- ask+ void $ liftIO $ forkIO $ do+ runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case+ Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e)+ Right () -> return ()
+ src/Test.hs view
@@ -0,0 +1,212 @@+module Test (+ Test(..),+ TestStep(..),+ SourceLine(..),++ MonadEval(..),+ VarName(..), TypedVarName(..), textVarName, unpackVarName,+ ExprType(..),+ SomeVarValue(..), fromSomeVarValue, textSomeVarValue,+ RecordSelector(..),+ ExprListUnpacker(..),+ ExprEnumerator(..),+ Expr(..), eval, gatherVars,+ AppAnnotation(..),++ Regex(RegexPart, RegexString), regexMatch,+) where++import Data.Char+import Data.List+import Data.Scientific+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable++import Text.Regex.TDFA qualified as RE+import Text.Regex.TDFA.Text qualified as RE++import {-# SOURCE #-} Network+import {-# SOURCE #-} Process+import Util++data Test = Test+ { testName :: Text+ , testSteps :: [TestStep]+ }++data TestStep = forall a. ExprType a => Let SourceLine (TypedVarName a) (Expr a) [TestStep]+ | forall a. ExprType a => For SourceLine (TypedVarName a) (Expr [a]) [TestStep]+ | Subnet (TypedVarName Network) (Expr Network) [TestStep]+ | DeclNode (TypedVarName Node) (Expr Network) [TestStep]+ | Spawn (TypedVarName Process) (Either (Expr Network) (Expr Node)) [TestStep]+ | Send (Expr Process) (Expr Text)+ | Expect SourceLine (Expr Process) (Expr Regex) [TypedVarName Text] [TestStep]+ | Flush (Expr Process) (Maybe (Expr Regex))+ | Guard SourceLine (Expr Bool)+ | DisconnectNode (Expr Node) [TestStep]+ | DisconnectNodes (Expr Network) [TestStep]+ | DisconnectUpstream (Expr Network) [TestStep]+ | PacketLoss (Expr Scientific) (Expr Node) [TestStep]+ | Wait++newtype SourceLine = SourceLine Text+++class MonadFail m => MonadEval m where+ lookupVar :: VarName -> m SomeVarValue+ rootNetwork :: m Network+++newtype VarName = VarName Text+ deriving (Eq, Ord)++newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName }+ deriving (Eq, Ord)++textVarName :: VarName -> Text+textVarName (VarName name ) = name++unpackVarName :: VarName -> String+unpackVarName = T.unpack . textVarName+++class Typeable a => ExprType a where+ textExprType :: proxy a -> Text+ textExprValue :: a -> Text+ emptyVarValue :: a++ recordMembers :: [(Text, RecordSelector a)]+ recordMembers = []++ exprListUnpacker :: proxy a -> Maybe (ExprListUnpacker a)+ exprListUnpacker _ = Nothing++ exprEnumerator :: proxy a -> Maybe (ExprEnumerator a)+ exprEnumerator _ = Nothing++instance ExprType Integer where+ textExprType _ = T.pack "integer"+ textExprValue x = T.pack (show x)+ emptyVarValue = 0++ exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo++instance ExprType Scientific where+ textExprType _ = T.pack "number"+ textExprValue x = T.pack (show x)+ emptyVarValue = 0++instance ExprType Bool where+ textExprType _ = T.pack "bool"+ textExprValue True = T.pack "true"+ textExprValue False = T.pack "false"+ emptyVarValue = False++instance ExprType Text where+ textExprType _ = T.pack "string"+ textExprValue x = T.pack (show x)+ emptyVarValue = T.empty++instance ExprType Regex where+ textExprType _ = T.pack "regex"+ textExprValue _ = T.pack "<regex>"+ emptyVarValue = either error id $ regexCompile T.empty++instance ExprType a => ExprType [a] where+ textExprType _ = "[" <> textExprType @a Proxy <> "]"+ textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]"+ emptyVarValue = []++ exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy)++data SomeVarValue = forall a. ExprType a => SomeVarValue a++data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b)++fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => VarName -> SomeVarValue -> m a+fromSomeVarValue name (SomeVarValue value) = maybe (fail err) return $ cast value+ where err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", textExprType (Just value) ]++textSomeVarValue :: SomeVarValue -> Text+textSomeVarValue (SomeVarValue value) = textExprValue value++data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e)++data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a])+++data Expr a where+ Variable :: ExprType a => VarName -> Expr a+ Pure :: a -> Expr a+ App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b+ Concat :: [Expr Text] -> Expr Text+ Regex :: [Expr Regex] -> Expr Regex+ RootNetwork :: Expr Network++data AppAnnotation b = AnnNone+ | ExprType b => AnnRecord Text++instance Functor Expr where+ fmap f x = Pure f <*> x++instance Applicative Expr where+ pure = Pure+ (<*>) = App AnnNone++eval :: MonadEval m => Expr a -> m a+eval (Variable name) = fromSomeVarValue name =<< lookupVar name+eval (Pure value) = return value+eval (App _ f x) = eval f <*> eval x+eval (Concat xs) = T.concat <$> mapM eval xs+eval (Regex xs) = mapM eval xs >>= \case+ [re@RegexCompiled {}] -> return re+ parts -> case regexCompile $ T.concat $ map regexSource parts of+ Left err -> fail err+ Right re -> return re+eval (RootNetwork) = rootNetwork++gatherVars :: forall a m. MonadEval m => Expr a -> m [((VarName, [Text]), SomeVarValue)]+gatherVars = fmap (uniqOn fst . sortOn fst) . helper+ where+ helper :: forall b. Expr b -> m [((VarName, [Text]), SomeVarValue)]+ helper (Variable var) = (:[]) . ((var, []),) <$> lookupVar var+ helper (Pure _) = return []+ helper e@(App (AnnRecord sel) _ x)+ | Just (var, sels) <- gatherSelectors x+ = do val <- SomeVarValue <$> eval e+ return [((var, sels ++ [sel]), val)]+ | otherwise = helper x+ helper (App _ f x) = (++) <$> helper f <*> helper x+ helper (Concat es) = concat <$> mapM helper es+ helper (Regex es) = concat <$> mapM helper es+ helper (RootNetwork) = return []++ gatherSelectors :: forall b. Expr b -> Maybe (VarName, [Text])+ gatherSelectors = \case+ Variable var -> Just (var, [])+ App (AnnRecord sel) _ x -> do+ (var, sels) <- gatherSelectors x+ return (var, sels ++ [sel])+ _ -> Nothing++data Regex = RegexCompiled Text RE.Regex+ | RegexPart Text+ | RegexString Text++regexCompile :: Text -> Either String Regex+regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $+ T.singleton '^' <> src <> T.singleton '$'++regexMatch :: Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text]))+regexMatch (RegexCompiled _ re) text = RE.regexec re text+regexMatch _ _ = Left "regex not compiled"++regexSource :: Regex -> Text+regexSource (RegexCompiled src _) = src+regexSource (RegexPart src) = src+regexSource (RegexString str) = T.concatMap escapeChar str+ where+ escapeChar c | isAlphaNum c = T.singleton c+ | c `elem` ['`', '\'', '<', '>'] = T.singleton c+ | otherwise = T.pack ['\\', c]
+ src/Util.hs view
@@ -0,0 +1,17 @@+module Util where++uniq :: Eq a => [a] -> [a]+uniq (x:y:xs) | x == y = uniq (x:xs)+ | otherwise = x : uniq (y:xs)+uniq xs = xs++uniqOn :: Eq b => (a -> b) -> [a] -> [a]+uniqOn f (x:y:xs) | f x == f y = uniqOn f (x:xs)+ | otherwise = x : uniqOn f (y:xs)+uniqOn _ xs = xs++andM :: (Foldable t, Monad m) => t (m Bool) -> m Bool+andM = foldr (\a b -> a >>= \case True -> b; False -> return False) (return True)++allM :: (Foldable t, Monad m) => (a -> m Bool) -> t a -> m Bool+allM f = foldr (\a b -> f a >>= \case True -> b; False -> return False) (return True)
+ src/Version.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}++-- "Pattern match is redundant" warning can be generated based on template+-- haskell $$tGitVersion value+{-# OPTIONS_GHC -Wno-error=overlapping-patterns #-}++module Version (+ versionLine,+) where++import Paths_erebos_tester (version)+import Data.Version (showVersion)+import Version.Git++{-# NOINLINE versionLine #-}+versionLine :: String+versionLine = do+ let ver = case $$tGitVersion of+ Just gver+ | 'v':v <- gver, not $ all (`elem` ('.': ['0'..'9'])) v+ -> "git " <> gver+ _ -> "version " <> showVersion version+ in "Erebos Tester " <> ver
+ src/Version/Git.hs view
@@ -0,0 +1,32 @@+module Version.Git (+ tGitVersion,+) where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax.Compat++import System.Directory+import System.Exit+import System.Process++tGitVersion :: SpliceQ (Maybe String)+tGitVersion = unsafeSpliceCoerce $ do+ let git args = do+ (ExitSuccess, out, _) <- readCreateProcessWithExitCode+ (proc "git" $ [ "--git-dir=./.git", "--work-tree=." ] ++ args) ""+ return $ lines out++ mbver <- runIO $ do+ doesPathExist "./.git" >>= \case+ False -> return Nothing+ True -> do+ desc:_ <- git [ "describe", "--always", "--dirty= (dirty)" ]+ files <- git [ "ls-files" ]+ return $ Just (desc, files)++ case mbver of+ Just (_, files) -> mapM_ addDependentFile files+ Nothing -> return ()++ lift (fst <$> mbver :: Maybe String)
+ src/Wrapper.hs view
@@ -0,0 +1,45 @@+module Main where++import Control.Monad++import GHC.Environment++import System.Directory+import System.Environment+import System.FilePath+import System.Linux.Namespaces+import System.Posix.Process+import System.Posix.User+import System.Process++main :: IO ()+main = do+ -- we must get uid/gid before unshare+ uid <- getEffectiveUserID+ gid <- getEffectiveGroupID++ unshare [User, Network, Mount]+ writeUserMappings Nothing [UserMapping 0 uid 1]+ writeGroupMappings Nothing [GroupMapping 0 gid 1] True++ -- needed for creating /run/netns+ callCommand "mount -t tmpfs tmpfs /run"++ epath <- takeDirectory <$> getExecutablePath -- directory containing executable+ fpath <- map takeDirectory . filter (any isPathSeparator) . take 1 <$> getFullArgs+ -- directory used for invocation, can differ from above for symlinked executable++ let dirs = concat+ [ [ epath ]+ , [ epath </> "../../../erebos-tester-core/build/erebos-tester-core" ]+ , fpath+ ]++ args <- getArgs+ mapM_ (\file -> executeFile file False args Nothing) =<<+ findExecutablesInDirectories dirs "erebos-tester-core"+ when (null fpath) $+ mapM_ (\file -> executeFile file False args Nothing) =<<+ findExecutables "erebos-tester-core"++ fail "core binary not found"