diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU 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. + + + Copyright (C) + + 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 . + +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: + + Copyright (C) + 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 +. + + 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 +. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/erebos-tester.cabal b/erebos-tester.cabal new file mode 100644 --- /dev/null +++ b/erebos-tester.cabal @@ -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 diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -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 diff --git a/src/GDB.hs b/src/GDB.hs new file mode 100644 --- /dev/null +++ b/src/GDB.hs @@ -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 + ] diff --git a/src/GDB.hs-boot b/src/GDB.hs-boot new file mode 100644 --- /dev/null +++ b/src/GDB.hs-boot @@ -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 () diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 diff --git a/src/Network.hs b/src/Network.hs new file mode 100644 --- /dev/null +++ b/src/Network.hs @@ -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", 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:", 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 diff --git a/src/Network.hs-boot b/src/Network.hs-boot new file mode 100644 --- /dev/null +++ b/src/Network.hs-boot @@ -0,0 +1,5 @@ +module Network where + +data Network +data Node +data NodeName diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ip.hs @@ -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) diff --git a/src/Output.hs b/src/Output.hs new file mode 100644 --- /dev/null +++ b/src/Output.hs @@ -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 diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -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 diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs new file mode 100644 --- /dev/null +++ b/src/Parser/Core.hs @@ -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 [] ] diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Parser/Expr.hs @@ -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 diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs new file mode 100644 --- /dev/null +++ b/src/Parser/Statement.hs @@ -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 _ = "" + +instance ExprType a => ParamType (TypedVarName a) where + parseParam _ = newVarName + showParamType _ = "" + +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 _ = "" + +instance ParamType TestStep where + parseParam _ = mzero + showParamType _ = "" + +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 + ] diff --git a/src/Process.hs b/src/Process.hs new file mode 100644 --- /dev/null +++ b/src/Process.hs @@ -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 diff --git a/src/Process.hs-boot b/src/Process.hs-boot new file mode 100644 --- /dev/null +++ b/src/Process.hs-boot @@ -0,0 +1,4 @@ +module Process where + +data Process +data ProcName diff --git a/src/Run.hs b/src/Run.hs new file mode 100644 --- /dev/null +++ b/src/Run.hs @@ -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 diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Run/Monad.hs @@ -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 () diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test.hs @@ -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 "" + 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] diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -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) diff --git a/src/Version.hs b/src/Version.hs new file mode 100644 --- /dev/null +++ b/src/Version.hs @@ -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 diff --git a/src/Version/Git.hs b/src/Version/Git.hs new file mode 100644 --- /dev/null +++ b/src/Version/Git.hs @@ -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) diff --git a/src/Wrapper.hs b/src/Wrapper.hs new file mode 100644 --- /dev/null +++ b/src/Wrapper.hs @@ -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"