diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,89 @@ +Dojang changelog +================ + +Version 0.2.0 +------------- + +Released on January 19, 2026. + + - The `dojang init` command now generates *.gitignore* if the source directory + is a Git repository and the file does not exist yet. [[#16]] + + - Fixed a bug that Dojang had not recognized `kernel.release` field in + a *dojang-env.toml* file unlike how it was documented and how `dojang env` + command have behaved. [[#17]] + + - Added disambiguation for ambiguous source paths in the `dojang reflect` + command. When multiple routes map to the same destination, Dojang now: + + - Auto-selects the route if only one source file exists + - Shows an interactive prompt with full source paths and `(exists)` labels + - Warns when multiple source files exist (potential configuration issue) + - Supports `DOJANG_AUTO_SELECT` environment variable (`first`, `error`) + - Accepts `--source` option to explicitly specify which source to use + + [[#22]] + + - Added the `dojang edit` command which opens the source file of a target + file in the user's editor and applies changes after editing. [[#21]] + + - Editor detection priority: `--editor` option → `$VISUAL` → `$EDITOR` + → platform default (`notepad` on Windows, `vi` on POSIX) + - Use `--no-apply` flag to skip automatic apply after editing + - Use `--force` flag to skip conflict warnings + - Use `--sequential` flag to edit files one at a time + - Use `--source` option or `DOJANG_AUTO_SELECT` to resolve + ambiguous routes + - Non-existent target paths create empty source files before editing + (prompts for route selection if multiple routes match) + + - Added a registry file (*~/.dojang*) that stores the repository path. + This allows the `dojang edit` command to work from any directory. [[#21]] + + - Created automatically during `dojang apply` + - If the registry points to a different repository, Dojang prompts + to overwrite (in interactive mode) or overwrites silently + (in non-interactive mode) + + - Enhanced `dojang reflect` and `dojang edit` commands to support + batch operations. [[#18]] + + - Without arguments, shows all changed files and prompts for + confirmation before processing + - Use `--all`/`-a` flag to process all changed files without + prompting + - Directory arguments process all changed files within the directory + - Ignored files are skipped by default with a warning; use `--force` + to include them + - Use `--include-unregistered`/`-u` flag to include unregistered files + found in destination directories (prompts for route selection in + interactive mode; `dojang reflect` only, not yet for `dojang edit`) + + - Added pre/post apply hooks that run custom scripts before and after + the `dojang apply` command. [[#19]] + + - `pre-apply`: Runs before every apply + - `pre-first-apply`: Runs only on first apply (when *~/.dojang* + doesn't exist) + - `post-first-apply`: Runs only on first apply, after file sync + - `post-apply`: Runs after every apply + - Hooks support conditional execution via `when` field using + environment predicates + - Use `ignore-failure = true` to continue even if a hook fails + - In dry-run mode, hooks print “Would run hook: …” instead of + executing + - Environment variables available to hooks: `DOJANG_REPOSITORY`, + `DOJANG_MANIFEST`, `DOJANG_DRY_RUN`, `DOJANG_OS`, `DOJANG_ARCH` + +[#16]: https://github.com/dahlia/dojang/issues/16 +[#17]: https://github.com/dahlia/dojang/issues/17 +[#18]: https://github.com/dahlia/dojang/issues/18 +[#19]: https://github.com/dahlia/dojang/issues/19 +[#21]: https://github.com/dahlia/dojang/issues/21 +[#22]: https://github.com/dahlia/dojang/issues/22 + + +Version 0.1.0 +------------- + +Initial release. Released on November 26, 2023. 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,42 @@ +*Available in other languages: [한국어](README.ko.md).* + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + +![](cat-pow.svg) +Dojang: A cross-platform dotfiles manager +========================================== + +[![GPL 3.0][License badge]](./LICENSE) +[![GitHub Actions][GitHub Actions status badge]][GitHub Actions] +[![Codecov][Codecov badge]][Codecov] + +Dojang is a cross-platform dotfiles manager. Here are some of the highlights: + + - Lightweight. It's built as a native executable, so it's easy to install + and fast to run. + - Cross-platform. It works on both the POSIX family and Windows. + - Flexible. It keeps in mind that config files can be placed in different + places or have different contents depending on the environment. + - Safe. Every run can be previewed by simulating it in a sandbox environment + with the `--dry-run` option. + - Friendly. Error messages are friendly and print helpful hints or warnings. + +For further information, see the docs: + + - [English] + - [한국어] (Korean) + +Distributed under the [GPL 3.0] or later. + +[License badge]: https://img.shields.io/github/license/dahlia/dojang +[GitHub Actions status badge]: https://github.com/dahlia/dojang/actions/workflows/build.yaml/badge.svg +[GitHub Actions]: https://github.com/dahlia/dojang/actions/workflows/build.yaml +[Codecov badge]: https://codecov.io/gh/dahlia/dojang/graph/badge.svg?token=JrwY5Yt2pD +[Codecov]: https://codecov.io/gh/dahlia/dojang +[English]: https://dojang.dev/ +[한국어]: https://dojang.dev/ko/ +[GPL 3.0]: https://www.gnu.org/licenses/gpl-3.0.html + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + + +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,545 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import Control.Applicative (Alternative ((<|>)), optional, (<**>)) +import Control.Monad (void, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Maybe (catMaybes, maybeToList) +import GHC.IO.Encoding (setLocaleEncoding, utf8) +import System.Exit (ExitCode (..), exitWith) +import System.IO (stderr) +import System.IO.CodePage (withCP65001) +import System.IO.Unsafe (unsafePerformIO) +import System.Info (os) + +import Control.Monad.Except (MonadError (catchError)) +import Options.Applicative + ( Parser + , ParserInfo + , ParserPrefs + , ParserResult + , action + , argument + , command + , commandGroup + , customExecParser + , defaultPrefs + , execParserPure + , flag + , flag' + , footer + , fullDesc + , handleParseResult + , header + , help + , helper + , info + , long + , many + , metavar + , progDesc + , short + , showDefault + , str + , strOption + , subparser + , switch + , value + ) +import System.OsPath (OsPath, encodeFS) +import TextShow (TextShow (showt)) + +import Dojang.App + ( App + , AppEnv (..) + , runAppWithStderrLogging + , runAppWithoutLogging + ) +import Dojang.Commands (Admonition (Error, Note), codeStyleFor, printStderr') +import Dojang.Commands.Apply qualified (apply) +import Dojang.Commands.Diff (DiffMode (..)) +import Dojang.Commands.Diff qualified (diff) +import Dojang.Commands.Edit qualified (edit) +import Dojang.Commands.Env qualified (env) +import Dojang.Commands.Init (InitPreset (..), initPresetName) +import Dojang.Commands.Init qualified (init) +import Dojang.Commands.Reflect qualified (reflect) +import Dojang.Commands.Status (StatusOptions (..)) +import Dojang.Commands.Status qualified (status) +import Dojang.ExitCodes (unhandledError) +import Dojang.MonadFileSystem (DryRunIO, MonadFileSystem, dryRunIO') +import Dojang.Types.Registry (Registry (..), readRegistry, registryFilename) +import Dojang.Version (toString, version) +import Options.Applicative.Path (hyphen, pathArgument, pathOption, period) +import System.Directory (getHomeDirectory) +import System.OsPath qualified as OsPath + + +intermediateDirname :: OsPath +intermediateDirname = unsafePerformIO $ encodeFS ".dojang" +{-# NOINLINE intermediateDirname #-} + + +manifestFilename :: OsPath +manifestFilename = unsafePerformIO $ encodeFS "dojang.toml" +{-# NOINLINE manifestFilename #-} + + +envFilename :: OsPath +envFilename = unsafePerformIO $ encodeFS "dojang-env.toml" +{-# NOINLINE envFilename #-} + + +appP + :: (MonadFileSystem i, MonadIO i) + => OsPath + -- ^ The default repository path (from registry or current directory). + -> Parser (AppEnv, App i ExitCode) +appP defaultRepoPath = do + sourceDirectory' <- + pathOption + ( long "repository-dir" + <> short 'r' + <> metavar "PATH" + <> value defaultRepoPath + <> showDefault + <> action "directory" + <> help "Repository (i.e., source tree) directory" + ) + intermediateDirectory' <- + pathOption + ( long "intermediate-dir" + <> short 'i' + <> metavar "PATH" + <> value intermediateDirname + <> showDefault + <> action "directory" + <> help + ( "Intermediate directory which is managed by Dojang. " + ++ "Relative to source tree directory (-s/--source-dir) " + ++ "if not absolute" + ) + ) + manifestFile' <- + pathOption + ( long "manifest-file" + <> short 'm' + <> metavar "PATH" + <> value manifestFilename + <> showDefault + <> action "file" + <> help + ( "Manifest file. Relative to source tree directory " + ++ "(-s/--source-dir) if not absolute" + ) + ) + envFile' <- + pathOption + ( long "env-file" + <> short 'e' + <> metavar "PATH" + <> value envFilename + <> showDefault + <> action "file" + <> help + ( "Environment file. Relative to source tree directory " + ++ "(-s/--source-dir) if not absolute. It will be silently " + ++ "ignored if the file does not exist" + ) + ) + dryRun' <- + switch + ( long "dry-run" + <> help + ( "Do not actually perform actions, but just print them. " + ++ "This option probably lets the program run much slower" + ) + ) + debug' <- switch (long "debug" <> short 'd' <> help "Enable debug logging") + cmd <- cmdP defaultRepoPath + return + ( AppEnv + sourceDirectory' + intermediateDirectory' + manifestFile' + envFile' + dryRun' + debug' + , cmd + ) + + +initPresetP :: Parser [InitPreset] +initPresetP = + (\a b c d e f' g -> catMaybes [a, b, c, d, e, f', g]) + <$> f Amd64Linux ("linux-x86_64", "linux-amd64") + <*> f Arm64Linux ("linux-aarch64", "linux-arm64") + <*> f AppleSiliconMac ("macos-aarch64", "apple-silicon-mac") + <*> f IntelMac ("macos-amd64", "intel-mac") + <*> f Win64 ("windows-amd64", "win64") + <*> f WinArm64 ("windows-aarch64", "win-arm64") + <*> f Wsl2 ("linux-wsl2", "wsl2") + where + f :: InitPreset -> (String, String) -> Parser (Maybe InitPreset) + f preset (longOpt, alias) = + flag + Nothing + (Just preset) + ( long longOpt + <> long alias + <> help ("Use " ++ initPresetName preset ++ " preset") + ) + + +cmdP + :: (MonadFileSystem i, MonadIO i) + => OsPath + -- ^ The default repository path (from registry or current directory). + -> Parser (App i ExitCode) +cmdP defaultRepoPath = + subparser + ( commandGroup "Managing commands:" + <> command + "init" + ( info + ( Dojang.Commands.Init.init + <$> initPresetP + <*> switch + ( long "no-interactive" + <> short 'I' + <> help "Do not prompt for anything" + ) + <**> helper + ) + (progDesc "Initialize repository") + ) + <> command + "env" + ( info + ( Dojang.Commands.Env.env + <$> switch + ( long "ignore-env-file" + <> short 'i' + <> help "Ignore environment file" + ) + <*> pathOption + ( long "output-file" + <> short 'o' + <> metavar "PATH" + <> value hyphen + <> showDefault + <> action "file" + <> help + ( "Output file path. Use - for stdout, " + ++ "and ./- for a file named -" + ) + ) + <**> helper + ) + ( progDesc $ + "Show environment in TOML format, " + ++ "which can be used with -e/--env-file" + ) + ) + <> command + "status" + ( info + ( Dojang.Commands.Status.status + <$> ( StatusOptions + <$> switch + ( long "no-trailing-slash" + <> short 'S' + <> help + ( "Do not append trailing slash (or backslash " + ++ "on Windows) to directory paths" + ) + ) + <*> switch + ( long "only-changes" + <> short 'c' + <> help "Only show changed files" + ) + <*> switch + ( long "show-destination-path" + <> short 'd' + <> help + ( "Show destination (target) path " + ++ "instead of source path" + ) + ) + ) + <**> helper + ) + ( progDesc + "Show status of repository and target (destination) tree" + ) + ) + <> command + "diff" + ( info + ( Dojang.Commands.Diff.diff + <$> ( flag' + Source + ( long "source" + <> short 's' + <> help + ( "Two-way diff between source tree and base " + ++ "(intermediate) tree" + ) + ) + <|> flag' + Destination + ( long "destination" + <> long "target" + <> short 'd' + <> help + ( "Two-way diff between destination (target) " + ++ "tree and base (intermediate) tree" + ) + ) + <|> pure Both + ) + <*> optional + ( pathOption + ( long "diff-program" + <> metavar "PROGRAM" + <> action "command" + <> help + ( "A program to use for two-way diff. " + ++ "If not specified, fall back to a program " + ++ "specified by the environment variable " + ++ "DOJANG_DIFF" + ) + ) + ) + <*> many (pathArgument $ metavar "FILE" <> action "file") + <**> helper + ) + ( progDesc $ + "Show changes between source tree and target " + ++ "(destination) tree" + ) + ) + <> command + "reflect" + ( info + ( Dojang.Commands.Reflect.reflect + <$> switch + ( long "force" + <> short 'f' + <> help + "Enforce reflecting if there are ignorable errors" + ) + <*> switch + ( long "all" + <> short 'a' + <> help + "Reflect all changed files without prompting" + ) + <*> switch + ( long "include-unregistered" + <> short 'u' + <> help + "Include unregistered files (prompts for route)" + ) + <*> optional + ( pathOption + ( long "source" + <> short 's' + <> metavar "PATH" + <> action "file" + <> help + "Explicitly specify source path (skip disambiguation)" + ) + ) + <*> many (pathArgument $ metavar "PATH" <> action "file") + <**> helper + ) + (progDesc "Let the repository reflect the target file") + ) + <> command + "apply" + ( info + ( Dojang.Commands.Apply.apply + <$> switch + ( long "force" + <> short 'f' + <> help + ( "Apply changes even if there are undergone " + ++ "changes in the target tree too" + ) + ) + <*> many (pathArgument $ metavar "FILE" <> action "file") + <**> helper + ) + (progDesc "Apply changes to target tree") + ) + <> command + "edit" + ( info + ( Dojang.Commands.Edit.edit + <$> optional + ( strOption + ( long "editor" + <> short 'E' + <> metavar "PROGRAM" + <> action "command" + <> help + ( "Editor program to use " + ++ "(overrides $VISUAL and $EDITOR)" + ) + ) + ) + <*> switch + ( long "no-apply" + <> short 'n' + <> help "Do not apply changes after editing" + ) + <*> switch + ( long "force" + <> short 'f' + <> help "Skip conflict warnings and proceed" + ) + <*> switch + ( long "sequential" + <> short 'S' + <> help "Edit files one at a time instead of all at once" + ) + <*> switch + ( long "all" + <> short 'a' + <> help + "Edit all changed source files without prompting" + ) + <*> switch + ( long "include-unregistered" + <> short 'u' + <> help + "Include unregistered files (prompts for route)" + ) + <*> optional + ( pathOption + ( long "source" + <> short 's' + <> metavar "PATH" + <> action "file" + <> help "Explicit source path (skip disambiguation)" + ) + ) + <*> many (pathArgument $ metavar "PATH" <> action "file") + <**> helper + ) + (progDesc "Edit source file of a target file and apply changes") + ) + ) + <|> subparser + ( commandGroup "Meta commands:" + <> command + "version" + ( info + (pure versionCmd <**> helper) + (progDesc "Show version") + ) + <> command "help" (info (helpP defaultRepoPath) (progDesc "Show help")) + ) + + +helpP + :: (MonadFileSystem i, MonadIO i) + => OsPath + -- ^ The default repository path (from registry or current directory). + -> Parser (App i ExitCode) +helpP defaultRepoPath = + helpCmd defaultRepoPath + <$> optional (argument str (metavar "COMMAND")) + <**> helper + + +parser + :: (MonadFileSystem i, MonadIO i) + => OsPath + -- ^ The default repository path (from registry or current directory). + -> ParserInfo (AppEnv, App i ExitCode) +parser defaultRepoPath = + info + (appP defaultRepoPath <**> helper) + ( fullDesc + <> progDesc "Manage dotfiles" + <> header "Dojang: A cross-platform dotfiles manager" + <> footer "Distributed under the GPL 3.0 or later." + ) + + +parserPrefs :: ParserPrefs +parserPrefs = defaultPrefs + + +versionCmd :: (MonadIO i) => App i ExitCode +versionCmd = do + liftIO $ putStrLn $ "dojang " <> toString version + return ExitSuccess + + +helpCmd + :: forall i + . (MonadFileSystem i, MonadIO i) + => OsPath + -- ^ The default repository path (from registry or current directory). + -> Maybe String + -> App i ExitCode +helpCmd defaultRepoPath cmdString = do + void $ liftIO $ handleParseResult result + return ExitSuccess + where + args = maybeToList cmdString ++ ["--help"] + result :: ParserResult (AppEnv, App i ExitCode) + result = execParserPure parserPrefs (parser defaultRepoPath) args + + +main :: IO () +main = withCP65001 $ do + when (System.Info.os == "mingw32") $ setLocaleEncoding utf8 + -- Try to read the repository path from the registry file (~/.dojang). + -- If the registry exists, use it as the default repository path. + -- Otherwise, default to the current directory. + defaultRepoPath <- do + homeDir <- OsPath.encodeFS =<< getHomeDirectory + let registryPath = homeDir OsPath. registryFilename + maybeRegistry <- readRegistry registryPath + return $ maybe period (.repositoryPath) maybeRegistry + (appEnv, _) <- + liftIO $ customExecParser parserPrefs (parser defaultRepoPath) + :: IO (AppEnv, App DryRunIO ExitCode) + (exitCode, ops) <- + if appEnv.dryRun + then dryRunIO' $ run defaultRepoPath appEnv + else do + exitCode' <- run defaultRepoPath appEnv + return (exitCode', -1) + codeColor <- codeStyleFor stderr + when (appEnv.dryRun && ops > 0) $ do + printStderr' Note $ + "Since " + <> codeColor "--dry-run" + <> " was specified, those " + <> showt ops + <> " changes were not actually committed to the filesystem." + exitWith exitCode + where + run :: (MonadFileSystem i, MonadIO i) => OsPath -> AppEnv -> i ExitCode + run defaultRepoPath appEnv = do + (_, cmd) <- liftIO $ customExecParser parserPrefs (parser defaultRepoPath) + (if appEnv.debug then runAppWithStderrLogging else runAppWithoutLogging) + appEnv + $ cmd + `catchError` \e -> do + printStderr' Error $ + "An unexpected error occurred; you may report this as a bug: " + <> showt e + return unhandledError diff --git a/dojang.cabal b/dojang.cabal new file mode 100644 --- /dev/null +++ b/dojang.cabal @@ -0,0 +1,212 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.39.1. +-- +-- see: https://github.com/sol/hpack + +name: dojang +version: 0.2.0 +synopsis: A cross-platform dotfiles manager +description: See also the README.md file. +category: Configuration +homepage: https://dojang.dev/ +author: Hong Minhee +maintainer: Hong Minhee +copyright: © 2023 Hong Minhee +license: GPL-3.0-or-later +license-file: LICENSE +build-type: Simple +extra-doc-files: + README.md + CHANGES.md + LICENSE + +flag static + description: Static link + manual: True + default: False + +library + exposed-modules: + Dojang.App + Dojang.Commands + Dojang.Commands.Apply + Dojang.Commands.Diff + Dojang.Commands.Disambiguation + Dojang.Commands.Edit + Dojang.Commands.Env + Dojang.Commands.Hook + Dojang.Commands.Init + Dojang.Commands.Reflect + Dojang.Commands.Status + Dojang.ExitCodes + Dojang.MonadFileSystem + Dojang.Syntax.Env + Dojang.Syntax.EnvironmentPredicate + Dojang.Syntax.EnvironmentPredicate.Parser + Dojang.Syntax.EnvironmentPredicate.Writer + Dojang.Syntax.FilePathExpression.Parser + Dojang.Syntax.Manifest.Internal + Dojang.Syntax.Manifest.Parser + Dojang.Syntax.Manifest.Writer + Dojang.Types.Context + Dojang.Types.Environment + Dojang.Types.Environment.Current + Dojang.Types.EnvironmentPredicate + Dojang.Types.EnvironmentPredicate.Evaluate + Dojang.Types.EnvironmentPredicate.Specificity + Dojang.Types.FilePathExpression + Dojang.Types.FilePathExpression.Expansion + Dojang.Types.FileRoute + Dojang.Types.FileRouteMap + Dojang.Types.FileRouteMap.Evaluate + Dojang.Types.Hook + Dojang.Types.Manifest + Dojang.Types.MonikerMap + Dojang.Types.MonikerName + Dojang.Types.Registry + Dojang.Types.Repository + Dojang.Version + Options.Applicative.Path + other-modules: + Paths_dojang + autogen-modules: + Paths_dojang + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wmissing-export-lists + build-depends: + Diff >=0.4.1 && <1.1 + , base >=4.7 && <5 + , bytestring >=0.11 && <0.13 + , case-insensitive >=1.2.1.0 && <2 + , containers >0 + , deepseq >=1.4 && <2 + , directory >=1.3.8 && <1.4 + , extra >=1.7 && <2 + , filepath >=1.4.100 && <2 + , filepattern >=0.1.3 && <2 + , fortytwo >=2 && <2.1 + , hashable >=1.4.2.0 && <2 + , megaparsec >=9.3 && <10 + , monad-logger ==0.3.* + , mtl >=2.3 && <3 + , optparse-applicative >=0.17 && <0.19 + , parser-combinators ==1.* + , pretty-terminal ==0.1.* + , process >=1.6 && <2 + , semver ==0.4.* + , text ==2.* + , text-show ==3.* + , toml-parser >=1.3 && <2 + , unordered-containers >=0.2.19.1 && <1 + default-language: Haskell2010 + +executable dojang + main-is: Main.hs + other-modules: + Paths_dojang + autogen-modules: + Paths_dojang + hs-source-dirs: + app + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + Diff >=0.4.1 && <1.1 + , base >=4.7 && <5 + , bytestring >=0.11 && <0.13 + , case-insensitive >=1.2.1.0 && <2 + , code-page ==0.2.* + , containers >0 + , directory >=1.3.8 && <1.4 + , dojang >0 + , filepath >=1.4.100 && <2 + , hashable >=1.4.2.0 && <2 + , megaparsec >=9.3 && <10 + , monad-logger ==0.3.* + , mtl >=2.3 && <3 + , optparse-applicative >=0.17 && <0.19 + , pretty-terminal ==0.1.* + , text ==2.* + , text-show ==3.* + , toml-parser >=1.3 && <2 + , unordered-containers >=0.2.19.1 && <1 + default-language: Haskell2010 + if flag(static) + if os(linux) + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wno-incomplete-uni-patterns -optP-Wno-nonportable-include-path -static -optl-static -optl-pthread -optc-Os -fPIC + else + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wno-incomplete-uni-patterns -optP-Wno-nonportable-include-path -static -optc-Os + else + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wno-incomplete-uni-patterns -optP-Wno-nonportable-include-path + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Dojang.Commands.DisambiguationSpec + Dojang.Commands.EditSpec + Dojang.Commands.HookSpec + Dojang.Gen + Dojang.MonadFileSystemSpec + Dojang.Syntax.EnvironmentPredicate.ParserSpec + Dojang.Syntax.EnvironmentPredicate.WriterSpec + Dojang.Syntax.EnvSpec + Dojang.Syntax.FilePathExpression.ParserSpec + Dojang.Syntax.Manifest.WriterSpec + Dojang.TestUtils + Dojang.Types.ContextSpec + Dojang.Types.Environment.CurrentSpec + Dojang.Types.EnvironmentPredicate.EvaluateSpec + Dojang.Types.EnvironmentPredicate.SpecificitySpec + Dojang.Types.EnvironmentPredicateSpec + Dojang.Types.EnvironmentSpec + Dojang.Types.FilePathExpression.ExpansionSpec + Dojang.Types.FilePathExpressionSpec + Dojang.Types.FileRouteMap.EvaluateSpec + Dojang.Types.FileRouteSpec + Dojang.Types.Gen + Dojang.Types.HookSpec + Dojang.Types.MonikerNameSpec + Dojang.Types.RegistrySpec + Dojang.Types.RepositorySpec + Spec + SpecHook + Paths_dojang + autogen-modules: + Paths_dojang + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -Wno-incomplete-uni-patterns -optP-Wno-nonportable-include-path + build-depends: + Diff >=0.4.1 && <1.1 + , base >=4.7 && <5 + , bytestring >=0.11 && <0.13 + , case-insensitive >=1.2.1.0 && <2 + , containers >0 + , directory >=1.3.8 && <1.4 + , dojang >0 + , filepath >=1.4.100 && <2 + , hashable >=1.4.2.0 && <2 + , hedgehog >=1.2 && <2 + , hspec >=2.10.10 && <2.12 + , hspec-api >=2.10 && <2.12 + , hspec-discover >=2.10.10 && <2.12 + , hspec-expectations-pretty-diff ==0.7.* + , hspec-hedgehog >=0.0.1.2 && <0.4 + , hspec-junit-formatter >=1.1.0.2 && <1.2 + , hspec-megaparsec ==2.2.* + , megaparsec >=9.3 && <10 + , monad-logger ==0.3.* + , mtl >=2.3 && <3 + , optparse-applicative >=0.17 && <0.19 + , os-string ==2.* + , pretty-terminal ==0.1.* + , random >=1.2 && <2 + , regex-tdfa >=1.3.2 && <1.4 + , temporary ==1.3.* + , text ==2.* + , text-show ==3.* + , toml-parser >=1.3 && <2 + , unordered-containers >=0.2.19.1 && <1 + default-language: Haskell2010 diff --git a/src/Dojang/App.hs b/src/Dojang/App.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/App.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | The application monad for Dojang. +module Dojang.App + ( App + , AppEnv (..) + , Loc + , LogLevel + , LogSource + , LogStr + , currentEnvironment' + , doesManifestExist + , ensureContext + , ensureRepository + , loadManifest + , loadRepository + , lookupEnv' + , runAppWithLogging + , runAppWithStderrLogging + , runAppWithoutLogging + , saveManifest + ) where + +import Control.Monad (forM_) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.List.NonEmpty (toList) +import Data.String (IsString (fromString)) +import Dojang.Types.FilePathExpression (EnvironmentVariable) +import System.Environment (lookupEnv) +import System.Exit (exitWith) +import System.IO (stderr) +import System.IO.Error (isDoesNotExistError) +import Prelude hiding (readFile, writeFile) + +import Control.Monad.Except (MonadError (..), tryError) +import Control.Monad.Logger + ( Loc + , LogLevel + , LogSource + , LogStr + , LoggingT (runLoggingT) + , MonadLogger + , logDebug + , logDebugSH + , logError + , logInfo + , logWarn + , runStderrLoggingT + ) +import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT) +import Control.Monad.Trans (MonadTrans (lift)) +import Data.Text (concat, pack, unlines, unpack) +import System.OsPath (OsPath, OsString, normalise, ()) +import TextShow (FromStringShow (FromStringShow), TextShow (showt)) + +import Dojang.Commands + ( Admonition (..) + , codeStyleFor + , die' + , dieWithErrors + , printStderr' + ) +import Dojang.ExitCodes + ( envFileReadError + , manifestReadError + , manifestUninitialized + , noEnvFile + ) +import Dojang.MonadFileSystem (MonadFileSystem (..)) +import Dojang.Syntax.Env (readEnvFile) +import Dojang.Syntax.Manifest.Parser (Error, formatErrors, readManifestFile) +import Dojang.Syntax.Manifest.Writer (writeManifestFile) +import Dojang.Types.Context (Context (..)) +import Dojang.Types.Environment (Environment (..)) +import Dojang.Types.Environment.Current + ( MonadArchitecture (currentArchitecture) + , MonadEnvironment (currentEnvironment) + , MonadOperatingSystem (currentOperatingSystem) + ) +import Dojang.Types.Manifest (Manifest) +import Dojang.Types.Repository (Repository (..)) + + +-- | The environment for the application monad. +data AppEnv = AppEnv + { sourceDirectory :: OsPath + -- ^ The source directory (i.e., repository). + , intermediateDirectory :: OsPath + -- ^ The intermediate directory which is managed by Dojang. It's normally + -- @.dojang@ in the source directory. + , manifestFile :: OsPath + -- ^ The manifest file. + , envFile :: OsPath + -- ^ The environment file. + , dryRun :: Bool + -- ^ Whether to actually perform actions or just print what would be done. + , debug :: Bool + -- ^ Whether debug logging is enabled. + } + deriving (Show) + + +-- | The application monad for Dojang. +newtype (MonadFileSystem i, MonadError IOError i, MonadIO i) => App i v = App + { unApp :: ReaderT AppEnv (LoggingT i) v + } + deriving + ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader AppEnv + , MonadLogger + ) + + +instance + (MonadFileSystem i, MonadError IOError i, MonadIO i) + => MonadError IOError (App i) + where + throwError = App . throwError + catchError action handler = App $ catchError (unApp action) (unApp . handler) + + +instance (MonadFileSystem i, MonadIO i) => MonadFileSystem (App i) where + encodePath = App . lift . lift . encodePath + decodePath = App . lift . lift . decodePath + exists = App . lift . lift . exists + isFile = App . lift . lift . isFile + isDirectory = App . lift . lift . isDirectory + isSymlink = App . lift . lift . isSymlink + readFile = App . lift . lift . readFile + writeFile dst = App . lift . lift . writeFile dst + readSymlinkTarget = App . lift . lift . readSymlinkTarget + copyFile src = App . lift . lift . copyFile src + createDirectory = App . lift . lift . createDirectory + removeFile = App . lift . lift . removeFile + removeDirectory = App . lift . lift . removeDirectory + listDirectory = App . lift . lift . listDirectory + getFileSize = App . lift . lift . getFileSize + + +currentEnvironment' :: (MonadFileSystem i, MonadIO i) => App i Environment +currentEnvironment' = do + sourceDir <- asks (.sourceDirectory) + envFile' <- asks (.envFile) + let filePath = sourceDir envFile' + $(logDebug) $ "Environment file path: " <> showt (FromStringShow filePath) + result <- + readEnvFile filePath `catchError` \e -> do + if isDoesNotExistError e + then do + $(logWarn) $ + "Environment file not found: " + <> showt (FromStringShow e) + env <- liftIO currentEnvironment + return $ Right (env, []) + else die' noEnvFile $ showt e + case result of + Left errors -> do + let formattedErrors = + Data.Text.concat + ["\n " <> pack e | e <- toList errors] + die' envFileReadError $ "Syntax errors in environment file:" <> formattedErrors + Right (env, warnings) -> do + $(logDebugSH) env + forM_ warnings $ \w -> $(logWarn) $ fromString w + return env + + +instance (MonadFileSystem i, MonadIO i) => MonadEnvironment (App i) where + currentEnvironment = currentEnvironment' + + +instance (MonadFileSystem i, MonadIO i) => MonadOperatingSystem (App i) where + currentOperatingSystem = (.operatingSystem) <$> currentEnvironment' + + +instance (MonadFileSystem i, MonadIO i) => MonadArchitecture (App i) where + currentArchitecture = (.architecture) <$> currentEnvironment' + + +runAppWithoutLogging + :: (MonadFileSystem i, MonadIO i) => AppEnv -> App i a -> i a +runAppWithoutLogging env app = runAppWithLogging env app (\_ _ _ _ -> pure ()) + + +-- | Run the application monad with logging handled by the given function. +runAppWithLogging + :: (MonadFileSystem i, MonadIO i) + => AppEnv + -> App i a + -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + -> i a +runAppWithLogging env app = runLoggingT (runReaderT app.unApp env) + + +-- | Run the application monad with logging to stderr. +runAppWithStderrLogging + :: (MonadFileSystem i, MonadIO i) => AppEnv -> App i a -> i a +runAppWithStderrLogging env = runStderrLoggingT . (`runReaderT` env) . unApp + + +manifestPath :: (MonadIO i) => App i OsPath +manifestPath = do + sourceDir <- asks (.sourceDirectory) + manifestFile' <- asks (.manifestFile) + let path = sourceDir manifestFile' + $(logDebug) $ "Manifest path: " <> showt (FromStringShow path) + return path + + +loadManifest + :: (MonadFileSystem i, MonadIO i) => App i (Either Error (Maybe Manifest)) +loadManifest = do + filename <- manifestPath + result <- tryError (readManifestFile filename) + case result of + Left e + | isDoesNotExistError e -> do + $(logInfo) "Manifest file not found" + return $ Right Nothing + Left e -> do + $(logError) $ "Error reading manifest file: " <> showt (FromStringShow e) + throwError e + Right (Left err) -> do + $(logError) $ + "Error parsing manifest file: " + <> Data.Text.unlines (formatErrors err) + return $ Left err + Right (Right (manifest, warnings)) -> do + forM_ warnings $ \w -> $(logWarn) w + $(logDebugSH) manifest + return $ Right $ Just manifest + + +doesManifestExist :: (MonadFileSystem i, MonadIO i) => App i Bool +doesManifestExist = do + filePath <- manifestPath + exists' <- exists filePath + $(logInfo) $ + "Manifest file " + <> showt (FromStringShow filePath) + <> " " + <> if exists' then "exists" else "does not exist" + return exists' + + +saveManifest :: (MonadFileSystem i, MonadIO i) => Manifest -> App i OsPath +saveManifest manifest = do + filename <- manifestPath + $(logDebugSH) manifest + writeManifestFile manifest filename `catchError` \e -> do + $(logError) $ "Error writing manifest file: " <> showt (FromStringShow e) + throwError e + $(logInfo) $ + "Manifest file " + <> showt (FromStringShow filename) + <> " written" + return filename + + +loadRepository + :: (MonadFileSystem i, MonadIO i) => App i (Either Error (Maybe Repository)) +loadRepository = do + sourceDir <- asks (normalise . (.sourceDirectory)) + intermediateDir <- asks (normalise . (.intermediateDirectory)) + result <- loadManifest + case result of + Left err -> return $ Left err + Right Nothing -> return $ Right Nothing + Right (Just manifest) -> do + return $ + Right $ + Just $ + Repository sourceDir (sourceDir intermediateDir) manifest + + +ensureRepository :: (MonadFileSystem i, MonadIO i) => App i Repository +ensureRepository = do + result <- loadRepository + case result of + Left e -> + dieWithErrors manifestReadError $ formatErrors e + Right Nothing -> do + printStderr' Error "No manifest found." + codeStyle <- codeStyleFor stderr + printStderr' + Note + ("Run `" <> codeStyle "dojang init" <> "' to create one.") + liftIO $ exitWith manifestUninitialized + Right (Just repo) -> return repo + + +ensureContext :: (MonadFileSystem i, MonadIO i) => App i (Context (App i)) +ensureContext = do + repo <- ensureRepository + currentEnv <- currentEnvironment' + $(logDebugSH) currentEnv + return $ Context repo currentEnv lookupEnv' + + +lookupEnv' + :: (MonadFileSystem i, MonadIO i) => EnvironmentVariable -> i (Maybe OsString) +lookupEnv' env = do + value <- liftIO $ lookupEnv $ unpack env + case value of + Just v -> do + Just <$> encodePath v + Nothing -> return Nothing diff --git a/src/Dojang/Commands.hs b/src/Dojang/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Commands.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Dojang.Commands + ( Admonition (..) + , Color (..) + , codeStyleFor + , colorFor + , die' + , dieWithErrors + , pathStyleFor + , pathStyleFor' + , printStderr + , printStderr' + , printTable + ) where + +import Control.Monad (forM_) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import System.Environment (lookupEnv) +import System.Exit (ExitCode, exitWith) +import System.IO.Extra (Handle, hIsTerminalDevice, stderr, stdout) +import System.IO.Unsafe (unsafePerformIO) +import Prelude hiding (putStr, replicate) + +import Data.List (transpose) +import Data.Text (Text, length, pack, replicate) +import Data.Text.IO (hPutStr, hPutStrLn, putStr) +import System.Console.Pretty + ( Color (..) + , Pretty + , Style (..) + , bgColor + , style + ) +import System.Console.Pretty qualified (color) +import System.OsPath (OsPath, decodeFS) +import TextShow (FromStringShow (FromStringShow), TextShow (showt)) + + +isColorAvailable :: (MonadIO m) => Handle -> m Bool +isColorAvailable handle = liftIO $ do + term <- lookupEnv "TERM" + noColor <- lookupEnv "NO_COLOR" + case (term, noColor) of + (Just "dumb", _) -> return False + (_, Just (_ : _)) -> return False + _ -> hIsTerminalDevice handle + + +colorFor + :: forall a m. (Pretty a, MonadIO m) => Handle -> m (Color -> Color -> a -> a) +colorFor handle = do + colorAvailable <- isColorAvailable handle + return $ if colorAvailable then color else dumb + where + dumb :: Color -> Color -> a -> a + dumb _ _ = id + color :: Color -> Color -> a -> a + color bg text v = bgColor bg $ System.Console.Pretty.color text v + + +codeStyleFor :: forall a m. (Pretty a, MonadIO m) => Handle -> m (a -> a) +codeStyleFor handle = do + colorAvailable <- isColorAvailable handle + return $ + if colorAvailable + then style Bold + else id + + +pathStyleFor :: forall m. (MonadIO m) => Handle -> m (OsPath -> Text) +pathStyleFor handle = do + pathStyle <- pathStyleFor' handle + return $ \path -> pathStyle $ decodeFS' path + where + decodeFS' :: OsPath -> Text + decodeFS' = pack . unsafePerformIO . decodeFS + + +pathStyleFor' :: forall a m. (Pretty a, MonadIO m) => Handle -> m (a -> a) +pathStyleFor' handle = do + colorAvailable <- isColorAvailable handle + return $ + if colorAvailable + then style Italic + else id + + +printStderr :: (MonadIO m) => Text -> m () +printStderr = liftIO . hPutStrLn stderr + + +data Admonition = Hint | Note | Warning | Error + deriving (Show, Eq, Ord, Enum, Bounded) + + +printStderr' :: (MonadIO m) => Admonition -> Text -> m () +printStderr' admonition message = do + color <- colorFor stderr + printStderr $ color Default color' prefix <> message + where + color' :: Color + color' = case admonition of + Hint -> Cyan + Note -> Yellow + Warning -> Yellow + Error -> Red + prefix :: Text + prefix = showt (FromStringShow admonition) <> ": " + + +die' :: (MonadIO m) => ExitCode -> Text -> m a +die' exitCode message = do + printStderr' Error message + liftIO $ exitWith exitCode + + +dieWithErrors :: (MonadIO m) => ExitCode -> [Text] -> m a +dieWithErrors exitCode errors = do + forM_ errors $ printStderr' Error + liftIO $ exitWith exitCode + + +printTable :: forall m. (MonadIO m) => [Text] -> [[(Color, Text)]] -> m () +printTable headers rows = do + -- Headers are printed to stderr, so that they can be piped to another + -- program without interfering with the table. + forM_ (zip headers columnWidths) $ \(header, width) -> do + putCol stderr Cyan header width + liftIO $ hPutStr stderr " " + putLnStderr + forM_ columnWidths $ \width -> do + putCol stderr Cyan (replicate width "\x2500") width + liftIO $ hPutStr stderr " " + putLnStderr + forM_ rows $ \row -> do + forM_ (zip3 row columnWidths [1 ..]) $ \((color', value), width, i) -> do + putCol stdout color' value $ + if i < Prelude.length row then width else Data.Text.length value + liftIO $ putStr " " + putLn + where + valueWidths :: [[Int]] + valueWidths = + [Data.Text.length c | c <- headers] + : [[Data.Text.length v | (_, v) <- row] | row <- rows] + columnWidths :: [Int] + columnWidths = map maximum $ transpose valueWidths + putCol :: Handle -> Color -> Text -> Int -> m () + putCol h color' value width = do + color <- colorFor stdout + liftIO $ hPutStr h $ color Default color' value + liftIO $ hPutStr h $ replicate (width - Data.Text.length value) " " + putLn :: m () + putLn = liftIO $ putStrLn mempty + putLnStderr :: m () + putLnStderr = liftIO $ hPutStrLn stderr mempty diff --git a/src/Dojang/Commands/Apply.hs b/src/Dojang/Commands/Apply.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Commands/Apply.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dojang.Commands.Apply (apply) where + +import Control.Monad (filterM, forM, forM_, unless, void, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Reader (asks) +import Data.Function ((&)) +import Data.List (nub, sort) +import System.Exit (ExitCode (..), exitWith) +import System.IO (hIsTerminalDevice, stderr, stdin) +import Prelude hiding (readFile) + +import Control.Monad.Logger (logDebug, logDebugSH) +import Data.CaseInsensitive (original) +import Data.Map.Strict (fromList, notMember, toList) +import FortyTwo.Prompts.Confirm (confirm) +import System.Directory.OsPath (getHomeDirectory, makeAbsolute) +import System.OsPath + ( OsPath + , addTrailingPathSeparator + , takeDirectory + , () + ) + +import Dojang.App + ( App + , AppEnv (debug, dryRun, manifestFile, sourceDirectory) + , ensureContext + , lookupEnv' + ) +import Dojang.Commands + ( Admonition (..) + , codeStyleFor + , die' + , pathStyleFor + , printStderr + , printStderr' + ) +import Dojang.Commands.Hook (HookEnv (HookEnv), executeHooks) +import Dojang.Commands.Status (defaultStatusOptions, printWarnings, status) +import Dojang.ExitCodes + ( accidentalDeletionWarning + , conflictError + , fileNotRoutedError + ) +import Dojang.MonadFileSystem (MonadFileSystem (..), dryRunIO) +import Dojang.Types.Context + ( Context (..) + , FileCorrespondence (..) + , FileDeltaKind (..) + , FileEntry (..) + , FileStat (..) + , RouteState (..) + , getRouteState + , makeCorrespond + ) +import Dojang.Types.Environment (Environment (..)) +import Dojang.Types.Hook (HookType (..)) +import Dojang.Types.Registry + ( Registry (..) + , readRegistry + , registryFilename + , writeRegistry + ) +import Dojang.Types.Repository (Repository (..)) + + +apply :: (MonadFileSystem i, MonadIO i) => Bool -> [OsPath] -> App i ExitCode +apply force filePaths = do + ctx <- ensureContext + + -- Determine if this is the first apply (registry doesn't exist) + homeDir <- liftIO getHomeDirectory + let registryPath = homeDir registryFilename + existingRegistry <- readRegistry registryPath + let isFirstApply = case existingRegistry of + Nothing -> True + Just _ -> False + + -- Build hook environment + sourceDir <- asks (.sourceDirectory) + manifestFile' <- asks (.manifestFile) + dryRun' <- asks (.dryRun) + let environment = ctx.environment + let hookEnv = + HookEnv + sourceDir + manifestFile' + dryRun' + (original environment.operatingSystem.identifier) + (original environment.architecture.identifier) + + -- Run pre-apply hooks + $(logDebug) "Running pre-apply hooks..." + executeHooks hookEnv ctx PreApply + when isFirstApply $ do + $(logDebug) "Running pre-first-apply hooks..." + executeHooks hookEnv ctx PreFirstApply + + (allFiles, ws) <- makeCorrespond ctx + fileMap <- fmap fromList $ forM allFiles $ \fc -> do + srcAbsPath <- liftIO $ makeAbsolute fc.source.path + return (srcAbsPath, fc) + pathStyle <- pathStyleFor stderr + filePaths' <- forM filePaths $ \fp -> do + fp' <- liftIO $ makeAbsolute fp + when (fp' `notMember` fileMap) $ do + die' fileNotRoutedError $ + "File " + <> pathStyle fp + <> " is not tracked by this repository." + return fp' + let files = + if null filePaths' + then allFiles + else + [ f + | (srcAbsPath, f) <- toList fileMap + , srcAbsPath `elem` filePaths' + ] + $(logDebugSH) files + -- Check if there are any conflicts: + conflicts <- filterConflicts files + codeStyle <- codeStyleFor stderr + unless (null conflicts) $ do + forM_ conflicts $ \c -> do + printStderr' (if force then Warning else Error) $ + "There is a conflict between " + <> pathStyle c.source.path + <> " and " + <> pathStyle c.destination.path + <> "." + printStderr' Hint $ + "Use `" + <> codeStyle "dojang diff" + <> "' to see the actual changes on both sides." + -- Check if there are any accidental deletions: + let ops = + syncSourceToIntermediate + [ (fc.source, fc.intermediate, fc.sourceDelta) + | fc <- files + ] + & nub + . sort + shimOps <- liftIO $ dryRunIO $ do + forM_ ops doSyncOp + let ctx' = Context ctx.repository ctx.environment lookupEnv' + (files', _) <- makeCorrespond ctx' + syncIntermediateToDestination + ctx' + [ (fc.intermediate, fc.destination, fc.destinationDelta) + | fc <- files' + ] + when (any isDeletion shimOps) $ do + forM_ shimOps $ \case + RemoveDirs path -> do + let path' = addTrailingPathSeparator path + if force + then + printStderr' Warning $ + "Would delete " + <> pathStyle path' + <> " (and its children)." + else + printStderr' Error $ + "Cancelled applying because " + <> pathStyle path' + <> " (and its children) would be deleted." + RemoveFile path -> do + if force + then printStderr' Warning ("Would delete " <> pathStyle path <> ".") + else + printStderr' + Error + $ "Cancelled applying because " + <> pathStyle path + <> " would be deleted." + _ -> return () + printStderr' Hint $ + "If these deletions are accidental, ignore them in your manifest (" + <> pathStyle manifestFile' + <> ")." + -- Exit if there are any problems (unless forced): + when (not force && (not (null conflicts) || any isDeletion shimOps)) $ do + printStderr' Hint $ + "Use " + <> codeStyle "-f" + <> "/" + <> codeStyle "--force" + <> " to ignore these warnings and go ahead." + liftIO $ + exitWith $ + if not (null conflicts) + then conflictError + else accidentalDeletionWarning + -- When everything is fine (or excused): + debug' <- asks (.debug) + when debug' (void $ status defaultStatusOptions) + forM_ ops $ \path -> printSyncOp path >> doSyncOp path + when debug' (void $ status defaultStatusOptions) + (files', _) <- makeCorrespond ctx + $(logDebugSH) files' + ops' <- + syncIntermediateToDestination + ctx + [ (fc.intermediate, fc.destination, fc.destinationDelta) + | fc <- files' + ] + forM_ (nub $ sort ops') $ \path -> printSyncOp path >> doSyncOp path + printWarnings ws + + -- Run post-apply hooks + when isFirstApply $ do + $(logDebug) "Running post-first-apply hooks..." + executeHooks hookEnv ctx PostFirstApply + $(logDebug) "Running post-apply hooks..." + executeHooks hookEnv ctx PostApply + + -- Update registry with current repository path: + currentRepo <- liftIO $ makeAbsolute ctx.repository.sourcePath + case existingRegistry of + Nothing -> do + -- No existing registry, create one + writeRegistry registryPath $ Registry currentRepo + Just reg + | reg.repositoryPath == currentRepo -> + -- Same repository, no need to update + return () + | otherwise -> do + -- Different repository, ask user + isTerminal <- liftIO $ hIsTerminalDevice stdin + proceed <- + if isTerminal + then do + oldPath <- decodePath reg.repositoryPath + newPath <- decodePath currentRepo + let msg = + "The registry already points to " + <> oldPath + <> ". Overwrite with " + <> newPath + <> "?" + liftIO $ confirm msg + else + -- Non-interactive mode, just overwrite + return True + when proceed $ writeRegistry registryPath $ Registry currentRepo + return ExitSuccess + where + isDeletion :: SyncOp -> Bool + isDeletion (RemoveDirs _) = True + isDeletion (RemoveFile _) = True + isDeletion _ = False + + +-- TODO: This should be in another module: +filterConflicts + :: (MonadFileSystem i, MonadIO i) + => [FileCorrespondence] + -> i [FileCorrespondence] +filterConflicts = filterM $ \c -> case (c.sourceDelta, c.destinationDelta) of + (Unchanged, _) -> return False + (_, Unchanged) -> return False + (Removed, Removed) -> return False + (Added, Added) -> case (c.source.stat, c.destination.stat) of + (Directory, Directory) -> return False + (File srcSize, File dstSize) -> + if srcSize /= dstSize + then return True + else do + src <- readFile c.source.path + dst <- readFile c.destination.path + return (src /= dst) + _ -> return True + _ -> return True + + +data SyncOp + = RemoveDirs OsPath + | RemoveFile OsPath + | CopyFile OsPath OsPath + | CreateDir OsPath + | CreateDirs OsPath + deriving (Eq, Show) + + +syncOpOrdKey :: SyncOp -> (OsPath, Int, OsPath) +syncOpOrdKey (RemoveFile path) = (takeDirectory path, 1, path) +syncOpOrdKey (RemoveDirs path) = (path, 2, path) +syncOpOrdKey (CreateDir path) = (path, 3, path) +syncOpOrdKey (CreateDirs path) = (path, 4, path) +syncOpOrdKey (CopyFile _ dst) = (takeDirectory dst, 5, dst) + + +instance Ord SyncOp where + compare a b = compare (syncOpOrdKey a) (syncOpOrdKey b) + + +printSyncOp :: (MonadIO i) => SyncOp -> App i () +printSyncOp (RemoveDirs path) = do + pathStyle <- pathStyleFor stderr + let path' = addTrailingPathSeparator path + printStderr ("Remove " <> pathStyle path' <> " (and its children)...") +printSyncOp (RemoveFile path) = do + pathStyle <- pathStyleFor stderr + printStderr ("Remove " <> pathStyle path <> "...") +printSyncOp (CopyFile src dst) = do + pathStyle <- pathStyleFor stderr + printStderr + ("Copy " <> pathStyle src <> " to " <> pathStyle dst <> "...") +printSyncOp (CreateDir path) = do + pathStyle <- pathStyleFor stderr + let path' = addTrailingPathSeparator path + printStderr ("Create " <> pathStyle path' <> "...") +printSyncOp (CreateDirs path) = do + pathStyle <- pathStyleFor stderr + let path' = addTrailingPathSeparator path + printStderr ("Create " <> pathStyle path' <> " (and its ancestors)...") + + +doSyncOp :: (MonadFileSystem i) => SyncOp -> i () +doSyncOp (RemoveDirs path) = removeDirectoryRecursively path +doSyncOp (RemoveFile path) = removeFile path +doSyncOp (CopyFile src dst) = copyFile src dst +doSyncOp (CreateDir path) = createDirectory path +doSyncOp (CreateDirs path) = createDirectories path + + +syncSourceToIntermediate + :: [(FileEntry, FileEntry, FileDeltaKind)] + -> [SyncOp] +syncSourceToIntermediate files = + concat + [ case delta of + Unchanged -> [] + Removed -> + if to.stat == Directory + then [RemoveDirs to.path] + else [RemoveFile to.path] + Modified -> + case (from.stat, to.stat) of + (Directory, _) -> [RemoveFile to.path, CreateDir to.path] + (_, Directory) -> [RemoveDirs to.path, CopyFile from.path to.path] + _ -> [CopyFile from.path to.path] + Added -> + if from.stat == Directory + then [CreateDirs to.path] + else [CreateDirs $ takeDirectory to.path, CopyFile from.path to.path] + | (from, to, delta) <- files + ] + + +syncIntermediateToDestination + :: (MonadFileSystem i, MonadIO i) + => Context i + -> [(FileEntry, FileEntry, FileDeltaKind)] + -> i [SyncOp] +syncIntermediateToDestination ctx files = + (fmap concat . sequence) + [ case delta of + Unchanged -> return [] + Removed -> + if from.stat == Directory + then return [CreateDirs to.path] + else return [CreateDirs $ takeDirectory to.path, CopyFile from.path to.path] + Modified -> + case (from.stat, to.stat) of + (Directory, _) -> return [RemoveFile to.path, CreateDir to.path] + (_, Directory) -> return [RemoveDirs to.path, CopyFile from.path to.path] + _ -> return [CopyFile from.path to.path] + Added -> do + (state, _) <- getRouteState ctx to.path + case state of + Ignored _ _ -> return [] + _ -> + if to.stat == Directory + then return [RemoveDirs to.path] + else return [RemoveFile to.path] + | (from, to, delta) <- files + ] diff --git a/src/Dojang/Commands/Diff.hs b/src/Dojang/Commands/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Commands/Diff.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Dojang.Commands.Diff (DiffMode (..), diff) where + +import Control.Monad (filterM, forM, forM_, unless, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.List (find, nub) +import Data.Maybe (maybeToList) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitWith) +import System.IO (stderr, stdout) +import System.Info (os) +import Prelude hiding (lines, putStrLn, readFile) +import Prelude qualified (putStrLn) + +import Data.Algorithm.Diff (getGroupedDiff) +import Data.Algorithm.DiffOutput + ( DiffOperation (..) + , LineRange (..) + , diffToLineRanges + ) +import Data.Text (Text, cons, lines, pack, unpack) +import Data.Text.Encoding (decodeUtf8) +import Data.Text.IO (putStrLn) +import System.Directory.OsPath (makeAbsolute) +import System.OsPath (OsPath) +import System.Process (spawnProcess, waitForProcess) +import TextShow (TextShow (showt)) + +import Dojang.App (App, ensureContext) +import Dojang.Commands + ( Admonition (..) + , Color (..) + , colorFor + , die' + , pathStyleFor + , pathStyleFor' + , printStderr' + ) +import Dojang.Commands.Status (printWarnings) +import Dojang.ExitCodes (externalProgramNonZeroExit, fileNotRoutedError) +import Dojang.MonadFileSystem (MonadFileSystem (..)) +import Dojang.Types.Context + ( FileCorrespondence (..) + , FileDeltaKind (..) + , FileEntry (..) + , FileStat (..) + , makeCorrespond + ) + + +data DiffMode = Both | Source | Destination deriving (Show) + + +diff + :: (MonadFileSystem i, MonadIO i) + => DiffMode + -> Maybe OsPath + -> [OsPath] + -> App i ExitCode +diff mode diffProgram files = do + ctx <- ensureContext + (corresponds, ws) <- makeCorrespond ctx + routedFiles <- forM corresponds $ \c -> do + sourcePath <- liftIO $ makeAbsolute c.source.path + destinationPath <- liftIO $ makeAbsolute c.destination.path + return (sourcePath, destinationPath) + pathStyle <- pathStyleFor stderr + nonExistents <- (`filterM` files) $ \file -> do + file' <- liftIO $ makeAbsolute file + if any (\(src, dst) -> file' == src || file' == dst) routedFiles + then return False + else do + printWarnings ws + printStderr' Error $ pathStyle file <> " is not a routed file." + return True + unless (null nonExistents) $ do + printWarnings ws + liftIO $ exitWith fileNotRoutedError + files' <- + nub <$> case files of + [] -> return corresponds + _ -> do + fs <- forM files $ \file -> do + file' <- liftIO $ makeAbsolute file + let found = + find (\((src, dst), _) -> file' == src || file' == dst) $ + zip routedFiles corresponds + return $ maybeToList $ fmap snd found + return $ concat fs + case mode of + Source -> twoWay diffProgram (.source) (.intermediate) files' + Destination -> twoWay diffProgram (.destination) (.intermediate) files' + Both -> twoWay diffProgram (.source) (.destination) files' + printWarnings ws + return ExitSuccess + + +nullPath :: FilePath +nullPath = if os == "mingw32" then "NUL" else "/dev/null" + + +getPath :: (MonadFileSystem m) => FileEntry -> m FilePath +getPath entry = case entry.stat of + Missing -> return nullPath + Directory -> return nullPath + _ -> decodePath entry.path + + +twoWay + :: (MonadFileSystem i, MonadIO i) + => Maybe OsPath + -> (FileCorrespondence -> FileEntry) + -> (FileCorrespondence -> FileEntry) + -> [FileCorrespondence] + -> App i () +twoWay program' srcSelector dstSelector files = do + program <- case program' of + Just p -> Just <$> decodePath p + Nothing -> liftIO $ lookupEnv "DOJANG_DIFF" + forM_ files $ \file -> when (hasChange file) $ do + let src = srcSelector file + let dst = dstSelector file + case program of + Nothing -> do + builtinDiff src dst + Just prog -> do + srcPath <- getPath src + dstPath <- getPath dst + handle <- liftIO $ spawnProcess prog [srcPath, dstPath] + exitCode <- liftIO $ waitForProcess handle + when (exitCode /= ExitSuccess && exitCode /= ExitFailure 1) $ do + cmdStyle <- pathStyleFor' stderr + die' externalProgramNonZeroExit $ + cmdStyle (pack prog) + <> " terminated with exit code " + <> showt exitCode + <> "." + + +hasChange :: FileCorrespondence -> Bool +hasChange c = case (c.sourceDelta, c.destinationDelta) of + (Unchanged, Unchanged) -> False + _ -> True + + +builtinDiff + :: forall i. (MonadFileSystem i, MonadIO i) => FileEntry -> FileEntry -> App i () +builtinDiff a b = do + color <- colorFor stdout + color' <- colorFor stdout + pathStyle <- pathStyleFor stdout + liftIO $ + putStrLn $ + color Default Red "--- " <> pathStyle a.path <> case a.stat of + Missing -> " (missing)" + Directory -> " (directory)" + _ -> "" + liftIO $ + putStrLn $ + color Default Green "+++ " <> pathStyle b.path <> case b.stat of + Missing -> " (missing)" + Directory -> " (directory)" + _ -> "" + textA <- readFileEntry a + textB <- readFileEntry b + let linesA = lines textA + let linesB = lines textB + let diffOps = + diffToLineRanges $ + getGroupedDiff (unpack <$> linesA) (unpack <$> linesB) + forM_ diffOps $ \op -> liftIO $ do + case op of + Deletion aRange bOffset -> do + let ( addRange + , delRange + , (headOffset, headLines) + , (tailOffset, tailLines) + ) = calcRange linesB (bOffset + 1, bOffset) linesA aRange.lrNumbers + printRange delRange addRange + forM_ (take headLines (drop headOffset linesB)) $ \line -> + putStrLn $ ' ' `cons` line + forM_ aRange.lrContents $ \line -> + Prelude.putStrLn $ color' Default Red ('-' : line) + forM_ (take tailLines (drop tailOffset linesB)) $ \line -> + putStrLn $ ' ' `cons` line + Addition bRange aOffset -> do + let ( addRange + , delRange + , (headOffset, headLines) + , (tailOffset, tailLines) + ) = calcRange linesB bRange.lrNumbers linesA (aOffset + 1, aOffset) + printRange delRange addRange + forM_ (take headLines (drop headOffset linesB)) $ \line -> + putStrLn $ ' ' `cons` line + forM_ bRange.lrContents $ \line -> + Prelude.putStrLn $ color' Default Green ('+' : line) + forM_ (take tailLines (drop tailOffset linesB)) $ \line -> + putStrLn $ ' ' `cons` line + Change aRange bRange -> do + let ( addRange + , delRange + , (headOffset, headLines) + , (tailOffset, tailLines) + ) = calcRange linesB bRange.lrNumbers linesA aRange.lrNumbers + printRange delRange addRange + forM_ (take headLines (drop headOffset linesB)) $ \line -> + putStrLn $ ' ' `cons` line + forM_ aRange.lrContents $ \line -> + Prelude.putStrLn $ color' Default Red ('-' : line) + forM_ bRange.lrContents $ \line -> + Prelude.putStrLn $ color' Default Green ('+' : line) + forM_ (take tailLines (drop tailOffset linesB)) $ \line -> + putStrLn $ ' ' `cons` line + where + context :: Int + context = 3 + calcRange + :: [Text] + -> (Int, Int) + -> [Text] + -> (Int, Int) + -> ((Int, Int), (Int, Int), (Int, Int), (Int, Int)) + calcRange addContentLines (addBegin, addEnd) delContentLines (delBegin, delEnd) = + let headOffset = max 0 (addBegin - 1 - context) + headLines = min context (addBegin - 1 - headOffset) + tailOffset = addEnd + tailLines = min context (length addContentLines - tailOffset) + addOffset = + min (length addContentLines) (1 + max 0 (addBegin - 1 - context)) + addLines = + min + (length addContentLines) + (addEnd - (addBegin - 1) + headLines + tailLines) + delOffset = + min (length delContentLines) (1 + max 0 (delBegin - 1 - context)) + delLines = + min + (length delContentLines) + (delEnd - (delBegin - 1) + headLines + tailLines) + in ( (addOffset, addLines) + , (delOffset, delLines) + , (headOffset, headLines) + , (tailOffset, tailLines) + ) + printRange :: (Int, Int) -> (Int, Int) -> IO () + printRange (delOffset, delLines) (addOffset, addLines) = do + color <- colorFor stdout + putStrLn $ + color Default Cyan $ + "@@ -" + <> showt delOffset + <> "," + <> showt delLines + <> " +" + <> showt addOffset + <> "," + <> showt addLines + <> " @@" + readFileEntry :: FileEntry -> App i Text + readFileEntry entry = case entry.stat of + Missing -> return "" + Directory -> return "" + _ -> + -- FIXME: It is assuming that the file is encoded in UTF-8, but it is not + -- always the case: + decodeUtf8 <$> readFile entry.path diff --git a/src/Dojang/Commands/Disambiguation.hs b/src/Dojang/Commands/Disambiguation.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Commands/Disambiguation.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} + +-- | This module provides disambiguation logic for resolving ambiguous source +-- paths when multiple routes map to the same destination. +module Dojang.Commands.Disambiguation + ( AutoSelectMode (..) + , disambiguateRoutes + , getAutoSelectMode + ) where + +import Control.Monad (forM, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Map.Strict (Map, fromList, lookup) +import System.Environment (lookupEnv) +import System.IO (stderr) +import Prelude hiding (lookup) + +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import FortyTwo.Prompts.Select (select) +import System.OsPath (OsPath) + +import Dojang.App (App) +import Dojang.Commands (Admonition (..), pathStyleFor, printStderr') +import Dojang.MonadFileSystem (MonadFileSystem (decodePath)) +import Dojang.Types.Context (CandidateRoute (..)) +import Dojang.Types.Repository (RouteResult (..)) + + +-- | The mode for auto-selecting among ambiguous routes. +data AutoSelectMode + = -- | Prompt the user interactively to select a route. + Interactive + | -- | Automatically select the first route without prompting. + AutoSelectFirst + | -- | Return an error when routes are ambiguous. + ErrorOnAmbiguity + deriving (Eq, Show) + + +-- | Get the auto-select mode from the @DOJANG_AUTO_SELECT@ environment +-- variable. +-- +-- Possible values: +-- +-- * @\"first\"@ - Auto-select the first route without prompting. +-- * @\"error\"@ - Return an error when routes are ambiguous. +-- * (unset or other) - Prompt the user interactively. +getAutoSelectMode :: (MonadIO m) => m AutoSelectMode +getAutoSelectMode = liftIO $ do + env <- lookupEnv "DOJANG_AUTO_SELECT" + return $ case env of + Just "first" -> AutoSelectFirst + Just "error" -> ErrorOnAmbiguity + _ -> Interactive + + +-- | Disambiguate routes when multiple candidates exist. +-- +-- The disambiguation strategy is: +-- +-- 1. If an explicit source path is provided via @--source@, use that. +-- 2. If exactly one source file exists, auto-select it. +-- 3. Otherwise, apply the 'AutoSelectMode': +-- +-- * 'Interactive' - Prompt the user to select a route. +-- * 'AutoSelectFirst' - Select the first route. +-- * 'ErrorOnAmbiguity' - Return 'Nothing' to signal an error. +disambiguateRoutes + :: (MonadFileSystem i, MonadIO i) + => AutoSelectMode + -- ^ The auto-select mode. + -> Maybe OsPath + -- ^ An explicit source path provided via @--source@ option. + -> NonEmpty CandidateRoute + -- ^ The candidate routes to disambiguate. + -> App i (Maybe RouteResult) + -- ^ The selected route, or 'Nothing' if disambiguation failed. +disambiguateRoutes mode explicitSource candidates = + case explicitSource of + Just srcPath -> do + -- Find a candidate matching the explicit source path. + let matching = + [c | c <- NE.toList candidates, c.route.routeName == srcPath] + case matching of + (c : _) -> return $ Just c.route + [] -> return Nothing + Nothing -> do + -- Try to auto-select based on existence. + let existingCandidates = + [c | c <- NE.toList candidates, c.sourceExists] + case existingCandidates of + [c] -> do + -- Auto-select the single existing file. + pathStyle <- pathStyleFor stderr + printStderr' Note $ + "Auto-selected existing file: " + <> pathStyle c.sourceFilePath + return $ Just c.route + _ -> case mode of + AutoSelectFirst -> return $ Just (NE.head candidates).route + ErrorOnAmbiguity -> return Nothing + Interactive -> promptForRoute candidates + + +-- | Prompt the user to select a route from multiple candidates. +promptForRoute + :: (MonadFileSystem i, MonadIO i) + => NonEmpty CandidateRoute + -> App i (Maybe RouteResult) +promptForRoute candidates = do + -- Build display strings with full source file paths and existence labels. + displayPairs <- forM (NE.toList candidates) $ \c -> do + pathStr <- decodePath c.sourceFilePath + let existsLabel = if c.sourceExists then " (exists)" else "" + let displayStr = pathStr ++ existsLabel + return (displayStr, c.route) + let displayStrings = map fst displayPairs + let displayToRoute :: Map String RouteResult + displayToRoute = fromList displayPairs + -- Warn if multiple files exist (potential configuration issue). + let existingCount = length [c | c <- NE.toList candidates, c.sourceExists] + when (existingCount > 1) $ + printStderr' + Warning + "Multiple files exist. This may indicate a configuration issue." + -- Prompt user to select. + selected <- + liftIO $ select "Multiple source paths found. Select one:" displayStrings + return $ lookup selected displayToRoute diff --git a/src/Dojang/Commands/Edit.hs b/src/Dojang/Commands/Edit.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Commands/Edit.hs @@ -0,0 +1,450 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | This module provides the @edit@ command which opens source files +-- in the user's editor and applies changes after editing. +module Dojang.Commands.Edit + ( defaultEditor + , edit + , getEditor + , runEditor + ) where + +import Control.Monad (filterM, foldM, forM, forM_, unless, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.List (isPrefixOf, nub) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..), exitWith) +import System.IO (hIsTerminalDevice, stderr, stdin) +import System.Process (spawnProcess, waitForProcess) + +import Control.Monad.Logger (logDebugSH) +import Data.List.NonEmpty qualified as NE +import Data.Text (Text, pack) +import FortyTwo.Prompts.Confirm (confirm) +import FortyTwo.Prompts.Select (select) +import System.Directory.OsPath (makeAbsolute) +import System.OsPath (OsPath, makeRelative, normalise, splitDirectories, ()) +import TextShow (showt) + +import Dojang.App (App, ensureContext) +import Dojang.Commands + ( Admonition (..) + , codeStyleFor + , die' + , dieWithErrors + , pathStyleFor + , printStderr + , printStderr' + ) +import Dojang.Commands.Apply qualified (apply) +import Dojang.Commands.Disambiguation + ( disambiguateRoutes + , getAutoSelectMode + ) +import Dojang.Commands.Status (printWarnings) +import Dojang.ExitCodes + ( ambiguousRouteError + , externalProgramNonZeroExit + , fileNotRoutedError + , sourceCannotBeTargetError + , userCancelledError + ) +import Dojang.MonadFileSystem (MonadFileSystem (..)) +import Dojang.MonadFileSystem qualified as FS +import Dojang.Types.Context + ( CandidateRoute (..) + , Context (..) + , FileCorrespondence (..) + , FileDeltaKind (..) + , FileEntry (..) + , IgnoredFile (..) + , RouteMatch (..) + , findCandidateRoutesFor + , findMatchingRoutes + , getIgnoredFiles + , makeCorrespond + , makeCorrespondBetweenThreeFiles + ) +import Dojang.Types.Repository (Repository (..), RouteResult (..)) + + +-- | The default editor for the platform. +defaultEditor :: String +#ifdef mingw32_HOST_OS +defaultEditor = "notepad" +#else +defaultEditor = "vi" +#endif + + +-- | Get the editor to use, checking --editor option, then VISUAL, then EDITOR. +-- Returns Nothing if no editor is specified (caller should use defaultEditor). +getEditor :: (MonadIO m) => Maybe String -> m (Maybe String) +getEditor (Just editor) = return $ Just editor +getEditor Nothing = liftIO $ do + visual <- lookupEnv "VISUAL" + case visual of + Just v -> return $ Just v + Nothing -> lookupEnv "EDITOR" + + +-- | Run the editor with the given files. +runEditor + :: (MonadIO m) + => String + -- ^ The editor program to run. + -> [FilePath] + -- ^ The files to edit. + -> m ExitCode +runEditor editor files = liftIO $ do + handle <- spawnProcess editor files + waitForProcess handle + + +-- | The edit command: open source files in an editor and apply changes. +edit + :: (MonadFileSystem i, MonadIO i) + => Maybe String + -- ^ The @--editor@ option. + -> Bool + -- ^ The @--no-apply@ flag. + -> Bool + -- ^ The @--force@ flag. + -> Bool + -- ^ The @--sequential@ flag. + -> Bool + -- ^ The @--all@ flag (skip confirmation). + -> Bool + -- ^ The @--include-unregistered@ flag. + -> Maybe OsPath + -- ^ The @--source@ option for disambiguation. + -> [OsPath] + -- ^ The target file paths to edit (may be empty for all changed files). + -> App i ExitCode +edit editorOpt noApply force sequential allFlag _includeUnregistered _explicitSource [] = do + -- No arguments: edit source files of all changed files + ctx <- ensureContext + pathStyle <- pathStyleFor stderr + codeStyle <- codeStyleFor stderr + (allFiles, ws) <- makeCorrespond ctx + let changedFiles = filter isChanged allFiles + printWarnings ws + + -- Get ignored files and warn about them + ignoredFiles <- getIgnoredFiles ctx + -- Filter to only ignored files that exist in destination + existingIgnored <- filterM (exists . (.destinationPath)) ignoredFiles + -- Create correspondences for ignored files if --force is used + ignoredCorrespondences <- + if force && not (null existingIgnored) + then do + forM existingIgnored $ \ignored -> do + let interPath = + ctx.repository.intermediatePath + ignored.routeName + makeRelative + (normalise ignored.routeName) + (normalise ignored.sourcePath) + makeCorrespondBetweenThreeFiles + interPath + ignored.sourcePath + ignored.destinationPath + else return [] + let changedIgnored = filter isChanged ignoredCorrespondences + + -- Print warnings for ignored files + unless (null existingIgnored) $ do + if force + then do + printStderr' Note $ + "Including " + <> pack (show $ length existingIgnored) + <> " ignored file(s) due to " + <> codeStyle "--force" + <> ":" + forM_ existingIgnored $ \ignored -> do + printStderr $ + " " + <> pathStyle ignored.destinationPath + <> " (pattern: " + <> codeStyle (pack $ show ignored.pattern) + <> ")" + else do + printStderr' Warning $ + "Skipping " + <> pack (show $ length existingIgnored) + <> " ignored file(s):" + forM_ existingIgnored $ \ignored -> do + printStderr $ + " " + <> pathStyle ignored.destinationPath + <> " (pattern: " + <> codeStyle (pack $ show ignored.pattern) + <> ")" + printStderr' Hint $ + "Use " + <> codeStyle "--force" + <> " to include ignored files." + + let allChangedFiles = changedFiles ++ changedIgnored + if null allChangedFiles + then do + printStderr "No changed files to edit." + return ExitSuccess + else do + -- Display changed files + printStderr $ + "Found " + <> pack (show $ length allChangedFiles) + <> " changed file(s):" + forM_ allChangedFiles $ \fc -> do + printStderr $ " " <> pathStyle fc.source.path + -- Confirm unless --all is specified + proceed <- + if allFlag + then return True + else do + isTerminal <- liftIO $ hIsTerminalDevice stdin + if isTerminal + then liftIO $ confirm "Edit all changed source files?" + else return True -- Non-interactive: proceed + if proceed + then do + let sourceFiles = map (.source.path) allChangedFiles + runEditorOnFiles editorOpt noApply force sequential sourceFiles + else do + printStderr "Cancelled." + liftIO $ exitWith userCancelledError +edit editorOpt noApply force sequential _allFlag _includeUnregistered explicitSource paths = do + ctx <- ensureContext + pathStyle <- pathStyleFor stderr + codeStyle <- codeStyleFor stderr + + -- Make paths absolute first. + absPaths <- liftIO $ mapM makeAbsolute paths + $(logDebugSH) (absPaths :: [OsPath]) + + -- Check if any target is inside the source repository (not allowed). + sourcePath' <- liftIO $ makeAbsolute ctx.repository.sourcePath + let sourcePathPrefix = splitDirectories sourcePath' + let overlappedPaths = + [ p + | p <- absPaths + , sourcePathPrefix `isPrefixOf` splitDirectories p + ] + $(logDebugSH) overlappedPaths + unless (null overlappedPaths) $ + dieWithErrors + sourceCannotBeTargetError + [ "Cannot edit " + <> pathStyle p + <> " because it is a file inside the repository." + | p <- overlappedPaths + ] + + -- Separate existing and non-existing files. + (existingPaths, nonExistentPaths) <- partitionM exists absPaths + $(logDebugSH) (nonExistentPaths :: [OsPath]) + + -- Map each existing target path to its source file. + autoSelectMode <- getAutoSelectMode + existingSourceFiles <- forM existingPaths $ \targetPath -> do + (routeMatch, ws) <- findMatchingRoutes ctx targetPath + printWarnings $ nub ws + case routeMatch of + NoMatch -> do + printStderr' Error ("File " <> pathStyle targetPath <> " is not routed.") + printStderr' Hint "Add a route for it in your manifest (dojang.toml)." + liftIO $ exitWith fileNotRoutedError + SingleMatch route -> do + srcPath <- computeSourcePath ctx targetPath route + return srcPath + AmbiguousMatch candidates -> do + maybeRoute <- disambiguateRoutes autoSelectMode explicitSource candidates + case maybeRoute of + Nothing -> do + let routeNames = [c.route.routeName | c <- NE.toList candidates] + routeNameStrs <- mapM decodePath routeNames + printStderr' Error $ + "Ambiguous source path for " + <> pathStyle targetPath + <> ". Multiple routes match:" + forM_ routeNameStrs $ \name -> + printStderr' Note $ " - " <> codeStyle (pack name) + printStderr' + Hint + $ "Use " + <> codeStyle "--source" + <> " to specify which source path to use, or set " + <> codeStyle "DOJANG_AUTO_SELECT=first" + <> " to auto-select." + liftIO $ exitWith ambiguousRouteError + Just route -> do + srcPath <- computeSourcePath ctx targetPath route + return srcPath + + -- Handle non-existent files: find candidate routes and create source files. + newSourceFiles <- forM nonExistentPaths $ \targetPath -> do + candidates <- findCandidateRoutesFor ctx targetPath + case candidates of + [] -> do + printStderr' Error ("File " <> pathStyle targetPath <> " is not routed.") + printStderr' Hint "Add a route for it in your manifest (dojang.toml)." + liftIO $ exitWith fileNotRoutedError + [route] -> do + srcPath <- computeSourcePath ctx targetPath route + createEmptySourceFile pathStyle srcPath + return srcPath + (firstRoute : restRoutes) -> do + let routes = firstRoute : restRoutes + -- Multiple routes: prompt for selection. + isTerminal <- liftIO $ hIsTerminalDevice stdin + if isTerminal + then do + routeLabels <- forM routes $ \route -> do + routeName' <- decodePath route.routeName + return routeName' + printStderr' Note $ + "Multiple routes can create " <> pathStyle targetPath <> ":" + selectedLabel <- + liftIO $ select "Select route to use:" routeLabels + -- Find the route that matches the selected label. + matchingRoutes <- + filterM + ( \r -> do + name <- decodePath r.routeName + return (name == selectedLabel) + ) + routes + let selectedRoute = case matchingRoutes of + (match : _) -> match + [] -> firstRoute -- Fallback to first if no match. + srcPath <- computeSourcePath ctx targetPath selectedRoute + createEmptySourceFile pathStyle srcPath + return srcPath + else do + -- Non-interactive: use first route. + routeName' <- decodePath firstRoute.routeName + printStderr' Note $ + "Auto-selecting route " + <> codeStyle (pack routeName') + <> " for " + <> pathStyle targetPath + srcPath <- computeSourcePath ctx targetPath firstRoute + createEmptySourceFile pathStyle srcPath + return srcPath + + let sourceFiles = existingSourceFiles ++ newSourceFiles + runEditorOnFiles editorOpt noApply force sequential sourceFiles + + +-- | Check if a file correspondence has changes. +isChanged :: FileCorrespondence -> Bool +isChanged fc = fc.sourceDelta /= Unchanged || fc.destinationDelta /= Unchanged + + +-- | Run the editor on the given source files. +runEditorOnFiles + :: (MonadFileSystem i, MonadIO i) + => Maybe String + -- ^ The @--editor@ option. + -> Bool + -- ^ The @--no-apply@ flag. + -> Bool + -- ^ The @--force@ flag. + -> Bool + -- ^ The @--sequential@ flag. + -> [OsPath] + -- ^ The source file paths to edit. + -> App i ExitCode +runEditorOnFiles editorOpt noApply force sequential sourceFiles = do + pathStyle <- pathStyleFor stderr + + -- Get the editor to use. + maybeEditor <- getEditor editorOpt + let editor = maybe defaultEditor id maybeEditor + + -- Convert source paths to FilePath for the editor. + sourceFilePaths <- mapM decodePath sourceFiles + + -- Early return if no files. + case sourceFiles of + [] -> return ExitSuccess + (firstFile : _) -> do + -- Run the editor. + printStderr $ + "Opening " <> pathStyle firstFile <> " in " <> pack editor <> "..." + if sequential + then do + -- Sequential mode: edit one file at a time. + forM_ sourceFilePaths $ \srcPath -> do + srcOsPath <- encodePath srcPath + printStderr $ "Editing " <> pathStyle srcOsPath <> "..." + exitCode <- runEditor editor [srcPath] + when (exitCode /= ExitSuccess) $ do + die' externalProgramNonZeroExit $ + pack editor <> " exited with code " <> showt exitCode <> "." + -- Apply after each file if not disabled. + unless noApply $ do + printStderr "Applying changes..." + _ <- Dojang.Commands.Apply.apply force [] + return () + else do + -- Concurrent mode: open all files at once. + exitCode <- runEditor editor sourceFilePaths + when (exitCode /= ExitSuccess) $ do + die' externalProgramNonZeroExit $ + pack editor <> " exited with code " <> showt exitCode <> "." + -- Apply changes if not disabled. + unless noApply $ do + printStderr "Applying changes..." + _ <- Dojang.Commands.Apply.apply force [] + return () + return ExitSuccess + + +-- | Compute the source path for a target path given a route. +-- This follows the same pattern as Reflect.hs 'makeCorrespondForRoute'. +computeSourcePath + :: (MonadFileSystem m) + => Context m + -> OsPath + -- ^ The target (destination) path. + -> RouteResult + -- ^ The matching route. + -> m OsPath +computeSourcePath _ctx targetPath route = do + period <- encodePath "." + let normalized = normalise route.destinationPath + let relPath = makeRelative normalized targetPath + if normalized == targetPath || relPath == period + then return $ normalise route.sourcePath + else return $ normalise $ route.sourcePath relPath + + +-- | Partition a list based on a monadic predicate. +partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM p xs = foldM go ([], []) xs + where + go (ts, fs) x = do + b <- p x + return $ if b then (ts ++ [x], fs) else (ts, fs ++ [x]) + + +-- | Create an empty source file for a new file. +createEmptySourceFile + :: (MonadFileSystem m, MonadIO m) + => (OsPath -> Text) + -- ^ Path style function for display. + -> OsPath + -- ^ The source file path to create. + -> m () +createEmptySourceFile pathStyle srcPath = do + srcExists <- exists srcPath + unless srcExists $ do + printStderr $ "Creating new source file: " <> pathStyle srcPath + FS.writeFile srcPath "" diff --git a/src/Dojang/Commands/Env.hs b/src/Dojang/Commands/Env.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Commands/Env.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Dojang.Commands.Env (env) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import System.Exit (ExitCode (..)) +import Prelude hiding (putStr) + +import Control.Monad.Except (MonadError (..)) +import Control.Monad.Logger (logDebugSH, logError) +import Data.Text.IO (putStr) +import Options.Applicative.Path (hyphen) +import System.OsPath (OsPath) +import TextShow (TextShow (showt)) + +import Dojang.App (App, currentEnvironment') +import Dojang.ExitCodes (fileWriteError) +import Dojang.MonadFileSystem (MonadFileSystem) +import Dojang.Syntax.Env (writeEnvFile, writeEnvironment) +import Dojang.Types.Environment.Current (MonadEnvironment (..)) + + +env :: (MonadFileSystem i, MonadIO i) => Bool -> OsPath -> App i ExitCode +env ignoreEnvFile outputPath = do + currentEnv <- + if ignoreEnvFile then liftIO currentEnvironment else currentEnvironment' + $(logDebugSH) currentEnv + if outputPath == hyphen + then do + liftIO $ putStr $ writeEnvironment currentEnv + return ExitSuccess + else + ( do + () <- writeEnvFile currentEnv outputPath + return ExitSuccess + ) + `catchError` \err -> do + $(logError) $ showt err + return fileWriteError diff --git a/src/Dojang/Commands/Hook.hs b/src/Dojang/Commands/Hook.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Commands/Hook.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Hook execution module for running pre/post apply hooks. +module Dojang.Commands.Hook + ( HookEnv (..) + , executeHooks + , shouldRunHook + ) where + +import Control.Monad (forM_, unless) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Reader (asks) +import System.Exit (ExitCode (..)) +import Prelude hiding (readFile) + +import Control.Monad.Logger (logDebug, logError, logInfo) +import Data.Map.Strict (lookup) +import Data.Text (Text, pack, unpack) +import System.Directory.OsPath (makeAbsolute) +import System.OsPath (OsPath, decodeFS) +import System.Process + ( CreateProcess (..) + , proc + , waitForProcess + , withCreateProcess + ) +import TextShow (FromStringShow (FromStringShow), TextShow (showt)) + +import Dojang.App (App, AppEnv (..)) +import Dojang.Commands (Admonition (..), die', pathStyleFor, printStderr') +import Dojang.ExitCodes (hookFailedError) +import Dojang.MonadFileSystem (MonadFileSystem) +import Dojang.Types.Context (Context (..)) +import Dojang.Types.Environment (Environment (..)) +import Dojang.Types.EnvironmentPredicate.Evaluate (evaluate) +import Dojang.Types.Hook (Hook (..), HookMap, HookType (..)) +import Dojang.Types.Manifest (Manifest (..)) +import Dojang.Types.MonikerMap (MonikerMap) +import Dojang.Types.Repository (Repository (..)) + +import System.IO (stderr) + + +-- | Environment information for hook execution. +data HookEnv = HookEnv + { repositoryPath :: OsPath + -- ^ The path to the repository. + , manifestPath :: OsPath + -- ^ The path to the manifest file. + , isDryRun :: Bool + -- ^ Whether we're in dry-run mode. + , currentOS :: Text + -- ^ The current operating system. + , currentArch :: Text + -- ^ The current architecture. + } + deriving (Show) + + +-- | Determine if a hook should run based on its condition. +shouldRunHook :: MonikerMap -> Environment -> Hook -> Bool +shouldRunHook monikers environment hook = + let (result, _) = evaluate environment monikers hook.condition + in result + + +-- | Execute all hooks of a given type. +executeHooks + :: (MonadFileSystem i, MonadIO i) + => HookEnv + -> Context (App i) + -> HookType + -> App i () +executeHooks hookEnv ctx hookType = do + let repo = ctx.repository :: Repository + let manifest' = repo.manifest :: Manifest + let hookMap = manifest'.hooks :: HookMap + case Data.Map.Strict.lookup hookType hookMap of + Nothing -> return () + Just hookList -> do + $(logDebug) $ "Executing " <> pack (show hookType) <> " hooks..." + forM_ hookList $ \hook -> do + let monikers = manifest'.monikers + let environment = ctx.environment + let shouldRun = shouldRunHook monikers environment hook + if shouldRun + then executeHook hookEnv hook + else + $(logDebug) $ + "Skipping hook (condition not met): " <> showt (FromStringShow hook) + + +-- | Execute a single hook. +executeHook + :: (MonadIO i) + => HookEnv + -> Hook + -> App i () +executeHook hookEnv hook = do + dryRun' <- asks (.dryRun) + pathStyle <- pathStyleFor stderr + cmdPath <- liftIO $ decodeFS hook.command + let argsStr = unpack <$> hook.args + + if dryRun' || hookEnv.isDryRun + then do + -- In dry-run mode, just print what would be done + printStderr' Note $ + "Would run hook: " + <> pathStyle hook.command + <> " " + <> pack (unwords argsStr) + else do + -- Actually execute the hook + $(logInfo) $ + "Running hook: " + <> showt (FromStringShow hook.command) + <> " " + <> showt argsStr + <> "..." + + workDir <- case hook.workingDirectory of + Just wd -> Just <$> liftIO (decodeFS wd) + Nothing -> Just <$> liftIO (decodeFS hookEnv.repositoryPath) + + -- Set up environment variables + repoPath <- liftIO $ makeAbsolute hookEnv.repositoryPath >>= decodeFS + manifestPath' <- liftIO $ decodeFS hookEnv.manifestPath + let envVars = + [ ("DOJANG_REPOSITORY", repoPath) + , ("DOJANG_MANIFEST", manifestPath') + , ("DOJANG_DRY_RUN", if hookEnv.isDryRun then "1" else "0") + , ("DOJANG_OS", unpack hookEnv.currentOS) + , ("DOJANG_ARCH", unpack hookEnv.currentArch) + ] + + let createProc = + (proc cmdPath argsStr) + { cwd = workDir + , env = Just envVars + , delegate_ctlc = True + } + + exitCode <- liftIO $ withCreateProcess createProc $ \_ _ _ ph -> + waitForProcess ph + + case exitCode of + ExitSuccess -> + $(logInfo) $ + "Hook completed successfully: " <> showt (FromStringShow hook.command) + ExitFailure code -> do + $(logError) $ + "Hook failed with exit code " + <> showt code + <> ": " + <> showt (FromStringShow hook.command) + unless hook.ignoreFailure $ do + die' hookFailedError $ + "Hook " + <> pathStyle hook.command + <> " failed with exit code " + <> showt code + <> "." diff --git a/src/Dojang/Commands/Init.hs b/src/Dojang/Commands/Init.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Commands/Init.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Dojang.Commands.Init + ( InitPreset (..) + , init + , initPresetName + ) where + +import Control.Monad (forM_, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Function ((&)) +import Data.List (maximumBy, sortOn) +import Data.List.NonEmpty as NonEmpty (NonEmpty ((:|)), toList) +import Data.Ord (comparing) +import Data.String (IsString) +import System.Exit (ExitCode (..), exitWith) +import System.IO (stderr) +import System.IO.Unsafe (unsafePerformIO) +import System.Info qualified (os) +import Prelude hiding (init, writeFile) + +import Control.Monad.Logger (logDebugSH, logInfo) +import Control.Monad.Reader (asks) +import Data.HashMap.Strict qualified as HashMap + ( filterWithKey + , lookup + , member + , toList + ) +import Data.Map.Strict + ( Map + , empty + , findWithDefault + , fromList + , fromListWith + , keys + , toAscList + , (!) + ) +import Data.Map.Strict qualified as Map (toList) +import Data.Set (Set) +import Data.Set qualified as Set (member, null, toAscList) +import Data.Text (Text, lines, unlines) +import FortyTwo.Prompts.Multiselect (multiselect) +import System.FilePattern (FilePattern) +import System.OsPath (OsPath, encodeFS, ()) + +import Data.ByteString (ByteString) +import Data.Text.Encoding (encodeUtf8) +import Dojang.App + ( App + , AppEnv (debug, dryRun, sourceDirectory) + , doesManifestExist + , saveManifest + ) +import Dojang.Commands + ( Admonition (..) + , codeStyleFor + , die' + , pathStyleFor + , printStderr + , printStderr' + ) +import Dojang.ExitCodes (manifestAlreadyExists, unsupportedOnEnvError) +import Dojang.MonadFileSystem (FileType (..), MonadFileSystem (..)) +import Dojang.Syntax.Manifest.Writer (writeManifest) +import Dojang.Types.Environment + ( Architecture (..) + , Environment (..) + , Kernel (..) + , OperatingSystem (..) + ) +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..)) +import Dojang.Types.EnvironmentPredicate.Evaluate (evaluate) +import Dojang.Types.EnvironmentPredicate.Specificity (specificity) +import Dojang.Types.FilePathExpression (FilePathExpression (..), (+/+)) +import Dojang.Types.FileRoute (FileRoute (fileType), fileRoute) +import Dojang.Types.FileRouteMap (FileRouteMap) +import Dojang.Types.Manifest (Manifest (..)) +import Dojang.Types.MonikerMap (MonikerMap) +import Dojang.Types.MonikerName (MonikerName, parseMonikerName) + + +data InitPreset + = Amd64Linux + | Arm64Linux + | AppleSiliconMac + | IntelMac + | Win64 + | WinArm64 + | Wsl2 + deriving (Show, Eq, Ord, Enum, Bounded) + + +initPresetName :: (IsString a) => InitPreset -> a +initPresetName = \case + Amd64Linux -> "Linux (AMD64)" + Arm64Linux -> "Linux (ARM64)" + AppleSiliconMac -> "Apple silicon Mac (M series)" + IntelMac -> "Intel Mac" + Win64 -> "Windows (64-bit)" + WinArm64 -> "Windows (ARM64)" + Wsl2 -> "Linux (WSL2)" + + +toEnvironment :: InitPreset -> Environment +toEnvironment = \case + Amd64Linux -> Environment Linux X86_64 (Kernel "Linux" "0.0.0.0") + Arm64Linux -> Environment Linux AArch64 (Kernel "Linux" "0.0.0.0") + AppleSiliconMac -> Environment MacOS AArch64 (Kernel "Darwin" "0.0.0") + IntelMac -> Environment MacOS X86_64 (Kernel "Darwin" "0.0.0") + Win64 -> Environment Windows X86_64 (Kernel "Windows" "0.0.0.0") + WinArm64 -> Environment Windows AArch64 (Kernel "Windows" "0.0.0.0") + Wsl2 -> + Environment + Linux + X86_64 + (Kernel "Linux" "0.0.0.0-microsoft-standard-WSL2") + + +monikers :: MonikerMap +monikers = + [ (moniker "linux", OperatingSystem Linux) + , (moniker "macos", OperatingSystem MacOS) + , (moniker "windows", OperatingSystem Windows) + , (moniker "posix", Or [OperatingSystem Linux, OperatingSystem MacOS]) + , (moniker "linux-amd64", And [OperatingSystem Linux, Architecture X86_64]) + , (moniker "linux-arm64", And [OperatingSystem Linux, Architecture AArch64]) + , (moniker "macos-intel", And [OperatingSystem MacOS, Architecture X86_64]) + , + ( moniker "macos-apple-silicon" + , And [OperatingSystem MacOS, Architecture AArch64] + ) + , + ( moniker "windows-amd64" + , And [OperatingSystem Windows, Architecture X86_64] + ) + , + ( moniker "windows-arm64" + , And [OperatingSystem Windows, Architecture AArch64] + ) + , + ( moniker "linux-wsl" + , And + [ OperatingSystem Linux + , KernelReleaseSuffix "-microsoft-standard-WSL2" + ] + ) + ] + + +moniker :: Text -> MonikerName +moniker name = case parseMonikerName name of + Right n -> n + Left _ -> error $ "Invalid moniker name: " <> show name + + +selectMonikers :: Environment -> [MonikerName] +selectMonikers env = + [ (name, predicate) + | (name, predicate) <- HashMap.toList monikers + , fst $ evaluate env monikers predicate + ] + & sortOn (specificity (`HashMap.lookup` monikers) . snd) + & map fst + + +listNeededMonikers :: [InitPreset] -> [(InitPreset, NonEmpty MonikerName)] +listNeededMonikers presets = + [ (preset, m :| ms'') + | (preset, ms) <- selectedMonikers + , let (havingDups, notHavingDups) = span (hasDuplicateMonikers preset) ms + , let ms' = havingDups ++ take 1 notHavingDups + , (m : ms'') <- [ms'] + ] + where + selectedMonikers :: [(InitPreset, [MonikerName])] + selectedMonikers = + [(preset, selectMonikers $ toEnvironment preset) | preset <- presets] + hasDuplicateMonikers :: InitPreset -> MonikerName -> Bool + hasDuplicateMonikers preset moniker' = + (not . null) + [ True + | (p, ms) <- selectedMonikers + , p /= preset + , m <- ms + , m == moniker' + ] + + +path :: String -> OsPath +path = unsafePerformIO . encodeFS + + +routes + :: Map OsPath ([(Set MonikerName, FilePathExpression)], Set OperatingSystem) +routes = + [ + ( path "HOME" + , + ( + [ ([moniker "posix", moniker "linux", moniker "macos"], posixHome) + , ([moniker "windows"], windowsUserProfile) + ] + , [Linux, MacOS, Linux] + ) + ) + , + ( path "XDG_CONFIG_HOME" + , + ( + [ + ( [moniker "posix", moniker "linux", moniker "macos"] + , posixXdgConfigHome + ) + , ([moniker "windows"], windowsXdgConfigHome) + ] + , [Linux, MacOS] + ) + ) + , + ( path "Application Support" + , + ( + [ ([moniker "macos"], macosApplicationSupport) + , ([moniker "linux"], posixXdgConfigHome) + , ([moniker "windows"], windowsAppData) + ] + , [MacOS] + ) + ) + , + ( path "AppData" + , + ( + [ ([moniker "windows"], windowsAppData) + , + ( [moniker "posix", moniker "linux", moniker "macos"] + , posixXdgConfigHome + ) + ] + , [Windows] + ) + ) + ] + + +ignorePatterns' :: Map OsPath [FilePattern] +ignorePatterns' = + [ (path "HOME", ["*"]) + , (path "Application Support", ["*"]) + , (path "AppData", ["*"]) + ] + + +makeRouteMap + :: [(InitPreset, NonEmpty MonikerName)] -> MonikerMap -> FileRouteMap +makeRouteMap neededMonikers monikers' = + fromList + [ (path', fileRoute monikers' (makePairs route) Directory) + | (path', (route, requiredOses)) <- Map.toList routes + , any + ((`Set.member` requiredOses) . (.operatingSystem) . toEnvironment . fst) + neededMonikers + ] + where + monikerScoreTable :: Map MonikerName Int + monikerScoreTable = + fromListWith (+) $ + zip (concatMap (NonEmpty.toList . snd) neededMonikers) [1, 1 ..] + makePairs + :: [(Set MonikerName, FilePathExpression)] + -> [(MonikerName, Maybe FilePathExpression)] + makePairs route = + [ ( maximumBy + ( comparing $ \k -> + ( findWithDefault 0 k monikerScoreTable + , specificity (`HashMap.lookup` monikers') $ Moniker k + ) + ) + (Set.toAscList names) + , Just expr + ) + | (names, expr) <- route + , not $ Set.null names + , any (`HashMap.member` monikers') $ Set.toAscList names + ] + + +makeManifest :: [InitPreset] -> Manifest +makeManifest presets = + Manifest monikers' routeMap ignorePatterns'' empty + where + neededMonikers :: [(InitPreset, NonEmpty MonikerName)] + neededMonikers = listNeededMonikers presets + monikers' :: MonikerMap + monikers' = + monikers + & HashMap.filterWithKey + ( \k _ -> + k `elem` [m | (_, ms) <- neededMonikers, m <- NonEmpty.toList ms] + ) + routeMap :: FileRouteMap + routeMap = makeRouteMap neededMonikers monikers' + ignorePatterns'' = + fromList + [ (p, ignores) + | p <- keys routeMap + , let ignores = findWithDefault [] p ignorePatterns' + , not $ null ignores + ] + + +init :: (MonadFileSystem i, MonadIO i) => [InitPreset] -> Bool -> App i ExitCode +init presets noInteractive = do + manifestExists <- doesManifestExist + when manifestExists $ do + die' manifestAlreadyExists "Manifest already exists." + $(logInfo) "No manifest found." + when (System.Info.os == "mingw32" && not noInteractive) $ do + codeStyle <- codeStyleFor stderr + printStderr' Error $ + "We are sorry, but interactive mode is currently not supported on " + <> "Windows. See the relevant issue:\n" + <> "\n https://github.com/dahlia/dojang/issues/4\n" + printStderr' Hint $ + ("Please use the " <> codeStyle "--linux-*" <> "/") + <> (codeStyle "--macos-*" <> "/" <> codeStyle "--windows-*") + <> " options with the " + <> (codeStyle "-I" <> "/" <> codeStyle "--no-interactive") + <> " flag. See also " + <> (codeStyle "-h" <> "/" <> codeStyle "--help") + <> " for command-line options." + liftIO $ exitWith unsupportedOnEnvError + presets' <- + if null presets && not noInteractive + then askPresets + else pure presets + $(logDebugSH) presets' + let manifest = makeManifest presets' + repoDir <- asks (.sourceDirectory) + pathStyle <- pathStyleFor stderr + forM_ (Data.Map.Strict.toAscList manifest.fileRoutes) $ \(path', route') -> do + when (route'.fileType == Directory) $ do + let dirPath = repoDir path' + createDirectories dirPath + printStderr $ "Directory created: " <> pathStyle dirPath <> "." + filename <- saveManifest manifest + printStderr $ "Manifest created: " <> pathStyle filename <> "." + generateGitIgnore + debug' <- asks (.debug) + dryRun' <- asks (.dryRun) + when (debug' || dryRun') $ do + let manifestText = indent $ writeManifest manifest + printStderr' Note $ + "The manifest file looks like below:\n\n" + <> manifestText + <> "\n" + return ExitSuccess + + +posixHome :: FilePathExpression +posixHome = Substitution "HOME" + + +windowsUserProfile :: FilePathExpression +windowsUserProfile = Substitution "UserProfile" + + +posixXdgConfigHome :: FilePathExpression +posixXdgConfigHome = + SubstitutionWithDefault "XDG_CONFIG_HOME" $ posixHome +/+ ".config" + + +windowsXdgConfigHome :: FilePathExpression +windowsXdgConfigHome = + SubstitutionWithDefault "XDG_CONFIG_HOME" $ windowsUserProfile +/+ ".config" + + +macosApplicationSupport :: FilePathExpression +macosApplicationSupport = + Substitution "HOME" +/+ "Library" +/+ "Application Support" + + +windowsAppData :: FilePathExpression +windowsAppData = Substitution "AppData" + + +askPresets :: (MonadIO i) => App i [InitPreset] +askPresets = do + -- FIXME: It doesn't seem to work on Windows... + -- https://github.com/GianlucaGuarini/fortytwo/issues/7 + presets <- + multiselect + "What operating systems and architectures do you use?" + (map initPresetName [minBound .. maxBound]) + return [namesToPresets ! name | name <- presets] + where + namesToPresets :: Map String InitPreset + namesToPresets = + fromList + [(initPresetName preset, preset) | preset <- [minBound .. maxBound]] + + +indent :: Text -> Text +indent = Data.Text.unlines . map (" " <>) . Data.Text.lines + + +generateGitIgnore :: (MonadFileSystem i, MonadIO i) => App i () +generateGitIgnore = do + sourceDir <- asks (.sourceDirectory) + gitDir <- encodePath ".git" + gitDirExists <- isDirectory (sourceDir gitDir) + gitIgnore <- encodePath ".gitignore" + gitIgnoreExists <- isFile (sourceDir gitIgnore) + when (gitDirExists && not gitIgnoreExists) $ do + writeFile gitIgnore gitIgnoreContents + printStderr ".gitignore created" + + +gitIgnoreContents :: ByteString +gitIgnoreContents = encodeUtf8 "# Generated by Dojang\n.dojang/\n" diff --git a/src/Dojang/Commands/Reflect.hs b/src/Dojang/Commands/Reflect.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Commands/Reflect.hs @@ -0,0 +1,604 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dojang.Commands.Reflect (reflect) where + +import Control.Monad (filterM, forM, forM_, unless, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.List (isPrefixOf, nub) +import System.Exit (ExitCode (..), exitWith) +import System.IO (hIsTerminalDevice, stderr, stdin) + +import Control.Monad.Logger (logDebug, logDebugSH) +import Control.Monad.Reader (asks) +import Data.List.NonEmpty qualified as NE +import Data.Text (pack) +import FortyTwo.Prompts.Confirm (confirm) +import FortyTwo.Prompts.Select (select) +import System.Directory.OsPath (makeAbsolute) +import System.OsPath + ( OsPath + , makeRelative + , normalise + , splitDirectories + , takeDirectory + , () + ) + +import Dojang.App (App, AppEnv (manifestFile), ensureContext) +import Dojang.Commands + ( Admonition (..) + , codeStyleFor + , die' + , dieWithErrors + , pathStyleFor + , printStderr + , printStderr' + ) +import Dojang.Commands.Disambiguation + ( disambiguateRoutes + , getAutoSelectMode + ) +import Dojang.Commands.Status (printWarnings) +import Dojang.ExitCodes + ( ambiguousRouteError + , fileNotFoundError + , fileNotRoutedError + , ignoredFileError + , sourceCannotBeTargetError + , userCancelledError + ) +import Dojang.MonadFileSystem (MonadFileSystem (..)) +import Dojang.Types.Context + ( CandidateRoute (..) + , Context (..) + , FileCorrespondence (..) + , FileDeltaKind (..) + , FileEntry (..) + , FileStat (..) + , IgnoredFile (..) + , RouteMatch (..) + , RouteState (..) + , UnregisteredFile (..) + , findMatchingRoutes + , getIgnoredFiles + , getRouteState + , getUnregisteredFiles + , makeCorrespond + , makeCorrespondBetweenThreeFiles + ) +import Dojang.Types.Repository (Repository (..), RouteResult (..)) + + +reflect + :: (MonadFileSystem i, MonadIO i) + => Bool + -- ^ Force flag. + -> Bool + -- ^ All flag (skip confirmation). + -> Bool + -- ^ Include unregistered files flag. + -> Maybe OsPath + -- ^ Explicit source path. + -> [OsPath] + -- ^ Target paths (may be empty for all changed files). + -> App i ExitCode +reflect force allFlag includeUnregistered _explicitSource [] = do + -- No arguments: reflect all changed files + ctx <- ensureContext + pathStyle <- pathStyleFor stderr + codeStyle <- codeStyleFor stderr + (allFiles, ws) <- makeCorrespond ctx + let changedFiles = filter isChanged allFiles + printWarnings ws + + -- Get ignored files and warn about them + ignoredFiles <- getIgnoredFiles ctx + -- Filter to only ignored files that exist in destination + existingIgnored <- filterM (exists . (.destinationPath)) ignoredFiles + -- Create correspondences for ignored files if --force is used + ignoredCorrespondences <- + if force && not (null existingIgnored) + then do + forM existingIgnored $ \ignored -> do + let interPath = + ctx.repository.intermediatePath + ignored.routeName + makeRelative + (normalise ignored.routeName) + (normalise ignored.sourcePath) + makeCorrespondBetweenThreeFiles + interPath + ignored.sourcePath + ignored.destinationPath + else return [] + let changedIgnored = filter isChanged ignoredCorrespondences + + -- Print warnings for ignored files + unless (null existingIgnored) $ do + if force + then do + printStderr' Note $ + "Including " + <> pack (show $ length existingIgnored) + <> " ignored file(s) due to " + <> codeStyle "--force" + <> ":" + forM_ existingIgnored $ \ignored -> do + printStderr $ + " " + <> pathStyle ignored.destinationPath + <> " (pattern: " + <> codeStyle (pack $ show ignored.pattern) + <> ")" + else do + printStderr' Warning $ + "Skipping " + <> pack (show $ length existingIgnored) + <> " ignored file(s):" + forM_ existingIgnored $ \ignored -> do + printStderr $ + " " + <> pathStyle ignored.destinationPath + <> " (pattern: " + <> codeStyle (pack $ show ignored.pattern) + <> ")" + printStderr' Hint $ + "Use " + <> codeStyle "--force" + <> " to include ignored files." + + -- Handle unregistered files if --include-unregistered is used + unregisteredCorrespondences <- + if includeUnregistered + then do + unregisteredFiles <- getUnregisteredFiles ctx + if null unregisteredFiles + then return [] + else do + printStderr $ + "Found " + <> pack (show $ length unregisteredFiles) + <> " unregistered file(s):" + forM_ unregisteredFiles $ \unreg -> do + printStderr $ " " <> pathStyle unreg.filePath + isTerminal <- liftIO $ hIsTerminalDevice stdin + if not isTerminal + then do + printStderr' Warning $ + "Cannot prompt for route selection in non-interactive mode." + printStderr' Hint $ + "Run interactively to select routes for unregistered files." + return [] + else do + -- Prompt for each unregistered file + correspondences <- forM unregisteredFiles $ \unreg -> do + case unreg.candidateRoutes of + [] -> do + printStderr' Warning $ + "No candidate routes for " + <> pathStyle unreg.filePath + <> ". Skipping." + return Nothing + [route] -> do + -- Auto-select single candidate + routeName' <- decodePath route.routeName + printStderr' Note $ + "Auto-selecting route " + <> codeStyle (pack routeName') + <> " for " + <> pathStyle unreg.filePath + correspond <- createUnregisteredCorrespondence ctx unreg route + return $ Just correspond + routes -> do + -- Prompt user to select route + routeNames <- mapM (decodePath . (.routeName)) routes + printStderr $ + "Select route for " <> pathStyle unreg.filePath <> ":" + selectedName <- + liftIO $ + select "Route: " routeNames + case [r | (r, name) <- zip routes routeNames, name == selectedName] of + (selectedRoute : _) -> do + correspond <- + createUnregisteredCorrespondence ctx unreg selectedRoute + return $ Just correspond + [] -> do + printStderr' Warning "No matching route found. Skipping." + return Nothing + return [c | Just c <- correspondences] + else return [] + + let allChangedFiles = + changedFiles ++ changedIgnored ++ unregisteredCorrespondences + if null allChangedFiles + then do + printStderr "No changed files to reflect." + return ExitSuccess + else do + -- Display changed files + printStderr $ + "Found " + <> pack (show $ length allChangedFiles) + <> " changed file(s):" + forM_ allChangedFiles $ \fc -> do + printStderr $ " " <> pathStyle fc.destination.path + -- Confirm unless --all is specified + proceed <- + if allFlag + then return True + else do + isTerminal <- liftIO $ hIsTerminalDevice stdin + if isTerminal + then liftIO $ confirm "Reflect all changed files?" + else return True -- Non-interactive: proceed + if proceed + then do + reflectCorrespondences force allChangedFiles + return ExitSuccess + else do + printStderr "Cancelled." + liftIO $ exitWith userCancelledError +reflect force allFlag _includeUnregistered explicitSource paths = do + ctx <- ensureContext + nonExistents <- filterM (fmap not . exists) paths + pathStyle <- pathStyleFor stderr + unless (null nonExistents) $ do + dieWithErrors + fileNotFoundError + ["No such file: " <> pathStyle p <> "." | p <- nonExistents] + absPaths <- liftIO $ mapM makeAbsolute paths + $(logDebugSH) (absPaths :: [OsPath]) + sourcePath' <- liftIO $ makeAbsolute ctx.repository.sourcePath + let sourcePathPrefix = splitDirectories sourcePath' + $(logDebugSH) sourcePathPrefix + let overlappedPaths = + [ p + | p <- absPaths + , sourcePathPrefix `isPrefixOf` splitDirectories p + ] + $(logDebugSH) overlappedPaths + unless (null overlappedPaths) $ do + dieWithErrors + sourceCannotBeTargetError + [ "Cannot reflect " + <> pathStyle p + <> " because it is a file inside the repository." + | p <- overlappedPaths + ] + -- Separate directories and files + (dirPaths, filePaths) <- partitionByType absPaths + -- For directories: get changed files within + dirFiles <- + if null dirPaths + then return [] + else do + (allFiles, ws) <- makeCorrespond ctx + printWarnings ws + let changedFiles = filter isChanged allFiles + -- Filter files within the directories + filterFilesInDirs dirPaths changedFiles + -- For files: process as before + codeStyle <- codeStyleFor stderr + warningLists <- forM filePaths $ \absPath -> do + (state, ws) <- getRouteState ctx absPath + case state of + NotRouted -> do + manifestFile' <- asks (.manifestFile) + printWarnings ws + printStderr' + Error + ("File " <> pathStyle absPath <> " is not routed.") + printStderr' + Hint + ("Add a route for it in " <> pathStyle manifestFile' <> ".") + liftIO $ exitWith fileNotRoutedError + Routed _ -> do + return ws + Ignored name pattern -> do + routeName' <- decodePath name + if force + then do + printStderr' Note $ + "File " + <> pathStyle absPath + <> " is ignored due to pattern " + <> codeStyle (pack $ show pattern) + <> " (route name: " + <> codeStyle (pack routeName') + <> "), but reflect it anyway as you enforced it using " + <> codeStyle "-f" + <> "/" + <> codeStyle "--force" + <> " option." + return ws + else do + printWarnings ws + printStderr' Error $ + "File " + <> pathStyle absPath + <> " is ignored due to pattern " + <> codeStyle (pack $ show pattern) + <> " (route name: " + <> codeStyle (pack routeName') + <> ")." + printStderr' + Hint + $ "You can reflect it anyway by enforcing it using " + <> codeStyle "-f" + <> "/" + <> codeStyle "--force" + <> " option." + liftIO $ exitWith ignoredFileError + autoSelectMode <- getAutoSelectMode + fileCorrespondences <- forM filePaths $ \p -> do + (routeMatch, ws) <- findMatchingRoutes ctx p + printWarnings $ nub ws + case routeMatch of + NoMatch -> + die' fileNotRoutedError ("File " <> pathStyle p <> " is not routed.") + SingleMatch route -> do + correspond <- makeCorrespondForRoute ctx p route + return correspond + AmbiguousMatch candidates -> do + maybeRoute <- disambiguateRoutes autoSelectMode explicitSource candidates + case maybeRoute of + Nothing -> do + -- Disambiguation failed (ErrorOnAmbiguity mode) + let routeNames = + [c.route.routeName | c <- NE.toList candidates] + routeNameStrs <- mapM decodePath routeNames + printStderr' Error $ + "Ambiguous source path for " + <> pathStyle p + <> ". Multiple routes match:" + forM_ routeNameStrs $ \name -> + printStderr' Note $ " - " <> codeStyle (pack name) + printStderr' + Hint + $ "Use " + <> codeStyle "--source" + <> " to specify which source path to use, or set " + <> codeStyle "DOJANG_AUTO_SELECT=first" + <> " to auto-select." + liftIO $ exitWith ambiguousRouteError + Just route -> do + correspond <- makeCorrespondForRoute ctx p route + return correspond + -- Combine directory files and individual file correspondences + let allCorrespondences = dirFiles ++ fileCorrespondences + -- For directory mode with confirmation + when (not (null dirPaths) && not allFlag && not (null allCorrespondences)) $ do + printStderr $ + "Found " + <> pack (show $ length allCorrespondences) + <> " changed file(s) in specified directories:" + forM_ allCorrespondences $ \fc -> do + printStderr $ " " <> pathStyle fc.destination.path + isTerminal <- liftIO $ hIsTerminalDevice stdin + proceed <- + if isTerminal + then liftIO $ confirm "Reflect these files?" + else return True + unless proceed $ do + printStderr "Cancelled." + liftIO $ exitWith userCancelledError + let conflicts = filterConflicts allCorrespondences + $(logDebugSH) conflicts + unless (force || null conflicts) $ do + printWarnings $ nub $ concat warningLists + dieWithErrors + sourceCannotBeTargetError + [ "Cannot reflect " + <> pathStyle c.destination.path + <> ", since " + <> pathStyle c.source.path + <> " is also changed." + | c <- conflicts + ] + reflectCorrespondences force allCorrespondences + printWarnings $ nub $ concat warningLists + return ExitSuccess + + +-- | Check if a file correspondence has changes. +isChanged :: FileCorrespondence -> Bool +isChanged fc = fc.sourceDelta /= Unchanged || fc.destinationDelta /= Unchanged + + +-- | Partition paths into directories and files. +partitionByType + :: (MonadFileSystem m) + => [OsPath] + -> m ([OsPath], [OsPath]) +partitionByType paths = do + results <- forM paths $ \p -> do + isDir <- isDirectory p + return (p, isDir) + let dirs = [p | (p, True) <- results] + let files = [p | (p, False) <- results] + return (dirs, files) + + +-- | Filter file correspondences to those within the given directories. +filterFilesInDirs + :: (Monad m) + => [OsPath] + -> [FileCorrespondence] + -> m [FileCorrespondence] +filterFilesInDirs dirPaths correspondences = do + let dirPrefixes = map splitDirectories dirPaths + return + [ fc + | fc <- correspondences + , let dstDirs = splitDirectories fc.destination.path + , any (`isPrefixOf` dstDirs) dirPrefixes + ] + + +-- | Perform the actual reflect operation on file correspondences. +reflectCorrespondences + :: (MonadFileSystem i, MonadIO i) + => Bool + -- ^ Force flag. + -> [FileCorrespondence] + -> App i () +reflectCorrespondences force files = do + pathStyle <- pathStyleFor stderr + let conflicts = filterConflicts files + unless (force || null conflicts) $ do + dieWithErrors + sourceCannotBeTargetError + [ "Cannot reflect " + <> pathStyle c.destination.path + <> ", since " + <> pathStyle c.source.path + <> " is also changed." + | c <- conflicts + ] + forM_ files $ \c -> do + if c.sourceDelta == Unchanged && c.destinationDelta == Unchanged + then + printStderr' + Note + ( "File " + <> pathStyle c.destination.path + <> " is skipped, since it is the same as file " + <> pathStyle c.source.path + <> "." + ) + else do + printStderr $ + "Reflect " + <> pathStyle c.destination.path + <> " to " + <> pathStyle c.source.path + <> "..." + cleanup c.intermediate + copy c.destination c.intermediate + cleanup c.source + copy c.intermediate c.source + + +-- | Create a 'FileCorrespondence' from a route result and destination path. +makeCorrespondForRoute + :: (MonadFileSystem m) + => Context m + -> OsPath + -- ^ The destination path. + -> RouteResult + -- ^ The selected route. + -> m FileCorrespondence +makeCorrespondForRoute ctx dstPath route = do + let normalized = normalise route.destinationPath + let relPath = makeRelative normalized dstPath + period <- encodePath "." + let (interPath, srcPath) = + if normalized == dstPath || relPath == period + then + let interPath' = + normalise + (ctx.repository.intermediatePath route.routeName) + srcPath' = normalise route.sourcePath + in (interPath', srcPath') + else + let interPath' = + normalise $ + ctx.repository.intermediatePath + route.routeName + relPath + srcPath' = normalise $ route.sourcePath relPath + in (interPath', srcPath') + makeCorrespondBetweenThreeFiles interPath srcPath dstPath + + +cleanup :: (MonadFileSystem i, MonadIO i) => FileEntry -> App i () +cleanup fileEntry = do + path <- decodePath fileEntry.path + case fileEntry.stat of + Missing -> return () + Directory -> do + $(logDebug) $ "Remove directory recursively: " <> pack path + removeDirectoryRecursively fileEntry.path + _ -> do + $(logDebug) $ "Remove file: " <> pack path + removeFile fileEntry.path + + +copy :: (MonadFileSystem i, MonadIO i) => FileEntry -> FileEntry -> App i () +copy from to = do + from' <- decodePath from.path + to' <- decodePath to.path + case from.stat of + Directory -> do + $(logDebug) $ "Create directory recursively: " <> pack to' + createDirectories to.path + _ -> do + let parent = takeDirectory to.path + parent' <- decodePath parent + $(logDebug) $ "Create directory recursively: " <> pack parent' + createDirectories parent + $(logDebug) $ "Copy file: " <> pack from' <> " -> " <> pack to' + copyFile from.path to.path + + +filterConflicts + :: [FileCorrespondence] + -> [FileCorrespondence] +filterConflicts corresponds = [c | c <- corresponds, c.sourceDelta /= Unchanged] + + +-- | Create a FileCorrespondence for an unregistered file. +-- The source file doesn't exist yet, so we create a correspondence that +-- will copy from destination to source. +createUnregisteredCorrespondence + :: forall m + . (MonadFileSystem m) + => Context m + -> UnregisteredFile + -> RouteResult + -> m FileCorrespondence +createUnregisteredCorrespondence ctx unreg route = do + -- Calculate the relative path from the route's destination to the file + let relPath = makeRelative (normalise route.destinationPath) (normalise unreg.filePath) + period <- encodePath "." + let (interPath, srcPath) = + if relPath == period + then + ( normalise (ctx.repository.intermediatePath route.routeName) + , normalise route.sourcePath + ) + else + ( normalise $ + ctx.repository.intermediatePath route.routeName relPath + , normalise $ route.sourcePath relPath + ) + -- Create correspondence: source doesn't exist, destination exists + dstStat <- getFileStat unreg.filePath + let srcEntry = FileEntry srcPath Missing + let interEntry = FileEntry interPath Missing + let dstEntry = FileEntry unreg.filePath dstStat + return + FileCorrespondence + { source = srcEntry + , sourceDelta = Removed -- Source is "missing" relative to intermediate + , intermediate = interEntry + , destination = dstEntry + , destinationDelta = Added -- Destination was "added" relative to intermediate + } + where + getFileStat :: OsPath -> m FileStat + getFileStat path = do + isDir <- isDirectory path + if isDir + then return Directory + else do + exists' <- exists path + if exists' + then do + size <- getFileSize path + return $ File size + else return Missing diff --git a/src/Dojang/Commands/Status.hs b/src/Dojang/Commands/Status.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Commands/Status.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Commands.Status + ( StatusOptions (..) + , defaultStatusOptions + , formatWarning + , printWarnings + , status + ) where + +import Control.Monad (forM, forM_) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.List.NonEmpty (NonEmpty ((:|)), toList) +import System.Exit (ExitCode (..)) +import System.IO (Handle, stderr) + +import Data.CaseInsensitive (original) +import Data.Text (Text, intercalate, pack) +import System.Console.Pretty (Color (..)) +import System.Directory.OsPath (makeAbsolute) +import System.OsPath (addTrailingPathSeparator, makeRelative) +import TextShow (FromStringShow (FromStringShow), TextShow (showt)) + +import Dojang.App (App, ensureContext) +import Dojang.Commands + ( Admonition (..) + , codeStyleFor + , pathStyleFor + , printStderr' + , printTable + ) +import Dojang.MonadFileSystem (MonadFileSystem (..)) +import Dojang.Types.Context + ( Context (..) + , FileCorrespondence (..) + , FileDeltaKind (..) + , FileEntry (..) + , FileStat (..) + , makeCorrespond + ) +import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning (..)) +import Dojang.Types.FilePathExpression.Expansion (ExpansionWarning (..)) +import Dojang.Types.MonikerName () +import Dojang.Types.Repository (Repository (..), RouteMapWarning (..)) + + +data StatusOptions = StatusOptions + { noTrailingSlash :: Bool + , onlyChanges :: Bool + , showDestinationPath :: Bool + } + deriving (Show) + + +defaultStatusOptions :: StatusOptions +defaultStatusOptions = + StatusOptions + { noTrailingSlash = False + , onlyChanges = False + , showDestinationPath = False + } + + +status :: (MonadFileSystem i, MonadIO i) => StatusOptions -> App i ExitCode +status options = do + ctx <- ensureContext + (files, ws) <- makeCorrespond ctx + let files' = if options.onlyChanges then filter isChanged files else files + sourcePath <- liftIO $ makeAbsolute ctx.repository.sourcePath + rows <- forM files' $ \file -> do + displayPath <- + if options.showDestinationPath + then liftIO $ makeAbsolute file.destination.path + else do + path <- liftIO $ makeAbsolute file.source.path + return $ makeRelative sourcePath path + let displayPathS = + if not options.noTrailingSlash + && ( (file.source.stat == Directory) + || (file.source.stat == Missing) + && (file.destination.stat == Directory) + ) + then addTrailingPathSeparator displayPath + else displayPath + displayPathFP <- decodePath displayPathS + return + [ renderDeltaKind file.sourceDelta + , renderFileStat file.source.stat + , renderDeltaKind file.destinationDelta + , renderFileStat file.destination.stat + , (Default, pack displayPathFP) + ] + printTable + [ "Source" + , "ST" + , "Destination" + , "DT" + , if options.showDestinationPath then "Destination File" else "Source File" + ] + rows + printWarnings ws + return ExitSuccess + + +isChanged :: FileCorrespondence -> Bool +isChanged file = + file.sourceDelta /= Unchanged || file.destinationDelta /= Unchanged + + +renderDeltaKind :: FileDeltaKind -> (Color, Text) +renderDeltaKind Unchanged = (Default, "unchanged") +renderDeltaKind Added = (Green, "added") +renderDeltaKind Removed = (Red, "removed") +renderDeltaKind Modified = (Yellow, "modified") + + +renderFileStat :: FileStat -> (Color, Text) +renderFileStat Missing = (Red, "-") +renderFileStat Directory = (Default, "D") +renderFileStat (File _) = (Default, "F") +renderFileStat (Symlink _) = (Default, "L") + + +-- TODO: This should be in a separate module: +formatWarning :: (MonadIO i) => Handle -> RouteMapWarning -> i Text +formatWarning handle (EnvironmentPredicateWarning w) = do + codeStyle <- codeStyleFor handle + case w of + (UndefinedMoniker moniker) -> + return $ + "Reference to an undefined moniker: " + <> codeStyle (original moniker.name) + <> "." + (UnrecognizedOperatingSystem os) -> + return $ + "Unrecognized operating system: " + <> codeStyle (showt $ FromStringShow os) + <> "." + (UnrecognizedArchitecture arch) -> + return $ + "Unrecognized architecture: " + <> codeStyle (showt $ FromStringShow arch) + <> "." +formatWarning handle (FilePathExpressionWarning (UndefinedEnvironmentVariable envVar)) = do + codeStyle <- codeStyleFor handle + return $ + "Reference to an undefined environment variable: " + <> codeStyle envVar + <> "." +formatWarning handle (OverlapDestinationPathsWarning name dst paths) = do + pathStyle <- pathStyleFor handle + pairStrings <- forM paths $ \(from, to) -> do + return $ pathStyle from <> " -> " <> pathStyle to + case pairStrings of + pairString :| [] -> + return $ + pathStyle name + <> " -> " + <> pathStyle dst + <> " overlaps with: " + <> pairString + <> "." + _ -> + return $ + pathStyle name + <> " -> " + <> pathStyle dst + <> " overlaps with:\n " + <> intercalate "\n " (toList pairStrings) + + +-- TODO: This should be in a separate module: +printWarnings :: (MonadIO i) => [RouteMapWarning] -> App i () +printWarnings ws = + forM_ ws $ \w -> do + formatted <- formatWarning stderr w + printStderr' Warning formatted diff --git a/src/Dojang/ExitCodes.hs b/src/Dojang/ExitCodes.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/ExitCodes.hs @@ -0,0 +1,81 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + +module Dojang.ExitCodes where + +import System.Exit (ExitCode (..)) + + +unhandledError :: ExitCode +unhandledError = ExitFailure $ -1 + + +cliError :: ExitCode +cliError = ExitFailure 1 + + +fileWriteError :: ExitCode +fileWriteError = ExitFailure 2 + + +fileNotFoundError :: ExitCode +fileNotFoundError = ExitFailure 3 + + +externalProgramNonZeroExit :: ExitCode +externalProgramNonZeroExit = ExitFailure 4 + + +unsupportedOnEnvError :: ExitCode +unsupportedOnEnvError = ExitFailure 9 + + +manifestUninitialized :: ExitCode +manifestUninitialized = ExitFailure 10 + + +manifestReadError :: ExitCode +manifestReadError = ExitFailure 11 + + +manifestAlreadyExists :: ExitCode +manifestAlreadyExists = ExitFailure 12 + + +noEnvFile :: ExitCode +noEnvFile = ExitFailure 20 + + +envFileReadError :: ExitCode +envFileReadError = ExitFailure 21 + + +conflictError :: ExitCode +conflictError = ExitFailure 30 + + +sourceCannotBeTargetError :: ExitCode +sourceCannotBeTargetError = ExitFailure 31 + + +fileNotRoutedError :: ExitCode +fileNotRoutedError = ExitFailure 32 + + +ignoredFileError :: ExitCode +ignoredFileError = ExitFailure 33 + + +accidentalDeletionWarning :: ExitCode +accidentalDeletionWarning = ExitFailure 34 + + +ambiguousRouteError :: ExitCode +ambiguousRouteError = ExitFailure 35 + + +userCancelledError :: ExitCode +userCancelledError = ExitFailure 36 + + +hookFailedError :: ExitCode +hookFailedError = ExitFailure 40 diff --git a/src/Dojang/MonadFileSystem.hs b/src/Dojang/MonadFileSystem.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/MonadFileSystem.hs @@ -0,0 +1,840 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE InstanceSigs #-} + +module Dojang.MonadFileSystem + ( DryRunIO + , FileType (..) + , MonadFileSystem (..) + , dryRunIO + , dryRunIO' + , tryDryRunIO + ) where + +import Control.Concurrent (threadDelay) +import Control.Monad (forM, forM_, unless, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.List (inits, isPrefixOf, sort, sortOn) +import Data.List.NonEmpty (NonEmpty ((:|)), filter, singleton, toList) +import Data.Ord (Down (Down)) +import GHC.IO.Exception (IOErrorType (InappropriateType)) +import GHC.Stack (HasCallStack) +import System.IO.Error + ( alreadyExistsErrorType + , doesNotExistErrorType + , ioeGetLocation + , ioeSetErrorString + , ioeSetLocation + , isDoesNotExistError + , isPermissionError + , mkIOError + ) +import System.Info (os) +import Prelude hiding (filter, readFile, writeFile) + +import Control.Monad.Except (MonadError (..), tryError) +import Control.Monad.Extra (partitionM) +import Control.Monad.State.Strict + ( MonadState + , StateT + , gets + , modify' + , runStateT + ) +import Data.ByteString (ByteString) +import Data.ByteString qualified (length, readFile, writeFile) +import Data.Map.Strict (Map, alter, fromList, keys, toAscList, (!?)) +import System.Directory.OsPath + ( doesDirectoryExist + , doesFileExist + , doesPathExist + , getSymbolicLinkTarget + , pathIsSymbolicLink + , removeDirectoryRecursive + ) +import System.Directory.OsPath qualified + ( copyFile + , createDirectory + , getFileSize + , listDirectory + , removeDirectory + , removeFile + ) +import System.FilePattern (FilePattern, Step (stepApply, stepDone), step_) +import System.OsPath + ( OsPath + , decodeFS + , encodeFS + , joinPath + , normalise + , splitDirectories + , takeDirectory + , takeFileName + , () + ) + + +-- | A type that represents a file or directory. +data FileType + = -- | A directory. + Directory + | -- | A file. + File + | -- | A symbolic link. + Symlink + deriving (Eq, Ord, Show) + + +-- | A monad that can perform filesystem operations. It's also based on +-- 'OsPath' instead of 'FilePath'. +class (MonadError IOError m) => MonadFileSystem m where + -- | Encodes a 'FilePath' into an 'OsPath'. + encodePath :: (HasCallStack) => FilePath -> m OsPath + + + -- | Decodes a 'OsPath' into a 'FilePath'. + decodePath :: (HasCallStack) => OsPath -> m FilePath + + + -- | Checks if a file (or directory) exists. If a path is a symbolic link, + -- then it tells whether the target of the symbolic link exists. + exists :: (HasCallStack) => OsPath -> m Bool + + + -- | Checks if a path exists and is a file. If a path is a symbolic link, + -- then it tells whether the target of the symbolic link is a file. + isFile :: (HasCallStack) => OsPath -> m Bool + + + -- | Checks if a path exists and is a directory. If a path is a symbolic + -- link, then it tells whether the target of the symbolic link is a directory. + isDirectory :: (HasCallStack) => OsPath -> m Bool + + + -- | Checks if a path exists and is a symbolic link. + isSymlink :: (HasCallStack) => OsPath -> m Bool + + + -- | Reads contents from a file. + readFile :: (HasCallStack) => OsPath -> m ByteString + + + -- | Writes contents into a file. + writeFile :: (HasCallStack) => OsPath -> ByteString -> m () + + + -- | Tells the target path of a symbolic link. If the path is not a symbolic + -- link, then it throws an 'IOError'. The target path is relative to the + -- symbolic link (i.e., resolved from the directory that contains the + -- symbolic link). + readSymlinkTarget :: OsPath -> m OsPath + + + -- | Copies a file from one path to another. + copyFile + :: (HasCallStack) + => OsPath + -- ^ Source path. + -> OsPath + -- ^ Destination path. + -> m () + + + -- | Creates a directory at the given path. + createDirectory :: (HasCallStack) => OsPath -> m () + + + -- | Creates a directory at the given path, including all parent directories. + createDirectories :: (HasCallStack) => OsPath -> m () + createDirectories path = + ( do + forM_ ancestors $ \ancestor -> do + isSymlink' <- isSymlink ancestor + when isSymlink' $ do + ancestor' <- decodePath ancestor + throwError $ fileError ancestor' + isDir <- isDirectory ancestor + unless isDir $ do + exists' <- isFile ancestor + if exists' + then do + ancestor' <- decodePath ancestor + throwError $ fileError ancestor' + else createDirectory ancestor + ) + `mapError` (`ioePrependLocation` "createDirectories") + where + split :: [OsPath] + split = splitDirectories path + ancestors :: [OsPath] + ancestors = map joinPath $ drop 1 (inits split) + fileError :: FilePath -> IOError + fileError path' = + mkIOError InappropriateType "createDirectories" Nothing (Just path') + `ioeSetErrorString` "one of its ancestors is a non-directory file" + + + -- | Removes a regular file. + removeFile :: (HasCallStack) => OsPath -> m () + + + -- | Removes a directory. It must be empty. + removeDirectory :: (HasCallStack) => OsPath -> m () + + + -- | Removes a directory entirely, including all its contents. + removeDirectoryRecursively :: (HasCallStack) => OsPath -> m () + removeDirectoryRecursively path = + ( do + entries <- listDirectoryRecursively path [] + forM_ (sortOn (Down . snd) entries) $ \(fileType, entry) -> + case fileType of + Directory -> removeDirectoryRecursively $ path entry + File -> removeFile $ path entry + Symlink -> removeFile $ path entry + removeDirectory path + ) + `mapError` (`ioePrependLocation` "removeDirectoryRecursively") + + + -- | Lists all files and directories in a directory except for @.@ and @..@, + -- without recursing into subdirectories. + listDirectory :: (HasCallStack) => OsPath -> m [OsPath] + + + -- | Lists all files and directories in a directory recursively. It doesn't + -- include @.@ and @..@. Paths are relative to the given directory, + -- and directories always go before their contents. + -- + -- Note that it doesn't follow symbolic links. Instead, it returns the + -- symbolic links themselves with the 'Symlink' file type. + listDirectoryRecursively + :: (HasCallStack) + => OsPath + -- ^ The directory to list recursively. + -> [FilePattern] + -- ^ The file patterns to ignore. If a directory matches one of these + -- patterns, then its contents will not be listed recursively either. + -> m [(FileType, OsPath)] + -- ^ The list of pairs of file types and paths. The paths are relative + -- to the given directory. + listDirectoryRecursively path ignorePatterns = + listDirectoryRecursively' path (step_ ignorePatterns) + `mapError` (`ioePrependLocation` "listDirectoryRecursively") + + + -- | Gets the size of a file in bytes. If the file doesn't exist or is + -- a directory, then it throws an 'IOError'. + getFileSize :: (HasCallStack) => OsPath -> m Integer + + +listDirectoryRecursively' + :: (HasCallStack, MonadFileSystem m) + => OsPath + -> Step () + -> m [(FileType, OsPath)] +listDirectoryRecursively' path ptnStep = do + unfilteredEntries <- listDirectory path + entriesWithSteps <- forM unfilteredEntries $ \entry -> do + decoded <- decodePath entry + let nextStep = stepApply ptnStep decoded + return (entry, nextStep) + let filteredEntries = + [ (entry, step) + | (entry, step) <- entriesWithSteps + , null $ stepDone step + ] + (symlinks, entries') <- + partitionM (isSymlink . (path ) . fst) filteredEntries + (dirs, files) <- partitionM (isDirectory . (path ) . fst) entries' + symlinks' <- forM symlinks $ \(symlink, _) -> return (Symlink, symlink) + files' <- forM files $ \(file, _) -> return (File, file) + dirs' <- forM dirs $ \(dir, step) -> do + subentries <- listDirectoryRecursively' (path dir) step + return $ (Directory, dir) : (fmap (dir ) <$> subentries) + return $ files' ++ symlinks' ++ concat dirs' + + +instance MonadFileSystem IO where + encodePath = encodeFS + + + decodePath = decodeFS + + + exists = doesPathExist + + + isFile = doesFileExist + + + isDirectory = doesDirectoryExist + + + isSymlink path = + pathIsSymbolicLink path `catchError` \e -> + if isDoesNotExistError e then return False else throwError e + + + readFile src = decodePath src >>= Data.ByteString.readFile + + + writeFile dst contents = do + dst' <- decodePath dst + Data.ByteString.writeFile dst' contents + + + readSymlinkTarget = getSymbolicLinkTarget + + + createDirectory = System.Directory.OsPath.createDirectory + + + removeFile = System.Directory.OsPath.removeFile + + + removeDirectory = System.Directory.OsPath.removeDirectory + + + removeDirectoryRecursively = + retryOnPermissionErrorsOnWindows 10 . removeDirectoryRecursive + where + -- See also: https://github.com/jaspervdj/hakyll/pull/783 + retryOnPermissionErrorsOnWindows :: Int -> IO () -> IO () + retryOnPermissionErrorsOnWindows retry action + | os /= "mingw32" = action + | retry < 1 = action + | otherwise = + action `catchError` \e -> + if isPermissionError e + then do + threadDelay 100 + retryOnPermissionErrorsOnWindows (retry - 1) action + else throwError e + + + listDirectory = System.Directory.OsPath.listDirectory + + + getFileSize path = do + isDir <- isDirectory path + when isDir $ do + path' <- decodePath path + throwError $ + mkIOError InappropriateType "getFileSize" Nothing (Just path') + `ioeSetErrorString` "it is a directory" + System.Directory.OsPath.getFileSize path + + + copyFile = System.Directory.OsPath.copyFile + + +type SeqNo = Int + + +-- | The result of a filesystem operation. +data OverlaidFile + = -- | A file with the given contents. + Contents ByteString + | -- | A directory. + Directory' + | -- | A file that doesn't exist (i.e., it was deleted). + Gone + | -- | A file that was copied from the given path. + Copied OsPath + deriving (Eq, Show) + + +-- | Internal state of 'DryRun'. +data DryRunState = DryRunState + { overlaidFiles :: Map OsPath (NonEmpty (SeqNo, OverlaidFile)) + -- ^ The overlaid files and their list of changes. Each change is a pair + -- of the global sequence number and the new event that occurred. The latest + -- change comes first and the oldest change comes last. + , nextSequenceNumber :: SeqNo + } + + +currentSequenceNumber :: DryRunState -> SeqNo +currentSequenceNumber state = nextSequenceNumber state - 1 + + +-- | A monad that can perform filesystem operations, but only in a sandbox. +-- Note that, however, it can bypass the sandboxing of the 'MonadFileSystem' +-- class by using 'liftIO'. +newtype DryRunIO a = DryRunIO {unDryRunIO :: StateT DryRunState IO a} + deriving + ( Functor + , Applicative + , Monad + , MonadFail + , MonadError IOError + , MonadIO + , MonadState DryRunState + ) + + +addChangeToFile :: OsPath -> OverlaidFile -> DryRunIO () +addChangeToFile path change = modify' $ \state -> + let oFiles = overlaidFiles state + nextSeqNo = nextSequenceNumber state + newOFiles = alter (appendChange nextSeqNo) (normalise path) oFiles + in state{overlaidFiles = newOFiles, nextSequenceNumber = nextSeqNo + 1} + where + appendChange + :: SeqNo + -> Maybe (NonEmpty (SeqNo, OverlaidFile)) + -> Maybe (NonEmpty (SeqNo, OverlaidFile)) + appendChange seqNo (Just changes) = Just $ (seqNo, change) :| toList changes + appendChange seqNo Nothing = Just $ singleton (seqNo, change) + + +readFileFromDryRunIO :: SeqNo -> OsPath -> DryRunIO ByteString +readFileFromDryRunIO seqOffset src = do + oFiles <- gets overlaidFiles + case oFiles !? normalise src of + Nothing -> fallback + Just changes -> + let filteredChanges = filter (\(no, _) -> no <= seqOffset) changes + in case filteredChanges of + [] -> fallback + (_, Contents contents) : _ -> return contents + (seqNo, Copied src') : _ -> + readFileFromDryRunIO seqNo src' + (_, Gone) : _ -> do + src' <- decodePath src + throwError $ + mkIOError doesNotExistErrorType "readFile" Nothing (Just src') + `ioeSetErrorString` "no such file" + (_, Directory') : _ -> do + src' <- decodePath src + throwError $ nonDirError src' + where + fallback :: DryRunIO ByteString + fallback = liftIO $ do + isDir <- doesDirectoryExist src + src' <- decodeFS src + when isDir $ throwError (nonDirError src') + Data.ByteString.readFile src' + nonDirError :: FilePath -> IOError + nonDirError src' = + mkIOError InappropriateType "readFile" Nothing (Just src') + `ioeSetErrorString` "is a directory" + + +instance MonadFileSystem DryRunIO where + encodePath = liftIO . encodeFS + + + decodePath = liftIO . decodeFS + + + exists path = do + oFiles <- gets overlaidFiles + case oFiles !? normalise path of + Just ((_, Gone) :| _) -> return False + Just (_ :| _) -> return True + Nothing -> liftIO $ doesPathExist path + + + isFile path = do + oFiles <- gets overlaidFiles + case oFiles !? normalise path of + Just ((_, Contents _) :| _) -> return True + Just ((_, Copied _) :| _) -> return True + Just (_ :| _) -> return False + Nothing -> liftIO $ doesFileExist path + + + isDirectory path = do + oFiles <- gets overlaidFiles + case oFiles !? normalise path of + Just ((_, Directory') :| _) -> return True + Just (_ :| _) -> return False + Nothing -> liftIO $ doesDirectoryExist path + + + isSymlink path = do + oFiles <- gets overlaidFiles + case oFiles !? normalise path of + Just _ -> return False + Nothing -> + liftIO (pathIsSymbolicLink path) + `catchError` \e -> + if isDoesNotExistError e then return False else throwError e + + + readFile src = do + seqNo <- gets currentSequenceNumber + readFileFromDryRunIO seqNo src + + + writeFile dst contents = do + oFiles <- gets overlaidFiles + let dstDir = normalise $ takeDirectory dst + dstParentExists <- liftIO $ doesPathExist dstDir + dstDirExists <- liftIO $ doesDirectoryExist dstDir + dst' <- decodePath dst + dstIsDir <- liftIO $ doesDirectoryExist dst + case (oFiles !? dstDir, oFiles !? normalise dst) of + (Just ((_, Gone) :| _), _) -> throwError $ noParentDirError dst' + (Nothing, _) | not dstParentExists -> throwError $ noParentDirError dst' + (Just ((_, Contents _) :| _), _) -> throwError $ notInsideDirError dst' + (Just ((_, Copied _) :| _), _) -> throwError $ notInsideDirError dst' + (Nothing, _) | not dstDirExists -> throwError $ notInsideDirError dst' + (_, Just ((_, Directory') :| _)) -> throwError $ dirError dst' + (_, Nothing) | dstIsDir -> throwError $ dirError dst' + _ -> do + addChangeToFile dst $ Contents contents + return () + where + dirError :: FilePath -> IOError + dirError dst' = + mkIOError InappropriateType "writeFile" Nothing (Just dst') + `ioeSetErrorString` "is a directory" + noParentDirError :: FilePath -> IOError + noParentDirError dst' = + mkIOError doesNotExistErrorType "writeFile" Nothing (Just dst') + `ioeSetErrorString` "no parent directory" + notInsideDirError :: FilePath -> IOError + notInsideDirError dst' = + mkIOError InappropriateType "writeFile" Nothing (Just dst') + `ioeSetErrorString` "not inside a directory" + + + readSymlinkTarget path = do + oFiles <- gets overlaidFiles + case oFiles !? normalise path of + Just ((_, Gone) :| _) -> do + path' <- decodePath path + throwError $ + mkIOError + doesNotExistErrorType + "readSymlinkTarget" + Nothing + (Just path') + `ioeSetErrorString` "no such file" + Just _ -> do + path' <- decodePath path + throwError $ + mkIOError InappropriateType "readSymlinkTarget" Nothing (Just path') + `ioeSetErrorString` "not a symbolic link" + Nothing -> + liftIO $ + getSymbolicLinkTarget path + `mapError` (`ioePrependLocation` "readSymlinkTarget") + + + copyFile src dst = do + oFiles <- gets overlaidFiles + src' <- decodePath src + srcExists <- liftIO $ doesPathExist src + srcIsDir <- liftIO $ doesDirectoryExist src + let dstDir = normalise $ takeDirectory dst + dstDirExists <- liftIO $ doesPathExist dstDir + dstDirIsDir <- liftIO $ doesDirectoryExist dstDir + dst' <- decodePath dst + dstIsDir <- liftIO $ doesDirectoryExist dst + case oFiles !? normalise src of + Just ((_, Gone) :| _) -> throwError $ noSrcFileError src' + Nothing | not srcExists -> throwError $ noSrcFileError src' + Just ((_, Directory') :| _) -> throwError $ srcIsDirError src' + Nothing | srcIsDir -> throwError $ srcIsDirError src' + _ -> case (oFiles !? dstDir, oFiles !? normalise dst) of + (Just ((_, Gone) :| _), _) -> throwError $ noParentDirError dst' + (Nothing, _) | not dstDirExists -> throwError $ noParentDirError dst' + (Just ((_, Contents _) :| _), _) -> throwError $ notInsideDirError dst' + (Just ((_, Copied _) :| _), _) -> throwError $ notInsideDirError dst' + (Nothing, _) | not dstDirIsDir -> throwError $ notInsideDirError dst' + (_, Just ((_, Directory') :| _)) -> throwError $ dstIsDirError dst' + (_, Nothing) | dstIsDir -> throwError $ dstIsDirError dst' + _ -> do + addChangeToFile dst $ Copied src + return () + where + noSrcFileError :: FilePath -> IOError + noSrcFileError src' = + mkIOError doesNotExistErrorType "copyFile" Nothing (Just src') + `ioeSetErrorString` "source does not exist" + srcIsDirError :: FilePath -> IOError + srcIsDirError src' = + mkIOError InappropriateType "copyFile" Nothing (Just src') + `ioeSetErrorString` "source is a directory" + noParentDirError :: FilePath -> IOError + noParentDirError dst' = + mkIOError doesNotExistErrorType "copyFile" Nothing (Just dst') + `ioeSetErrorString` "no parent directory" + notInsideDirError :: FilePath -> IOError + notInsideDirError dst' = + mkIOError InappropriateType "copyFile" Nothing (Just dst') + `ioeSetErrorString` "not inside a directory" + dstIsDirError :: FilePath -> IOError + dstIsDirError dst' = + mkIOError InappropriateType "copyFile" Nothing (Just dst') + `ioeSetErrorString` "destination is a directory" + + + createDirectory dst = do + oFiles <- gets overlaidFiles + dst' <- decodePath dst + isFile' <- liftIO $ doesFileExist dst + isDir <- liftIO $ doesDirectoryExist dst + isSymlink' <- + liftIO $ + pathIsSymbolicLink dst `catchError` \e -> + if isDoesNotExistError e + then return False + else throwError $ e `ioePrependLocation` "createDirectory" + parentExists <- liftIO $ doesPathExist parent + parentIsDir <- liftIO $ doesDirectoryExist parent + case (oFiles !? parent, oFiles !? normalise dst) of + (Just ((_, Gone) :| _), _) -> throwError $ noParentDirError dst' + (Nothing, _) | not parentExists -> throwError $ noParentDirError dst' + (Just ((_, Contents _) :| _), _) -> throwError $ notInsideDirError dst' + (Just ((_, Copied _) :| _), _) -> throwError $ notInsideDirError dst' + (Nothing, _) | not parentIsDir -> throwError $ notInsideDirError dst' + (_, Just ((_, Contents _) :| _)) -> throwError $ dstIsFileError dst' + (_, Just ((_, Copied _) :| _)) -> throwError $ dstIsFileError dst' + (Nothing, _) | isFile' -> throwError $ dstIsFileError dst' + (_, Just ((_, Directory') :| _)) -> throwError $ dstIsDirError dst' + _ | isDir && not isSymlink' -> throwError $ dstIsDirError dst' + _ -> do + addChangeToFile dst Directory' + return () + where + parent :: OsPath + parent = normalise $ takeDirectory dst + noParentDirError :: FilePath -> IOError + noParentDirError dst' = + mkIOError doesNotExistErrorType "createDirectory" Nothing (Just dst') + `ioeSetErrorString` "no parent directory" + notInsideDirError :: FilePath -> IOError + notInsideDirError dst' = + mkIOError InappropriateType "createDirectory" Nothing (Just dst') + `ioeSetErrorString` "not inside a directory" + dstIsFileError :: FilePath -> IOError + dstIsFileError dst' = + mkIOError alreadyExistsErrorType "createDirectory" Nothing (Just dst') + `ioeSetErrorString` "destination is already a file" + dstIsDirError :: FilePath -> IOError + dstIsDirError dst' = + mkIOError alreadyExistsErrorType "createDirectory" Nothing (Just dst') + `ioeSetErrorString` "destination is already a directory" + + + removeFile path = do + oFiles <- gets overlaidFiles + path' <- decodePath path + exists' <- liftIO $ doesPathExist path + isSymlink' <- + liftIO $ + pathIsSymbolicLink path + `catchError` \e -> + if isDoesNotExistError e + then return False + else throwError $ e `ioePrependLocation` "removeFile" + isDir <- liftIO $ doesDirectoryExist path + case oFiles !? normalise path of + Just ((_, Gone) :| _) -> throwError $ noFileError path' + Nothing | not exists' -> throwError $ noFileError path' + Just ((_, Directory') :| _) -> throwError $ dirError path' + Nothing | isDir && not isSymlink' -> throwError $ dirError path' + _ -> do + addChangeToFile path Gone + return () + where + noFileError :: FilePath -> IOError + noFileError path' = + mkIOError doesNotExistErrorType "removeFile" Nothing (Just path') + `ioeSetErrorString` "no such file" + dirError :: FilePath -> IOError + dirError path' = + mkIOError InappropriateType "removeFile" Nothing (Just path') + `ioeSetErrorString` "is a directory" + + + removeDirectory path = do + oFiles <- gets overlaidFiles + path' <- decodePath path + exists' <- liftIO $ doesPathExist path + isDir <- liftIO $ doesDirectoryExist path + case oFiles !? normalise path of + Just ((_, Gone) :| _) -> + throwError $ noDirError path' + Nothing + | not exists' -> + throwError $ noDirError path' + Just ((_, Contents _) :| _) -> + throwError $ nonDirError path' + Just ((_, Copied _) :| _) -> + throwError $ nonDirError path' + Nothing + | not isDir -> + throwError $ nonDirError path' + _ -> do + addChangeToFile path Gone + return () + where + noDirError :: FilePath -> IOError + noDirError path' = + mkIOError + doesNotExistErrorType + "removeDirectory" + Nothing + (Just path') + `ioeSetErrorString` "no such directory" + nonDirError :: FilePath -> IOError + nonDirError path' = + mkIOError + InappropriateType + "removeDirectory" + Nothing + (Just path') + `ioeSetErrorString` "not a directory" + + + listDirectory path = do + oFiles <- gets overlaidFiles + pathFP <- decodePath path + case oFiles !? path' of + Just ((_, Gone) :| _) -> + throwError $ noDirError pathFP + Just ((_, Contents _) :| _) -> + throwError $ nonDirError pathFP + Just ((_, Copied _) :| _) -> + throwError $ nonDirError pathFP + Just ((_, Directory') :| _) -> + return $ map takeFileName $ keys $ directOChildren oFiles + Nothing -> do + isSymlink' <- + liftIO $ + pathIsSymbolicLink path + `catchError` \e -> + if isDoesNotExistError e + then return False + else throwError $ e `ioePrependLocation` "listDirectory" + isFile' <- liftIO $ doesFileExist path + when (isSymlink' || isFile') $ throwError (nonDirError pathFP) + files <- + liftIO $ + System.Directory.OsPath.listDirectory path + `mapError` (`ioePrependLocation` "listDirectory") + let directOChildren' = directOChildren oFiles + let result = + [f | f <- files, directOChildren' !? (path' f) /= Just Gone] + ++ [ filename + | (filePath, f) <- toAscList directOChildren' + , f /= Gone + , let split = splitDirectories filePath + , pathDirs `isPrefixOf` split + , length pathDirs < length split + , let filename = split !! length pathDirs + , filename `notElem` files + ] + return $ sort result + where + path' :: OsPath + path' = normalise path + pathDirs :: [OsPath] + pathDirs = splitDirectories path' + directOChildren + :: Map OsPath (NonEmpty (SeqNo, OverlaidFile)) -> Map OsPath OverlaidFile + directOChildren oFiles = + fromList + [ (filePath, f) + | (filePath, (_, f) :| []) <- toAscList oFiles + , let split = splitDirectories filePath + , pathDirs `isPrefixOf` split + , length pathDirs + 1 == length split + ] + noDirError :: FilePath -> IOError + noDirError pathFP = + mkIOError + doesNotExistErrorType + "listDirectory" + Nothing + (Just pathFP) + `ioeSetErrorString` "no such directory" + nonDirError :: FilePath -> IOError + nonDirError pathFP = + mkIOError + InappropriateType + "listDirectory" + Nothing + (Just pathFP) + `ioeSetErrorString` "not a directory" + + + getFileSize path = do + oFiles <- gets overlaidFiles + path' <- decodePath path + case oFiles !? normalise path of + Just ((_, Gone) :| _) -> + throwError $ noFileError path' + Just ((_, Directory') :| _) -> + throwError $ nonFileError path' + Just _ -> do + contents <- readFile path + return $ + fromIntegral $ + Data.ByteString.length contents + Nothing -> do + isDir <- isDirectory path + if isDir + then throwError $ nonFileError path' + else + liftIO (System.Directory.OsPath.getFileSize path) + `mapError` (`ioeSetLocation` "getFileSize") + where + noFileError :: FilePath -> IOError + noFileError pathFP = + mkIOError + doesNotExistErrorType + "getFileSize" + Nothing + (Just pathFP) + `ioeSetErrorString` "no such file" + nonFileError :: FilePath -> IOError + nonFileError pathFP = + mkIOError + InappropriateType + "getFileSize" + Nothing + (Just pathFP) + `ioeSetErrorString` "not a regular file, but a directory" + + +-- | Performs 'DryRunIO' action in the sandbox and returns the result. +dryRunIO :: DryRunIO a -> IO a +dryRunIO = fmap fst . dryRunIO' + + +-- | Performs 'DryRunIO' action in the sandbox and returns the result and +-- the total number of filesystem operations that were performed. +dryRunIO' :: DryRunIO a -> IO (a, Int) +dryRunIO' action = do + (value, state) <- runStateT (unDryRunIO action) initialState + return (value, nextSequenceNumber state) + where + initialState = DryRunState{overlaidFiles = mempty, nextSequenceNumber = 0} + + +-- | Performs 'DryRunIO' action in the sandbox and returns either the result +-- or an 'IOError' that occurred. +tryDryRunIO :: DryRunIO a -> IO (Either IOError a) +tryDryRunIO action = dryRunIO $ tryError action + + +ioePrependLocation :: IOError -> String -> IOError +ioePrependLocation e location = + ioeSetLocation e $ case loc of + "" -> location + _ -> location ++ ':' : loc + where + loc :: String + loc = ioeGetLocation e + + +mapError :: (MonadError e m) => m a -> (e -> e) -> m a +mapError action transform = catchError action (throwError . transform) diff --git a/src/Dojang/Syntax/Env.hs b/src/Dojang/Syntax/Env.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Syntax/Env.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Dojang.Syntax.Env + ( TomlError + , TomlWarning + , readEnvFile + , readEnvironment + , writeEnvFile + , writeEnvironment + ) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.String (IsString (fromString)) +import Prelude hiding (readFile, writeFile) + +import Control.DeepSeq (force) +import Data.CaseInsensitive (CI (original)) +import Data.Text (Text, unpack) +import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8) +import System.OsPath (OsPath) +import TextShow (FromStringShow (FromStringShow), TextShow (showt)) +import Toml (decode, encode) +import Toml.FromValue + ( FromValue (fromValue) + , Result (Failure, Success) + , parseTableFromValue + , reqKey + ) +import Toml.ToValue + ( ToTable (toTable) + , ToValue (toValue) + , defaultTableToValue + , table + , (.=) + ) + +import Dojang.MonadFileSystem (MonadFileSystem (..)) +import Dojang.Types.Environment + ( Architecture + , Environment (..) + , Kernel (..) + , OperatingSystem + ) + + +instance FromValue OperatingSystem where + fromValue os = fromString <$> fromValue os + + +instance ToValue OperatingSystem where + toValue = toValue . original . (.identifier) + + +instance FromValue Architecture where + fromValue arch = fromString <$> fromValue arch + + +instance ToValue Architecture where + toValue = toValue . original . (.identifier) + + +instance FromValue Kernel where + fromValue = + parseTableFromValue $ + Kernel + <$> (fromString <$> reqKey "name") + <*> (fromString <$> reqKey "release") + + +instance ToValue Kernel where + toValue = defaultTableToValue + + +instance ToTable Kernel where + toTable kernel = + table + [ "name" .= original kernel.name + , "release" .= original kernel.release + ] + + +instance FromValue Environment where + fromValue = + parseTableFromValue $ + Environment + <$> reqKey "os" + <*> reqKey "arch" + <*> reqKey "kernel" + + +instance ToValue Environment where + toValue = defaultTableToValue + + +instance ToTable Environment where + toTable env = + table + [ "os" .= env.operatingSystem + , "arch" .= env.architecture + , "kernel" .= env.kernel + ] + + +-- | An error made during parsing. +type TomlError = String + + +-- | A warning message made during parsing. +type TomlWarning = String + + +-- | Decodes a TOML-encoded 'Environment'. +readEnvironment + :: Text + -- ^ A TOML document text to parse. + -> Either (NonEmpty TomlError) (Environment, [TomlWarning]) + -- ^ A decoded 'Environment' with warnings, or a list of errors. +readEnvironment toml = case decode $ unpack toml of + Success warnings env -> Right (env, warnings) + Failure (e : es) -> Left $ e :| es + Failure [] -> Left $ "unknown error" :| [] + + +-- | Reads a TOML-encoded 'Environment' from the given file path. It assumes +-- that the file is encoded in UTF-8. Throws an 'IOError' if the file cannot +-- be read. +readEnvFile + :: (MonadFileSystem m) + => OsPath + -- ^ A path to the env file. + -> m (Either (NonEmpty TomlError) (Environment, [TomlWarning])) + -- ^ A decoded 'Environment' with warnings, or error(s). +readEnvFile filePath = do + content <- readFile filePath + let decoded = decodeUtf8Lenient content + return $ readEnvironment $ force decoded + + +-- | Encodes an 'Environment' into a TOML document. +writeEnvironment :: Environment -> Text +writeEnvironment = showt . FromStringShow . encode + + +-- | Writes an 'Environment' file to the given path. Throws an 'IOError' if +-- any occurs while writing the file. +writeEnvFile + :: (MonadFileSystem m) + => Environment + -- ^ The 'Environment' to write. + -> OsPath + -- ^ The path to write the 'Environment' to. + -> m () +writeEnvFile env filePath = + writeFile filePath $ encodeUtf8 $ writeEnvironment env diff --git a/src/Dojang/Syntax/EnvironmentPredicate.hs b/src/Dojang/Syntax/EnvironmentPredicate.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Syntax/EnvironmentPredicate.hs @@ -0,0 +1,15 @@ +-- | A human-friendly syntax for describing +-- 'Dojang.Types.EnvironmentPredicate.EnvironmentPredicate's. It is mainly +-- used for @when@ statements in /dojang.toml/ files. +module Dojang.Syntax.EnvironmentPredicate + ( errorBundlePretty + , parseEnvironmentPredicate + , writeEnvironmentPredicate + ) where + +import Dojang.Syntax.EnvironmentPredicate.Parser + ( errorBundlePretty + , parseEnvironmentPredicate + ) +import Dojang.Syntax.EnvironmentPredicate.Writer (writeEnvironmentPredicate) + diff --git a/src/Dojang/Syntax/EnvironmentPredicate/Parser.hs b/src/Dojang/Syntax/EnvironmentPredicate/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Syntax/EnvironmentPredicate/Parser.hs @@ -0,0 +1,349 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Syntax.EnvironmentPredicate.Parser + ( Field (..) + , FieldOp (..) + , ParseErrorBundle + , andExpression + , bareStringLiteral + , charactersInStringLiteral + , doubleQuoteStringLiteral + , equalOp + , errorBundlePretty + , expression + , field + , fieldOp + , inOp + , notEqualOp + , notInOp + , parse + , parseEnvironmentPredicate + , prefixOp + , simpleExpression + , singleQuoteStringLiteral + , stringLiteral + , strings + , suffixOp + ) where + +import Control.Applicative (optional, (<|>)) +import Control.Applicative.Combinators (choice, sepBy1, sepEndBy) +import Control.Monad (void) +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..)) +import Dojang.Types.MonikerName (parseMonikerName) + +import Data.CaseInsensitive (mk) +import Data.Char (isAlpha, isAlphaNum, isDigit) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.String (IsString (fromString)) +import Data.Text (Text, concat, cons, pack, singleton, unpack) +import Data.Void (Void) +import Text.Megaparsec + ( MonadParsec (eof, takeWhile1P, takeWhileP, try) + , Parsec + , label + , many + , parse + , satisfy + ) +import Text.Megaparsec.Char (char, hexDigitChar, space, space1, string) +import Text.Megaparsec.Error (ParseErrorBundle) +import Text.Megaparsec.Error qualified (errorBundlePretty) +import Prelude hiding (concat) + + +type Parser = Parsec Void Text + + +-- | Parse a 'EnvironmentPredicate' from a 'Text'. +parseEnvironmentPredicate + :: FilePath + -- ^ The name of source file. + -> Text + -- ^ The input text. + -> Either (ParseErrorBundle Text Void) EnvironmentPredicate + -- ^ The result of parsing. +parseEnvironmentPredicate = parse $ expression <* eof + + +-- | A parser for 'EnvironmentPredicate'. +expression :: Parser EnvironmentPredicate +expression = label "expression" $ do + space + subExprs <- andExpression `sepBy1` (space >> string "||" >> space) + space + return $ case subExprs of + [x] -> x + x : xs -> Or $ x :| xs + [] -> error "sepBy1 should never return an empty list" + + +andExpression :: Parser EnvironmentPredicate +andExpression = do + space + subExprs <- simpleExpression `sepBy1` (space >> string "&&" >> space) + space + return $ case subExprs of + [x] -> x + x : xs -> And $ x :| xs + [] -> error "sepBy1 should never return an empty list" + + +simpleExpression :: Parser EnvironmentPredicate +simpleExpression = do + space + expr <- + choice + [ char '(' >> space >> expression <* space <* char ')' + , string "always" >> return Always + , string "never" >> return (Not Always) + , do + void $ char '!' + space + void $ char '(' + space + expr' <- expression + space + void $ char ')' + return $ Not expr' + , fieldOp + ] + space + return expr + + +data FieldOp + = EqualOp Text + | NotEqualOp Text + | PrefixOp Text + | SuffixOp Text + | InOp [Text] + | NotInOp [Text] + + +fieldOp :: Parser EnvironmentPredicate +fieldOp = do + space + field' <- field + op <- + choice + [ try equalOp + , try notEqualOp + , try inOp + , try notInOp + , if field' == KernelRelease' then try prefixOp else fail "" + , if field' == KernelRelease' then try suffixOp else fail "" + ] + space + return $ case op of + EqualOp value -> makePredicate field' value + NotEqualOp value -> Not $ makePredicate field' value + PrefixOp prefix -> KernelReleasePrefix $ mk prefix + SuffixOp suffix -> KernelReleaseSuffix $ mk suffix + InOp [] -> Not Always + InOp (x : xs) -> Or $ makePredicate field' <$> (x :| xs) + NotInOp [] -> Always + NotInOp (x : xs) -> And $ Not . makePredicate field' <$> (x :| xs) + where + makePredicate :: Field -> Text -> EnvironmentPredicate + makePredicate OS = OperatingSystem . fromString . unpack + makePredicate Arch = Architecture . fromString . unpack + makePredicate Kernel = KernelName . fromString . unpack + makePredicate KernelRelease' = KernelRelease . fromString . unpack + makePredicate Moniker' = + either (const $ Not Always) Moniker . parseMonikerName + + +equalOp :: Parser FieldOp +equalOp = do + space + void $ char '=' + void $ optional (char '=') + space + EqualOp <$> stringLiteral + + +notEqualOp :: Parser FieldOp +notEqualOp = do + space + void $ string "!=" + space + NotEqualOp <$> stringLiteral + + +prefixOp :: Parser FieldOp +prefixOp = do + space + void $ string "^=" + space + PrefixOp <$> stringLiteral + + +suffixOp :: Parser FieldOp +suffixOp = do + space + void $ string "$=" + space + SuffixOp <$> stringLiteral + + +inOp :: Parser FieldOp +inOp = do + space1 + void $ string "in" + space + InOp <$> strings + + +notInOp :: Parser FieldOp +notInOp = do + space1 + void $ string "not" + space1 + void $ string "in" + space + NotInOp <$> strings + + +strings :: Parser [Text] +strings = do + space + void $ char '(' + space + members <- stringLiteral `sepEndBy` (space >> char ',' >> space) + space + void $ char ')' + space + return members + + +data Field = OS | Arch | Kernel | KernelRelease' | Moniker' deriving (Eq) + + +field :: Parser Field +field = + choice + [ OS <$ string "os" + , Arch <$ string "arch" + , KernelRelease' <$ string "kernel-release" + , Kernel <$ string "kernel" + , Moniker' <$ string "moniker" + ] + + +stringLiteral :: Parser Text +stringLiteral = label "string literal" $ do + space + string' <- + choice + [ doubleQuoteStringLiteral + , singleQuoteStringLiteral + , bareStringLiteral + ] + space + return string' + + +bareStringLiteral :: Parser Text +bareStringLiteral = label "bare string literal" $ do + first <- satisfy isAlpha + str <- takeWhileP Nothing isAlphaNum + return $ first `cons` str + + +doubleQuoteStringLiteral :: Parser Text +doubleQuoteStringLiteral = label "double quote string literal" $ do + void $ char '"' + str <- charactersInStringLiteral '"' + void $ char '"' + return str + + +singleQuoteStringLiteral :: Parser Text +singleQuoteStringLiteral = label "single quote string literal" $ do + void $ char '\'' + str <- charactersInStringLiteral '\'' + void $ char '\'' + return str + + +charactersInStringLiteral :: Char -> Parser Text +charactersInStringLiteral terminal = do + chunks <- + many $ + takeWhile1P (Just "string character") (\c -> c /= '\\' && c /= terminal) + <|> singleton + <$> charEscape + return $ concat chunks + where + charEscape :: Parser Char + charEscape = do + void $ char '\\' + choice + [ char '\\' >> return '\\' + , char '\'' >> return '\'' + , char '"' >> return '"' + , char 'b' >> return '\b' + , char 'f' >> return '\f' + , char 'n' >> return '\n' + , char 'r' >> return '\r' + , char 't' >> return '\t' + , char 'v' >> return '\v' + , char '0' >> return '\0' + , do + void $ char 'x' + d1 <- hex + d2 <- hex + return $ toEnum $ d1 * 0x10 + d2 + , do + void $ char 'u' + d1 <- hex + d2 <- hex + d3 <- hex + d4 <- hex + return $ toEnum $ d1 * 0x1000 + d2 * 0x100 + d3 * 0x10 + d4 + , do + void $ char 'U' + d1 <- hex + d2 <- hex + d3 <- hex + d4 <- hex + d5 <- hex + d6 <- hex + d7 <- hex + d8 <- hex + return $ + toEnum $ + d1 + * 0x10000000 + + d2 + * 0x1000000 + + d3 + * 0x100000 + + d4 + * 0x10000 + + d5 + * 0x1000 + + d6 + * 0x100 + + d7 + * 0x10 + + d8 + ] + hex :: Parser Int + hex = do + c <- hexDigitChar + return $ + if isDigit c + then fromEnum c - 0x30 + else + if 'A' <= c && c <= 'F' + then fromEnum c - 0x37 + else fromEnum c - 0x57 + + +-- | Basically the same as 'Text.Megaparsec.Error.errorBundlePretty' but +-- returns a 'Text' instead of a 'String'. +errorBundlePretty :: ParseErrorBundle Text Void -> Text +errorBundlePretty = pack . Text.Megaparsec.Error.errorBundlePretty diff --git a/src/Dojang/Syntax/EnvironmentPredicate/Writer.hs b/src/Dojang/Syntax/EnvironmentPredicate/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Syntax/EnvironmentPredicate/Writer.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Syntax.EnvironmentPredicate.Writer + ( writeEnvironmentPredicate + ) +where + +import Dojang.Types.Environment (Architecture, OperatingSystem) +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..)) +import Dojang.Types.MonikerName (MonikerName) + +import Data.CaseInsensitive (CI (original)) +import Data.Char (isAlpha, isAlphaNum, isControl) +import Data.List.NonEmpty (toList) +import Data.Text + ( Text + , all + , concatMap + , elem + , intercalate + , justifyRight + , pack + , singleton + , uncons + ) +import Numeric (showHex) +import Prelude hiding (all, concatMap, elem, reverse) + + +-- | Turns an 'EnvironmentPredicate' into a string that can be used in a +-- @dojang.toml@ file. The string can be parsed back into an +-- 'EnvironmentPredicate' using +-- 'Dojang.Syntax.EnvironmentPredicate.Parser.parseEnvironmentPredicate'. +writeEnvironmentPredicate :: EnvironmentPredicate -> Text +writeEnvironmentPredicate = fst . write + + +write + :: EnvironmentPredicate + -> (Text, Bool) +-- \^ @(when, can be split by &&)@ +write Always = ("always", False) +write (OperatingSystem os) = + ("os = " <> stringLiteral (original os.identifier), False) +write (Architecture arch) = + ("arch = " <> stringLiteral (original arch.identifier), False) +write (KernelName kernel) = + ("kernel = " <> stringLiteral (original kernel), False) +write (KernelRelease rel) = + ("kernel-release = " <> stringLiteral (original rel), False) +write (KernelReleasePrefix prefix) = + ("kernel-release ^= " <> stringLiteral (original prefix), False) +write (KernelReleaseSuffix suffix) = + ("kernel-release $= " <> stringLiteral (original suffix), False) +write (Moniker moniker) = + ("moniker = " <> stringLiteral (original moniker.name), False) +write (And predicates) = + case (excludeOses, excludeArchitectures, excludeMonikers) of + (_ : _, [], []) + | length excludeOses == length predicates -> + ( "os not in " + <> strings [original os.identifier | os <- excludeOses] + , False + ) + ([], _ : _, []) + | length excludeArchitectures == length predicates -> + ( "arch not in " + <> strings + [ original arch.identifier + | arch <- excludeArchitectures + ] + , False + ) + ([], [], _ : _) + | length excludeMonikers == length predicates -> + ( "moniker not in " + <> strings [original moniker.name | moniker <- excludeMonikers] + , False + ) + _ -> + ( intercalate + " && " + [ let (when', needParentheses) = write p + in if needParentheses then "(" <> when' <> ")" else when' + | p <- toList predicates + ] + , False + ) + where + excludeOses :: [OperatingSystem] + excludeOses = [os | Not (OperatingSystem os) <- toList predicates] + excludeArchitectures :: [Architecture] + excludeArchitectures = [arch | Not (Architecture arch) <- toList predicates] + excludeMonikers :: [MonikerName] + excludeMonikers = [moniker | Not (Moniker moniker) <- toList predicates] +write (Or predicates) = + case (oses, architectures, monikers) of + (_ : _, [], []) + | length oses == length predicates -> + ("os in " <> strings [original os.identifier | os <- oses], False) + ([], _ : _, []) + | length architectures == length predicates -> + ( "arch in " + <> strings [original arch.identifier | arch <- architectures] + , False + ) + ([], [], _ : _) + | length monikers == length predicates -> + ( "moniker in " + <> strings [original moniker.name | moniker <- monikers] + , False + ) + _ -> (intercalate " || " (fst . write <$> toList predicates), True) + where + oses :: [OperatingSystem] + oses = [os | OperatingSystem os <- toList predicates] + architectures :: [Architecture] + architectures = [arch | Architecture arch <- toList predicates] + monikers :: [MonikerName] + monikers = [moniker | Moniker moniker <- toList predicates] +write (Not Always) = ("never", False) +write (Not (OperatingSystem os)) = + ("os != " <> stringLiteral (original os.identifier), False) +write (Not (Architecture arch)) = + ("arch != " <> stringLiteral (original arch.identifier), False) +write (Not (Moniker moniker)) = + ("moniker != " <> stringLiteral (original moniker.name), False) +write (Not p) = ("!(" <> fst (write p) <> ")", False) + + +stringLiteral :: Text -> Text +stringLiteral v = case uncons v of + Nothing -> "\"\"" + Just (c, cs) | isAlpha c && all isAlphaNum cs -> v + _ | '"' `elem` v && not ('\'' `elem` v) -> "'" <> escapeText False v <> "'" + _ -> "\"" <> escapeText True v <> "\"" + where + escapeText :: Bool -> Text -> Text + escapeText doubleQuote = concatMap (escape doubleQuote) + escape :: Bool -> Char -> Text + escape True '"' = "\\\"" + escape False '\'' = "\\'" + escape _ '\\' = "\\\\" + escape _ '\b' = "\\b" + escape _ '\f' = "\\f" + escape _ '\n' = "\\n" + escape _ '\r' = "\\r" + escape _ '\t' = "\\t" + escape _ '\v' = "\\v" + escape _ '\0' = "\\0" + escape _ c + | not (isControl c) && c < '\x80' = singleton c + | c <= '\xff' = "\\x" <> justifyRight 2 '0' (hex c) + | c <= '\xffff' = "\\u" <> justifyRight 4 '0' (hex c) -- cSpell: disable-line + | otherwise = "\\U" <> justifyRight 8 '0' (hex c) + where + hex :: Char -> Text + hex = pack . (`showHex` "") . fromEnum + + +strings :: [Text] -> Text +strings = ("(" <>) . (<> ")") . intercalate ", " . fmap stringLiteral diff --git a/src/Dojang/Syntax/FilePathExpression/Parser.hs b/src/Dojang/Syntax/FilePathExpression/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Syntax/FilePathExpression/Parser.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Syntax.FilePathExpression.Parser + ( ParseErrorBundle + , bareComponent + , environmentVariable + , errorBundlePretty + , filePathExpression + , filePathExpression' + , parseFilePathExpression + , parse + , root + , substitution + , substitutionConditional + , substitutionDefault + , substitutionInBraces + , substitutionModifierAfterColon + ) where + +import Dojang.Types.FilePathExpression + ( EnvironmentVariable + , FilePathExpression (..) + ) + +import Control.Applicative (Alternative ((<|>)), optional) +import Control.Monad (void) +import Data.Char (isAlpha, isAlphaNum, isAscii, isControl) +import Data.Text (Text, cons, pack) +import Data.Void (Void) +import Text.Megaparsec + ( MonadParsec (eof, takeWhile1P, takeWhileP) + , Parsec + , label + , many + , oneOf + , parse + , satisfy + , some + , try + , () + ) +import Text.Megaparsec.Char (char, string) +import Text.Megaparsec.Error (ParseErrorBundle) +import Text.Megaparsec.Error qualified (errorBundlePretty) + + +type Parser = Parsec Void Text + + +-- | Parse a 'FilePathExpression' from a 'Text'. +parseFilePathExpression + :: FilePath + -- ^ The name of source file. + -> Text + -- ^ The input text. + -> Either (ParseErrorBundle Text Void) FilePathExpression + -- ^ The result of parsing. +parseFilePathExpression = parse $ filePathExpression <* eof + + +-- | A parser for 'FilePathExpression'. +filePathExpression :: Parser FilePathExpression +filePathExpression = filePathExpression' True [] +{-# INLINE filePathExpression #-} + + +filePathExpression' :: Bool -> [Char] -> Parser FilePathExpression +filePathExpression' begin disallowedBareChars = do + root' <- if begin then optional $ try root else return Nothing + head' <- case root' of + Nothing -> do + firstComponent <- component begin disallowedBareChars + components <- many $ component False disallowedBareChars + return $ foldl Concatenation firstComponent components + Just r -> do + components <- many $ component False disallowedBareChars + return $ case components of + [] -> r + c : cs -> PathSeparator r $ foldl Concatenation c cs + betweenSeparators <- many $ try $ do + void $ oneOf ['/', '\\'] + components' <- some $ component False disallowedBareChars + return $ foldl1 Concatenation components' + let topExpr = foldl PathSeparator head' betweenSeparators + void $ optional $ oneOf ['/', '\\'] + return topExpr +{-# INLINE filePathExpression' #-} + + +component :: Bool -> [Char] -> Parser FilePathExpression +component begin disallowedBareChars = + bareComponent disallowedBareChars + <|> substitutionInBraces begin + <|> substitution +{-# INLINE component #-} + + +bareComponent :: [Char] -> Parser FilePathExpression +bareComponent disallowedChars = do + component' <- takeWhile1P (Just "component") isValidChar + return $ BareComponent component' + where + isValidChar :: Char -> Bool + isValidChar = not . isInvalidChar + isInvalidChar :: Char -> Bool + isInvalidChar c = + isControl c + || c + == '/' + || c + == '\\' + || c + == '$' + || c + == '\r' + || c + == '\n' + || c + `elem` disallowedChars +{-# INLINE bareComponent #-} + + +root :: Parser FilePathExpression +root = + driveLetter <|> rootSlash + where + driveLetter :: Parser FilePathExpression + driveLetter = do + letter <- satisfy (`elem` ['A' .. 'Z']) "drive letter" + void $ char ':' + void $ satisfy (`elem` ['/', '\\']) + return $ Root $ Just letter + rootSlash :: Parser FilePathExpression + rootSlash = char '/' >> return (Root Nothing) + + +environmentVariable :: Parser EnvironmentVariable +environmentVariable = label "environment variable" $ do + first <- satisfy (\c -> isAscii c && isAlpha c || c == '_') + rest <- takeWhileP Nothing (\c -> isAscii c && isAlphaNum c || c == '_') + return $ cons first rest +{-# INLINE environmentVariable #-} + + +substitution :: Parser FilePathExpression +substitution = + char '$' >> Substitution <$> environmentVariable +{-# INLINE substitution #-} + + +substitutionInBraces :: Bool -> Parser FilePathExpression +substitutionInBraces begin = do + void $ string "${" + envVar <- environmentVariable + colon <- optional $ char ':' + expr <- case colon of + Nothing -> return $ Substitution envVar + Just _ -> substitutionModifierAfterColon begin envVar + void $ char '}' + return expr +{-# INLINE substitutionInBraces #-} + + +substitutionModifierAfterColon + :: Bool + -> EnvironmentVariable + -> Parser FilePathExpression +substitutionModifierAfterColon begin envVar = + substitutionDefault begin envVar <|> substitutionConditional begin envVar +{-# INLINE substitutionModifierAfterColon #-} + + +substitutionDefault :: Bool -> EnvironmentVariable -> Parser FilePathExpression +substitutionDefault begin envVar = do + void $ char '-' + SubstitutionWithDefault envVar <$> filePathExpression' begin "}" +{-# INLINE substitutionDefault #-} + + +substitutionConditional + :: Bool -> EnvironmentVariable -> Parser FilePathExpression +substitutionConditional begin envVar = do + void $ char '+' + ConditionalSubstitution envVar <$> filePathExpression' begin "}" +{-# INLINE substitutionConditional #-} + + +-- | Basically the same as 'Text.Megaparsec.Error.errorBundlePretty' but +-- returns a 'Text' instead of a 'String'. +errorBundlePretty :: ParseErrorBundle Text Void -> Text +errorBundlePretty = pack . Text.Megaparsec.Error.errorBundlePretty diff --git a/src/Dojang/Syntax/Manifest/Internal.hs b/src/Dojang/Syntax/Manifest/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Syntax/Manifest/Internal.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Dojang.Syntax.Manifest.Internal + ( FileRoute' + , FileRouteMap' + , EnvironmentPredicate' (..) + , FlatOrNonEmptyStrings (..) + , Hook' (..) + , Hooks' (..) + , IgnoreMap' + , Manifest' (..) + , MonikerMap' + , always + , emptyHooks + ) where + +import Data.List.NonEmpty (NonEmpty) +import GHC.Generics (Generic) +import Prelude hiding (all, any) + +import Data.CaseInsensitive (CI (original)) +import Data.Map.Strict (Map) +import Data.Text (Text, pack, unpack) +import Dojang.Types.MonikerName (MonikerName, parseMonikerName) +import System.FilePattern (FilePattern) +import Toml (Value (..)) +import Toml.FromValue + ( FromKey (..) + , FromValue (..) + , optKey + , parseTableFromValue + ) +import Toml.FromValue.Generic (genericParseTable) +import Toml.FromValue.Matcher (Matcher) +import Toml.ToValue + ( ToKey (..) + , ToTable (toTable) + , ToValue (toValue) + , defaultTableToValue + , table + ) +import Toml.ToValue.Generic (genericToTable) + + +data FlatOrNonEmptyStrings + = Flat String + | NonEmpty (NonEmpty String) + deriving (Eq, Show) + + +typeError :: Value -> String -> Matcher a +typeError actual wanted = + fail $ + "type error. wanted: " ++ wanted ++ " got: " ++ case actual of + Integer{} -> "integer" + Float{} -> "float" + String{} -> "string" + Table{} -> "table" + Array{} -> "array" + Bool{} -> "boolean" + TimeOfDay{} -> "local time" + LocalTime{} -> "local date-time" + Day{} -> "locate date" + ZonedTime{} -> "offset date-time" + + +instance FromValue FlatOrNonEmptyStrings where + fromValue v@Array{} = NonEmpty <$> fromValue v + fromValue v@String{} = Flat <$> fromValue v + fromValue v = typeError v "string or array of strings" + + +instance ToValue FlatOrNonEmptyStrings where + toValue (Flat a) = toValue a + toValue (NonEmpty as) = toValue as + + +instance FromKey MonikerName where + fromKey key = case parseMonikerName $ pack key of + Right monikerName -> return monikerName + Left _ -> fail $ "invalid moniker name: " ++ show key + + +instance FromValue MonikerName where + fromValue v@String{} = do + result <- fromValue v + case parseMonikerName result of + Right monikerName -> return monikerName + Left _ -> fail $ "invalid moniker name: " ++ show v + fromValue v = typeError v "string" + + +instance ToKey MonikerName where + toKey = unpack . original . (.name) + + +instance ToValue MonikerName where + toValue monikerName = toValue $ original monikerName.name + + +data EnvironmentPredicate' = EnvironmentPredicate' + { os :: Maybe FlatOrNonEmptyStrings + , arch :: Maybe FlatOrNonEmptyStrings + , kernel :: Maybe FlatOrNonEmptyStrings + , kernelRelease :: Maybe FlatOrNonEmptyStrings + , all :: Maybe (NonEmpty MonikerName) + , any :: Maybe (NonEmpty MonikerName) + , when :: Maybe Text + } + deriving (Eq, Show) + + +always :: EnvironmentPredicate' +always = + EnvironmentPredicate' + { os = Nothing + , arch = Nothing + , kernel = Nothing + , kernelRelease = Nothing + , all = Nothing + , any = Nothing + , when = Nothing + } + + +instance FromValue EnvironmentPredicate' where + fromValue = + parseTableFromValue $ + EnvironmentPredicate' + <$> optKey "os" + <*> optKey "arch" + <*> optKey "kernel" + <*> optKey "kernel-release" + <*> optKey "all" + <*> optKey "any" + <*> optKey "when" + + +instance ToValue EnvironmentPredicate' where + toValue = defaultTableToValue + + +instance ToTable EnvironmentPredicate' where + toTable pred' = + table $ + fieldsToValue fields + ++ fieldsToValue fields' + ++ fieldsToValue + [("when", pred'.when)] + where + fields :: [(String, Maybe FlatOrNonEmptyStrings)] + fields = + [ ("os", pred'.os) + , ("arch", pred'.arch) + , ("kernel", pred'.kernel) + , ("kernel-release", pred'.kernelRelease) + ] + fields' :: [(String, Maybe (NonEmpty MonikerName))] + fields' = + [ ("all", pred'.all) + , ("any", pred'.any) + ] + fieldsToValue :: (ToValue a) => [(String, Maybe a)] -> [(String, Value)] + fieldsToValue fs = [(key, toValue value) | (key, Just value) <- fs] + + +type MonikerMap' = Map MonikerName EnvironmentPredicate' + + +type FileRoute' = Map MonikerName Text + + +type FileRouteMap' = Map FilePath FileRoute' + + +type IgnoreMap' = Map FilePath [FilePattern] + + +-- | A single hook configuration in detailed form. +data Hook' = Hook' + { command :: Text + -- ^ The executable path (required). + , args :: Maybe [Text] + -- ^ Command arguments (default: []). + , moniker :: Maybe MonikerName + -- ^ Run only when this moniker matches. + , condition :: Maybe Text + -- ^ Run only when this predicate matches (parsed from "when" in TOML). + , workingDirectory :: Maybe FilePath + -- ^ Working directory (default: repository root). + , ignoreFailure :: Maybe Bool + -- ^ Continue on failure (default: False). + } + deriving (Eq, Show) + + +instance FromValue Hook' where + fromValue = + parseTableFromValue $ + Hook' + <$> reqKey "command" + <*> optKey "args" + <*> optKey "moniker" + <*> optKey "when" + <*> optKey "working-directory" + <*> optKey "ignore-failure" + where + reqKey key = + optKey key >>= \case + Just v -> return v + Nothing -> fail $ "missing required key: " ++ key + + +instance ToValue Hook' where + toValue = defaultTableToValue + + +instance ToTable Hook' where + toTable hook = + table $ + [("command", toValue hook.command)] + ++ maybeField "args" hook.args + ++ maybeField "moniker" hook.moniker + ++ maybeField "when" hook.condition + ++ maybeField "working-directory" hook.workingDirectory + ++ maybeField "ignore-failure" hook.ignoreFailure + where + maybeField :: (ToValue a) => String -> Maybe a -> [(String, Value)] + maybeField key (Just v) = [(key, toValue v)] + maybeField _ Nothing = [] + + +-- | Hooks section of the manifest. +data Hooks' = Hooks' + { preApply :: Maybe [Hook'] + , preFirstApply :: Maybe [Hook'] + , postFirstApply :: Maybe [Hook'] + , postApply :: Maybe [Hook'] + } + deriving (Eq, Show) + + +-- | Empty hooks (no hooks defined). +emptyHooks :: Hooks' +emptyHooks = + Hooks' + { preApply = Nothing + , preFirstApply = Nothing + , postFirstApply = Nothing + , postApply = Nothing + } + + +instance FromValue Hooks' where + fromValue = + parseTableFromValue $ + Hooks' + <$> optKey "pre-apply" + <*> optKey "pre-first-apply" + <*> optKey "post-first-apply" + <*> optKey "post-apply" + + +instance ToValue Hooks' where + toValue = defaultTableToValue + + +instance ToTable Hooks' where + toTable hooks = + table $ + maybeField "pre-apply" hooks.preApply + ++ maybeField "pre-first-apply" hooks.preFirstApply + ++ maybeField "post-first-apply" hooks.postFirstApply + ++ maybeField "post-apply" hooks.postApply + where + maybeField :: (ToValue a) => String -> Maybe a -> [(String, Value)] + maybeField key (Just v) = [(key, toValue v)] + maybeField _ Nothing = [] + + +data Manifest' = Manifest' + { monikers :: MonikerMap' + , dirs :: FileRouteMap' + , files :: FileRouteMap' + , ignores :: IgnoreMap' + , hooks :: Maybe Hooks' + } + deriving (Eq, Show, Generic) + + +instance FromValue Manifest' where + fromValue = parseTableFromValue genericParseTable + + +instance ToValue Manifest' where + toValue = defaultTableToValue + + +instance ToTable Manifest' where + toTable = genericToTable diff --git a/src/Dojang/Syntax/Manifest/Parser.hs b/src/Dojang/Syntax/Manifest/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Syntax/Manifest/Parser.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Dojang.Syntax.Manifest.Parser + ( Error (..) + , formatErrors + , readManifest + , readManifestFile + ) where + +import Data.Bifunctor (Bifunctor (first)) +import Data.Either (lefts) +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty (toList) +import Data.String (IsString (fromString)) +import Data.Void (Void) +import System.IO.Unsafe (unsafePerformIO) +import Prelude hiding (readFile) + +import Data.HashMap.Strict as HashMap (fromList) +import Data.Map.Strict as Map (Map, empty, fromList, toList) +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (decodeUtf8Lenient) +import System.FilePattern (FilePattern) +import System.OsPath (OsPath, encodeFS) +import Toml (Result (..), decode) + +import qualified Data.HashMap.Strict as HashMap +import Dojang.MonadFileSystem (FileType (..), MonadFileSystem (readFile)) +import Dojang.Syntax.EnvironmentPredicate.Parser + ( ParseErrorBundle + , errorBundlePretty + , parseEnvironmentPredicate + ) +import Dojang.Syntax.FilePathExpression.Parser + ( errorBundlePretty + , parseFilePathExpression + ) +import Dojang.Syntax.Manifest.Internal + ( EnvironmentPredicate' (..) + , FileRoute' + , FileRouteMap' + , FlatOrNonEmptyStrings (..) + , Manifest' (..) + , MonikerMap' + ) +import qualified Dojang.Syntax.Manifest.Internal as Internal +import Dojang.Types.EnvironmentPredicate + ( EnvironmentPredicate (..) + , normalizePredicate + ) +import Dojang.Types.FilePathExpression (FilePathExpression) +import Dojang.Types.FileRoute (FileRoute, fileRoute) +import Dojang.Types.FileRouteMap (FileRouteMap) +import Dojang.Types.Hook (Hook (..), HookMap, HookType (..)) +import Dojang.Types.Manifest (Manifest (Manifest)) +import Dojang.Types.MonikerMap (MonikerMap) +import Dojang.Types.MonikerName (MonikerName) + + +-- | An error made during parsing. +data Error + = -- | TOML parsing errors. + TomlErrors (NonEmpty String) + | -- | An error made during parsing an 'EnvironmentPredicate'. + EnvironmentPredicateError (ParseErrorBundle Text Void) + | -- | An error made during parsing a 'FilePathExpression'. + FilePathExpressionError (ParseErrorBundle Text Void) + + +-- | A warning message made during parsing. +type TomlWarning = Text + + +-- | Decodes a 'Manifest' from a 'Text'. +readManifest + :: Text + -- ^ A TOML document text to parse. + -> Either Error (Manifest, [TomlWarning]) + -- ^ A decoded 'Manifest' with warnings, or a list of errors. +readManifest toml = case decode $ unpack toml of + Success warnings manifest' -> + case mapManifest manifest' of + Left e -> Left e + Right m -> Right (m, pack <$> warnings) + Failure (e : es) -> Left $ TomlErrors $ e :| es + Failure [] -> Left $ TomlErrors $ "unknown error" :| [] + + +-- | Reads a 'Manifest' file from the given path. It assumes that the file +-- is encoded in UTF-8. Throws an 'IOError' if the file cannot be read. +readManifestFile + :: (MonadFileSystem m) + => OsPath + -- ^ A path to the manifest file. + -> m (Either Error (Manifest, [TomlWarning])) + -- ^ A decoded manifest with warnings, or a list of errors. +readManifestFile filePath = do + content <- readFile filePath + return $ readManifest $ decodeUtf8Lenient content + + +-- | Format error messages. +formatErrors :: Error -> [Text] +formatErrors (TomlErrors es) = Data.List.NonEmpty.toList $ fmap pack es +formatErrors (EnvironmentPredicateError e) = + [Dojang.Syntax.EnvironmentPredicate.Parser.errorBundlePretty e] +formatErrors (FilePathExpressionError e) = + [Dojang.Syntax.FilePathExpression.Parser.errorBundlePretty e] + + +mapManifest :: Manifest' -> Either Error Manifest +mapManifest manifest' = + case monikersResult of + Left e -> Left e + Right monikers' -> + case mapFileRouteMap monikers' manifest'.dirs manifest'.files of + Left e -> Left e + Right fileRoutes' -> + case mapHooks monikers' manifest'.hooks of + Left e -> Left e + Right hooks' -> + Right $ Manifest monikers' fileRoutes' ignores' hooks' + where + monikersResult :: Either Error MonikerMap + monikersResult = mapMonikerMap manifest'.monikers + ignores' :: Map OsPath [FilePattern] + ignores' = + Map.fromList + [ (encodePath path, pattern) + | (path, pattern) <- Map.toList manifest'.ignores + ] + + +mapMonikerMap :: MonikerMap' -> Either Error MonikerMap +mapMonikerMap m = + case errors of + e : _ -> Left e + _ -> + Right $ + HashMap.fromList + [(name, pred') | (name, Right pred') <- results] + where + results :: [(MonikerName, Either Error EnvironmentPredicate)] + results = + [ (name, mapEnvironmentPredicate' pred') + | (name, pred') <- toList m + ] + errors :: [Error] + errors = lefts [r | (_, r) <- results] + + +mapEnvironmentPredicate' + :: EnvironmentPredicate' + -> Either Error EnvironmentPredicate +mapEnvironmentPredicate' envPred' = + case when of + Right pred' -> + Right $ + normalizePredicate $ + And [os, arch, kernel, kernelRelease, all', any', pred'] + Left err -> Left err + where + os :: EnvironmentPredicate + os = + maybe + Always + (Or . fmap OperatingSystem . mapFlatOrNonEmptyStrings) + envPred'.os + arch :: EnvironmentPredicate + arch = + maybe + Always + (Or . fmap Architecture . mapFlatOrNonEmptyStrings) + envPred'.arch + kernel :: EnvironmentPredicate + kernel = + maybe + Always + (Or . fmap KernelName . mapFlatOrNonEmptyStrings) + envPred'.kernel + kernelRelease :: EnvironmentPredicate + kernelRelease = + maybe + Always + (Or . fmap KernelRelease . mapFlatOrNonEmptyStrings) + envPred'.kernelRelease + all' :: EnvironmentPredicate + all' = maybe Always (And . fmap Moniker) envPred'.all + any' :: EnvironmentPredicate + any' = maybe Always (Or . fmap Moniker) envPred'.any + when :: Either Error EnvironmentPredicate + when = + maybe + (Right Always) + (first EnvironmentPredicateError . parseEnvironmentPredicate "") + envPred'.when + + +mapFlatOrNonEmptyStrings :: (IsString a) => FlatOrNonEmptyStrings -> NonEmpty a +mapFlatOrNonEmptyStrings (Flat a) = [fromString a] +mapFlatOrNonEmptyStrings (NonEmpty as) = fromString <$> as + + +mapFileRouteMap + :: MonikerMap -> FileRouteMap' -> FileRouteMap' -> Either Error FileRouteMap +mapFileRouteMap monikerMap dirs files = + case errors of + e : _ -> Left e + _ -> Right $ Map.fromList [(name, route) | (name, Right route) <- results] + where + results :: [(OsPath, Either Error FileRoute)] + results = + [ (encodePath name, mapFileRoute monikerMap route Directory) + | (name, route) <- toList dirs + ] + ++ [ (encodePath name, mapFileRoute monikerMap route File) + | (name, route) <- toList files + ] + errors :: [Error] + errors = lefts [r | (_, r) <- results] + + +encodePath :: String -> OsPath +encodePath = unsafePerformIO . encodeFS + + +mapFileRoute + :: MonikerMap + -> FileRoute' + -> FileType + -> Either Error FileRoute +mapFileRoute monikerMap fileRoute' fileType = + case errors of + e : _ -> Left $ FilePathExpressionError e + _ -> + Right $ + fileRoute + monikerMap + ( [(name, Just expr') | (name, Just (Right expr')) <- results] + ++ [(name, Nothing) | (name, Nothing) <- results] + ) + fileType + where + results + :: [ ( MonikerName + , Maybe (Either (ParseErrorBundle Text Void) FilePathExpression) + ) + ] + results = + [ ( name + , if expr == "" then Nothing else Just $ parseFilePathExpression "" expr + ) + | (name, expr) <- toList fileRoute' + ] + errors :: [ParseErrorBundle Text Void] + errors = lefts [r | (_, Just r) <- results] + + +mapHooks :: MonikerMap -> Maybe Internal.Hooks' -> Either Error HookMap +mapHooks _ Nothing = Right Map.empty +mapHooks monikers (Just hooks') = + case errors of + e : _ -> Left e + _ -> + Right $ + Map.fromList + [ (hookType, hookList) + | (hookType, Right hookList) <- results + , not (null hookList) + ] + where + results :: [(HookType, Either Error [Hook])] + results = + [ (PreApply, mapHookList monikers hooks'.preApply) + , (PreFirstApply, mapHookList monikers hooks'.preFirstApply) + , (PostFirstApply, mapHookList monikers hooks'.postFirstApply) + , (PostApply, mapHookList monikers hooks'.postApply) + ] + errors :: [Error] + errors = lefts [r | (_, r) <- results] + + +mapHookList :: MonikerMap -> Maybe [Internal.Hook'] -> Either Error [Hook] +mapHookList _ Nothing = Right [] +mapHookList monikers (Just hooks') = + case errors of + e : _ -> Left e + _ -> Right [hook | Right hook <- results] + where + results :: [Either Error Hook] + results = mapHook monikers <$> hooks' + errors :: [Error] + errors = lefts results + + +mapHook :: MonikerMap -> Internal.Hook' -> Either Error Hook +mapHook monikers hook' = + case conditionResult of + Left e -> Left e + Right cond -> + Right + Hook + { command = encodePath $ unpack hook'.command + , args = maybe [] id hook'.args + , condition = cond + , workingDirectory = encodePath <$> hook'.workingDirectory + , ignoreFailure = maybe False id hook'.ignoreFailure + } + where + conditionResult :: Either Error EnvironmentPredicate + conditionResult = case hook'.moniker of + Just monikerName -> + -- If moniker is specified, it takes precedence + case HashMap.lookup monikerName monikers of + Just pred' -> Right pred' + Nothing -> Right $ Moniker monikerName + Nothing -> + -- Otherwise, parse the condition (when) field + case hook'.condition of + Nothing -> Right Always + Just condText -> + first EnvironmentPredicateError $ + parseEnvironmentPredicate "" condText diff --git a/src/Dojang/Syntax/Manifest/Writer.hs b/src/Dojang/Syntax/Manifest/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Syntax/Manifest/Writer.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Dojang.Syntax.Manifest.Writer + ( writeManifest + , writeManifestFile + ) where + +import Data.Bifunctor (Bifunctor (bimap, second)) +import Data.List (partition) +import Data.List.NonEmpty (NonEmpty ((:|)), length, toList) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) +import GHC.IsList (IsList (fromList)) +import System.IO.Unsafe (unsafePerformIO) +import Prelude hiding (all, any, writeFile) + +import Data.CaseInsensitive (CI (original)) +import Data.HashMap.Strict (toList) +import Data.Map.Strict (toList) +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (encodeUtf8) +import System.OsPath (OsPath, decodeFS) +import TextShow (FromStringShow (FromStringShow), TextShow (showt)) +import Toml.Pretty (prettyTomlOrdered) +import Toml.ToValue (ToTable (toTable)) +import Toml.Value (Table) + +import qualified Data.Map.Strict +import Dojang.MonadFileSystem + ( FileType (Directory) + , MonadFileSystem (writeFile) + ) +import Dojang.Syntax.EnvironmentPredicate.Writer (writeEnvironmentPredicate) +import Dojang.Syntax.Manifest.Internal + ( EnvironmentPredicate' (..) + , FileRoute' + , FileRouteMap' + , FlatOrNonEmptyStrings (..) + , Hooks' (..) + , IgnoreMap' + , Manifest' (Manifest') + , MonikerMap' + , always + ) +import qualified Dojang.Syntax.Manifest.Internal as Internal +import Dojang.Types.EnvironmentPredicate + ( EnvironmentPredicate (..) + , normalizePredicate + ) +import Dojang.Types.FilePathExpression (toPathText) +import Dojang.Types.FileRoute (FileRoute (..)) +import Dojang.Types.FileRouteMap (FileRouteMap) +import Dojang.Types.Hook (Hook (..), HookMap, HookType (..)) +import Dojang.Types.Manifest (Manifest (..)) +import Dojang.Types.MonikerMap (MonikerMap) +import Dojang.Types.MonikerName (MonikerName) + + +schema :: Text +schema = "https://schema.dojang.dev/2023-11/manifest.schema.json" + + +-- | Encodes a 'Manifest' into a TOML document. +writeManifest :: Manifest -> Text +writeManifest manifest = + "#:schema " + <> schema + <> "\n\n" + <> (showt $ FromStringShow $ prettyTomlOrdered order tbl) + where + manifest' :: Manifest' + manifest' = mapManifest' manifest + tbl :: Table + tbl = toTable manifest' + order :: [String] -> String -> Either Int String + order [] field = case field of + "dirs" -> Left 1 + "files" -> Left 2 + "ignores" -> Left 3 + "monikers" -> Left 4 + _ -> Right field + order _ field = Right field + + +-- | Writes a 'Manifest' file to the given path. Throw an 'IOError' if the +-- an occurs while writing the file. +writeManifestFile + :: (MonadFileSystem m) + => Manifest + -- ^ The 'Manifest' to write. + -> OsPath + -- ^ The path to write the 'Manifest' to. + -> m () +writeManifestFile manifest filePath = + writeFile filePath $ encodeUtf8 $ writeManifest manifest + + +mapManifest' :: Manifest -> Manifest' +mapManifest' manifest = + Manifest' monikers' dirs files ignores hooks' + where + dirs :: FileRouteMap' + files :: FileRouteMap' + (dirs, files) = mapFiles manifest.fileRoutes manifest.monikers + monikers' :: MonikerMap' + monikers' = mapMonikers' manifest.monikers + ignores :: IgnoreMap' + ignores = + fromList + [ (decodePath path, pattern) + | (path, pattern) <- Data.Map.Strict.toList manifest.ignorePatterns + ] + hooks' :: Maybe Hooks' + hooks' = + if Data.Map.Strict.null manifest.hooks + then Nothing + else Just $ mapHooks' manifest.hooks + + +mapFiles :: FileRouteMap -> MonikerMap -> (FileRouteMap', FileRouteMap') +mapFiles fileRouteMap monikers = + ( fromList (bimap decodePath (`mapFileRoute'` monikers) <$> dirs) + , fromList (bimap decodePath (`mapFileRoute'` monikers) <$> files) + ) + where + dirs :: [(OsPath, FileRoute)] + files :: [(OsPath, FileRoute)] + (dirs, files) = + partition + ((== Directory) . fileType . snd) + $ Data.Map.Strict.toList fileRouteMap + + +decodePath :: OsPath -> FilePath +decodePath = unsafePerformIO . decodeFS + + +mapFileRoute' :: FileRoute -> MonikerMap -> FileRoute' +mapFileRoute' fileRoute monikers = + (fromList . catMaybes) + [ case (normalizePredicate pred', maybe "" toPathText filePath) of + (Moniker n, path) -> Just (n, path) + (pred'', path) -> case lookBack monikers pred'' of + Just n -> Just (n, path) + Nothing -> Nothing + | (pred', filePath) <- fileRoute.predicates + ] + + +lookBack :: MonikerMap -> EnvironmentPredicate -> Maybe MonikerName +lookBack monikers predicate = + listToMaybe + [ n + | (n, p) <- Data.HashMap.Strict.toList monikers + , normalizePredicate p == normalizedPred + ] + where + normalizedPred :: EnvironmentPredicate + normalizedPred = normalizePredicate predicate + + +mapMonikers' :: MonikerMap -> MonikerMap' +mapMonikers' monikers = + fromList $ + second (mapEnvironmentPredicate' . normalizePredicate) + <$> Data.HashMap.Strict.toList monikers + + +mapEnvironmentPredicate' :: EnvironmentPredicate -> EnvironmentPredicate' +mapEnvironmentPredicate' Always = always +mapEnvironmentPredicate' (Moniker n) = always{all = Just $ fromList [n]} +mapEnvironmentPredicate' (OperatingSystem os) = + always{os = Just $ Flat $ unpack $ original os.identifier} +mapEnvironmentPredicate' (Architecture arch) = + always{arch = Just $ Flat $ unpack $ original arch.identifier} +mapEnvironmentPredicate' (KernelName kernel) = + always{kernel = Just $ Flat $ unpack $ original kernel} +mapEnvironmentPredicate' (KernelRelease kernelRelease) = + always{kernelRelease = Just $ Flat $ unpack $ original kernelRelease} +mapEnvironmentPredicate' (And predicates') = + fromMaybe + always{when = Just $ writeEnvironmentPredicate $ And predicates'} + (xor' $ mapEnvironmentPredicate' <$> predicates') + where + xor' :: NonEmpty EnvironmentPredicate' -> Maybe EnvironmentPredicate' + xor' (predicate :| []) = Just predicate + xor' (a :| predicates'') = + let r : est = predicates'' + in case xor' (r :| est) of + Nothing -> Nothing + Just b -> do + os' <- xorMaybe a.os b.os + arch' <- xorMaybe a.arch b.arch + kernel' <- xorMaybe a.kernel b.kernel + kernelRelease' <- xorMaybe a.kernelRelease b.kernelRelease + all' <- xorMaybe a.all b.all + any' <- xorMaybe a.any b.any + when' <- xorMaybe a.when b.when + return + EnvironmentPredicate' + { os = os' + , arch = arch' + , kernel = kernel' + , kernelRelease = kernelRelease' + , all = all' + , any = any' + , when = when' + } + xorMaybe :: Maybe a -> Maybe a -> Maybe (Maybe a) + xorMaybe (Just _) (Just _) = Nothing + xorMaybe (Just a) Nothing = Just $ Just a + xorMaybe Nothing (Just b) = Just $ Just b + xorMaybe Nothing Nothing = Just Nothing +mapEnvironmentPredicate' (Or predicates') + | Prelude.length oses == length' = + always{os = Just $ NonEmpty $ toNonEmpty oses} + | Prelude.length arches == length' = + always{arch = Just $ NonEmpty $ toNonEmpty arches} + | Prelude.length kernels == length' = + always{kernel = Just $ NonEmpty $ toNonEmpty kernels} + | Prelude.length kernelReleases == length' = + always{kernelRelease = Just $ NonEmpty $ toNonEmpty kernelReleases} + | Prelude.length monikers' == length' = + always{any = Just $ toNonEmpty monikers'} + | otherwise = + always{when = Just $ writeEnvironmentPredicate $ Or predicates'} + where + length' :: Int + length' = Data.List.NonEmpty.length predicates' + oses :: [String] + oses = + [ unpack $ original os'.identifier + | OperatingSystem os' <- Data.List.NonEmpty.toList predicates' + ] + arches :: [String] + arches = + [ unpack $ original arch'.identifier + | Architecture arch' <- Data.List.NonEmpty.toList predicates' + ] + kernels :: [String] + kernels = + [ unpack $ original kernel' + | KernelName kernel' <- Data.List.NonEmpty.toList predicates' + ] + kernelReleases :: [String] + kernelReleases = + [ unpack $ original kernelRelease' + | KernelRelease kernelRelease' <- Data.List.NonEmpty.toList predicates' + ] + monikers' :: [MonikerName] + monikers' = [n | Moniker n <- Data.List.NonEmpty.toList predicates'] + toNonEmpty :: [a] -> NonEmpty a + toNonEmpty (x : xs) = x :| xs + toNonEmpty [] = error "toNonEmpty: empty list" +mapEnvironmentPredicate' pred' = + always{when = Just $ writeEnvironmentPredicate pred'} + + +mapHooks' :: HookMap -> Hooks' +mapHooks' hookMap = + Hooks' + { preApply = mapHookList PreApply + , preFirstApply = mapHookList PreFirstApply + , postFirstApply = mapHookList PostFirstApply + , postApply = mapHookList PostApply + } + where + mapHookList :: HookType -> Maybe [Internal.Hook'] + mapHookList hookType = + case Data.Map.Strict.lookup hookType hookMap of + Nothing -> Nothing + Just [] -> Nothing + Just hooks' -> Just $ mapHook <$> hooks' + mapHook :: Hook -> Internal.Hook' + mapHook hook = + Internal.Hook' + { Internal.command = decodePath' hook.command + , Internal.args = if null hook.args then Nothing else Just hook.args + , Internal.moniker = Nothing -- moniker is already resolved into condition + , Internal.condition = + if hook.condition == Always + then Nothing + else Just $ writeEnvironmentPredicate hook.condition + , Internal.workingDirectory = decodePath <$> hook.workingDirectory + , Internal.ignoreFailure = if hook.ignoreFailure then Just True else Nothing + } + decodePath' :: OsPath -> Text + decodePath' = unsafePerformIO . fmap pack . decodeFS diff --git a/src/Dojang/Types/Context.hs b/src/Dojang/Types/Context.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/Context.hs @@ -0,0 +1,839 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Dojang.Types.Context + ( CandidateRoute (..) + , Context (..) + , FileCorrespondence (..) + , FileDeltaKind (..) + , FileEntry (..) + , FileStat (..) + , IgnoredFile (..) + , RouteMatch (..) + , RouteState (..) + , UnregisteredFile (..) + , calculateSpecificity + , filterBySpecificity + , findCandidateRoutesFor + , findMatchingRoutes + , getIgnoredFiles + , getRouteState + , getUnregisteredFiles + , listFiles + , makeCorrespond + , makeCorrespondBetweenThreeDirs + , makeCorrespondBetweenThreeFiles + , makeCorrespondBetweenTwoDirs + , makeCorrespondWithDestination + , routePaths + ) where + +import Control.Monad (forM, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.List (isPrefixOf) +import GHC.IO.Exception (IOErrorType (InappropriateType)) +import GHC.Stack (HasCallStack) +import System.IO.Error + ( ioeSetErrorString + , ioeSetFileName + , isPermissionError + , mkIOError + ) +import Prelude hiding (readFile) + +import Control.Monad.Except (MonadError (..)) +import Data.Map.Strict + ( Map + , filter + , findWithDefault + , fromList + , keysSet + , unionWith + , (!?) + ) +import System.Directory.OsPath (makeAbsolute) +import System.FilePattern (FilePattern, matchMany) +import System.OsPath + ( OsPath + , OsString + , joinPath + , makeRelative + , normalise + , splitDirectories + , () + ) + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Set (toList, union) +import Dojang.MonadFileSystem (MonadFileSystem (..)) +import Dojang.MonadFileSystem qualified (FileType (..)) +import Dojang.Types.Environment (Environment) +import Dojang.Types.FilePathExpression (EnvironmentVariable) +import Dojang.Types.Manifest (Manifest (..)) +import Dojang.Types.Repository + ( Repository (..) + , RouteMapWarning + , RouteResult (..) + ) +import Dojang.Types.Repository qualified (routePaths) + + +-- | The context in which repository operations are performed. +data (MonadFileSystem m) => Context m = Context + { repository :: Repository + -- ^ The repository. + , environment :: Environment + -- ^ The environment. + , environmentVariableGetter :: EnvironmentVariable -> m (Maybe OsString) + -- ^ A function to look up an environment variable. + } + + +-- | Route the paths in the repository. This will return a list of expanded +-- paths, along with any warnings that were generated. Null routes will be +-- ignored. +routePaths + :: (MonadFileSystem m) + => Context m + -- ^ The context in which to perform path routing. + -> m ([RouteResult], [RouteMapWarning]) + -- ^ The expanded paths, along with any warnings that were generated. +routePaths ctx = + Dojang.Types.Repository.routePaths + ctx.repository + ctx.environment + ctx.environmentVariableGetter + + +-- | The small stat of a file. +data FileStat + = -- | The file is missing. + Missing + | -- | The file is a directory. + Directory + | -- | The file is a regular file, and this is its size in bytes. + File Integer + | -- | The file is a symlink, and this is the path to the symlink target. + Symlink OsPath + deriving (Eq, Ord, Show) + + +-- | A file/directory in the repository or the destination directory. +data FileEntry = FileEntry + { path :: OsPath + -- ^ The path to the file. + , stat :: FileStat + -- ^ Whether the file is a file, a directory, or missing. + } + deriving (Eq, Ord, Show) + + +-- | The kind of change that was made to a file. +data FileDeltaKind = Unchanged | Added | Removed | Modified + deriving (Eq, Ord, Show) + + +-- | A correspondence between a source file, an intermediate file, and +-- a destination file. +data FileCorrespondence = FileCorrespondence + { source :: FileEntry + -- ^ The source file. + , sourceDelta :: FileDeltaKind + -- ^ The kind of change that was made to the source file. + , intermediate :: FileEntry + -- ^ The intermediate file. + , destination :: FileEntry + -- ^ The destination file. + , destinationDelta :: FileDeltaKind + -- ^ The kind of change that was made to the destination file. + } + deriving (Eq, Ord, Show) + + +-- | Creates a 'FileCorrespondence' from a single destination file. +makeCorrespondWithDestination + :: forall m + . (MonadFileSystem m) + => Context m + -- ^ The context in which to perform file correspondence. + -> OsPath + -- ^ The path to the destination file. + -> m (Maybe FileCorrespondence, [RouteMapWarning]) + -- ^ The file correspondence, along with a list of warnings that occurred + -- during path routing (if any). The file paths in the returned + -- 'FileCorrespondence' value are absolute, or relative to the current + -- working directory at least. +makeCorrespondWithDestination ctx dstPath = do + (routeMatch, warnings) <- findMatchingRoutes ctx dstPath + case routeMatch of + NoMatch -> return (Nothing, warnings) + SingleMatch route -> do + correspond <- makeCorrespondForRoute route + return (Just correspond, warnings) + AmbiguousMatch candidates -> do + -- For backward compatibility: auto-select by existence if possible, + -- or return the first route. + let existingCandidates = + [c | c <- NE.toList candidates, c.sourceExists] + route <- case existingCandidates of + [c] -> return c.route + _ -> return (NE.head candidates).route + correspond <- makeCorrespondForRoute route + return (Just correspond, warnings) + where + makeCorrespondForRoute :: RouteResult -> m FileCorrespondence + makeCorrespondForRoute route = do + let normalized = normalise route.destinationPath + let relPath = makeRelative normalized dstPath + period <- encodePath "." + let (interPath, srcPath) = + if normalized == dstPath || relPath == period + then + let interPath' = + normalise + (ctx.repository.intermediatePath route.routeName) + srcPath' = normalise route.sourcePath + in (interPath', srcPath') + else + let interPath' = + normalise $ + ctx.repository.intermediatePath + route.routeName + relPath + srcPath' = normalise $ route.sourcePath relPath + in (interPath', srcPath') + makeCorrespondBetweenThreeFiles interPath srcPath dstPath + + +-- | Creates a list of file correspondences between the source files, the +-- intermediate files, and the destination files. Throws an 'IOError' if any of +-- the files cannot be read. +makeCorrespond + :: (HasCallStack, MonadFileSystem m) + => Context m + -- ^ The context in which to perform file correspondence. + -> m ([FileCorrespondence], [RouteMapWarning]) + -- ^ The file correspondences, along with a list of warnings that occurred + -- during path routing (if any). The file paths in the returned + -- 'FileCorrespondence' values are absolute, or relative to the current + -- working directory at least. +makeCorrespond ctx = do + (paths, warnings) <- routePaths ctx + files <- forM paths $ \expanded -> do + let interAbsPath = repo.intermediatePath expanded.routeName + case expanded.fileType of + Dojang.MonadFileSystem.Directory -> do + fs <- + makeCorrespondBetweenThreeDirs + interAbsPath + expanded.sourcePath + expanded.destinationPath + (findWithDefault [] (normalise expanded.routeName) ignorePatterns) + return + [ correspond + { source = + correspond.source{path = expanded.sourcePath correspond.source.path} + , intermediate = + correspond.intermediate + { path = interAbsPath correspond.intermediate.path + } + , destination = + correspond.destination + { path = + expanded.destinationPath correspond.destination.path + } + } + | correspond <- fs + ] + _ -> do + f <- + makeCorrespondBetweenThreeFiles + interAbsPath + expanded.sourcePath + expanded.destinationPath + return [f] + return (concat files, warnings) + where + repo :: Repository + repo = ctx.repository + ignorePatterns :: Map OsPath [FilePattern] + ignorePatterns = repo.manifest.ignorePatterns + + +makeCorrespondBetweenThreeFiles + :: forall m + . (HasCallStack, MonadFileSystem m) + => OsPath + -> OsPath + -> OsPath + -> m FileCorrespondence +makeCorrespondBetweenThreeFiles intermediatePath srcPath dstPath = do + interStat <- getFileStat intermediatePath + let interEntry = FileEntry intermediatePath interStat + srcStat <- getFileStat srcPath + let srcEntry = FileEntry srcPath srcStat + srcDelta <- getDelta interEntry srcEntry + dstStat <- getFileStat dstPath + let dstEntry = FileEntry dstPath dstStat + dstDelta <- getDelta interEntry dstEntry + return + FileCorrespondence + { source = srcEntry + , sourceDelta = srcDelta + , intermediate = interEntry + , destination = dstEntry + , destinationDelta = dstDelta + } + where + getFileStat :: OsPath -> m FileStat + getFileStat path = do + isDir <- isDirectory path + when isDir $ do + path' <- decodePath path + throwError $ + userError + ( "makeCorrespondBetweenThreeFiles: " + ++ "expected a file, but got a directory" + ) + `ioeSetFileName` path' + exists' <- exists path + if exists' + then do + size <- getFileSize path + return $ File size + else return Missing + getDelta :: FileEntry -> FileEntry -> m FileDeltaKind + getDelta (FileEntry _ Missing) (FileEntry _ Missing) = return Unchanged + getDelta (FileEntry _ Missing) (FileEntry _ _) = return Added + getDelta (FileEntry _ File{}) (FileEntry _ Missing) = return Removed + getDelta (FileEntry _ Symlink{}) (FileEntry _ Missing) = return Removed + getDelta (FileEntry _ (Symlink path)) (FileEntry _ (Symlink path')) = + if path == path' + then return Unchanged + else return Modified + getDelta interEntry targetEntry = + if interEntry.stat /= targetEntry.stat + then return Modified + else do + interData <- readFile interEntry.path + targetData <- readFile targetEntry.path + return $ if interData == targetData then Unchanged else Modified + + +makeCorrespondBetweenThreeDirs + :: forall m + . (HasCallStack, MonadFileSystem m) + => OsPath + -> OsPath + -> OsPath + -> [FilePattern] + -> m [FileCorrespondence] +makeCorrespondBetweenThreeDirs intermediatePath srcPath dstPath ignores = do + srcEntries <- makeCorrespondBetweenTwoDirs intermediatePath srcPath [] + dstEntries <- + makeCorrespondBetweenTwoDirs intermediatePath dstPath ignores + let paths = keysSet srcEntries `union` keysSet dstEntries + forM (Data.Set.toList paths) $ \path -> do + let missing = FileEntry path Missing + (interEntry, srcEntry, srcDelta) <- case srcEntries !? path of + Nothing -> return (missing, missing, Unchanged) + Just (interEntry', srcEntry') -> do + delta <- + getDelta path srcPath interEntry'.stat srcEntry'.stat + return (interEntry', srcEntry', delta) + (interEntry2, dstEntry, dstDelta) <- case dstEntries !? path of + Nothing -> return (missing, missing, Unchanged) + Just (interEntry', dstEntry') -> do + delta <- getDelta path dstPath interEntry'.stat dstEntry'.stat + return (interEntry', dstEntry', delta) + (dstEntry', dstDelta') <- + if null ignores || dstEntry.stat /= Missing + then return (dstEntry, dstDelta) + else do + actualDstStat <- getFileStat (dstPath path) + actualDelta <- getDelta path dstPath interEntry2.stat actualDstStat + return (dstEntry{stat = actualDstStat}, actualDelta) + return $ + FileCorrespondence + { source = srcEntry + , sourceDelta = srcDelta + , intermediate = + if interEntry.stat == Missing + then interEntry2 + else interEntry + , destination = dstEntry' + , destinationDelta = dstDelta' + } + where + getDelta + :: OsPath + -- \^ The relative path to the file. + -> OsPath + -- \^ The path to the target directory. + -> FileStat + -- \^ An intermediate file stat. + -> FileStat + -- \^ A target (source or destination) file stat. + -> m FileDeltaKind + getDelta _ _ Directory Directory = return Unchanged + getDelta _ _ Directory Missing = return Removed + getDelta _ _ Directory _ = return Modified + getDelta path targetPath (File size) (File size') = + if size /= size' + then return Modified + else do + interData <- readFile (intermediatePath path) + targetData <- readFile (targetPath path) + return $ if interData == targetData then Unchanged else Modified + getDelta _ _ (File _) Missing = return Removed + getDelta _ _ (File _) _ = return Modified + getDelta _ _ (Symlink path) (Symlink path') = + if path == path' + then return Unchanged + else return Modified + getDelta _ _ (Symlink _) Missing = return Added + getDelta _ _ (Symlink _) _ = return Modified + getDelta _ _ Missing Missing = return Unchanged + getDelta _ _ Missing _ = return Added + getFileStat :: OsPath -> m FileStat + getFileStat path' = do + isSym <- isSymlink path' + if isSym + then do + target <- readSymlinkTarget path' + return $ Symlink target + else do + isDir <- isDirectory path' + if isDir + then return Directory + else do + isFle <- isFile path' + if isFle + then do + size <- getFileSize path' + return $ File size + else return Missing + + +makeCorrespondBetweenTwoDirs + :: forall m + . (HasCallStack, MonadFileSystem m) + => OsPath + -> OsPath + -> [FilePattern] + -> m (Map OsPath (FileEntry, FileEntry)) +makeCorrespondBetweenTwoDirs intermediatePath targetPath ignorePatterns = do + intermediateDirExists <- exists intermediatePath + intermediateFiles <- + if intermediateDirExists + then listFiles intermediatePath [] + else return [] + targetFiles <- listFiles targetPath ignorePatterns + let intermediateEntries = + fromList + [(p, (e, e{stat = Missing})) | e@(FileEntry p _) <- intermediateFiles] + targetEntries = + fromList + [(p, (e{stat = Missing}, e)) | e@(FileEntry p _) <- targetFiles] + allEntries = unionWith combinePairs intermediateEntries targetEntries + return $ Data.Map.Strict.filter eitherExists allEntries + where + combinePairs + :: (FileEntry, FileEntry) + -> (FileEntry, FileEntry) + -> (FileEntry, FileEntry) + combinePairs (a1, b1) (a2, b2) + | isNotMissing a1 && isNotMissing b2 = (a1, b2) + | isNotMissing a2 && isNotMissing b1 = (a2, b1) + | isMissing a1 && isNotMissing b2 = (a2, b2) + | otherwise = (a1, b1) + where + isMissing :: FileEntry -> Bool + isMissing (FileEntry _ Missing) = True + isMissing _ = False + isNotMissing :: FileEntry -> Bool + isNotMissing = not . isMissing + eitherExists :: (FileEntry, FileEntry) -> Bool + eitherExists (FileEntry _ Missing, FileEntry _ Missing) = False + eitherExists _ = True + + +-- | Lists all 'FilEntry' values in the given directory. Throws an 'IOError' if +-- the directory cannot be read. +listFiles + :: (MonadFileSystem m) + => OsPath + -- ^ The path to the directory to list entries in. + -> [FilePattern] + -- ^ The file patterns to ignore. If a directory matches one of these + -- patterns, then its contents will not be listed either. + -> m [FileEntry] + -- ^ The list of 'FileEntry' values in the directory. +listFiles path ignorePatterns = do + isSymlink' <- isSymlink path + isFile' <- isFile path + when (isSymlink' || isFile') $ do + path' <- decodePath path + throwError $ + mkIOError InappropriateType "listFiles" Nothing (Just path') + `ioeSetErrorString` "not a directory" + exists' <- exists path + if exists' + then do + entries <- + listDirectoryRecursively path ignorePatterns `catchError` \e -> + if isPermissionError e + then return [] + else throwError e + forM entries $ \case + (Dojang.MonadFileSystem.Directory, d) -> + return $ FileEntry d Directory + (Dojang.MonadFileSystem.File, f) -> do + size <- getFileSize $ path f + return $ FileEntry f $ File size + (Dojang.MonadFileSystem.Symlink, s) -> do + target <- readSymlinkTarget $ path s + return $ FileEntry s $ Symlink target + else return [] + + +-- | Represents the route state of a (potential) destination file +-- in the repository. +data RouteState + = -- | The file is routed. The 'OsPath' is the name of the relevant route + -- name. + Routed OsPath + | -- | The file is routed but ignored. The 'OsPath' is the name of + -- the relevant route name, and the 'FilePattern' is the ignore pattern + -- that matched the file. + Ignored OsPath FilePattern + | -- | The file is not routed at all. + NotRouted + deriving (Eq, Ord, Show) + + +-- | Represents a file that is ignored by a route's ignore patterns. +data IgnoredFile = IgnoredFile + { routeName :: OsPath + -- ^ The name of the route that contains the ignore pattern. + , sourcePath :: OsPath + -- ^ The path to the source file (in the repository). + , destinationPath :: OsPath + -- ^ The path to the destination file. + , pattern :: FilePattern + -- ^ The ignore pattern that matched the file. + } + deriving (Eq, Show) + + +-- | A candidate route with computed metadata for disambiguation. +data CandidateRoute = CandidateRoute + { route :: RouteResult + -- ^ The route result. + , specificity :: Int + -- ^ The specificity of the route, i.e., the number of path components + -- from the route's destination to the target path. Lower is more specific. + , sourceFilePath :: OsPath + -- ^ The computed source file path (combining route source path with relative + -- path from destination to target). + , sourceExists :: Bool + -- ^ Whether the source file for this route already exists. + } + deriving (Eq, Show) + + +-- | Result of finding routes for a destination path. +data RouteMatch + = -- | No matching routes found. + NoMatch + | -- | A single unambiguous route was found. + SingleMatch RouteResult + | -- | Multiple routes match with the same specificity. + AmbiguousMatch (NonEmpty CandidateRoute) + deriving (Eq, Show) + + +-- | Calculate the specificity of a route relative to a target path. +-- Returns the number of path components between the route's destination +-- and the target path. Lower values indicate more specific routes. +-- +-- ==== Examples +-- +-- >>> calculateSpecificity "/foo/bar/baz" route -- route.destinationPath = "/foo" +-- 2 -- bar/baz +-- +-- >>> calculateSpecificity "/foo" route -- route.destinationPath = "/foo" +-- 0 -- exact match +calculateSpecificity + :: OsPath + -- ^ The target path. + -> RouteResult + -- ^ The route result. + -> Int + -- ^ The specificity (number of path components from route destination to + -- target). +calculateSpecificity targetPath route = + let dstDirs = splitDirectories $ normalise route.destinationPath + targetDirs = splitDirectories $ normalise targetPath + in length targetDirs - length dstDirs + + +-- | Filter routes by specificity, keeping only those with the lowest +-- (most specific) specificity value. +filterBySpecificity + :: OsPath + -- ^ The target path. + -> [RouteResult] + -- ^ The list of routes to filter. + -> [RouteResult] + -- ^ The routes with the lowest specificity. +filterBySpecificity _ [] = [] +filterBySpecificity targetPath routes = + let specificityCounts = [(r, calculateSpecificity targetPath r) | r <- routes] + minSpec = minimum $ map snd specificityCounts + in [r | (r, s) <- specificityCounts, s == minSpec] + + +-- | Find matching routes for a destination path. +-- Returns a 'RouteMatch' indicating whether no routes, a single route, +-- or multiple ambiguous routes match. +findMatchingRoutes + :: (MonadFileSystem m) + => Context m + -- ^ The context in which to perform route matching. + -> OsPath + -- ^ The target path. + -> m (RouteMatch, [RouteMapWarning]) + -- ^ The route match result, along with any warnings that were generated. +findMatchingRoutes ctx targetPath = do + (routes, warnings) <- routePaths ctx + let targetDirs = splitDirectories $ normalise targetPath + let matching = [r | r <- routes, startsWithRoute r targetDirs] + case matching of + [] -> return (NoMatch, warnings) + [r] -> return (SingleMatch r, warnings) + rs -> do + let filtered = filterBySpecificity targetPath rs + case filtered of + [] -> return (NoMatch, warnings) + [r] -> return (SingleMatch r, warnings) + (r : rs') -> do + candidates <- mapM (makeCandidateRoute targetPath) (r :| rs') + return (AmbiguousMatch candidates, warnings) + where + startsWithRoute :: RouteResult -> [OsPath] -> Bool + startsWithRoute route targetDirs' = + splitDirectories (normalise route.destinationPath) `isPrefixOf` targetDirs' + makeCandidateRoute + :: (MonadFileSystem m) => OsPath -> RouteResult -> m CandidateRoute + makeCandidateRoute target route = do + let spec = calculateSpecificity target route + let relPath = makeRelative (normalise route.destinationPath) (normalise target) + period <- encodePath "." + let srcPath = + if relPath == period + then normalise route.sourcePath + else normalise $ route.sourcePath relPath + srcExists <- exists srcPath + return $ CandidateRoute route spec srcPath srcExists + + +-- | Gets the route state of the given path (which is a potential destination). +getRouteState + :: (HasCallStack, MonadFileSystem m, MonadIO m) + => Context m + -- ^ The context in which to perform path routing. + -> OsPath + -- ^ The path (which is a potential destination) to get the route state of. + -> m (RouteState, [RouteMapWarning]) + -- ^ The route state of the path, along with any warnings that were generated. +getRouteState ctx path = do + absPath <- liftIO $ makeAbsolute path + let dirs = splitDirectories absPath + (routes, ws) <- routePaths ctx + states <- forM routes $ \route -> do + dstPath <- liftIO $ makeAbsolute route.destinationPath + let prefix = splitDirectories dstPath + if prefix `isPrefixOf` dirs + then do + let ignores = + findWithDefault + [] + (normalise route.routeName) + ignorePatterns + relPath <- decodePath $ joinPath $ drop (length prefix) dirs + case matchMany [(i, i) | i <- ignores] [((), relPath)] of + (pattern, _, _) : _ -> return $ Ignored route.routeName pattern + _ -> return $ Routed route.routeName + else return NotRouted + return (if null states then NotRouted else minimum states, ws) + where + ignorePatterns :: Map OsPath [FilePattern] + ignorePatterns = ctx.repository.manifest.ignorePatterns + + +-- | Gets a list of files that are ignored by the repository's ignore patterns. +-- This function scans all directory routes for files that would be excluded +-- by their ignore patterns. +getIgnoredFiles + :: forall m + . (HasCallStack, MonadFileSystem m) + => Context m + -- ^ The context in which to perform the operation. + -> m [IgnoredFile] + -- ^ The list of ignored files. +getIgnoredFiles ctx = do + (routes, _) <- routePaths ctx + ignoredLists <- forM routes $ \route -> + case route.fileType of + Dojang.MonadFileSystem.Directory -> do + let ignores = findWithDefault [] (normalise route.routeName) ignorePatterns + if null ignores + then return [] + else do + -- List all files (including those that would be ignored) + allFiles <- listFilesWithoutIgnore route.destinationPath + -- Find which files match ignore patterns + forM allFiles $ \entry -> do + relPath <- decodePath entry.path + case matchMany [(i, i) | i <- ignores] [((), relPath)] of + (ptn, _, _) : _ -> + return $ + Just $ + IgnoredFile + { routeName = route.routeName + , sourcePath = route.sourcePath entry.path + , destinationPath = route.destinationPath entry.path + , pattern = ptn + } + _ -> return Nothing + _ -> return [] + return $ concat [[f | Just f <- fs] | fs <- ignoredLists] + where + ignorePatterns :: Map OsPath [FilePattern] + ignorePatterns = ctx.repository.manifest.ignorePatterns + + listFilesWithoutIgnore :: OsPath -> m [FileEntry] + listFilesWithoutIgnore path = do + exists' <- exists path + if exists' + then do + entries <- + listDirectoryRecursively path [] `catchError` \e -> + if isPermissionError e + then return [] + else throwError e + forM entries $ \case + (Dojang.MonadFileSystem.Directory, d) -> + return $ FileEntry d Directory + (Dojang.MonadFileSystem.File, f) -> do + size <- getFileSize $ path f + return $ FileEntry f $ File size + (Dojang.MonadFileSystem.Symlink, s) -> do + target <- readSymlinkTarget $ path s + return $ FileEntry s $ Symlink target + else return [] + + +-- | Represents a file that is not registered in any route. +data UnregisteredFile = UnregisteredFile + { filePath :: OsPath + -- ^ The path to the unregistered file in the destination. + , candidateRoutes :: [RouteResult] + -- ^ The candidate routes that could contain this file (based on path prefix). + } + deriving (Eq, Show) + + +-- | Gets a list of files in destination directories that are not registered +-- in any route. These are files that exist in destination directories but +-- are not part of the repository. +getUnregisteredFiles + :: forall m + . (HasCallStack, MonadFileSystem m) + => Context m + -- ^ The context in which to perform the operation. + -> m [UnregisteredFile] + -- ^ The list of unregistered files. +getUnregisteredFiles ctx = do + (routes, _) <- routePaths ctx + -- Get all files from makeCorrespond (these are registered) + (registeredCorrespondences, _) <- makeCorrespond ctx + let registeredPaths = + [ normalise c.destination.path + | c <- registeredCorrespondences + , c.destination.stat /= Missing + ] + + -- For each directory route, find files not in the registered set + unregisteredLists <- forM routes $ \route -> + case route.fileType of + Dojang.MonadFileSystem.Directory -> do + allFiles <- listFilesInDir route.destinationPath + let unregistered = + [ f + | f <- allFiles + , normalise (route.destinationPath f.path) + `notElem` registeredPaths + ] + -- For each unregistered file, find candidate routes + forM unregistered $ \entry -> do + let fullPath = route.destinationPath entry.path + candidates <- findCandidateRoutesFor ctx fullPath + return $ + UnregisteredFile + { filePath = fullPath + , candidateRoutes = candidates + } + _ -> return [] + + return $ concat unregisteredLists + where + listFilesInDir :: OsPath -> m [FileEntry] + listFilesInDir path = do + exists' <- exists path + if exists' + then do + entries <- + listDirectoryRecursively path [] `catchError` \e -> + if isPermissionError e + then return [] + else throwError e + forM entries $ \case + (Dojang.MonadFileSystem.Directory, d) -> + return $ FileEntry d Directory + (Dojang.MonadFileSystem.File, f) -> do + size <- getFileSize $ path f + return $ FileEntry f $ File size + (Dojang.MonadFileSystem.Symlink, s) -> do + target <- readSymlinkTarget $ path s + return $ FileEntry s $ Symlink target + else return [] + + +-- | Finds candidate routes for an unregistered file. +-- Returns routes whose destination path is a prefix of the file path. +findCandidateRoutesFor + :: forall m + . (MonadFileSystem m) + => Context m + -- ^ The context in which to perform the operation. + -> OsPath + -- ^ The path to the unregistered file. + -> m [RouteResult] + -- ^ The list of candidate routes. +findCandidateRoutesFor ctx filePath = do + (routes, _) <- routePaths ctx + let fileDirs = splitDirectories $ normalise filePath + return + [ route + | route <- routes + , route.fileType == Dojang.MonadFileSystem.Directory + , let routeDirs = splitDirectories $ normalise route.destinationPath + , routeDirs `isPrefixOf` fileDirs + ] diff --git a/src/Dojang/Types/Environment.hs b/src/Dojang/Types/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/Environment.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Dojang.Types.Environment + ( Architecture (..) + , Environment (..) + , Kernel (..) + , OperatingSystem (..) + ) where + +import Data.Maybe (fromMaybe) +import Data.String (IsString (fromString)) +import GHC.Records (HasField (getField)) + +import Data.CaseInsensitive (CI, mk) +import Data.HashMap.Strict (HashMap, fromList, toList, (!), (!?)) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Text (Text, pack) + + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> :seti -XOverloadedRecordDot + + +-- | An operating system identifier. +data OperatingSystem + = Android + | FreeBSD + | Linux + | MacOS + | NetBSD + | OpenBSD + | Windows + | -- | An operating system that is not one of the above. + OtherOS (CI Text) + deriving (Eq, Ord, Read, Show) + + +operatingSystems :: HashMap OperatingSystem (CI Text) +operatingSystems = + [ (Android, "android") + , (FreeBSD, "freebsd") + , (Linux, "linux") + , (MacOS, "macos") + , (NetBSD, "netbsd") + , (OpenBSD, "openbsd") + , (Windows, "windows") + ] + + +operatingSystemIdentifiers :: HashMap (CI Text) OperatingSystem +operatingSystemIdentifiers = + fromList $! [(ident, os') | (os', ident) <- toList operatingSystems] + + +-- | Gets an 'OperatingSystem' from an identifier. +-- +-- >>> fromString "linux" :: OperatingSystem +-- Linux +-- >>> fromString "windows" :: OperatingSystem +-- Windows +-- >>> fromString "amigaos" :: OperatingSystem +-- OtherOS "amigaos" +instance IsString OperatingSystem where + fromString s = + fromMaybe (OtherOS ident) (operatingSystemIdentifiers !? ident) + where + ident :: CI Text + ident = mk $ pack s + + +-- | Gets the identifier for an 'OperatingSystem'. +-- +-- >>> (Linux).identifier +-- "linux" +-- >>> (Windows).identifier +-- "windows" +-- +-- If the 'OperatingSystem' is 'OtherOS', then the identifier is returned +-- unchanged. +-- +-- >>> (OtherOS "amigaos").identifier +-- "amigaos" +instance HasField "identifier" OperatingSystem (CI Text) where + getField (OtherOS os') = os' + getField os' = operatingSystems ! os' + + +instance Hashable OperatingSystem where + hashWithSalt salt = hashWithSalt salt . show + + +-- | An architecture identifier. +data Architecture + = -- | ARM64 + AArch64 + | -- | x86 (i.e., i386) + X86 + | -- | x86-64 (i.e., amd64) + X86_64 + | -- | An architecture that is not one of the above. + Etc (CI Text) + deriving (Eq, Ord, Read, Show) + + +architectures :: HashMap Architecture (CI Text) +architectures = + [ (AArch64, "aarch64") + , (X86, "x86") + , (X86_64, "x86_64") + ] + + +architectureIdentifiers :: HashMap (CI Text) Architecture +architectureIdentifiers = + fromList $! [(ident, arch') | (arch', ident) <- toList architectures] + + +-- | Gets an 'Architecture' from an identifier. +-- +-- >>> fromString "x86_64" :: Architecture +-- X86_64 +-- >>> fromString "aarch64" :: Architecture +-- AArch64 +-- >>> fromString "alpha" :: Architecture +-- Etc "alpha" +instance IsString Architecture where + fromString s = + fromMaybe (Etc ident) (architectureIdentifiers !? ident) + where + ident :: CI Text + ident = mk $ pack s + + +-- | Gets the identifier for an 'Architecture'. +-- +-- >>> (X86_64).identifier +-- "x86_64" +-- >>> (AArch64).identifier +-- "aarch64" +-- +-- If the 'Architecture' is 'Etc', then the identifier is returned unchanged. +-- +-- >>> (Etc "alpha").identifier +-- "alpha" +instance HasField "identifier" Architecture (CI Text) where + getField (Etc arch') = arch' + getField arch' = architectures ! arch' + + +instance Hashable Architecture where + hashWithSalt salt = hashWithSalt salt . show + + +-- | A kernel information. Equivalent to @uname -sr@. +data Kernel = Kernel + { name :: CI Text + -- ^ The kernel name. Equivalent to @uname -s@. + , release :: CI Text + -- ^ The kernel release. Equivalent to @uname -r@. + } + deriving (Eq, Ord, Read, Show) + + +instance Hashable Kernel where + hashWithSalt salt (Kernel name' release') = + salt `hashWithSalt` name' `hashWithSalt` release' + + +-- | An environment. +data Environment = Environment + { operatingSystem :: OperatingSystem + -- ^ The operating system (e.g. 'Linux', 'MacOS'). + , architecture :: Architecture + -- ^ The architecture (e.g. 'X86_64', 'AArch64'). + , kernel :: Kernel + -- ^ The kernel information. Equivalent to @uname -sr@. + } + deriving (Eq, Ord, Read, Show) + + +instance Hashable Environment where + hashWithSalt salt (Environment os' arch' kernel) = + salt `hashWithSalt` os' `hashWithSalt` arch' `hashWithSalt` kernel diff --git a/src/Dojang/Types/Environment/Current.hs b/src/Dojang/Types/Environment/Current.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/Environment/Current.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Dojang.Types.Environment.Current + ( MonadArchitecture (..) + , MonadEnvironment (..) + , MonadOperatingSystem (..) + , MonadKernel (..) + , parseArchitecture + , parseOperatingSystem + ) where + +import Data.Char (isDigit) +import Data.String (IsString (fromString)) +import System.Info (arch, os) +import Prelude hiding (break) + +import Data.CaseInsensitive (mk) +import Data.Text (break, dropAround, pack, strip, stripEnd) +import System.Process (readCreateProcess, readProcess, shell) + +import Dojang.Types.Environment + ( Architecture (..) + , Environment (..) + , Kernel (..) + , OperatingSystem (..) + ) + + +-- | Turns a string returned by 'System.Info.os' into an 'OperatingSystem'. +parseOperatingSystem :: String -> OperatingSystem +parseOperatingSystem = \case + "linux-android" -> Android + "darwin" -> MacOS + "freebsd" -> FreeBSD + "linux" -> Linux + "netbsd" -> NetBSD + "openbsd" -> OpenBSD + "mingw32" -> Windows + os' -> OtherOS $ fromString os' + + +-- | Turns a string returned by 'System.Info.arch' into an 'Architecture'. +parseArchitecture :: String -> Architecture +parseArchitecture = \case + "aarch64" -> AArch64 + "i386" -> X86 + "x86_64" -> X86_64 + arch' -> Etc $ fromString arch' + + +-- | A monad that can get the current 'Environment'. +class (Monad m) => MonadOperatingSystem m where + -- | Gets the current 'OperatingSystem'. + currentOperatingSystem :: m OperatingSystem + + +instance MonadOperatingSystem IO where + currentOperatingSystem = return $ parseOperatingSystem os + + +-- | A monad that can get the current 'Architecture'. +class (Monad m) => MonadArchitecture m where + -- | Gets the current 'Architecture'. + currentArchitecture :: m Architecture + + +instance MonadArchitecture IO where + currentArchitecture = return $ parseArchitecture arch + + +-- | A monad that can get the current 'Kernel' information. +class (Monad m) => MonadKernel m where + -- | Gets the current 'Kernel' information. + currentKernel :: m Kernel + + +instance MonadKernel IO where + currentKernel + | os == "mingw32" = do + ver <- strip . pack <$> readCreateProcess (shell "cmd /c ver") "" + let (name, rest) = break (== '[') ver + let (_, release) = break (isDigit) $ dropAround (`elem` "[]") rest + return $ Kernel (mk $ stripEnd name) (mk $ strip release) + | otherwise = do + name <- strip . pack <$> readProcess "uname" ["-s"] "" + release <- strip . pack <$> readProcess "uname" ["-r"] "" + return $ Kernel (mk name) (mk release) + + +-- | A monad that can get the current 'Environment'. +class (Monad m) => MonadEnvironment m where + -- | Gets the current 'Environment'. + currentEnvironment :: m Environment + + +instance + (Monad m, MonadOperatingSystem m, MonadArchitecture m, MonadKernel m) + => MonadEnvironment m + where + currentEnvironment = do + os' <- currentOperatingSystem + arch' <- currentArchitecture + kernel' <- currentKernel + return + Environment + { operatingSystem = os' + , architecture = arch' + , kernel = kernel' + } diff --git a/src/Dojang/Types/EnvironmentPredicate.hs b/src/Dojang/Types/EnvironmentPredicate.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/EnvironmentPredicate.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordUpdate #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} + +-- | A predicate expression that can be used to match an environment, e.g., +-- @And [OperatingSystem "linux", Architecture "x86_64"]@. +module Dojang.Types.EnvironmentPredicate + ( EnvironmentPredicate (..) + , normalizePredicate + ) where + +import Data.List.NonEmpty (NonEmpty, filter, nonEmpty, nub, sortWith, toList) +import Prelude hiding (filter) + +import Data.CaseInsensitive (CI) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Text (Text) + +import Data.Ord (Down (..)) +import Dojang.Types.Environment (Architecture, OperatingSystem) +import Dojang.Types.MonikerName (MonikerName) + + +-- | A predicate that can be used to match an environment. +data EnvironmentPredicate + = -- | A predicate that always matches. + Always + | -- | A predicate that matches if the given predicate does not match. + Not EnvironmentPredicate + | -- | A predicate that matches if all of the given predicates match. + And (NonEmpty EnvironmentPredicate) + | -- | A predicate that matches if any of the given predicates match. + Or (NonEmpty EnvironmentPredicate) + | -- | A predicate that matches to another moniker. Mostly used to eliminate + -- duplication. + Moniker MonikerName + | -- | A predicate that matches to the given operating system (e.g. @linux@). + -- For a list of possible values, see the 'System.Info.os' field. + OperatingSystem OperatingSystem + | -- | A predicate that matches to the given architecture (e.g. @x86_64@). + -- For a list of possible values, see the 'System.Info.arch' field. + Architecture Architecture + | -- | A predicate that matches to the given kernel name (e.g. @Darwin@). + KernelName (CI Text) + | -- | A predicate that exactly matches to the given kernel release + -- (e.g. @23.1.0@). + KernelRelease (CI Text) + | -- | A predicate that matches to the given kernel release prefix + -- (e.g. @23.1@ for @23.1.0@). + KernelReleasePrefix (CI Text) + | -- | A predicate that matches to the given kernel release suffix + -- (e.g. @amd64@ for @4.19.0-16-amd64@). + KernelReleaseSuffix (CI Text) + deriving (Show) + + +instance Eq EnvironmentPredicate where + Always == Always = True + Always == _ = False + Not p == Not p' = p == p' + Not _ == _ = False + And ps == And ps' = normalizePredicateList ps == normalizePredicateList ps' + And _ == _ = False + Or ps == Or ps' = normalizePredicateList ps == normalizePredicateList ps' + Or _ == _ = False + Moniker monikerName == Moniker monikerName' = monikerName == monikerName' + Moniker _ == _ = False + OperatingSystem os == OperatingSystem os' = os == os' + OperatingSystem _ == _ = False + Architecture arch == Architecture arch' = arch == arch' + Architecture _ == _ = False + KernelName kernel == KernelName kernel' = kernel == kernel' + KernelName _ == _ = False + KernelRelease ver == KernelRelease ver' = ver == ver' + KernelRelease _ == _ = False + KernelReleasePrefix prefix == KernelReleasePrefix prefix' = prefix == prefix' + KernelReleasePrefix _ == _ = False + KernelReleaseSuffix suffix == KernelReleaseSuffix suffix' = suffix == suffix' + KernelReleaseSuffix _ == _ = False + + +instance Hashable EnvironmentPredicate where + hashWithSalt salt Always = + salt `hashWithSalt` ("Always" :: Text) + hashWithSalt salt (Not predicate) = + salt `hashWithSalt` ("Not" :: Text) `hashWithSalt` predicate + hashWithSalt salt (And predicates) = + salt + `hashWithSalt` ("And" :: Text) + `hashWithSalt` normalizePredicateList predicates + hashWithSalt salt (Or predicates) = + salt + `hashWithSalt` ("Or" :: Text) + `hashWithSalt` normalizePredicateList predicates + hashWithSalt salt (Moniker monikerName) = + salt `hashWithSalt` ("Moniker" :: Text) `hashWithSalt` monikerName + hashWithSalt salt (OperatingSystem os') = + salt `hashWithSalt` ("OperatingSystem" :: Text) `hashWithSalt` os' + hashWithSalt salt (Architecture arch') = + salt `hashWithSalt` ("Architecture" :: Text) `hashWithSalt` arch' + hashWithSalt salt (KernelName kernel) = + salt `hashWithSalt` ("KernelName" :: Text) `hashWithSalt` kernel + hashWithSalt salt (KernelRelease ver) = + salt `hashWithSalt` ("KernelRelease" :: Text) `hashWithSalt` ver + hashWithSalt salt (KernelReleasePrefix prefix) = + salt `hashWithSalt` ("KernelReleasePrefix" :: Text) `hashWithSalt` prefix + hashWithSalt salt (KernelReleaseSuffix suffix) = + salt `hashWithSalt` ("KernelReleaseSuffix" :: Text) `hashWithSalt` suffix + + +normalizePredicateList + :: NonEmpty EnvironmentPredicate -> NonEmpty EnvironmentPredicate +normalizePredicateList = nub . sortWith (Down . hashWithSalt 1) + + +-- | Normalize an environment predicate by removing redundant predicates. +-- +-- >>> normalizePredicate $ And [Not Always, Always] +-- Not Always +-- >>> normalizePredicate $ Or [Not Always, Always] +-- Always +-- >>> import Dojang.Types.MonikerName (parseMonikerName) +-- >>> let Right foo = parseMonikerName "foo" +-- >>> normalizePredicate $ And [Moniker foo, Not $ Moniker foo] +-- Not Always +-- >>> normalizePredicate $ Or [Moniker foo, Not $ Moniker foo] +-- Always +-- >>> let Right a = parseMonikerName "a" +-- >>> let Right b = parseMonikerName "b" +-- >>> let Right c = parseMonikerName "c" +-- >>> normalizePredicate $ And [Moniker a, And [Moniker b, Moniker c]] +-- And (Moniker (MonikerName "a") :| [Moniker (MonikerName "b"),Moniker (MonikerName "c")]) +normalizePredicate :: EnvironmentPredicate -> EnvironmentPredicate +normalizePredicate pred' + | normalized == normalized2 = normalized + | otherwise = normalizePredicate normalized2 + where + normalized :: EnvironmentPredicate + normalized = normalizePredicate' pred' + normalized2 :: EnvironmentPredicate + normalized2 = normalizePredicate' normalized + + +normalizePredicate' :: EnvironmentPredicate -> EnvironmentPredicate +normalizePredicate' (And [p]) = normalizePredicate' p +normalizePredicate' (And ps) = + if Not Always `elem` ps' + then Not Always + else + let filtered = filter (/= Always) ps' + in if (`any` filtered) $ \case Not p' -> p' `elem` filtered; _ -> False + then Not Always + else + let reduced = + maybe Always And $ + nonEmpty + [ p' + | p <- filtered + , p' <- case p of + And ps'' -> normalizePredicate' <$> toList ps'' + p'' -> [p''] + ] + in case reduced of + And [p'] -> p' + _ -> reduced + where + ps' :: NonEmpty EnvironmentPredicate + ps' = normalizePredicate' <$> ps +normalizePredicate' (Or [p]) = normalizePredicate' p +normalizePredicate' (Or ps) = + if Always `elem` ps' + then Always + else + let filtered = filter (/= Not Always) ps' + in if (`any` filtered) $ \case Not p' -> p' `elem` filtered; _ -> False + then Always + else + let reduced = + maybe (Not Always) Or $ + nonEmpty + [ p' + | p <- filtered + , p' <- case p of + Or ps'' -> normalizePredicate' <$> toList ps'' + p'' -> [p''] + ] + in case reduced of + Or [p'] -> p' + _ -> reduced + where + ps' :: NonEmpty EnvironmentPredicate + ps' = normalizePredicate' <$> ps +normalizePredicate' (Not (Not p)) = normalizePredicate' p +normalizePredicate' (Not p) = Not $ normalizePredicate' p +normalizePredicate' p = p diff --git a/src/Dojang/Types/EnvironmentPredicate/Evaluate.hs b/src/Dojang/Types/EnvironmentPredicate/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/EnvironmentPredicate/Evaluate.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Dojang.Types.EnvironmentPredicate.Evaluate + ( EvaluationWarning (..) + , evaluate + , evaluate' + ) where + +import Prelude hiding (length, lookup, take) + +import Data.CaseInsensitive (mk, original) +import Data.HashMap.Strict (lookup) +import Data.Text (Text, length, take, takeEnd) + +import Dojang.Types.Environment + ( Architecture (Etc) + , Environment (..) + , Kernel (..) + , OperatingSystem (OtherOS) + ) +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..)) +import Dojang.Types.MonikerMap (MonikerMap, MonikerResolver) +import Dojang.Types.MonikerName (MonikerName) + + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> :seti -XOverloadedLists + + +-- | A warning that occurred during evaluation. +data EvaluationWarning + = -- | A moniker was referenced that was not defined. + UndefinedMoniker MonikerName + | -- | The operating system was not recognized. + UnrecognizedOperatingSystem OperatingSystem + | -- | The architecture was not recognized. + UnrecognizedArchitecture Architecture + deriving (Eq, Show) + + +-- | Evaluates the given predicate against the given environment. +-- +-- >>> import Dojang.Types.Environment (Environment (..)) +-- >>> import Dojang.Types.MonikerMap (MonikerMap) +-- >>> import Dojang.Types.MonikerName (MonikerName, parseMonikerName) +-- >>> let (Right linuxAmd64) = parseMonikerName "linux-amd64" +-- >>> :{ +-- let monikerMap = +-- [ (linuxAmd64, And [OperatingSystem "linux", Architecture "x86_64"]) +-- ] :: MonikerMap +-- :} +-- +-- >>> let environment = Environment "linux" "x86_64" +-- >>> evaluate environment monikerMap (OperatingSystem "linux") +-- (True,[]) +-- >>> evaluate environment monikerMap (Architecture "aarch64") +-- (False,[]) +-- +-- The 'snd' of the result is a list of warnings that occurred during +-- evaluation: +-- +-- >>> let (Right nonExistentMoniker) = parseMonikerName "non-existent" +-- >>> evaluate environment monikerMap (Moniker nonExistentMoniker) +-- (False,[UndefinedMoniker (MonikerName "non-existent")]) +evaluate + :: Environment + -- ^ The 'Environment' to evaluate against. + -> MonikerMap + -- ^ The 'MonikerMap' to resolve 'MonikerName's against. + -> EnvironmentPredicate + -- ^ The 'EnvironmentPredicate' to evaluate. + -> (Bool, [EvaluationWarning]) + -- ^ The result of the evaluation. The 'snd' of the result is a list of + -- warnings that occurred during evaluation. Note that warnings can be + -- present even if the result is 'True'. +evaluate environment monikerMap = + evaluate' environment (`lookup` monikerMap) + + +-- | Same as 'evaluate', but takes a resolver function instead of a +-- 'MonikerMap'. +evaluate' + :: Environment + -- ^ The 'Environment' to evaluate against. + -> MonikerResolver + -- ^ A function that resolves 'MonikerName's to 'EnvironmentPredicate's. + -> EnvironmentPredicate + -- ^ The 'EnvironmentPredicate' to evaluate. + -> (Bool, [EvaluationWarning]) + -- ^ The result of the evaluation. The 'snd' of the result is a list of + -- warnings that occurred during evaluation. Note that warnings can be + -- present even if the result is 'True'. +evaluate' _ _ Always = + (True, []) +evaluate' environment resolver (Not predicate) = + let (result, warnings) = evaluate' environment resolver predicate + in (not result, warnings) +evaluate' environment resolver (And predicates) = + let results = fmap (evaluate' environment resolver) predicates + in (all fst results, concatMap snd results) +evaluate' environment resolver (Or predicates) = + let results = fmap (evaluate' environment resolver) predicates + in (any fst results, concatMap snd results) +evaluate' environment resolver (Moniker monikerName) = + case resolver monikerName of + Nothing -> (False, [UndefinedMoniker monikerName]) + Just predicate -> evaluate' environment resolver predicate +evaluate' environment _ (OperatingSystem os) = + ( os == environment.operatingSystem + , case os of + OtherOS _ -> [UnrecognizedOperatingSystem os] + _ -> [] + ) +evaluate' environment _ (Architecture arch) = + ( arch == environment.architecture + , case arch of + Etc _ -> [UnrecognizedArchitecture arch] + _ -> [] + ) +evaluate' environment _ (KernelName kernel) = + (kernel == environment.kernel.name, []) +evaluate' environment _ (KernelRelease ver) = + (ver == environment.kernel.release, []) +evaluate' environment _ (KernelReleasePrefix prefix) = + (length rel >= prefixLen && mk (take prefixLen rel) == prefix, []) + where + rel :: Text + rel = original environment.kernel.release + prefixLen :: Int + prefixLen = length $ original prefix +evaluate' environment _ (KernelReleaseSuffix suffix) = + (length rel >= suffixLen && mk (takeEnd suffixLen rel) == suffix, []) + where + rel :: Text + rel = original environment.kernel.release + suffixLen :: Int + suffixLen = length $ original suffix diff --git a/src/Dojang/Types/EnvironmentPredicate/Specificity.hs b/src/Dojang/Types/EnvironmentPredicate/Specificity.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/EnvironmentPredicate/Specificity.hs @@ -0,0 +1,81 @@ +-- | This module contains the 'Specificity' type and the 'specificity' function, +-- which are used to determine how specific an 'EnvironmentPredicate' is, i.e., +-- when there are multiple predicates that could match, which one should be +-- chosen. +module Dojang.Types.EnvironmentPredicate.Specificity + ( Specificity (..) + , specificity + ) where + +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..)) +import Dojang.Types.MonikerName (MonikerName) + + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> :seti -XOverloadedLists + + +-- | The specificity of an 'EnvironmentPredicate'. It guarantees that +-- the more specific predicate will always be greater than the less specific +-- predicate (e.g. @And [OperatingSystem "linux", Architecture "x86_64"]@ is +-- more specific than @OperatingSystem "linux"@). +data Specificity = Specificity + { maxPredicates :: Int + -- ^ The number of predicates that must be evaluated at a maximum. + , totalPredicates :: Int + -- ^ The total number of predicates regardless of whether they would be + -- evaluated or not (e.g. if the first predicate in an 'Or' matches, + -- then the second predicate would not be evaluated, but it would still be + -- counted). + } + deriving (Eq, Show, Read) + + +instance Ord Specificity where + compare (Specificity maxA totalA) (Specificity maxB totalB) = + case compare maxA maxB of + EQ -> compare totalB totalA + x -> x + + +-- | Calculates the 'Specificity' of an 'EnvironmentPredicate'. For details +-- on how the 'Specificity' is calculated, see the documentation for +-- 'Specificity'. +-- +-- >>> import Data.List (sortOn) +-- >>> import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..)) +-- >>> :{ +-- let predicates = +-- [ OperatingSystem "linux" +-- , Architecture "x86_64" +-- , And [OperatingSystem "linux", Architecture "x86_64"] +-- , Or [OperatingSystem "linux", Architecture "x86_64"] +-- ] :: [EnvironmentPredicate] +-- :} +-- +-- >>> sortOn (specificity (const Nothing)) predicates +-- [Or (...),OperatingSystem Linux,Architecture X86_64,And (...)] +specificity + :: (MonikerName -> Maybe EnvironmentPredicate) + -> EnvironmentPredicate + -> Specificity +specificity _ Always = Specificity 0 0 +specificity monikerResolver (Not predicate) = + specificity monikerResolver predicate +specificity monikerResolver (And predicates) = + let qs = specificity monikerResolver <$> predicates + in Specificity (sum $ maxPredicates <$> qs) (sum $ totalPredicates <$> qs) +specificity monikerResolver (Or predicates) = + let qs = specificity monikerResolver <$> predicates + in Specificity (maximum $ maxPredicates <$> qs) (sum $ totalPredicates <$> qs) +specificity monikerResolver (Moniker monikerName) = + case monikerResolver monikerName of + Nothing -> Specificity 0 0 + Just predicate -> specificity monikerResolver predicate +specificity _ (OperatingSystem _) = Specificity 1 1 +specificity _ (Architecture _) = Specificity 1 1 +specificity _ (KernelName _) = Specificity 1 1 +specificity _ (KernelRelease _) = Specificity 1 1 +specificity _ (KernelReleasePrefix _) = Specificity 1 1 +specificity _ (KernelReleaseSuffix _) = Specificity 1 1 diff --git a/src/Dojang/Types/FilePathExpression.hs b/src/Dojang/Types/FilePathExpression.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/FilePathExpression.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.FilePathExpression + ( EnvironmentVariable + , FilePathExpression (..) + , toPathText + , (++) + , (+/+) + ) where + +import Data.Char (isAlphaNum, isAscii) +import Data.String (IsString (..)) +import Prelude hiding (head, null, (++)) + +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Text (Text, head, null, pack) + + +-- | An environment variable. +type EnvironmentVariable = Text + + +-- | An expression that can be used to build a file path. +data FilePathExpression + = -- | A bare component of a file path. E.g., @foo@ and @bar@ in @/foo/bar@. + BareComponent Text + | -- | The root of a file path. E.g., @/@ on POSIX systems or @C:\@ on + -- Windows. The 'Maybe' 'Char' is the drive letter on Windows, if present. + -- On POSIX systems, this is always 'Nothing'. + Root (Maybe Char) + | -- | A concatenation of two 'FilePathExpression's. E.g., @${FOO}bar@ is + -- a concatenation of @${FOO}@ and @bar@. + Concatenation FilePathExpression FilePathExpression + | -- | A path separator which combines two 'FilePathExpression's. E.g., + -- @/@ on POSIX systems or @\@ on Windows. + PathSeparator FilePathExpression FilePathExpression + | -- | A simple substitution of an environment variable. E.g., @$FOO@ or + -- @${BAR}@. + Substitution EnvironmentVariable + | -- | A substitution of an environment variable with a default value for when + -- the environment variable is not set. E.g., @${FOO:-this value is used if + -- FOO is not set or is empty}@. + SubstitutionWithDefault EnvironmentVariable FilePathExpression + | -- | A conditional substitution of an environment variable with an expression + -- to be expanded if the environment variable is set. E.g., @${FOO:+this + -- value is used if FOO is set and non-empty}@. + ConditionalSubstitution EnvironmentVariable FilePathExpression + -- TODO: Add support for SubstringSubstitution (e.g., ${FOO:0:3}) + -- See also https://www.gnu.org/software/bash/manual/html_node/Shell-Parameter-Expansion.html + deriving (Eq, Show) + + +instance Hashable FilePathExpression where + hashWithSalt salt (BareComponent component) = + salt `hashWithSalt` (0 :: Int) `hashWithSalt` component + hashWithSalt salt (Root driveLetter) = + salt `hashWithSalt` (1 :: Int) `hashWithSalt` driveLetter + hashWithSalt salt (Concatenation expr1 expr2) = + salt `hashWithSalt` (2 :: Int) `hashWithSalt` expr1 `hashWithSalt` expr2 + hashWithSalt salt (PathSeparator expr1 expr2) = + salt `hashWithSalt` (3 :: Int) `hashWithSalt` expr1 `hashWithSalt` expr2 + hashWithSalt salt (Substitution envVar) = + salt `hashWithSalt` (4 :: Int) `hashWithSalt` envVar + hashWithSalt salt (SubstitutionWithDefault envVar expr) = + salt `hashWithSalt` (5 :: Int) `hashWithSalt` envVar `hashWithSalt` expr + hashWithSalt salt (ConditionalSubstitution envVar expr) = + salt `hashWithSalt` (6 :: Int) `hashWithSalt` envVar `hashWithSalt` expr + + +infixl 5 ++, +/+ + + +-- | Concatenates two 'FilePathExpression's. A synonym for 'Concatenation'. +(++) :: FilePathExpression -> FilePathExpression -> FilePathExpression +(++) = Concatenation +{-# INLINE (++) #-} + + +-- | Combines two 'FilePathExpression's with a path separator. A synonym for +-- 'PathSeparator'. +(+/+) :: FilePathExpression -> FilePathExpression -> FilePathExpression +(+/+) = PathSeparator +{-# INLINE (+/+) #-} + + +-- | Converts a 'FilePathExpression' to a textual representation. +toPathText :: FilePathExpression -> Text +toPathText (Root (Just driveLetter)) = pack [driveLetter, ':', '/'] +toPathText expr = toPathText' False expr + + +-- | Internal implementation of 'toPathText'. +toPathText' + :: Bool + -- ^ Whether it is followed by a 'BareComponent'. + -> FilePathExpression + -- ^ The 'FilePathExpression' to render. + -> Text + -- ^ The rendered 'FilePathExpression'. +toPathText' _ (BareComponent component) = component +toPathText' _ (Root Nothing) = "/" +toPathText' _ (Root (Just driveLetter)) = pack [driveLetter, ':'] +toPathText' followedByBare (Concatenation a b) = + toPathText' doesBStartWithBare a <> renderedB + where + renderedB :: Text + renderedB = toPathText' followedByBare b + doesBStartWithBare :: Bool + doesBStartWithBare = + not (null renderedB) + && let c = head renderedB in isAscii c && isAlphaNum c || c == '_' +toPathText' followedByBare (PathSeparator a@(Root Nothing) b) = + toPathText' False a <> toPathText' followedByBare b +toPathText' followedByBare (PathSeparator a b) = + toPathText' False a <> "/" <> toPathText' followedByBare b +toPathText' False (Substitution envVar) = "$" <> envVar +toPathText' True (Substitution envVar) = "${" <> envVar <> "}" +toPathText' _ (SubstitutionWithDefault envVar expr) = + "${" <> envVar <> ":-" <> toPathText' False expr <> "}" +toPathText' _ (ConditionalSubstitution envVar expr) = + "${" <> envVar <> ":+" <> toPathText' False expr <> "}" + + +instance IsString FilePathExpression where + fromString = BareComponent . pack diff --git a/src/Dojang/Types/FilePathExpression/Expansion.hs b/src/Dojang/Types/FilePathExpression/Expansion.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/FilePathExpression/Expansion.hs @@ -0,0 +1,77 @@ +module Dojang.Types.FilePathExpression.Expansion + ( ExpansionWarning (..) + , expandFilePath + ) where + +import Dojang.Types.FilePathExpression + ( EnvironmentVariable + , FilePathExpression (..) + ) + +import Data.Text (Text) +import System.OsPath + ( OsPath + , OsString + , pack + , pathSeparator + , unsafeFromChar + , () + ) + + +-- | A set of warnings that can occur during expansion. +newtype ExpansionWarning + = -- | The case where an environment variable that is referenced in a + -- 'Substitution' is not defined. + UndefinedEnvironmentVariable EnvironmentVariable + deriving (Eq, Show) + + +-- | Expands a 'FilePathExpression' into an 'OsPath'. +expandFilePath + :: (Monad m) + => FilePathExpression + -- ^ The 'FilePathExpression' to expand. + -> (EnvironmentVariable -> m (Maybe OsString)) + -- ^ A function that can look up an environment variable. + -> (Text -> m OsString) + -- ^ A function that encodes a 'Text' into an 'OsString'. + -> m (OsPath, [ExpansionWarning]) + -- ^ The expanded 'OsPath', along with a list of warnings that occurred during + -- expansion (if any). +expandFilePath (BareComponent component) _ encode = do + f <- encode component + return (f, []) +expandFilePath (Root Nothing) _ _ = return (pack [pathSeparator], []) +expandFilePath (Root (Just driveLetter)) _ _ = + return + ( pack + [ unsafeFromChar driveLetter + , unsafeFromChar ':' + , pathSeparator + ] + , [] + ) +expandFilePath (Concatenation expr1 expr2) lookupEnv encode = do + (expanded1, ws1) <- expandFilePath expr1 lookupEnv encode + (expanded2, ws2) <- expandFilePath expr2 lookupEnv encode + return (expanded1 <> expanded2, ws1 ++ ws2) +expandFilePath (PathSeparator expr1 expr2) lookupEnv encode = do + (expanded1, ws1) <- expandFilePath expr1 lookupEnv encode + (expanded2, ws2) <- expandFilePath expr2 lookupEnv encode + return (expanded1 expanded2, ws1 ++ ws2) +expandFilePath (Substitution envVar) lookupEnv _ = do + v <- lookupEnv envVar + case v of + Just v' -> return (v', []) + Nothing -> return (mempty, [UndefinedEnvironmentVariable envVar]) +expandFilePath (SubstitutionWithDefault envVar expr) lookupEnv encode = do + env <- lookupEnv envVar + case env of + Just env' | env' /= mempty -> return (env', []) + _ -> expandFilePath expr lookupEnv encode +expandFilePath (ConditionalSubstitution envVar expr) lookupEnv encode = do + env <- lookupEnv envVar + case env of + Just env' | env' /= mempty -> expandFilePath expr lookupEnv encode + _ -> return (mempty, []) diff --git a/src/Dojang/Types/FileRoute.hs b/src/Dojang/Types/FileRoute.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/FileRoute.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.FileRoute + ( FileRoute (..) + , RouteWarning (..) + , fileRoute + , fileRoute' + , dispatch + , routePath + ) where + +import Data.List (sortOn) +import Data.Ord (Down (Down)) +import Prelude hiding (lookup) + +import Data.HashMap.Strict (lookup) +import Data.HashSet (HashSet, singleton, union, unions) +import Data.Text (unpack) +import System.OsPath (OsPath, OsString) + +import Dojang.MonadFileSystem (FileType, MonadFileSystem (..)) +import Dojang.Types.Environment (Environment) +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..)) +import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning, evaluate') +import Dojang.Types.EnvironmentPredicate.Specificity (Specificity, specificity) +import Dojang.Types.FilePathExpression (EnvironmentVariable, FilePathExpression) +import Dojang.Types.FilePathExpression.Expansion + ( ExpansionWarning + , expandFilePath + ) +import Dojang.Types.MonikerMap (MonikerMap, MonikerResolver) +import Dojang.Types.MonikerName (MonikerName) + + +-- | A route that maps 'EnvironmentPredicate's to 'FilePathExpression's. +-- +-- Each 'EnvironmentPredicate' represents a condition that must be met for the +-- 'FilePathExpression' to be dispatched. The 'FilePathExpression' is +-- the path to the directory that should be dispatched to. If it is 'Nothing', +-- then it is considered a "null route" and will be ignored. +-- +-- Note that a null route will still be considered a match, and will be +-- dispatched as 'Nothing'. +data FileRoute = FileRoute + { monikerResolver :: MonikerResolver + -- ^ The 'MonikerResolver' used to resolve 'MonikerName's. + , predicates :: [(EnvironmentPredicate, Maybe FilePathExpression)] + -- ^ The pairs of 'EnvironmentPredicate's and 'FilePathExpression's that make + -- up the 'FileRoute'. If the file path expression is 'Nothing', then it is + -- considered a "null route" and will be ignored. + , fileType :: FileType + -- ^ Whether the 'FileRoute' represents a file or a directory. + } + + +instance Eq FileRoute where + a == b = + (a.fileType == b.fileType) + && (a.predicates == b.predicates) + && all (\m -> a.monikerResolver m == b.monikerResolver m) allMonikerRefs + where + monikerRefs :: EnvironmentPredicate -> HashSet MonikerName + monikerRefs predicates' = + case predicates' of + Moniker monikerName -> singleton monikerName + Or ps -> foldMap monikerRefs ps + And ps -> foldMap monikerRefs ps + Not p -> monikerRefs p + OperatingSystem _ -> mempty + Architecture _ -> mempty + Always -> mempty + KernelName _ -> mempty + KernelRelease _ -> mempty + KernelReleasePrefix _ -> mempty + KernelReleaseSuffix _ -> mempty + allMonikerRefs :: HashSet MonikerName + allMonikerRefs = + unions (monikerRefs . fst <$> a.predicates) + `union` unions (monikerRefs . fst <$> b.predicates) + + +-- | Creates a 'FileRoute' from a 'MonikerMap' and pairs of +-- 'MonikerName's and 'FilePathExpression's. +fileRoute + :: MonikerMap + -- ^ The 'MonikerMap' to resolve 'MonikerName's against. + -> [(MonikerName, Maybe FilePathExpression)] + -- ^ The pairs of 'MonikerName's and 'FilePathExpression's that make up the + -- 'FileRoute'. If the file path expression is 'Nothing', then it is + -- considered a "null route" and will be ignored. + -> FileType + -- ^ Whether the 'FileRoute' represents a file or a directory. + -> FileRoute + -- ^ The resulting 'FileRoute'. +fileRoute monikerMap predicates' = + fileRoute' + (`lookup` monikerMap) + [(Moniker name, pathExpr) | (name, pathExpr) <- predicates'] + + +-- | Similar to 'FileRoute', but it takes more raw arguments: a 'MonikerResolver' +-- (instead of a 'MonikerMap'), and a pairs of 'EnvironmentPredicate' (instead +-- of 'MonikerName') and 'FilePathExpression'. +fileRoute' + :: MonikerResolver + -- ^ A function that resolves a 'MonikerName' to an 'EnvironmentPredicate'. + -> [(EnvironmentPredicate, Maybe FilePathExpression)] + -- ^ The pairs of 'EnvironmentPredicate's and 'FilePathExpression's that make + -- up the 'FileRoute'. If the file path expression is 'Nothing', then it is + -- considered a "null route" and will be ignored. + -> FileType + -- ^ Whether the 'FileRoute' represents a file or a directory. + -> FileRoute + -- ^ The resulting 'FileRoute'. +fileRoute' resolver predicates' = + FileRoute resolver $ sortOn sortKey predicates' + where + sortKey + :: (EnvironmentPredicate, Maybe FilePathExpression) + -> Down (Specificity, String) + sortKey (pred', _) = Down (specificity resolver pred', show pred') + + +-- | Dispatches the given 'FileRoute' against the given 'Environment'. +dispatch + :: Environment + -- ^ The 'Environment' to dispatch against. + -> FileRoute + -- ^ The 'FileRoute' to dispatch. + -> ([Maybe FilePathExpression], [EvaluationWarning]) + -- ^ The list of 'Maybe' 'FilePathExpression's that matched + -- the given 'Environment' and 'MonikerMap'. Even if matches are made, + -- their values may be 'Nothing' if the 'FilePathExpression' was + -- a "null route". + -- The 'snd' of the result is a list of warnings that occurred + -- during evaluation whether or not any 'FilePathExpression' matched. +dispatch environment (FileRoute resolver route _) = + (matched, warnings) + where + eval :: EnvironmentPredicate -> (Bool, [EvaluationWarning]) + eval = evaluate' environment resolver + evaluated :: [((Bool, [EvaluationWarning]), Maybe FilePathExpression)] + evaluated = [(eval predicate, expr) | (predicate, expr) <- route] + warnings :: [EvaluationWarning] + warnings = concatMap (snd . fst) evaluated + matched :: [Maybe FilePathExpression] + matched = [expr | ((True, _), expr) <- evaluated] + + +-- | A warning that can occur during path routing. +data RouteWarning + = -- | A warning that can occur during environment predicate evaluation. + EnvironmentPredicateWarning EvaluationWarning + | -- | A warning that can occur during file path expression expansion. + FilePathExpressionWarning ExpansionWarning + deriving (Eq, Show) + + +-- | Routes the given 'FileRoute' against the given 'Environment', and expands +-- the resulting 'FilePathExpression' into an 'OsPath', if any. For null +-- routes, returns 'Nothing'. +routePath + :: (MonadFileSystem m) + => FileRoute + -- ^ The 'FileRoute' to route and expand. + -> Environment + -- ^ The environment to use when evaluating environment predicates. + -> (EnvironmentVariable -> m (Maybe OsString)) + -- ^ A function that can look up an environment variable. + -> m (Maybe OsPath, [RouteWarning]) + -- ^ The resulting 'OsPath', if any, and a list of warnings that occurred + -- during evaluation and expansion. For null routes, returns 'Nothing', + -- but still returns any warnings that occurred (if any). +routePath route env lookupEnvVar = do + let (matched, warnings) = dispatch env route + let predWarnings = map EnvironmentPredicateWarning warnings + case matched of + [] -> return (Nothing, predWarnings) + (Nothing : _) -> return (Nothing, predWarnings) + (Just pathExpr : _) -> do + (path, exprWarnings) <- + expandFilePath pathExpr lookupEnvVar (encodePath . unpack) + return (Just path, predWarnings ++ map FilePathExpressionWarning exprWarnings) + + +instance Show FileRoute where + show (FileRoute _ route fileType') = + "FileRoute " ++ show route ++ " " ++ show fileType' diff --git a/src/Dojang/Types/FileRouteMap.hs b/src/Dojang/Types/FileRouteMap.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/FileRouteMap.hs @@ -0,0 +1,10 @@ +module Dojang.Types.FileRouteMap (FileRouteMap) where + +import Data.Map.Strict (Map) +import System.OsPath (OsPath) + +import Dojang.Types.FileRoute (FileRoute) + + +-- | A map of directories and their routes. +type FileRouteMap = Map OsPath FileRoute diff --git a/src/Dojang/Types/FileRouteMap/Evaluate.hs b/src/Dojang/Types/FileRouteMap/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/FileRouteMap/Evaluate.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Dojang.Types.FileRouteMap.Evaluate + ( evaluateRoutes + , evaluateRoutesWithFileTypes + ) where + +import Data.Map.Strict (Map, fromList, mapWithKey, toList, (!?)) +import System.OsPath (OsPath) + +import Dojang.MonadFileSystem (FileType (..)) +import Dojang.Types.Environment (Environment) +import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning) +import Dojang.Types.FilePathExpression (FilePathExpression) +import Dojang.Types.FileRoute (FileRoute (..), dispatch) +import Dojang.Types.FileRouteMap (FileRouteMap) + + +-- | Evaluates the 'FileRouteMap' against an 'Environment'. +evaluateRoutes + :: FileRouteMap + -- ^ The 'FileRouteMap' to evaluate. + -> Environment + -- ^ The 'Environment' to evaluate against. + -> (Map OsPath FilePathExpression, [EvaluationWarning]) + -- ^ The evaluated routes and the warnings that occurred during evaluation. + -- Unmatched routes or null routes will not be included in the result. +evaluateRoutes fileRoutes env = + (evaluated, warnings) + where + results :: [(OsPath, FilePathExpression, [EvaluationWarning])] + results = + [ (filePath, match, warnings') + | (filePath, route) <- toList fileRoutes + , let (matches, warnings') = dispatch env route + , Just match : _ <- [matches] + ] + warnings :: [EvaluationWarning] + warnings = concatMap (\(_, _, w) -> w) results + evaluated :: Map OsPath FilePathExpression + evaluated = fromList [(filePath, match) | (filePath, match, _) <- results] + + +-- | Similar to 'evaluateRoutes', but also includes the 'FileType' of each +-- evaluated route. +evaluateRoutesWithFileTypes + :: FileRouteMap + -- ^ The 'FileRouteMap' to evaluate. + -> Environment + -- ^ The 'Environment' to evaluate against. + -> (Map OsPath (FilePathExpression, FileType), [EvaluationWarning]) + -- ^ The evaluated routes and the warnings that occurred during evaluation. + -- Unmatched routes or null routes will not be included in the result. +evaluateRoutesWithFileTypes fileRoutes env = + (evaluatedRoutesWithFileTypes, warnings) + where + evaluatedRoutes :: Map OsPath FilePathExpression + warnings :: [EvaluationWarning] + (evaluatedRoutes, warnings) = evaluateRoutes fileRoutes env + evaluatedRoutesWithFileTypes :: Map OsPath (FilePathExpression, FileType) + evaluatedRoutesWithFileTypes = mapWithKey addFileType evaluatedRoutes + addFileType :: OsPath -> FilePathExpression -> (FilePathExpression, FileType) + addFileType path expr = + ( expr + , maybe File (\FileRoute{fileType} -> fileType) (fileRoutes !? path) + ) diff --git a/src/Dojang/Types/Hook.hs b/src/Dojang/Types/Hook.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/Hook.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE NoFieldSelectors #-} + +module Dojang.Types.Hook + ( Hook (..) + , HookType (..) + , HookMap + , allHookTypes + ) where + +import Data.Map.Strict (Map) +import Data.Text (Text) +import System.OsPath (OsPath) + +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate) + + +-- | The type of hook, determining when it runs. +data HookType + = -- | Runs before file sync (every apply). + PreApply + | -- | Runs before file sync (first apply only). + PreFirstApply + | -- | Runs after file sync (first apply only). + PostFirstApply + | -- | Runs after file sync (every apply). + PostApply + deriving (Eq, Show, Ord, Enum, Bounded) + + +-- | All hook types in execution order. +allHookTypes :: [HookType] +allHookTypes = [minBound .. maxBound] + + +-- | A hook configuration. +data Hook = Hook + { command :: OsPath + -- ^ The executable path (required). + , args :: [Text] + -- ^ Command arguments (default: []). + , condition :: EnvironmentPredicate + -- ^ Condition to run (combined from moniker and when fields). + , workingDirectory :: Maybe OsPath + -- ^ Working directory (default: repository root). + , ignoreFailure :: Bool + -- ^ Continue on failure (default: False). + } + deriving (Eq, Show) + + +-- | A map from hook types to lists of hooks. +type HookMap = Map HookType [Hook] diff --git a/src/Dojang/Types/Manifest.hs b/src/Dojang/Types/Manifest.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/Manifest.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedRecordUpdate #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Dojang.Types.Manifest + ( IgnoreMap + , Manifest (..) + , manifest + ) where + +import Data.Map.Strict (Map, fromList, toAscList, toList) +import System.FilePattern (FilePattern) +import System.OsPath (OsPath, normalise) + +import Dojang.MonadFileSystem (FileType (..)) +import Dojang.Types.FilePathExpression (FilePathExpression) +import Dojang.Types.FileRoute (FileRoute, fileRoute) +import Dojang.Types.FileRouteMap (FileRouteMap) +import Dojang.Types.Hook (HookMap) +import Dojang.Types.MonikerMap (MonikerMap) +import Dojang.Types.MonikerName (MonikerName) + + +-- | A map of directory routes to file patterns that should be ignored. +type IgnoreMap = Map OsPath [FilePattern] + + +-- | A manifest of the directory routes and the definitions of monikers that +-- are used to resolve them. +data Manifest = Manifest + { monikers :: MonikerMap + -- ^ The definitions of monikers that are used to resolve the directory routes. + , fileRoutes :: FileRouteMap + -- ^ The directory routes that are resolved by the monikers. + , ignorePatterns :: IgnoreMap + -- ^ The file patterns that should be ignored for each directory route. + , hooks :: HookMap + -- ^ The hooks to run before and after applying. + } + deriving (Eq, Show) + + +-- | Makes a 'Manifest' from definitions of monikers and directory routes. +manifest + :: MonikerMap + -- ^ The monikers that are used to resolve the directory routes. + -> Map OsPath [(MonikerName, Maybe FilePathExpression)] + -- ^ The file routes that are resolved by the monikers. The keys are + -- the file names, and the values are the pairs of 'MonikerName's and + -- 'FilePathExpression's that make up each 'FileRoute'. + -- If the same 'MonikerName' is used more than once, then the latest one + -- will be used. If the same file name appears in the directory routes + -- (the next parameter), then the directory route will take precedence. + -> Map OsPath [(MonikerName, Maybe FilePathExpression)] + -- ^ The directory routes that are resolved by the monikers. The keys are + -- the names of the directories, and the values are the pairs of + -- 'MonikerName's and 'FilePathExpression's that make up each 'FileRoute'. + -- If the same 'MonikerName' is used more than once, then the latest one + -- will be used. If the same file name appears in the file routes + -- (the previous parameter), then the directory route will take precedence. + -> IgnoreMap + -- ^ The file patterns that should be ignored for each directory route. + -> HookMap + -- ^ The hooks to run before and after applying. + -> Manifest + -- ^ The made 'Manifest'. +manifest monikers' fileRoutes' dirRoutes' ignorePatterns' hooks' = + Manifest + { monikers = monikers' + , fileRoutes = fromList $ files ++ dirs + , ignorePatterns = ignores + , hooks = hooks' + } + where + files :: [(OsPath, FileRoute)] + files = do + (filename, monikerPairs) <- toList fileRoutes' + pure (normalise filename, fileRoute monikers' monikerPairs File) + dirs :: [(OsPath, FileRoute)] + dirs = do + (dirName, monikerPairs) <- toList dirRoutes' + pure (normalise dirName, fileRoute monikers' monikerPairs Directory) + ignores :: IgnoreMap + ignores = + fromList + [ (normalise p, pattern) + | (p, pattern) <- toAscList ignorePatterns' + ] diff --git a/src/Dojang/Types/MonikerMap.hs b/src/Dojang/Types/MonikerMap.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/MonikerMap.hs @@ -0,0 +1,14 @@ +module Dojang.Types.MonikerMap (MonikerMap, MonikerResolver) where + +import Data.HashMap.Strict (HashMap) + +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate) +import Dojang.Types.MonikerName (MonikerName) + + +-- | A map that defines the monikers and what conditions they match. +type MonikerMap = HashMap MonikerName EnvironmentPredicate + + +-- | A function that resolves a 'MonikerName' to an 'EnvironmentPredicate'. +type MonikerResolver = MonikerName -> Maybe EnvironmentPredicate diff --git a/src/Dojang/Types/MonikerName.hs b/src/Dojang/Types/MonikerName.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/MonikerName.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedRecordUpdate #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use guards" #-} + +module Dojang.Types.MonikerName + ( MonikerName + , MonikerNameError (..) + , parseMonikerName + ) where + +import Data.CaseInsensitive (CI, mk) +import Data.Char (isAlpha, isAlphaNum) +import Data.Hashable (Hashable) +import Data.Text (Text, findIndex, head, null) +import GHC.Records (HasField (getField)) + +import Prelude hiding (head, null) + + +-- $setup +-- >>> :seti -XOverloadedStrings -XOverloadedRecordDot + + +-- | A moniker name. The name must start with a letter and contain only +-- letters, digits, hyphens, and underscores (no spaces, no special characters). +-- Non-Latin letters and digits are allowed too. The name must not be empty. +-- +-- >>> parseMonikerName "foo-bar" +-- Right (MonikerName "foo-bar") +-- >>> parseMonikerName "甲乙_丙丁" +-- Right (MonikerName "甲乙_丙丁") +-- +-- Case insensitive, but the original case is preserved: +-- +-- >>> parseMonikerName "FOO-BAR" == parseMonikerName "foo-bar" +-- True +-- >>> parseMonikerName "GIÁP_ẤT" == parseMonikerName "giáp_ất" -- cSpell:disable-line +-- True +newtype MonikerName = MonikerName (CI Text) deriving (Eq, Ord, Hashable, Show) + + +-- | A record field named @name@ for 'MonikerName': +-- +-- >>> let (Right monikerName) = parseMonikerName "foo-bar" +-- >>> monikerName.name +-- "foo-bar" +instance HasField "name" MonikerName (CI Text) where + getField (MonikerName name) = name + + +-- | Errors that can occur when parsing a moniker name. +data MonikerNameError + = -- | The moniker name is empty. + Empty + | -- | The moniker name starts with a non-letter character. + StartingWithNonLetter + | -- | The moniker name contains an invalid character at the given index. + HavingInvalidCharacter Int + deriving (Eq, Show, Read) + + +-- | Parse a moniker name. +-- +-- >>> parseMonikerName "foo-bar" +-- Right (MonikerName "foo-bar") +-- >>> parseMonikerName "1" +-- Left StartingWithNonLetter +-- >>> parseMonikerName "foo bar" +-- Left (HavingInvalidCharacter 3) +-- >>> parseMonikerName "甲乙_丙丁" +-- Right (MonikerName "甲乙_丙丁") +-- >>> parseMonikerName "" +-- Left Empty +parseMonikerName :: Text -> Either MonikerNameError MonikerName +parseMonikerName name = + if null name + then Left Empty + else + if isAlpha $ head name + then case findIndex isInvalidChar name of + Nothing -> Right $ MonikerName $ mk name + Just i -> Left $ HavingInvalidCharacter i + else Left StartingWithNonLetter + where + isInvalidChar :: Char -> Bool + isInvalidChar c = not $ isAlphaNum c || c == '-' || c == '_' diff --git a/src/Dojang/Types/Registry.hs b/src/Dojang/Types/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/Registry.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module provides the registry type and functions for reading and +-- writing the registry file. The registry file stores the path to the +-- repository so that commands like @dojang edit@ can be run from any +-- directory. +module Dojang.Types.Registry + ( Registry (..) + , readRegistry + , registryFilename + , writeRegistry + ) where + +import Control.DeepSeq (force) +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8) +import System.IO.Unsafe (unsafePerformIO) + +import System.OsPath (OsPath, decodeFS, encodeFS) +import TextShow (FromStringShow (FromStringShow), showt) +import Toml (decode, encode) +import Toml.FromValue + ( FromValue (fromValue) + , Result (Failure, Success) + , parseTableFromValue + , reqKey + ) +import Toml.ToValue + ( ToTable (toTable) + , ToValue (toValue) + , defaultTableToValue + , table + , (.=) + ) + +import Dojang.MonadFileSystem (MonadFileSystem (..)) + + +-- | The registry stores the path to the repository. +data Registry = Registry + { repositoryPath :: OsPath + -- ^ The path to the repository. + } + deriving (Eq, Show) + + +-- | The filename for the registry file. +registryFilename :: OsPath +registryFilename = unsafePerformIO $ encodeFS ".dojang" +{-# NOINLINE registryFilename #-} + + +instance FromValue Registry where + fromValue = + parseTableFromValue $ + Registry + <$> (textToOsPath <$> reqKey "repository") + where + textToOsPath :: Text -> OsPath + textToOsPath t = unsafePerformIO $ encodeFS $ unpack t + + +instance ToValue Registry where + toValue = defaultTableToValue + + +instance ToTable Registry where + toTable reg = + table + [ "repository" .= osPathToText reg.repositoryPath + ] + where + osPathToText :: OsPath -> Text + osPathToText p = pack $ unsafePerformIO $ decodeFS p + + +-- | Read the registry from a file. +readRegistry + :: (MonadFileSystem m, MonadIO m) + => OsPath + -- ^ The path to the registry file. + -> m (Maybe Registry) +readRegistry path = do + fileExists <- exists path + if not fileExists + then return Nothing + else do + contents <- Dojang.MonadFileSystem.readFile path + let textContents = decodeUtf8Lenient contents + case decode $ unpack $ force textContents of + Success _ reg -> return $ Just reg + Failure _ -> return Nothing + + +-- | Write the registry to a file. +writeRegistry + :: (MonadFileSystem m) + => OsPath + -- ^ The path to the registry file. + -> Registry + -- ^ The registry to write. + -> m () +writeRegistry path registry = do + let contents = showt $ FromStringShow $ encode registry + Dojang.MonadFileSystem.writeFile path (encodeUtf8 contents) diff --git a/src/Dojang/Types/Repository.hs b/src/Dojang/Types/Repository.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Types/Repository.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Dojang.Types.Repository + ( Repository (..) + , RouteMapWarning (..) + , RouteResult (..) + , findOverlappingRouteResults + , overlaps + , routePaths + ) where + +import Control.Monad (forM) +import Data.Function ((&)) +import Data.List (isPrefixOf, nub) +import Data.List.NonEmpty + ( NonEmpty ((:|)) + , append + , nub + , singleton + , sort + , toList + ) + +import Data.Map.Strict (Map, findWithDefault, fromListWith, toList) +import System.FilePattern (FilePattern, matchMany) +import System.OsPath + ( OsPath + , OsString + , makeRelative + , normalise + , splitDirectories + , () + ) + +import Dojang.MonadFileSystem (FileType, MonadFileSystem (..)) +import Dojang.Types.Environment (Environment) +import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning) +import Dojang.Types.FilePathExpression (EnvironmentVariable) +import Dojang.Types.FilePathExpression.Expansion (ExpansionWarning) +import Dojang.Types.FileRoute (FileRoute (..), RouteWarning, routePath) +import Dojang.Types.FileRoute qualified as FileRoute (RouteWarning (..)) +import Dojang.Types.Manifest (Manifest (..)) + + +-- | A repository, which is a directory containing a manifest file and dotfiles. +data Repository = Repository + { sourcePath :: OsPath + -- ^ The path to the repository. + , intermediatePath :: OsPath + -- ^ The path to the intermediate directory, which is managed by Dojang and + -- contains the post-processed files. + , manifest :: Manifest + -- ^ The manifest of the repository. + } + + +-- | The expanded dispatch paths of a 'FileRoute'. +data RouteResult = RouteResult + { sourcePath :: OsPath + -- ^ The source path. It is either absolute or relative to the current + -- working directory. + , routeName :: OsPath + -- ^ The source path relative from the repository root, i.e., the route name. + , destinationPath :: OsPath + -- ^ The destination path. It is either absolute or relative to + -- the current working directory. + , fileType :: FileType + } + deriving (Eq, Show) + + +-- | A warning that can occur during routing paths. +data RouteMapWarning + = -- | A warning that can occur during environment predicate evaluation. + EnvironmentPredicateWarning EvaluationWarning + | -- | A warning that can occur during file path expression expansion. + FilePathExpressionWarning ExpansionWarning + | -- | A warning that two or more routes overlap in their destination paths + -- (e.g., @/foo/bar@ and @/foo/bar/baz@). + OverlapDestinationPathsWarning + OsPath + -- ^ The source path of the route that have overlapping destination paths. + OsPath + -- ^ The destination path that overlaps. + (NonEmpty (OsPath, OsPath)) + -- ^ The pairs of corresponding source and destination paths that overlap. + deriving (Eq, Show) + + +-- | Route the paths in the repository. This will return a list of expanded +-- paths, along with any warnings that were generated. Null routes will be +-- ignored. +routePaths + :: forall m + . (MonadFileSystem m) + => Repository + -- ^ The repository. + -> Environment + -- ^ The environment to use when evaluating the environment predicates. + -> (EnvironmentVariable -> m (Maybe OsString)) + -- ^ The function to look up environment variables. + -> m ([RouteResult], [RouteMapWarning]) + -- ^ The expanded paths, along with any warnings that were generated. +routePaths repo env lookupEnvVar = do + paths <- forM fileRoutes $ \(src, route) -> do + (dstPath, warnings) <- routePath route env lookupEnvVar + return (src, dstPath, route.fileType, warnings) + let paths' = + [ RouteResult (repo.sourcePath src) src dst' ft + | (src, Just dst', ft, _) <- paths + ] + overlappingRoutes <- + forM (Data.Map.Strict.toList $ findOverlappingRouteResults paths') $ + \((name, dst), overlaps') -> do + let ignorePatterns = + findWithDefault [] name repo.manifest.ignorePatterns + filtered <- filterIgnoredPathsFromOverlaps dst ignorePatterns overlaps' + return ((name, dst), filtered) + let warnings = + [translateWarning w | (_, _, _, ws) <- paths, w <- ws] + ++ [ OverlapDestinationPathsWarning name dst (o :| overlaps') + | ((name, dst), o : overlaps') <- overlappingRoutes + ] + return (paths', Data.List.nub warnings) + where + fileRoutes :: [(OsPath, FileRoute)] + fileRoutes = Data.Map.Strict.toList repo.manifest.fileRoutes + filterIgnoredPathsFromOverlaps + :: OsPath + -> [FilePattern] + -> NonEmpty (OsPath, OsPath) + -> m [(OsPath, OsPath)] + filterIgnoredPathsFromOverlaps base patterns paths = do + paths' <- forM pathList $ \pair@(_, dst') -> do + dstFP <- decodePath $ makeRelative base' $ normalise dst' + return (pair, dstFP) + let ignored = [pair | (_, pair, _) <- matchMany patterns' paths'] + return [pair | pair <- pathList, pair `notElem` ignored] + where + base' :: OsPath + base' = normalise base + pathList :: [(OsPath, OsPath)] + pathList = Data.List.NonEmpty.toList paths + patterns' :: [((), FilePattern)] + patterns' = + [((), pattern) | pattern <- patterns] + ++ [((), pattern ++ "/**/*") | pattern <- patterns] + + +translateWarning :: RouteWarning -> RouteMapWarning +translateWarning (FileRoute.EnvironmentPredicateWarning w) = + EnvironmentPredicateWarning w +translateWarning (FileRoute.FilePathExpressionWarning w) = + FilePathExpressionWarning w + + +findOverlappingRouteResults + :: [RouteResult] -> Map (OsPath, OsPath) (NonEmpty (OsPath, OsPath)) +findOverlappingRouteResults routes = + fromListWith append found & fmap (Data.List.NonEmpty.nub . sort) + where + pairs :: [(OsPath, OsPath)] + pairs = + [ (name, dst) + | RouteResult{routeName = name, destinationPath = dst} <- routes + ] + found :: [((OsPath, OsPath), NonEmpty (OsPath, OsPath))] + found = + [ ((name, dst), singleton (name', dst')) + | (name, dst) <- pairs + , (name', dst') <- pairs + , name /= name' + , dst `overlaps` dst' + ] + + +-- | Returns whether the two paths overlap. The former path is assumed to be +-- shorter than or equal to the latter path. +overlaps :: OsPath -> OsPath -> Bool +overlaps a b = + (a' == b') || aDirs `isPrefixOf` bDirs + where + a' :: OsPath + a' = normalise a + b' :: OsPath + b' = normalise b + aDirs :: [OsPath] + aDirs = splitDirectories a' + bDirs :: [OsPath] + bDirs = splitDirectories b' diff --git a/src/Dojang/Version.hs b/src/Dojang/Version.hs new file mode 100644 --- /dev/null +++ b/src/Dojang/Version.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Dojang.Version (toString, toText, version) where + + +#if defined(DOJANG_DEV_BUILD) +import Data.Maybe (fromJust) +#endif + +import Data.Version qualified + +import Data.SemVer hiding (version) +import Data.SemVer qualified (version) + +import Paths_dojang qualified + + +{- FOURMOLU_DISABLE -} +version :: Version +version = + let (Data.Version.Version [major', minor', patch'] _) = Paths_dojang.version + in Data.SemVer.version + major' + minor' + patch' +#if defined(DOJANG_DEV_BUILD) + [fromJust $ textual "dev", numeric (DOJANG_DEV_BUILD)] +#else + [] +#endif + [] +{- FOURMOLU_ENABLE -} diff --git a/src/Options/Applicative/Path.hs b/src/Options/Applicative/Path.hs new file mode 100644 --- /dev/null +++ b/src/Options/Applicative/Path.hs @@ -0,0 +1,42 @@ +module Options.Applicative.Path + ( hyphen + , path + , pathOption + , pathArgument + , period + ) where + +import System.IO.Unsafe (unsafePerformIO) + +import Options.Applicative + ( ArgumentFields + , Mod + , OptionFields + , Parser + , argument + , option + ) +import Options.Applicative.Types (ReadM, readerAsk) +import System.OsPath (OsPath, encodeFS) + + +hyphen :: OsPath +hyphen = unsafePerformIO $ encodeFS "-" +{-# NOINLINE hyphen #-} + + +period :: OsPath +period = unsafePerformIO $ encodeFS "." +{-# NOINLINE period #-} + + +path :: ReadM OsPath +path = unsafePerformIO . encodeFS <$> readerAsk + + +pathOption :: Mod OptionFields OsPath -> Parser OsPath +pathOption = option path + + +pathArgument :: Mod ArgumentFields OsPath -> Parser OsPath +pathArgument = argument path diff --git a/test/Dojang/Commands/DisambiguationSpec.hs b/test/Dojang/Commands/DisambiguationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Commands/DisambiguationSpec.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Commands.DisambiguationSpec (spec) where + +import Prelude hiding (readFile, writeFile) + +import Control.Exception (bracket_) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.OsPath (encodeFS) +import Test.Hspec (Spec, describe, it, runIO, sequential) +import Test.Hspec.Expectations.Pretty (shouldBe) + +import Dojang.Commands.Disambiguation + ( AutoSelectMode (..) + , getAutoSelectMode + ) +import Dojang.MonadFileSystem qualified (FileType (..)) +import Dojang.Types.Context (CandidateRoute (..)) +import Dojang.Types.Repository (RouteResult (..)) + + +-- | Helper to run a test with a specific environment variable setting. +withEnvVar :: String -> Maybe String -> IO a -> IO a +withEnvVar name value action = do + oldValue <- lookupEnv name + bracket_ + (setOrUnset value) + (setOrUnset oldValue) + action + where + setOrUnset :: Maybe String -> IO () + setOrUnset (Just v) = setEnv name v + setOrUnset Nothing = unsetEnv name + + +spec :: Spec +spec = do + foo <- runIO $ encodeFS "foo" + dst <- runIO $ encodeFS "dst" + + -- These tests must run sequentially because they modify global env vars. + sequential $ describe "getAutoSelectMode" $ do + it "returns Interactive when DOJANG_AUTO_SELECT is unset" $ do + withEnvVar "DOJANG_AUTO_SELECT" Nothing $ do + mode <- getAutoSelectMode + mode `shouldBe` Interactive + + it "returns AutoSelectFirst when DOJANG_AUTO_SELECT is 'first'" $ do + withEnvVar "DOJANG_AUTO_SELECT" (Just "first") $ do + mode <- getAutoSelectMode + mode `shouldBe` AutoSelectFirst + + it "returns ErrorOnAmbiguity when DOJANG_AUTO_SELECT is 'error'" $ do + withEnvVar "DOJANG_AUTO_SELECT" (Just "error") $ do + mode <- getAutoSelectMode + mode `shouldBe` ErrorOnAmbiguity + + it "returns Interactive for unknown values" $ do + withEnvVar "DOJANG_AUTO_SELECT" (Just "unknown") $ do + mode <- getAutoSelectMode + mode `shouldBe` Interactive + + describe "CandidateRoute" $ do + it "has expected fields" $ do + let route = + RouteResult + { sourcePath = foo + , routeName = foo + , destinationPath = dst + , fileType = Dojang.MonadFileSystem.Directory + } + let candidate = CandidateRoute route 1 foo True + candidate.specificity `shouldBe` 1 + candidate.sourceFilePath `shouldBe` foo + candidate.sourceExists `shouldBe` True + candidate.route.routeName `shouldBe` foo diff --git a/test/Dojang/Commands/EditSpec.hs b/test/Dojang/Commands/EditSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Commands/EditSpec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Commands.EditSpec (spec) where + +import Control.Exception (bracket_) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.Info (os) + +import Test.Hspec (Spec, describe, it, sequential) +import Test.Hspec.Expectations.Pretty (shouldBe) + +import Dojang.Commands.Edit (defaultEditor, getEditor) + + +-- | Helper to run a test with a specific environment variable setting. +withEnvVar :: String -> Maybe String -> IO a -> IO a +withEnvVar name value action = do + oldValue <- lookupEnv name + bracket_ + (setOrUnset value) + (setOrUnset oldValue) + action + where + setOrUnset :: Maybe String -> IO () + setOrUnset (Just v) = setEnv name v + setOrUnset Nothing = unsetEnv name + + +-- | Helper to run a test with multiple environment variables set. +withEnvVars :: [(String, Maybe String)] -> IO a -> IO a +withEnvVars [] action = action +withEnvVars ((name, value) : rest) action = + withEnvVar name value (withEnvVars rest action) + + +spec :: Spec +spec = do + describe "defaultEditor" $ do + it "is vi on POSIX" $ do + if os == "mingw32" + then defaultEditor `shouldBe` "notepad" + else defaultEditor `shouldBe` "vi" + + -- These tests must run sequentially because they modify global env vars. + sequential $ describe "getEditor" $ do + it "returns --editor option when provided" $ do + withEnvVars [("VISUAL", Just "emacs"), ("EDITOR", Just "nano")] $ do + editor <- getEditor (Just "vim") + editor `shouldBe` Just "vim" + + it "returns VISUAL when --editor not provided" $ do + withEnvVars [("VISUAL", Just "emacs"), ("EDITOR", Just "nano")] $ do + editor <- getEditor Nothing + editor `shouldBe` Just "emacs" + + it "returns EDITOR when VISUAL not set" $ do + withEnvVars [("VISUAL", Nothing), ("EDITOR", Just "nano")] $ do + editor <- getEditor Nothing + editor `shouldBe` Just "nano" + + it "returns Nothing when no env vars set and no option" $ do + withEnvVars [("VISUAL", Nothing), ("EDITOR", Nothing)] $ do + editor <- getEditor Nothing + editor `shouldBe` Nothing diff --git a/test/Dojang/Commands/HookSpec.hs b/test/Dojang/Commands/HookSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Commands/HookSpec.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Commands.HookSpec (spec) where + +import System.IO.Unsafe (unsafePerformIO) + +import Data.HashMap.Strict (empty) +import System.OsPath (OsPath, encodeFS) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Dojang.Commands.Hook (shouldRunHook) +import Dojang.Types.Environment (Environment (..), Kernel (..)) +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..)) +import Dojang.Types.Hook (Hook (..)) +import Dojang.Types.MonikerMap (MonikerMap) +import Dojang.Types.MonikerName (parseMonikerName) + + +encodePath :: String -> OsPath +encodePath = unsafePerformIO . encodeFS + + +spec :: Spec +spec = do + describe "shouldRunHook" $ do + let env = Environment "linux" "x86_64" $ Kernel "Linux" "6.0.0" + + it "returns True for Always condition" $ do + let hook = + Hook + { command = encodePath "/bin/echo" + , args = ["hello"] + , condition = Always + , workingDirectory = Nothing + , ignoreFailure = False + } + shouldRunHook empty env hook `shouldBe` True + + it "returns True when OS matches" $ do + let hook = + Hook + { command = encodePath "/bin/echo" + , args = [] + , condition = OperatingSystem "linux" + , workingDirectory = Nothing + , ignoreFailure = False + } + shouldRunHook empty env hook `shouldBe` True + + it "returns False when OS does not match" $ do + let hook = + Hook + { command = encodePath "/bin/echo" + , args = [] + , condition = OperatingSystem "windows" + , workingDirectory = Nothing + , ignoreFailure = False + } + shouldRunHook empty env hook `shouldBe` False + + it "returns True when moniker matches" $ do + let Right monikerName = parseMonikerName "linux" + let monikers = [(monikerName, OperatingSystem "linux")] :: MonikerMap + let hook = + Hook + { command = encodePath "/bin/echo" + , args = [] + , condition = Moniker monikerName + , workingDirectory = Nothing + , ignoreFailure = False + } + shouldRunHook monikers env hook `shouldBe` True + + it "returns False when moniker does not match" $ do + let Right linuxMoniker = parseMonikerName "linux" + let Right windowsMoniker = parseMonikerName "windows" + let monikers = + [ (linuxMoniker, OperatingSystem "linux") + , (windowsMoniker, OperatingSystem "windows") + ] + :: MonikerMap + let hook = + Hook + { command = encodePath "/bin/echo" + , args = [] + , condition = Moniker windowsMoniker + , workingDirectory = Nothing + , ignoreFailure = False + } + shouldRunHook monikers env hook `shouldBe` False diff --git a/test/Dojang/Gen.hs b/test/Dojang/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Gen.hs @@ -0,0 +1,12 @@ +module Dojang.Gen (evaluationWarning) where + +import Test.Hspec.Hedgehog (MonadGen) + +import Dojang.Types.EnvironmentPredicate.Evaluate + ( EvaluationWarning (UndefinedMoniker) + ) +import Dojang.Types.Gen (monikerName) + + +evaluationWarning :: (MonadGen m) => m EvaluationWarning +evaluationWarning = UndefinedMoniker <$> monikerName diff --git a/test/Dojang/MonadFileSystemSpec.hs b/test/Dojang/MonadFileSystemSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/MonadFileSystemSpec.hs @@ -0,0 +1,1000 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.MonadFileSystemSpec (spec) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.List (sort, sortOn) +import GHC.IO.Exception (IOErrorType (InappropriateType)) +import System.IO.Error + ( alreadyExistsErrorType + , doesNotExistErrorType + , ioeGetErrorType + , ioeGetFileName + , ioeGetLocation + , isDoesNotExistError + ) +import Prelude hiding (readFile, writeFile) +import Prelude qualified (readFile, writeFile) + +import Control.Monad.Except (MonadError (catchError), tryError) +import Data.ByteString qualified (readFile, writeFile) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range (constantFrom) +import System.Directory.OsPath + ( createDirectoryLink + , createFileLink + , doesDirectoryExist + , doesFileExist + , doesPathExist + ) +import System.Directory.OsPath qualified (createDirectory) +import System.FilePath (combine) +import System.OsPath (dropFileName, encodeFS, ()) +import Test.Hspec (Spec, describe, it, runIO, specify, xit, xspecify) +import Test.Hspec.Expectations.Pretty + ( shouldBe + , shouldContain + , shouldReturn + , shouldSatisfy + , shouldStartWith + , shouldThrow + ) +import Test.Hspec.Hedgehog (forAll, hedgehog, (===)) + +import Dojang.MonadFileSystem + ( FileType (..) + , MonadFileSystem (..) + , dryRunIO + , tryDryRunIO + ) +import Dojang.TestUtils (withTempDir) + + +packageYamlFP :: FilePath +packageYamlFP = "package.yaml" + + +testFP :: FilePath +testFP = "test" + + +nonExistentFP :: FilePath +nonExistentFP = "---non-existent---" + + +nonExistentFP' :: FilePath +nonExistentFP' = "---non-existent-2---" + + +spec :: Spec +spec = do + packageYamlP <- runIO $ encodeFS packageYamlFP + testP <- runIO $ encodeFS testFP + nonExistentP <- runIO $ encodeFS nonExistentFP + nonExistentP' <- runIO $ encodeFS nonExistentFP' + + -- cSpell:ignore quux corge + foo <- runIO $ encodeFS "foo" + bar <- runIO $ encodeFS "bar" + baz <- runIO $ encodeFS "baz" + qux <- runIO $ encodeFS "qux" + quux <- runIO $ encodeFS "quux" + corge <- runIO $ encodeFS "corge" + + symlinkAvailable <- runIO $ withTempDir $ \tmpDir tmpDir' -> + ( do + Prelude.writeFile (tmpDir' `combine` "foo") "" + createFileLink foo (tmpDir bar) + return True + ) + `catchError` const (return False) + let symIt = if symlinkAvailable then it else xit + let symSpecify = if symlinkAvailable then specify else xspecify + + let withFixture action = withTempDir $ \tmpDir tmpDir' -> do + () <- Prelude.writeFile (tmpDir' `combine` "foo") "" + () <- System.Directory.OsPath.createDirectory $ tmpDir bar + () <- System.Directory.OsPath.createDirectory $ tmpDir baz + () <- + System.Directory.OsPath.createDirectory + (tmpDir baz qux) + action tmpDir tmpDir' + + describe "MonadFileSystem IO" $ do + specify "encodePath" $ hedgehog $ do + filePath <- forAll $ Gen.string (constantFrom 0 0 256) Gen.unicode + filePath' <- liftIO $ encodePath filePath >>= decodePath + filePath' === filePath + + specify "exists" $ do + exists packageYamlP `shouldReturn` True + exists testP `shouldReturn` True + exists nonExistentP `shouldReturn` False + + specify "isFile" $ do + isFile packageYamlP `shouldReturn` True + isFile testP `shouldReturn` False + isFile nonExistentP `shouldReturn` False + + specify "isDirectory" $ do + isDirectory packageYamlP `shouldReturn` False + isDirectory testP `shouldReturn` True + isDirectory nonExistentP `shouldReturn` False + + symSpecify "isSymlink" $ do + isSymlink packageYamlP `shouldReturn` False + isSymlink testP `shouldReturn` False + isSymlink nonExistentP `shouldReturn` False + withTempDir $ \tmpDir tmpDir' -> do + Prelude.writeFile (tmpDir' `combine` "foo") "" + createFileLink foo (tmpDir bar) + isSymlink (tmpDir bar) `shouldReturn` True + + specify "readFile" $ withTempDir $ \tmpDir tmpDir' -> do + () <- Prelude.writeFile (tmpDir' `combine` "foo") "Foo contents" + contents <- readFile $ tmpDir foo + contents `shouldBe` "Foo contents" + Left error' <- tryError $ readFile nonExistentP + ioeGetErrorType error' `shouldBe` doesNotExistErrorType + ioeGetFileName error' `shouldBe` Just nonExistentFP + + specify "writeFile" $ withTempDir $ \tmpDirP tmpDirFP -> do + () <- writeFile (tmpDirP nonExistentP) "foo" + Data.ByteString.readFile (tmpDirFP `combine` nonExistentFP) + `shouldReturn` "foo" + + describe "readSymlinkTarget" $ do + symIt "tells the target path of a symbolic link" $ withTempDir $ \tmpDir tmpDir' -> do + () <- Prelude.writeFile (tmpDir' `combine` "foo") "" + createFileLink foo (tmpDir bar) + readSymlinkTarget (tmpDir bar) `shouldReturn` foo + + it "fails with IOError if the path does not exist" $ do + readSymlinkTarget nonExistentP `shouldThrow` \e -> do + isDoesNotExistError e && ioeGetFileName e == Just nonExistentFP + + specify "copyFile" $ withTempDir $ \tmpDirP tmpDirFP -> do + () <- copyFile packageYamlP (tmpDirP nonExistentP) + contents <- Data.ByteString.readFile (tmpDirFP `combine` nonExistentFP) + original <- Data.ByteString.readFile packageYamlFP + contents `shouldBe` original + + specify "createDirectory" $ withTempDir $ \tmpDirP _ -> do + () <- createDirectory (tmpDirP nonExistentP) + doesDirectoryExist (tmpDirP nonExistentP) + `shouldReturn` True + + specify "removeFile" $ withTempDir $ \tmpDirP tmpDirFP -> do + Data.ByteString.writeFile (tmpDirFP `combine` nonExistentFP) "" + doesFileExist (tmpDirP nonExistentP) `shouldReturn` True + () <- removeFile (tmpDirP nonExistentP) + doesFileExist (tmpDirP nonExistentP) `shouldReturn` False + + specify "removeDirectory" $ withTempDir $ \tmpDirP tmpDirFP -> do + () <- createDirectory (tmpDirP nonExistentP) + () <- removeDirectory (tmpDirP nonExistentP) + doesDirectoryExist (tmpDirP nonExistentP) + `shouldReturn` False + removeDirectory (tmpDirP nonExistentP) `shouldThrow` \e -> + isDoesNotExistError e + && (ioeGetFileName e == Just (tmpDirFP `combine` nonExistentFP)) + + specify "removeDirectoryRecursively" $ withFixture $ \tmpDirP tmpDirFP -> do + removeDirectoryRecursively tmpDirP + doesPathExist tmpDirP `shouldReturn` False + removeDirectoryRecursively tmpDirP `shouldThrow` \e -> + isDoesNotExistError e && ioeGetFileName e == Just tmpDirFP + + specify "listDirectory" $ withFixture $ \tmpDir _ -> do + result <- listDirectory tmpDir + sort result `shouldBe` [bar, baz, foo] + + describe "listDirectoryRecursively" $ do + specify "basic behavior" $ withFixture $ \tmpDir tmpDir' -> do + () <- Prelude.writeFile (tmpDir' `combine` "bar" `combine` "quux") "" + () <- Prelude.writeFile (tmpDir' `combine` "baz" `combine` "corge") "" + result <- listDirectoryRecursively tmpDir [] + sortOn snd result + `shouldBe` [ (Directory, bar) + , (File, bar quux) + , (Directory, baz) + , (File, baz corge) + , (Directory, baz qux) + , (File, foo) + ] + + it "filters out files by ignorePatterns" $ withFixture $ \tmpDir tmpDir' -> do + () <- Prelude.writeFile (tmpDir' `combine` "bar" `combine` "quux") "" + () <- Prelude.writeFile (tmpDir' `combine` "baz" `combine` "corge") "" + result <- listDirectoryRecursively tmpDir ["bar/q*", "baz"] + sortOn snd result `shouldBe` [(Directory, bar), (File, foo)] + + symIt "distinguishes symlinks from regular files and directories" $ + withFixture $ + \tmpDir tmpDir' -> do + () <- Prelude.writeFile (tmpDir' `combine` "bar" `combine` "quux") "" + () <- createFileLink quux (tmpDir baz corge) + () <- createDirectoryLink baz (tmpDir corge) + result <- listDirectoryRecursively tmpDir [] + sortOn snd result + `shouldBe` [ (Directory, bar) + , (File, bar quux) + , (Directory, baz) + , (Symlink, baz corge) + , (Directory, baz qux) + , (Symlink, corge) + , (File, foo) + ] + + specify "getFileSize" $ withFixture $ \tmpDir tmpDirFP -> do + Data.ByteString.writeFile (tmpDirFP `combine` "foo") "asdf" + getFileSize (tmpDir foo) `shouldReturn` 4 + Left e <- tryError $ getFileSize (tmpDir nonExistentP) + ioeGetErrorType e `shouldBe` doesNotExistErrorType + ioeGetFileName e `shouldBe` Just (tmpDirFP `combine` nonExistentFP) + Left e' <- tryError $ getFileSize tmpDir + ioeGetErrorType e' `shouldBe` InappropriateType + ioeGetLocation e' `shouldBe` "getFileSize" + ioeGetFileName e' `shouldBe` Just tmpDirFP + show e' `shouldContain` "it is a directory" + + describe "DryRunIO" $ do + specify "encodePath" $ hedgehog $ do + filePath <- forAll $ Gen.string (constantFrom 0 0 256) Gen.unicode + filePath' <- liftIO $ dryRunIO (encodePath filePath >>= decodePath) + filePath' === filePath + + describe "isFile" $ do + it "checks an actual file that exists on the real file system" $ do + packageYamlIsFile <- dryRunIO $ isFile packageYamlP + packageYamlIsFile `shouldBe` True + + it "checks an actual directory that exists on the real file system" $ do + testIsFile <- dryRunIO $ isFile testP + testIsFile `shouldBe` False + + it "checks a non-existent file" $ do + nonExistentIsFile <- dryRunIO $ isFile nonExistentP + nonExistentIsFile `shouldBe` False + + it "checks a virtual file (Contents) that exists in memory" $ do + nonExistentIsFile <- dryRunIO $ do + () <- writeFile nonExistentP "" + isFile nonExistentP + nonExistentIsFile `shouldBe` True + + it "checks a virtual file (Copied) that exists in memory" $ do + nonExistentIsFile <- dryRunIO $ do + () <- copyFile packageYamlP nonExistentP + isFile nonExistentP + nonExistentIsFile `shouldBe` True + + it "checks a virtual directory that exists in memory" $ do + nonExistentIsFile <- dryRunIO $ do + () <- createDirectory nonExistentP + isFile nonExistentP + nonExistentIsFile `shouldBe` False + + it "checks a virtual non-existent file" $ do + packageYamlIsFile <- dryRunIO $ do + () <- removeFile packageYamlP + isFile packageYamlP + packageYamlIsFile `shouldBe` False + + describe "isDirectory" $ do + it "check an actual file that exists on the real file system" $ do + packageYamlIsDir <- dryRunIO $ isDirectory packageYamlP + packageYamlIsDir `shouldBe` False + + it "checks an actual directory that exists on the real file system" $ do + testIsDir <- dryRunIO $ isDirectory testP + testIsDir `shouldBe` True + + it "checks a non-existent directory" $ do + nonExistentIsDir <- dryRunIO $ isDirectory nonExistentP + nonExistentIsDir `shouldBe` False + + it "checks a virtual directory that exists in memory" $ do + nonExistentIsDir' <- dryRunIO $ do + () <- createDirectory nonExistentP + isDirectory nonExistentP + nonExistentIsDir' `shouldBe` True + + it "checks a virtual file (Copied) that exists in memory" $ do + nonExistentIsDir'' <- dryRunIO $ do + () <- copyFile packageYamlP nonExistentP + isDirectory nonExistentP + nonExistentIsDir'' `shouldBe` False + + it "checks a virtual file (Contents) that exists in memory" $ do + nonExistentIsDir''' <- dryRunIO $ do + () <- writeFile nonExistentP "" + isDirectory nonExistentP + nonExistentIsDir''' `shouldBe` False + + it "checks a virtual non-existent directory" $ do + packageYamlIsFile <- dryRunIO $ do + () <- removeFile packageYamlP + isDirectory packageYamlP + packageYamlIsFile `shouldBe` False + + describe "isSymlink" $ do + symIt "checks an actual symlink that exists on the real file system" $ + withTempDir $ + \tmpDir tmpDir' -> do + () <- Prelude.writeFile (tmpDir' `combine` "foo") "" + createFileLink foo (tmpDir bar) + dryRunIO (isSymlink $ tmpDir bar) `shouldReturn` True + + it "return False if a path does not exist" $ do + dryRunIO (isSymlink nonExistentP) `shouldReturn` False + + it "checks a virtual file that exists in memory" $ do + nonExistentExists' <- dryRunIO $ do + () <- writeFile nonExistentP "" + isSymlink nonExistentP + nonExistentExists' `shouldBe` False + + describe "exists" $ do + it "checks an actual file that exists on the real file system" $ do + packageYamlExists <- dryRunIO $ exists packageYamlP + packageYamlExists `shouldBe` True + + it "checks an actual directory that exists on the real file system" $ do + testExists <- dryRunIO $ exists testP + testExists `shouldBe` True + + it "checks a non-existent file" $ do + nonExistentExists <- dryRunIO $ exists nonExistentP + nonExistentExists `shouldBe` False + + it "checks a virtual file (Contents) that exists in memory" $ do + nonExistentExists' <- dryRunIO $ do + () <- writeFile nonExistentP "" + exists nonExistentP + nonExistentExists' `shouldBe` True + + it "checks a virtual file (Copied) that exists in memory" $ do + nonExistentExists'' <- dryRunIO $ do + () <- copyFile packageYamlP nonExistentP + exists nonExistentP + nonExistentExists'' `shouldBe` True + + it "checks a virtual directory that exists in memory" $ do + nonExistentExists''' <- dryRunIO $ do + () <- createDirectory nonExistentP + exists nonExistentP + nonExistentExists''' `shouldBe` True + + it "checks a virtual non-existent file" $ do + packageYamlIsFile <- dryRunIO $ do + () <- removeFile packageYamlP + exists packageYamlP + packageYamlIsFile `shouldBe` False + + describe "readFile" $ do + it "can read an actual file that exists on the real file system" $ + withTempDir $ + \tmpDir tmpDir' -> do + () <- Prelude.writeFile (tmpDir' `combine` "foo") "Foo contents" + packageYamlData <- dryRunIO $ readFile $ tmpDir foo + packageYamlData `shouldBe` "Foo contents" + + it "can't read a directory that exists on the real file system" $ do + Left failToReadTest <- tryDryRunIO $ readFile testP + ioeGetErrorType failToReadTest `shouldBe` InappropriateType + ioeGetFileName failToReadTest `shouldBe` Just testFP + + it "can't read a non-existent file" $ do + Left failToReadNonExistent <- tryDryRunIO $ readFile nonExistentP + ioeGetErrorType failToReadNonExistent `shouldBe` doesNotExistErrorType + ioeGetFileName failToReadNonExistent + `shouldBe` Just nonExistentFP + + it "can read a virtual file (Contents) that exists in memory" $ do + nonExistentData <- dryRunIO $ do + () <- writeFile nonExistentP "foo" + readFile nonExistentP + nonExistentData `shouldBe` "foo" + + it "can read a virtual file (Copied) that exists in memory" $ + withTempDir $ + \tmpDir tmpDir' -> do + Prelude.writeFile (tmpDir' `combine` "foo") "Foo contents" + nonExistentData <- dryRunIO $ do + () <- copyFile (tmpDir foo) nonExistentP + () <- writeFile packageYamlP "foo" -- must not affect the result + () <- copyFile nonExistentP nonExistentP' + () <- writeFile nonExistentP "bar" -- must not affect the result + readFile nonExistentP' + nonExistentData `shouldBe` "Foo contents" + + it "can't read a virtual directory that exists in memory" $ do + Left failToReadNonExistent <- tryDryRunIO $ do + () <- createDirectory nonExistentP + readFile nonExistentP + ioeGetErrorType failToReadNonExistent `shouldBe` InappropriateType + ioeGetFileName failToReadNonExistent + `shouldBe` Just nonExistentFP + ioeGetLocation failToReadNonExistent `shouldBe` "readFile" + show failToReadNonExistent `shouldContain` "is a directory" + + it "can't read a virtual non-existent file" $ do + Left failToReadNonExistent <- tryDryRunIO $ do + () <- removeFile packageYamlP + readFile packageYamlP + ioeGetErrorType failToReadNonExistent `shouldBe` doesNotExistErrorType + ioeGetFileName failToReadNonExistent `shouldBe` Just packageYamlFP + ioeGetLocation failToReadNonExistent `shouldBe` "readFile" + show failToReadNonExistent `shouldContain` "no such file" + + describe "writeFile" $ do + it "can write data to an non-existent file" $ do + data' <- dryRunIO $ do + () <- writeFile nonExistentP "foo" + readFile nonExistentP + data' `shouldBe` "foo" + withTempDir $ \tmpDir tmpDir' -> do + () <- Prelude.writeFile (tmpDir' `combine` "foo") "Foo contents" + data'' <- dryRunIO $ do + () <- removeFile $ tmpDir foo + () <- writeFile (tmpDir foo) "bar" + readFile $ tmpDir foo + data'' `shouldBe` "bar" + Prelude.readFile (tmpDir' `combine` "foo") + `shouldReturn` "Foo contents" + + it "can write data to an existing file" $ + withTempDir $ + \tmpDir tmpDir' -> do + () <- Prelude.writeFile (tmpDir' `combine` "foo") "Foo contents" + data' <- dryRunIO $ do + () <- writeFile (tmpDir foo) "modified" + readFile (tmpDir foo) + data' `shouldBe` "modified" + Prelude.readFile (tmpDir' `combine` "foo") + `shouldReturn` "Foo contents" + data'' <- dryRunIO $ do + () <- writeFile nonExistentP "bar" + () <- writeFile nonExistentP "baz" + readFile nonExistentP + data'' `shouldBe` "baz" + doesFileExist nonExistentP `shouldReturn` False + + it "can't write data to a directory" $ do + Left failToWriteToTest <- tryDryRunIO $ writeFile testP "foo" + ioeGetErrorType failToWriteToTest `shouldBe` InappropriateType + ioeGetFileName failToWriteToTest `shouldBe` Just testFP + ioeGetLocation failToWriteToTest `shouldBe` "writeFile" + show failToWriteToTest `shouldContain` "is a directory" + Left failToWriteToTest' <- tryDryRunIO $ do + () <- createDirectory nonExistentP + writeFile nonExistentP "foo" + ioeGetErrorType failToWriteToTest' `shouldBe` InappropriateType + ioeGetFileName failToWriteToTest' `shouldBe` Just nonExistentFP + ioeGetLocation failToWriteToTest' `shouldBe` "writeFile" + show failToWriteToTest' `shouldContain` "is a directory" + + it "can't write data to a file path in a non-existent directory" $ do + Left failToWrite <- tryDryRunIO $ do + writeFile (nonExistentP nonExistentP) "foo" + ioeGetErrorType failToWrite `shouldBe` doesNotExistErrorType + ioeGetFileName failToWrite + `shouldBe` Just (nonExistentFP `combine` nonExistentFP) + ioeGetLocation failToWrite `shouldBe` "writeFile" + show failToWrite `shouldContain` "no parent directory" + Left failToWrite' <- tryDryRunIO $ do + () <- removeFile packageYamlP + writeFile (packageYamlP nonExistentP) "foo" + ioeGetErrorType failToWrite' `shouldBe` doesNotExistErrorType + ioeGetFileName failToWrite' + `shouldBe` Just (packageYamlFP `combine` nonExistentFP) + ioeGetLocation failToWrite' `shouldBe` "writeFile" + show failToWrite' `shouldContain` "no parent directory" + + it "can't write data to a file path inside a non-directory file" $ do + Left failToWrite <- tryDryRunIO $ do + writeFile (packageYamlP nonExistentP) "bar" + ioeGetErrorType failToWrite `shouldBe` InappropriateType + ioeGetFileName failToWrite + `shouldBe` Just (packageYamlFP `combine` nonExistentFP) + ioeGetLocation failToWrite `shouldBe` "writeFile" + show failToWrite `shouldContain` "not inside a directory" + Left failToWrite' <- tryDryRunIO $ do + () <- writeFile nonExistentP "" + writeFile (nonExistentP nonExistentP) "bar" + ioeGetErrorType failToWrite' `shouldBe` InappropriateType + ioeGetFileName failToWrite' + `shouldBe` Just (nonExistentFP `combine` nonExistentFP) + ioeGetLocation failToWrite' `shouldBe` "writeFile" + show failToWrite' `shouldContain` "not inside a directory" + Left failToWrite'' <- tryDryRunIO $ do + () <- copyFile packageYamlP nonExistentP + writeFile (nonExistentP nonExistentP) "bar" + ioeGetErrorType failToWrite'' `shouldBe` InappropriateType + ioeGetFileName failToWrite'' + `shouldBe` Just (nonExistentFP `combine` nonExistentFP) + ioeGetLocation failToWrite'' `shouldBe` "writeFile" + show failToWrite'' `shouldContain` "not inside a directory" + + describe "readSymlinkTarget" $ do + symIt "returns the target path of a symbolic link" $ + withTempDir $ + \tmpDir tmpDir' -> do + () <- Prelude.writeFile (tmpDir' `combine` "foo") "" + createFileLink foo (tmpDir bar) + dryRunIO (readSymlinkTarget $ tmpDir bar) `shouldReturn` foo + + it "fails with non-existent file" $ do + dryRunIO (readSymlinkTarget nonExistentP) `shouldThrow` \e -> + isDoesNotExistError e && ioeGetFileName e == Just nonExistentFP + + it "just fails with any virtual files as they can't be a symlink" $ do + Left failToReadSymlink <- tryDryRunIO $ do + () <- writeFile nonExistentP "" + readSymlinkTarget nonExistentP + ioeGetErrorType failToReadSymlink `shouldBe` InappropriateType + ioeGetFileName failToReadSymlink `shouldBe` Just nonExistentFP + ioeGetLocation failToReadSymlink `shouldBe` "readSymlinkTarget" + show failToReadSymlink `shouldContain` "not a symbolic link" + + it "fails with an overlaid removal tag" $ do + Left failToReadSymlink <- tryDryRunIO $ do + () <- writeFile nonExistentP "" + () <- removeFile nonExistentP + readSymlinkTarget nonExistentP + ioeGetErrorType failToReadSymlink `shouldBe` doesNotExistErrorType + ioeGetFileName failToReadSymlink `shouldBe` Just nonExistentFP + ioeGetLocation failToReadSymlink `shouldBe` "readSymlinkTarget" + show failToReadSymlink `shouldContain` "no such file" + + describe "copyFile" $ do + it "copies a source file to a destination path" $ do + data' <- dryRunIO $ do + () <- copyFile packageYamlP nonExistentP + readFile nonExistentP + packageYamlData <- Data.ByteString.readFile packageYamlFP + data' `shouldBe` packageYamlData + doesFileExist nonExistentP `shouldReturn` False + data'' <- dryRunIO $ do + () <- writeFile nonExistentP "foo" + () <- copyFile nonExistentP nonExistentP' + readFile nonExistentP' + data'' `shouldBe` "foo" + doesFileExist nonExistentP' `shouldReturn` False + data''' <- dryRunIO $ do + () <- copyFile packageYamlP nonExistentP + () <- copyFile nonExistentP nonExistentP' + readFile nonExistentP' + data''' `shouldBe` packageYamlData + doesFileExist nonExistentP' `shouldReturn` False + + it "can copy a source file to an existing file by overwriting it" $ do + data' <- dryRunIO $ do + () <- writeFile nonExistentP "foo" + () <- copyFile packageYamlP nonExistentP + readFile nonExistentP + packageYamlData <- Data.ByteString.readFile packageYamlFP + data' `shouldBe` packageYamlData + doesPathExist nonExistentP `shouldReturn` False + + it "can't copy a non-existent file" $ do + Left failToCopy <- tryDryRunIO $ copyFile nonExistentP nonExistentP' + ioeGetErrorType failToCopy `shouldBe` doesNotExistErrorType + ioeGetFileName failToCopy `shouldBe` Just nonExistentFP + ioeGetLocation failToCopy `shouldBe` "copyFile" + show failToCopy `shouldContain` "source does not exist" + Left failToCopy' <- tryDryRunIO $ do + () <- removeFile packageYamlP + copyFile packageYamlP nonExistentP + ioeGetErrorType failToCopy' `shouldBe` doesNotExistErrorType + ioeGetFileName failToCopy' `shouldBe` Just packageYamlFP + ioeGetLocation failToCopy' `shouldBe` "copyFile" + show failToCopy' `shouldContain` "source does not exist" + + it "can't copy a directory" $ do + Left failToCopy <- tryDryRunIO $ copyFile testP nonExistentP + ioeGetErrorType failToCopy `shouldBe` InappropriateType + ioeGetFileName failToCopy `shouldBe` Just testFP + ioeGetLocation failToCopy `shouldBe` "copyFile" + show failToCopy `shouldContain` "source is a directory" + doesPathExist nonExistentP `shouldReturn` False + Left failToCopy' <- tryDryRunIO $ do + () <- createDirectory nonExistentP + copyFile nonExistentP nonExistentP' + ioeGetErrorType failToCopy' `shouldBe` InappropriateType + ioeGetFileName failToCopy' `shouldBe` Just nonExistentFP + ioeGetLocation failToCopy' `shouldBe` "copyFile" + show failToCopy' `shouldContain` "source is a directory" + doesPathExist nonExistentP' `shouldReturn` False + + it "can't copy a file to a file path that has no parent directory" $ do + Left failToCopy <- tryDryRunIO $ do + copyFile packageYamlP (nonExistentP nonExistentP) + failToCopy `shouldSatisfy` isDoesNotExistError + ioeGetFileName failToCopy + `shouldBe` Just (nonExistentFP `combine` nonExistentFP) + ioeGetLocation failToCopy `shouldBe` "copyFile" + show failToCopy `shouldContain` "no parent directory" + Left failToCopy' <- tryDryRunIO $ do + () <- writeFile nonExistentP "" + () <- removeFile nonExistentP + copyFile packageYamlP (nonExistentP nonExistentP) + failToCopy' `shouldSatisfy` isDoesNotExistError + ioeGetFileName failToCopy' + `shouldBe` Just (nonExistentFP `combine` nonExistentFP) + ioeGetLocation failToCopy' `shouldBe` "copyFile" + show failToCopy' `shouldContain` "no parent directory" + + it "can't copy a file to a file path inside a non-directory path" $ do + Left failToCopy <- tryDryRunIO $ do + copyFile packageYamlP (packageYamlP nonExistentP) + ioeGetErrorType failToCopy `shouldBe` InappropriateType + ioeGetFileName failToCopy + `shouldBe` Just (packageYamlFP `combine` nonExistentFP) + ioeGetLocation failToCopy `shouldBe` "copyFile" + show failToCopy `shouldContain` "not inside a directory" + Left failToCopy' <- tryDryRunIO $ do + () <- writeFile nonExistentP "" + copyFile packageYamlP (nonExistentP nonExistentP) + ioeGetErrorType failToCopy `shouldBe` InappropriateType + ioeGetFileName failToCopy' + `shouldBe` Just (nonExistentFP `combine` nonExistentFP) + ioeGetLocation failToCopy' `shouldBe` "copyFile" + show failToCopy' `shouldContain` "not inside a directory" + Left failToCopy'' <- tryDryRunIO $ do + () <- copyFile packageYamlP nonExistentP + copyFile nonExistentP (nonExistentP nonExistentP) + ioeGetErrorType failToCopy `shouldBe` InappropriateType + ioeGetFileName failToCopy'' + `shouldBe` Just (nonExistentFP `combine` nonExistentFP) + ioeGetLocation failToCopy'' `shouldBe` "copyFile" + show failToCopy'' `shouldContain` "not inside a directory" + + it "can't copy a file to a directory path" $ do + Left failToCopy <- tryDryRunIO $ copyFile packageYamlP testP + ioeGetErrorType failToCopy `shouldBe` InappropriateType + ioeGetFileName failToCopy `shouldBe` Just testFP + ioeGetLocation failToCopy `shouldBe` "copyFile" + show failToCopy `shouldContain` "destination is a directory" + doesDirectoryExist testP `shouldReturn` True + Left failToCopy' <- tryDryRunIO $ do + () <- createDirectory nonExistentP + copyFile packageYamlP nonExistentP + ioeGetErrorType failToCopy' `shouldBe` InappropriateType + ioeGetFileName failToCopy' `shouldBe` Just nonExistentFP + ioeGetLocation failToCopy' `shouldBe` "copyFile" + show failToCopy' `shouldContain` "destination is a directory" + + describe "createDirectory" $ do + it "creates an empty directory" $ do + dryRunIO (createDirectory nonExistentP >> isDirectory nonExistentP) + `shouldReturn` True + + it "can't create a directory inside a non-existent path" $ do + Left failToCreate <- tryDryRunIO $ do + createDirectory (nonExistentP nonExistentP) + ioeGetErrorType failToCreate `shouldBe` doesNotExistErrorType + ioeGetFileName failToCreate + `shouldBe` Just (nonExistentFP `combine` nonExistentFP) + ioeGetLocation failToCreate `shouldBe` "createDirectory" + show failToCreate `shouldContain` "no parent directory" + Left failToCreate' <- tryDryRunIO $ do + () <- writeFile nonExistentP "" + () <- removeFile nonExistentP + createDirectory (nonExistentP nonExistentP) + ioeGetErrorType failToCreate' `shouldBe` doesNotExistErrorType + ioeGetFileName failToCreate' + `shouldBe` Just (nonExistentFP `combine` nonExistentFP) + ioeGetLocation failToCreate' `shouldBe` "createDirectory" + show failToCreate' `shouldContain` "no parent directory" + + it "can't create a directory inside a non-directory path" $ do + Left failToCreate <- tryDryRunIO $ do + createDirectory (packageYamlP nonExistentP) + ioeGetErrorType failToCreate `shouldBe` InappropriateType + ioeGetFileName failToCreate + `shouldBe` Just (packageYamlFP `combine` nonExistentFP) + ioeGetLocation failToCreate `shouldStartWith` "createDirectory" + doesFileExist packageYamlP `shouldReturn` True + Left failToCreate' <- tryDryRunIO $ do + () <- writeFile nonExistentP "" + createDirectory (nonExistentP nonExistentP) + ioeGetErrorType failToCreate' `shouldBe` InappropriateType + ioeGetFileName failToCreate' + `shouldBe` Just (nonExistentFP `combine` nonExistentFP) + ioeGetLocation failToCreate' `shouldStartWith` "createDirectory" + show failToCreate' `shouldContain` "not inside a directory" + Left failToCreate'' <- tryDryRunIO $ do + () <- copyFile packageYamlP nonExistentP + createDirectory (nonExistentP nonExistentP) + ioeGetErrorType failToCreate'' `shouldBe` InappropriateType + ioeGetFileName failToCreate'' + `shouldBe` Just (nonExistentFP `combine` nonExistentFP) + ioeGetLocation failToCreate'' `shouldStartWith` "createDirectory" + show failToCreate'' `shouldContain` "not inside a directory" + + it "can't create a directory by overwriting an existing file" $ do + Left failToCreate <- tryDryRunIO $ do + createDirectory packageYamlP + ioeGetErrorType failToCreate `shouldBe` alreadyExistsErrorType + ioeGetFileName failToCreate `shouldBe` Just packageYamlFP + ioeGetLocation failToCreate `shouldBe` "createDirectory" + show failToCreate `shouldContain` "destination is already a file" + doesFileExist packageYamlP `shouldReturn` True + Left failToCreate' <- tryDryRunIO $ do + () <- writeFile nonExistentP "" + createDirectory nonExistentP + ioeGetErrorType failToCreate' `shouldBe` alreadyExistsErrorType + ioeGetFileName failToCreate' `shouldBe` Just nonExistentFP + ioeGetLocation failToCreate' `shouldBe` "createDirectory" + show failToCreate' `shouldContain` "destination is already a file" + Left failToCreate'' <- tryDryRunIO $ do + () <- copyFile packageYamlP nonExistentP + createDirectory nonExistentP + ioeGetErrorType failToCreate'' `shouldBe` alreadyExistsErrorType + ioeGetFileName failToCreate'' `shouldBe` Just nonExistentFP + ioeGetLocation failToCreate'' `shouldBe` "createDirectory" + show failToCreate'' `shouldContain` "destination is already a file" + + it "can't create a directory if it's already a directory" $ do + Left failToCreate <- tryDryRunIO $ do + createDirectory testP + ioeGetErrorType failToCreate `shouldBe` alreadyExistsErrorType + ioeGetFileName failToCreate `shouldBe` Just testFP + ioeGetLocation failToCreate `shouldBe` "createDirectory" + show failToCreate `shouldContain` "destination is already a directory" + doesDirectoryExist testP `shouldReturn` True + Left failToCreate' <- tryDryRunIO $ do + () <- createDirectory nonExistentP + createDirectory nonExistentP + ioeGetErrorType failToCreate' `shouldBe` alreadyExistsErrorType + ioeGetFileName failToCreate' `shouldBe` Just nonExistentFP + ioeGetLocation failToCreate' `shouldBe` "createDirectory" + show failToCreate' `shouldContain` "destination is already a directory" + + describe "removeFile" $ do + it "removes an existing file" $ do + dryRunIO (removeFile packageYamlP >> exists packageYamlP) + `shouldReturn` False + doesFileExist packageYamlP `shouldReturn` True + fileExists <- dryRunIO $ do + () <- writeFile nonExistentP "" + () <- removeFile nonExistentP + exists nonExistentP + fileExists `shouldBe` False + fileExists' <- dryRunIO $ do + () <- copyFile packageYamlP nonExistentP + () <- removeFile nonExistentP + exists nonExistentP + fileExists' `shouldBe` False + + it "can't remove a non-existent file" $ do + Left failToRemove <- tryDryRunIO $ removeFile nonExistentP + ioeGetErrorType failToRemove `shouldBe` doesNotExistErrorType + ioeGetFileName failToRemove `shouldBe` Just nonExistentFP + ioeGetLocation failToRemove `shouldBe` "removeFile" + show failToRemove `shouldContain` "no such file" + Left failToRemove' <- tryDryRunIO $ do + () <- removeFile packageYamlP + removeFile packageYamlP + ioeGetErrorType failToRemove' `shouldBe` doesNotExistErrorType + ioeGetFileName failToRemove' `shouldBe` Just packageYamlFP + ioeGetLocation failToRemove' `shouldBe` "removeFile" + show failToRemove' `shouldContain` "no such file" + + it "can't remove a directory" $ do + Left failToRemove <- tryDryRunIO $ removeFile testP + ioeGetErrorType failToRemove `shouldBe` InappropriateType + ioeGetFileName failToRemove `shouldBe` Just testFP + ioeGetLocation failToRemove `shouldBe` "removeFile" + show failToRemove `shouldContain` "is a directory" + doesDirectoryExist testP `shouldReturn` True + Left failToRemove' <- tryDryRunIO $ do + () <- createDirectory nonExistentP + removeFile nonExistentP + ioeGetErrorType failToRemove' `shouldBe` InappropriateType + ioeGetFileName failToRemove' `shouldBe` Just nonExistentFP + ioeGetLocation failToRemove' `shouldBe` "removeFile" + show failToRemove' `shouldContain` "is a directory" + + describe "removeDirectory" $ do + it "removes an existing directory" $ do + result <- dryRunIO $ do + createDirectory nonExistentP + removeDirectory nonExistentP + exists nonExistentP + result `shouldBe` False + + it "can't remove a non-existent directory" $ do + Left failToRemove <- tryDryRunIO $ removeDirectory nonExistentP + failToRemove `shouldSatisfy` isDoesNotExistError + ioeGetFileName failToRemove `shouldBe` Just nonExistentFP + Left failToRemove' <- tryDryRunIO $ do + () <- removeFile packageYamlP + removeDirectory packageYamlP + failToRemove' `shouldSatisfy` isDoesNotExistError + ioeGetFileName failToRemove' `shouldBe` Just packageYamlFP + + it "can't remove a non-directory" $ do + Left failToRemove <- tryDryRunIO $ removeDirectory packageYamlP + ioeGetErrorType failToRemove `shouldBe` InappropriateType + ioeGetFileName failToRemove `shouldBe` Just packageYamlFP + doesFileExist packageYamlP `shouldReturn` True + Left failToRemove' <- tryDryRunIO $ do + () <- writeFile nonExistentP "" + removeDirectory nonExistentP + ioeGetErrorType failToRemove' `shouldBe` InappropriateType + ioeGetFileName failToRemove' `shouldBe` Just nonExistentFP + Left failToRemove'' <- tryDryRunIO $ do + () <- copyFile packageYamlP nonExistentP + removeDirectory nonExistentP + ioeGetErrorType failToRemove'' `shouldBe` InappropriateType + ioeGetFileName failToRemove'' `shouldBe` Just nonExistentFP + + describe "removeDirectoryRecursively" $ do + it "removes an existing directory recursively" $ do + result <- dryRunIO $ do + createDirectory nonExistentP + writeFile (nonExistentP foo) "" + createDirectory (nonExistentP bar) + writeFile (nonExistentP bar baz) "" + removeDirectoryRecursively nonExistentP + exists nonExistentP + result `shouldBe` False + + it "can't remove a non-existent directory" $ do + Left failToRemove <- tryDryRunIO $ do + removeDirectoryRecursively nonExistentP + failToRemove `shouldSatisfy` isDoesNotExistError + ioeGetFileName failToRemove `shouldBe` Just nonExistentFP + Left failToRemove' <- tryDryRunIO $ do + () <- removeFile packageYamlP + removeDirectoryRecursively packageYamlP + failToRemove' `shouldSatisfy` isDoesNotExistError + ioeGetFileName failToRemove' `shouldBe` Just packageYamlFP + + it "can't remove a non-directory" $ do + Left failToRemove <- tryDryRunIO $ removeDirectoryRecursively packageYamlP + ioeGetErrorType failToRemove `shouldBe` InappropriateType + ioeGetLocation failToRemove + `shouldStartWith` "removeDirectoryRecursively" + ioeGetFileName failToRemove `shouldBe` Just packageYamlFP + doesFileExist packageYamlP `shouldReturn` True + Left failToRemove' <- tryDryRunIO $ do + () <- writeFile nonExistentP "" + removeDirectoryRecursively nonExistentP + ioeGetErrorType failToRemove' `shouldBe` InappropriateType + ioeGetLocation failToRemove' + `shouldStartWith` "removeDirectoryRecursively" + ioeGetFileName failToRemove' `shouldBe` Just nonExistentFP + Left failToRemove'' <- tryDryRunIO $ do + () <- copyFile packageYamlP nonExistentP + removeDirectoryRecursively nonExistentP + ioeGetErrorType failToRemove'' `shouldBe` InappropriateType + ioeGetLocation failToRemove'' + `shouldStartWith` "removeDirectoryRecursively" + ioeGetFileName failToRemove'' `shouldBe` Just nonExistentFP + + describe "createDirectories" $ do + it "creates a directory and its ancestors if needed" $ do + result <- dryRunIO $ do + () <- createDirectories (nonExistentP nonExistentP) + isDirectory (nonExistentP nonExistentP) + result `shouldBe` True + doesDirectoryExist nonExistentP `shouldReturn` False + + it "can't create a directory if any of its ancestors is a file" $ do + Left failToCreate <- tryDryRunIO $ do + createDirectories (packageYamlP nonExistentP nonExistentP) + ioeGetErrorType failToCreate `shouldBe` InappropriateType + ioeGetFileName failToCreate `shouldBe` Just packageYamlFP + ioeGetLocation failToCreate `shouldStartWith` "createDirectories" + show failToCreate + `shouldContain` "one of its ancestors is a non-directory file" + + describe "listDirectory" $ do + it "lists direct children in a directory" $ do + withFixture $ \tmpDir tmpDir' -> do + result <- dryRunIO $ listDirectory tmpDir + result `shouldBe` [bar, baz, foo] + () <- Prelude.writeFile (tmpDir' `combine` "corge") "" + result' <- dryRunIO $ do + () <- writeFile (tmpDir qux) "" + () <- createDirectory (tmpDir quux) + () <- writeFile (tmpDir corge) "" + () <- writeFile (dropFileName tmpDir foo) "" + listDirectory tmpDir + result' `shouldBe` [bar, baz, corge, foo, quux, qux] + + it "lists direct children in a virtual directory" $ do + result <- dryRunIO $ do + () <- createDirectory nonExistentP + () <- writeFile (nonExistentP foo) "" + () <- createDirectory (nonExistentP bar) + () <- createDirectory (nonExistentP baz) + () <- createDirectory (nonExistentP baz qux) + listDirectory nonExistentP + result `shouldBe` [bar, baz, foo] + + it "hides removed files in the sandbox" $ withFixture $ \tmpDir _ -> do + result <- dryRunIO $ do + () <- removeFile (tmpDir foo) + listDirectory tmpDir + result `shouldBe` [bar, baz] + + it "fails if a specified path does not exist" $ do + Left e <- tryDryRunIO $ listDirectory nonExistentP + e `shouldSatisfy` isDoesNotExistError + ioeGetFileName e `shouldBe` Just nonExistentFP + ioeGetErrorType e `shouldBe` doesNotExistErrorType + ioeGetLocation e `shouldStartWith` "listDirectory" + Left e' <- tryDryRunIO $ do + () <- removeFile packageYamlP + listDirectory packageYamlP + e' `shouldSatisfy` isDoesNotExistError + ioeGetFileName e' `shouldBe` Just packageYamlFP + ioeGetLocation e' `shouldStartWith` "listDirectory" + show e' `shouldContain` "no such directory" + + it "fails if a specified path is a regular file" $ do + Left e <- tryDryRunIO $ listDirectory packageYamlP + ioeGetErrorType e `shouldBe` InappropriateType + ioeGetFileName e `shouldBe` Just packageYamlFP + ioeGetLocation e `shouldBe` "listDirectory" + Left e' <- tryDryRunIO $ do + () <- writeFile nonExistentP "" + listDirectory nonExistentP + ioeGetErrorType e' `shouldBe` InappropriateType + ioeGetFileName e' `shouldBe` Just nonExistentFP + ioeGetLocation e' `shouldBe` "listDirectory" + show e' `shouldContain` "not a directory" + Left e'' <- tryDryRunIO $ do + () <- copyFile packageYamlP nonExistentP + listDirectory nonExistentP + ioeGetErrorType e'' `shouldBe` InappropriateType + ioeGetFileName e'' `shouldBe` Just nonExistentFP + ioeGetLocation e'' `shouldBe` "listDirectory" + show e'' `shouldContain` "not a directory" + + describe "getFileSize" $ do + it "returns the size of a file" $ withTempDir $ \tmpDir tmpDirFP -> do + Data.ByteString.writeFile (tmpDirFP `combine` "foo") "asdf" + dryRunIO (getFileSize $ tmpDir foo) `shouldReturn` 4 + size <- dryRunIO $ do + () <- writeFile (tmpDir bar) "asdf asdf" + getFileSize $ tmpDir bar + size `shouldBe` 9 + size' <- dryRunIO $ do + () <- writeFile (tmpDir bar) "asdf" + () <- copyFile (tmpDir bar) (tmpDir baz) + getFileSize $ tmpDir baz + size' `shouldBe` 4 + + it "fails if path doesn't exist" $ withTempDir $ \tmpDir tmpDirFP -> do + Left e <- tryDryRunIO $ getFileSize $ tmpDir nonExistentP + ioeGetErrorType e `shouldBe` doesNotExistErrorType + ioeGetFileName e `shouldBe` Just (tmpDirFP `combine` nonExistentFP) + ioeGetLocation e `shouldBe` "getFileSize" + Left e' <- tryDryRunIO $ do + () <- removeFile packageYamlP + getFileSize packageYamlP + ioeGetErrorType e' `shouldBe` doesNotExistErrorType + ioeGetFileName e' `shouldBe` Just packageYamlFP + ioeGetLocation e' `shouldBe` "getFileSize" + show e' `shouldContain` "does not exist" + + it "fails if path is a directory" $ withTempDir $ \tmpDir tmpDirFP -> do + Left e <- tryDryRunIO $ getFileSize tmpDir + ioeGetErrorType e `shouldBe` InappropriateType + ioeGetFileName e `shouldBe` Just tmpDirFP + ioeGetLocation e `shouldBe` "getFileSize" + show e `shouldContain` "not a regular file, but a directory" + Left e' <- tryDryRunIO $ do + () <- createDirectory nonExistentP + getFileSize nonExistentP + ioeGetErrorType e' `shouldBe` InappropriateType + ioeGetFileName e' `shouldBe` Just nonExistentFP + ioeGetLocation e' `shouldBe` "getFileSize" + show e' `shouldContain` "not a regular file, but a directory" diff --git a/test/Dojang/Syntax/EnvSpec.hs b/test/Dojang/Syntax/EnvSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Syntax/EnvSpec.hs @@ -0,0 +1,18 @@ +module Dojang.Syntax.EnvSpec (spec) where + +import Test.Hspec (Spec, specify) +import Test.Hspec.Hedgehog (annotateShow, forAll, hedgehog, (===)) + +import Dojang.Syntax.Env (readEnvironment, writeEnvironment) +import Dojang.Types.Gen as Gen (environment) + + +spec :: Spec +spec = do + specify "writeEnvironment & readEnvironment" $ hedgehog $ do + env <- forAll Gen.environment + let toml = writeEnvironment env + annotateShow toml + let parsed = readEnvironment toml + annotateShow parsed + parsed === Right (env, []) diff --git a/test/Dojang/Syntax/EnvironmentPredicate/ParserSpec.hs b/test/Dojang/Syntax/EnvironmentPredicate/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Syntax/EnvironmentPredicate/ParserSpec.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Dojang.Syntax.EnvironmentPredicate.ParserSpec (spec) where + +import Dojang.Syntax.EnvironmentPredicate.Parser + ( Field (..) + , FieldOp (..) + , andExpression + , bareStringLiteral + , charactersInStringLiteral + , doubleQuoteStringLiteral + , equalOp + , errorBundlePretty + , expression + , field + , fieldOp + , inOp + , notEqualOp + , notInOp + , parseEnvironmentPredicate + , prefixOp + , simpleExpression + , singleQuoteStringLiteral + , stringLiteral + , strings + , suffixOp + ) +import Dojang.Types.Environment (Architecture (..), OperatingSystem (..)) +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..)) +import Dojang.Types.MonikerName (parseMonikerName) + +import Control.Monad (forM_) +import Data.Text (singleton) +import Test.Hspec (Spec, specify) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.Megaparsec + ( eeof + , elabel + , err + , etok + , etoks + , shouldFailWith + , shouldParse + , ueof + , utok + , utoks + ) +import Text.Megaparsec (eof, parse) + + +deriving instance Show Field +deriving instance Eq FieldOp +deriving instance Show FieldOp + + +spec :: Spec +spec = do + specify "expression" $ do + let p = expression <* eof + parse p "" "os=linux" `shouldParse` OperatingSystem Linux + parse p "" "os=windows || arch=aarch64" + `shouldParse` Or [OperatingSystem Windows, Architecture AArch64] + parse p "" " os=linux && arch=x86 || os=macos && arch=aarch64 " + `shouldParse` Or + [ And [OperatingSystem Linux, Architecture X86] + , And [OperatingSystem MacOS, Architecture AArch64] + ] + parse p "" "os=linux && ( arch=x86 || os=macos ) && arch=aarch64" + `shouldParse` And + [ OperatingSystem Linux + , Or [Architecture X86, OperatingSystem MacOS] + , Architecture AArch64 + ] + + specify "andExpression" $ do + let p = andExpression <* eof + parse p "" "os=linux&&arch=aarch64" + `shouldParse` And [OperatingSystem Linux, Architecture AArch64] + parse p "" " ( always ) && ( always )" `shouldParse` And [Always, Always] + + specify "simpleExpression" $ do + let p = simpleExpression <* eof + parse p "" "os=linux" `shouldParse` OperatingSystem Linux + parse p "" "(os = windows)" `shouldParse` OperatingSystem Windows + parse p "" " ( os == macos ) " `shouldParse` OperatingSystem MacOS + parse p "" "always" `shouldParse` Always + parse p "" "never" `shouldParse` Not Always + parse p "" "!(arch = x86)" `shouldParse` Not (Architecture X86) + parse p "" "!(arch == 'x86_64')" + `shouldParse` Not (Architecture X86_64) + parse p "" "! ( arch != aarch64 )" + `shouldParse` Not (Not (Architecture AArch64)) + + specify "fieldOp" $ do + let p = fieldOp <* eof + parse p "" "os=linux" `shouldParse` OperatingSystem Linux + parse p "" " arch = 'x86_64' " `shouldParse` Architecture X86_64 + parse p "" "kernel = Darwin" `shouldParse` KernelName "Darwin" + parse p "" "kernel-release=\"1.2.3\"" `shouldParse` KernelRelease "1.2.3" + let Right fooBar = parseMonikerName "foo-bar" + parse p "" " moniker == \"foo-bar\" " `shouldParse` Moniker fooBar + parse p "" " moniker = 'invalid moniker' " `shouldParse` Not Always + parse p "" " os != \"windows\" " `shouldParse` Not (OperatingSystem Windows) + parse p "" "arch!=aarch64" `shouldParse` Not (Architecture AArch64) + parse p "" "kernel != Linux" `shouldParse` Not (KernelName "Linux") + parse p "" "kernel-release!='4.5.6'" + `shouldParse` Not (KernelRelease "4.5.6") + parse p "" "moniker!='foo-bar'" `shouldParse` Not (Moniker fooBar) + parse p "" "kernel-release ^= '1.2'" `shouldParse` KernelReleasePrefix "1.2" + parse p "" "kernel-release$='2.3'" `shouldParse` KernelReleaseSuffix "2.3" + parse p "" "os in ()" `shouldParse` Not Always + parse p "" " arch in ( x86, \"x86_64\", ) " + `shouldParse` Or [Architecture X86, Architecture X86_64] + let Right baz = parseMonikerName "baz" + parse p "" "moniker in (\"foo-bar\", baz)" + `shouldParse` Or [Moniker fooBar, Moniker baz] + parse p "" "os not in (linux, macos,)" + `shouldParse` And + [ Not $ OperatingSystem Linux + , Not $ OperatingSystem MacOS + ] + parse p "" " arch not in () " `shouldParse` Always + parse p "" "moniker not in ('foo-bar', baz,)" + `shouldParse` And [Not $ Moniker fooBar, Not $ Moniker baz] + parse p "" "os ^= lin" + `shouldFailWith` err + 3 + ( utoks "^= " + <> etoks "!=" + <> etoks "in" + <> etoks "not" + <> etoks "=" + <> elabel "white space" + ) + + specify "equalOp" $ do + let p = equalOp <* eof + parse p "" "=foo" `shouldParse` EqualOp "foo" + parse p "" "==bar" `shouldParse` EqualOp "bar" + parse p "" " = foo" `shouldParse` EqualOp "foo" + parse p "" " == bar" `shouldParse` EqualOp "bar" + parse p "" "='foo bar'" `shouldParse` EqualOp "foo bar" + parse p "" " = \"foo bar\"" `shouldParse` EqualOp "foo bar" + parse p "" "=" + `shouldFailWith` err + 1 + (ueof <> etok '=' <> elabel "white space" <> elabel "string literal") + parse p "" "= " + `shouldFailWith` err + 2 + (ueof <> elabel "white space" <> elabel "string literal") + parse p "" "= = foo" + `shouldFailWith` err + 2 + (utok '=' <> elabel "white space" <> elabel "string literal") + + specify "notEqualOp" $ do + let p = notEqualOp <* eof + parse p "" "!=foo" `shouldParse` NotEqualOp "foo" + parse p "" " != foo" `shouldParse` NotEqualOp "foo" + parse p "" "!='foo bar'" `shouldParse` NotEqualOp "foo bar" + parse p "" " != \"foo bar\"" `shouldParse` NotEqualOp "foo bar" + parse p "" "!=" + `shouldFailWith` err + 2 + (ueof <> elabel "white space" <> elabel "string literal") + parse p "" "!= " + `shouldFailWith` err + 3 + (ueof <> elabel "white space" <> elabel "string literal") + parse p "" "! = foo" + `shouldFailWith` err + 0 + (utoks "! " <> elabel "white space" <> etoks "!=") + + specify "prefixOp" $ do + let p = prefixOp <* eof + parse p "" "^=foo" `shouldParse` PrefixOp "foo" + parse p "" " ^= foo" `shouldParse` PrefixOp "foo" + parse p "" "^='foo bar'" `shouldParse` PrefixOp "foo bar" + parse p "" " ^= \"foo bar\"" `shouldParse` PrefixOp "foo bar" + parse p "" "^=" + `shouldFailWith` err + 2 + (ueof <> elabel "white space" <> elabel "string literal") + parse p "" "^= " + `shouldFailWith` err + 3 + (ueof <> elabel "white space" <> elabel "string literal") + parse p "" "^ = foo" + `shouldFailWith` err + 0 + (utoks "^ " <> elabel "white space" <> etoks "^=") + + specify "suffixOp" $ do + let p = suffixOp <* eof + parse p "" "$=foo" `shouldParse` SuffixOp "foo" + parse p "" " $= foo" `shouldParse` SuffixOp "foo" + parse p "" "$='foo bar'" `shouldParse` SuffixOp "foo bar" + parse p "" " $= \"foo bar\"" `shouldParse` SuffixOp "foo bar" + parse p "" "$=" + `shouldFailWith` err + 2 + (ueof <> elabel "white space" <> elabel "string literal") + parse p "" "$= " + `shouldFailWith` err + 3 + (ueof <> elabel "white space" <> elabel "string literal") + parse p "" "$ = foo" + `shouldFailWith` err + 0 + (utoks "$ " <> elabel "white space" <> etoks "$=") + + specify "inOp" $ do + let p = inOp <* eof + parse p "" " in ()" `shouldParse` InOp [] + parse p "" " in (foo)" `shouldParse` InOp ["foo"] + parse p "" " in (foo, bar,) " `shouldParse` InOp ["foo", "bar"] + parse p "" "in ()" `shouldFailWith` err 0 (utok 'i' <> elabel "white space") + parse p "" " in" + `shouldFailWith` err 3 (ueof <> etok '(' <> elabel "white space") + parse p "" " in " + `shouldFailWith` err 4 (ueof <> etok '(' <> elabel "white space") + parse p "" " in (" + `shouldFailWith` err + 5 + (ueof <> etok ')' <> elabel "string literal" <> elabel "white space") + + specify "notInOp" $ do + let p = notInOp <* eof + parse p "" " not in ()" `shouldParse` NotInOp [] + parse p "" " not in (foo)" `shouldParse` NotInOp ["foo"] + parse p "" " not in (foo, bar,) " `shouldParse` NotInOp ["foo", "bar"] + parse p "" "not in ()" + `shouldFailWith` err 0 (utok 'n' <> elabel "white space") + parse p "" " not" `shouldFailWith` err 4 (ueof <> elabel "white space") + parse p "" " not " + `shouldFailWith` err 5 (ueof <> etoks "in" <> elabel "white space") + parse p "" " not in" + `shouldFailWith` err 7 (ueof <> etok '(' <> elabel "white space") + parse p "" " not in " + `shouldFailWith` err 8 (ueof <> etok '(' <> elabel "white space") + parse p "" " not in (" + `shouldFailWith` err + 9 + (ueof <> etok ')' <> elabel "string literal" <> elabel "white space") + + specify "strings" $ do + let p = strings <* eof + parse p "" "(foo, 'bar', \"baz\")" `shouldParse` ["foo", "bar", "baz"] + parse p "" "('foo bar', \"baz qux\",)" `shouldParse` ["foo bar", "baz qux"] + parse p "" "( 'foo bar' , )" `shouldParse` ["foo bar"] + parse p "" "" + `shouldFailWith` err 0 (ueof <> etok '(' <> elabel "white space") + parse p "" "(foo" + `shouldFailWith` err + 4 + (ueof <> etok ')' <> etok ',' <> elabel "white space") + parse p "" "(foo, " + `shouldFailWith` err + 6 + (ueof <> etok ')' <> elabel "string literal" <> elabel "white space") + + specify "field" $ do + let p = field <* eof + parse p "" "os" `shouldParse` OS + parse p "" "arch" `shouldParse` Arch + parse p "" "kernel" `shouldParse` Kernel + parse p "" "kernel-release" `shouldParse` KernelRelease' + parse p "" "moniker" `shouldParse` Moniker' + parse p "" "foo" + `shouldFailWith` err + 0 + ( utoks "foo" + <> etoks "arch" + <> etoks "kernel" + <> etoks "kernel-release" + <> etoks "moniker" + <> etoks "os" + ) + + specify "stringLiteral" $ do + let p = stringLiteral <* eof + parse p "" "foo" `shouldParse` "foo" + parse p "" "'foo'" `shouldParse` "foo" + parse p "" "\"foo\"" `shouldParse` "foo" + parse p "" "foo bar" + `shouldFailWith` err 4 (utok 'b' <> eeof <> elabel "white space") + parse p "" "'foo bar'" `shouldParse` "foo bar" + parse p "" "\"foo bar\"" `shouldParse` "foo bar" + + specify "bareStringLiteral" $ do + let p = bareStringLiteral <* eof + parse p "" "foo" `shouldParse` "foo" + parse p "" "foo123" `shouldParse` "foo123" + parse p "" "" `shouldFailWith` err 0 (ueof <> elabel "bare string literal") + parse p "" "123foo" + `shouldFailWith` err 0 (utok '1' <> elabel "bare string literal") + parse p "" "foo bar" `shouldFailWith` err 3 (utok ' ' <> eeof) + parse p "" "foo-bar" `shouldFailWith` err 3 (utok '-' <> eeof) + parse p "" "foo_bar" `shouldFailWith` err 3 (utok '_' <> eeof) + parse p "" "foo.bar" `shouldFailWith` err 3 (utok '.' <> eeof) + + specify "doubleQuoteStringLiteral" $ do + let p = doubleQuoteStringLiteral <* eof + parse p "" "\"foo\"" `shouldParse` "foo" + parse p "" "\"foo bar\"" `shouldParse` "foo bar" + parse p "" "\"\\\"Hello\\'\\n\\\\\"" `shouldParse` "\"Hello'\n\\" + parse p "" "foo" + `shouldFailWith` err 0 (utok 'f' <> elabel "double quote string literal") + parse p "" "\"foo" + `shouldFailWith` err + 4 + (ueof <> etok '"' <> etok '\\' <> elabel "string character") + + specify "singleQuoteStringLiteral" $ do + let p = singleQuoteStringLiteral <* eof + parse p "" "'foo'" `shouldParse` "foo" + parse p "" "'foo bar'" `shouldParse` "foo bar" + parse p "" "'\\\"Hello\\'\\n\\\\'" `shouldParse` "\"Hello'\n\\" + parse p "" "foo" + `shouldFailWith` err 0 (utok 'f' <> elabel "single quote string literal") + parse p "" "'foo" + `shouldFailWith` err + 4 + (ueof <> etok '\'' <> etok '\\' <> elabel "string character") + + forM_ (['\'', '"'] :: [Char]) $ \terminal -> do + specify ("charactersInStringLiteral " ++ show terminal) $ do + let p = charactersInStringLiteral terminal <* eof + parse p "" "foo" `shouldParse` "foo" + parse p "" "foo bar" `shouldParse` "foo bar" + parse p "" "\\\"Hello\\'\\n\\\\" `shouldParse` "\"Hello'\n\\" + parse p "" "\\b\\f\\n\\r\\t\\v\\0" `shouldParse` "\b\f\n\r\t\v\0" + parse p "" "\\x41\\x42\\x43\\x44" `shouldParse` "ABCD" + parse p "" "\\u0045\\u0046\\u0047\\u0048" `shouldParse` "EFGH" -- cSpell: disable-line + parse p "" "\\U00000049\\U0000004A\\U0000004b" `shouldParse` "IJK" + parse p "" "\\" + `shouldFailWith` err + 1 + ( (ueof <> etok '"' <> etok '\'' <> etok '0' <> etok 'U' <> etok '\\') + <> (etok 'b' <> etok 'f' <> etok 'n' <> etok 'r' <> etok 't') + <> (etok 'u' <> etok 'v' <> etok 'x') + ) + parse p "" (singleton terminal) + `shouldFailWith` err + 0 + (utok terminal <> etok '\\' <> eeof <> elabel "string character") + + specify "errorBundlePretty" $ do + let Left e = parseEnvironmentPredicate "" "invalid" + errorBundlePretty e + `shouldBe` ":1:1:\n" + <> " |\n" + <> "1 | invalid\n" + <> " | ^^^^^^^\n" + <> "unexpected \"invalid\"\n" + <> "expecting expression\n" diff --git a/test/Dojang/Syntax/EnvironmentPredicate/WriterSpec.hs b/test/Dojang/Syntax/EnvironmentPredicate/WriterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Syntax/EnvironmentPredicate/WriterSpec.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Syntax.EnvironmentPredicate.WriterSpec (spec) where + +import Data.Text (Text, unpack) +import Test.Hspec (Spec, describe, it, specify) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.Hedgehog (annotateShow, footnote, forAll, hedgehog, (===)) + +import Dojang.Syntax.EnvironmentPredicate.Parser + ( errorBundlePretty + , parseEnvironmentPredicate + ) +import Dojang.Syntax.EnvironmentPredicate.Writer (writeEnvironmentPredicate) +import Dojang.Types.EnvironmentPredicate + ( EnvironmentPredicate (..) + , normalizePredicate + ) +import Dojang.Types.Gen qualified as Gen +import Dojang.Types.MonikerName (parseMonikerName) + + +write :: EnvironmentPredicate -> Text +write = writeEnvironmentPredicate + + +spec :: Spec +spec = do + describe "writeEnvironmentPredicate" $ do + specify "simple expressions" $ do + write Always `shouldBe` "always" + write (Not Always) `shouldBe` "never" + write (OperatingSystem "linux") `shouldBe` "os = linux" + write (Architecture "x86_64") + `shouldBe` "arch = \"x86_64\"" + let Right fooBar = parseMonikerName "foo-bar" + write (Moniker fooBar) `shouldBe` "moniker = \"foo-bar\"" + + it "escape special characters in string literal" $ do + write (OperatingSystem "\\'\"\b\f\n\r\t\v\0\x01\xff\xffff") + `shouldBe` "os = \"\\\\'\\\"\\b\\f\\n\\r\\t\\v\\0\\x01\\xff\\uffff\"" + write (OperatingSystem "\\'\b\f\n\r\t\v\0\x01\xff\xffff") + `shouldBe` "os = \"\\\\'\\b\\f\\n\\r\\t\\v\\0\\x01\\xff\\uffff\"" + + specify "string literal is around by quotes if needed" $ do + write (OperatingSystem "test") `shouldBe` "os = test" + write (OperatingSystem "te st") `shouldBe` "os = \"te st\"" + write (OperatingSystem "") `shouldBe` "os = \"\"" + + specify "string literal is around by single quotes if it has double quote" $ + do + write (OperatingSystem "\"test\"") `shouldBe` "os = '\"test\"'" + write (OperatingSystem "\"test'") `shouldBe` "os = \"\\\"test'\"" + + specify "homogenous predicates in Or are expressed using in operator" $ do + write (Or [OperatingSystem "linux", OperatingSystem "macos"]) + `shouldBe` "os in (linux, macos)" + write (Or [Architecture "x86_64", Architecture "aarch64"]) + `shouldBe` "arch in (\"x86_64\", aarch64)" + let Right foo = parseMonikerName "foo" + let Right bar = parseMonikerName "bar" + write (Or [Moniker foo, Moniker bar]) `shouldBe` "moniker in (foo, bar)" + + specify + ( "homogenous negative predicates in And are expressed using " + ++ "not in operator" + ) + $ do + write + (And [Not $ OperatingSystem "linux", Not $ OperatingSystem "macos"]) + `shouldBe` "os not in (linux, macos)" + write (And [Not $ Architecture "x86_64", Not $ Architecture "aarch64"]) + `shouldBe` "arch not in (\"x86_64\", aarch64)" + let Right foo = parseMonikerName "foo" + let Right bar = parseMonikerName "bar" + write (And [Not $ Moniker foo, Not $ Moniker bar]) + `shouldBe` "moniker not in (foo, bar)" + + it "properly wrap sub-expressions with parentheses" $ do + let Right foo = parseMonikerName "foo" + let Right bar = parseMonikerName "bar" + write + ( And + [ Or [OperatingSystem "linux", Architecture "aarch64"] + , Or [Moniker foo, Moniker bar] + ] + ) + `shouldBe` "(os = linux || arch = aarch64) && moniker in (foo, bar)" + + specify "yields what parseEnvironmentPredicate can parse" $ hedgehog $ do + predicate <- normalizePredicate <$> forAll Gen.environmentPredicate + let predText = write predicate + annotateShow predText + let parseResult = parseEnvironmentPredicate "test" predText + case parseResult of + Left err -> footnote $ unpack $ errorBundlePretty err + Right _ -> return () + let Right pred' = parseResult + pred' === predicate diff --git a/test/Dojang/Syntax/FilePathExpression/ParserSpec.hs b/test/Dojang/Syntax/FilePathExpression/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Syntax/FilePathExpression/ParserSpec.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Syntax.FilePathExpression.ParserSpec (spec) where + +import Control.Monad (forM_) +import Prelude hiding (unlines) + +import Data.Text (unlines) +import Test.Hspec (Spec, specify) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.Megaparsec + ( eeof + , elabel + , err + , etok + , etoks + , shouldFailWith + , shouldParse + , ueof + , utok + , utoks + ) +import Text.Megaparsec (eof, parse) + +import Dojang.Syntax.FilePathExpression.Parser + ( bareComponent + , environmentVariable + , errorBundlePretty + , filePathExpression + , filePathExpression' + , parseFilePathExpression + , root + , substitution + , substitutionConditional + , substitutionDefault + , substitutionInBraces + , substitutionModifierAfterColon + ) +import Dojang.Types.FilePathExpression (FilePathExpression (..), (+/+)) + + +spec :: Spec +spec = do + specify "environmentVariable" $ do + let environmentVariable' = environmentVariable <* eof + parse environmentVariable' "" "FOO_BAR" `shouldParse` "FOO_BAR" + parse environmentVariable' "" "foo_bar" `shouldParse` "foo_bar" + parse environmentVariable "" "_BAR_123" `shouldParse` "_BAR_123" + parse environmentVariable "" "123_FOO" + `shouldFailWith` err 0 (utok '1' <> elabel "environment variable") + parse environmentVariable "" "-FOO" + `shouldFailWith` err 0 (utok '-' <> elabel "environment variable") + parse environmentVariable' "" "FOO-BAR" + `shouldFailWith` err 3 (utok '-' <> eeof) + parse environmentVariable "" "甲_乙" + `shouldFailWith` err 0 (utok '甲' <> elabel "environment variable") + parse environmentVariable' "" "FOO_乙" + `shouldFailWith` err 4 (utok '乙' <> eeof) + parse environmentVariable "" "" + `shouldFailWith` err 0 (ueof <> elabel "environment variable") + + specify "bareComponent" $ do + let bareComponent' = bareComponent "" <* eof + parse bareComponent' "" "foo" `shouldParse` BareComponent "foo" + parse bareComponent' "" "123" `shouldParse` BareComponent "123" + parse bareComponent' "" "甲" `shouldParse` BareComponent "甲" + parse bareComponent' "" "123-foo-乙" + `shouldParse` BareComponent "123-foo-乙" + parse (bareComponent "") "" "/foo" + `shouldFailWith` err + 0 + (utok '/' <> elabel "component") + parse bareComponent' "" "foo/" + `shouldFailWith` err + 3 + (utok '/' <> elabel "component" <> eeof) + parse bareComponent' "" "" + `shouldFailWith` err + 0 + (ueof <> elabel "component") + + specify "root" $ do + let root' = root <* eof + parse root' "" "/" `shouldParse` Root Nothing + parse root' "" "C:\\" `shouldParse` Root (Just 'C') + parse root' "" "C:/" `shouldParse` Root (Just 'C') + parse root "" "" + `shouldFailWith` err 0 (ueof <> etok '/' <> elabel "drive letter") + parse root "" "C" `shouldFailWith` err 1 (ueof <> etok ':') + + specify "substitution" $ do + let substitution' = substitution <* eof + parse substitution' "" "$FOO" `shouldParse` Substitution "FOO" + parse substitution' "" "$FOO_BAR" `shouldParse` Substitution "FOO_BAR" + parse substitution "" "" + `shouldFailWith` err 0 (ueof <> etok '$') + parse substitution "" "FOO" + `shouldFailWith` err 0 (utok 'F' <> etok '$') + parse substitution' "" "$FOO-" + `shouldFailWith` err 4 (utok '-' <> eeof) + + trueFalse $ \begin -> specify ("substitutionDefault " ++ show begin) $ do + let substitutionDefault' env = substitutionDefault begin env <* eof + parse (substitutionDefault' "FOO") "" "-bar" + `shouldParse` SubstitutionWithDefault "FOO" (BareComponent "bar") + parse (substitutionDefault' "FOO") "" "-bar${BAZ}qux" + `shouldParse` SubstitutionWithDefault + "FOO" + ( Concatenation + (Concatenation (BareComponent "bar") (Substitution "BAZ")) + $ BareComponent "qux" + ) + parse (substitutionDefault begin "FOO") "" "" + `shouldFailWith` err 0 (ueof <> etok '-') + parse (substitutionDefault begin "FOO") "" "+bar" + `shouldFailWith` err 0 (utok '+' <> etok '-') + parse (substitutionDefault' "FOO") "" "-$BAR}" + `shouldFailWith` err + 5 + ( utok '}' + <> etoks "${" + <> etok '$' + <> elabel "component" + <> eeof + ) + parse (substitutionDefault' "FOO") "" "-${BAR}}" + `shouldFailWith` err + 7 + ( utok '}' + <> etoks "${" + <> etok '$' + <> elabel "component" + <> eeof + ) + + trueFalse $ \begin -> specify ("substitutionConditional " ++ show begin) $ do + let substitutionConditional' env = substitutionConditional begin env <* eof + parse (substitutionConditional' "FOO") "" "+bar" + `shouldParse` ConditionalSubstitution "FOO" (BareComponent "bar") + parse (substitutionConditional' "FOO") "" "+bar${BAZ}qux" + `shouldParse` ConditionalSubstitution + "FOO" + ( Concatenation + (Concatenation (BareComponent "bar") (Substitution "BAZ")) + $ BareComponent "qux" + ) + parse (substitutionConditional begin "FOO") "" "" + `shouldFailWith` err 0 (ueof <> etok '+') + parse (substitutionConditional begin "FOO") "" "-bar" + `shouldFailWith` err 0 (utok '-' <> etok '+') + parse (substitutionConditional' "FOO") "" "+$BAR}" + `shouldFailWith` err + 5 + ( utok '}' + <> etoks "${" + <> etok '$' + <> elabel "component" + <> eeof + ) + parse (substitutionConditional' "FOO") "" "+${BAR}}" + `shouldFailWith` err + 7 + ( utok '}' + <> etoks "${" + <> etok '$' + <> elabel "component" + <> eeof + ) + + trueFalse $ \begin -> specify + ("substitutionModifierAfterColon" ++ show begin) + $ do + let substitutionModifierAfterColon' env = + substitutionModifierAfterColon begin env <* eof + parse (substitutionModifierAfterColon' "FOO") "" "-bar" + `shouldParse` SubstitutionWithDefault "FOO" (BareComponent "bar") + parse (substitutionModifierAfterColon' "FOO") "" "+bar" + `shouldParse` ConditionalSubstitution "FOO" (BareComponent "bar") + parse (substitutionModifierAfterColon begin "FOO") "" "!bar" + `shouldFailWith` err 0 (utok '!' <> etok '+' <> etok '-') + + trueFalse $ \begin -> specify ("substitutionInBraces" ++ show begin) $ do + let substitutionInBraces' = substitutionInBraces begin <* eof + parse substitutionInBraces' "" "${FOO}" + `shouldParse` Substitution "FOO" + parse substitutionInBraces' "" "${FOO:-bar}" + `shouldParse` SubstitutionWithDefault "FOO" (BareComponent "bar") + parse substitutionInBraces' "" "${FOO:+bar}" + `shouldParse` ConditionalSubstitution "FOO" (BareComponent "bar") + parse (substitutionInBraces begin) "" "" + `shouldFailWith` err 0 (ueof <> etoks "${") + parse (substitutionInBraces begin) "" "${FOO-bar}" + `shouldFailWith` err 5 (utok '-' <> etok ':' <> etok '}') + + specify "filePathExpression' False" $ do + let filePathExpr' disallowed = filePathExpression' False disallowed <* eof + parse (filePathExpr' []) "" "foo}" + `shouldParse` BareComponent "foo}" + parse (filePathExpr' "}") "" "foo}" + `shouldFailWith` err + 3 + ( utok '}' + <> etoks "${" + <> etok '$' + <> elabel "component" + <> eeof + ) + parse (filePathExpr' []) "" "/foo" + `shouldFailWith` err + 0 + (utoks "/f" <> etoks "${" <> etok '$' <> elabel "component") + parse (filePathExpr' []) "" "C:\\foo" + `shouldParse` PathSeparator + (BareComponent "C:") + (BareComponent "foo") + parse (filePathExpr' []) "" "D:/bar" + `shouldParse` PathSeparator + (BareComponent "D:") + (BareComponent "bar") + + specify "filePathExpression' True" $ do + let filePathExpr' = filePathExpression' True [] <* eof + parse filePathExpr' "" "/foo" + `shouldParse` PathSeparator (Root Nothing) (BareComponent "foo") + parse filePathExpr' "" "C:\\foo" + `shouldParse` PathSeparator (Root $ Just 'C') (BareComponent "foo") + parse filePathExpr' "" "D:/bar" + `shouldParse` PathSeparator (Root $ Just 'D') (BareComponent "bar") + + specify "filePathExpression" $ do + let filePathExpr = filePathExpression <* eof + parse filePathExpr "" "/" `shouldParse` Root (Nothing) + parse filePathExpr "" "A" `shouldParse` BareComponent "A" + parse filePathExpr "" "A/" `shouldParse` BareComponent "A" + parse filePathExpr "" "A:\\" `shouldParse` Root (Just 'A') + parse filePathExpr "" "A:/" `shouldParse` Root (Just 'A') + parse filePathExpr "" "foo" `shouldParse` BareComponent "foo" + parse filePathExpr "" "foo/" `shouldParse` BareComponent "foo" + parse filePathExpr "" "foo/bar" + `shouldParse` PathSeparator (BareComponent "foo") (BareComponent "bar") + parse filePathExpr "" "foo/bar/" + `shouldParse` PathSeparator (BareComponent "foo") (BareComponent "bar") + parse filePathExpr "" "foo/bar/baz" + `shouldParse` PathSeparator + (PathSeparator (BareComponent "foo") (BareComponent "bar")) + (BareComponent "baz") + parse filePathExpr "" "foo${BAR}baz/qux" + `shouldParse` PathSeparator + ( Concatenation + (Concatenation (BareComponent "foo") (Substitution "BAR")) + $ BareComponent "baz" + ) + (BareComponent "qux") + parse filePathExpr "" "foo/bar${BAZ}qux" + `shouldParse` PathSeparator + (BareComponent "foo") + ( Concatenation + (Concatenation (BareComponent "bar") (Substitution "BAZ")) + $ BareComponent "qux" + ) + parse filePathExpr "" "foo/${BAR:-bar}/${BAZ:+baz}" + `shouldParse` PathSeparator + ( PathSeparator + (BareComponent "foo") + (SubstitutionWithDefault "BAR" (BareComponent "bar")) + ) + (ConditionalSubstitution "BAZ" (BareComponent "baz")) + parse filePathExpr "" "/$FOO/bar" + `shouldParse` PathSeparator + (PathSeparator (Root Nothing) (Substitution "FOO")) + (BareComponent "bar") + parse filePathExpr "" "C:\\D:\\bar" + `shouldParse` PathSeparator + (PathSeparator (Root $ Just 'C') (BareComponent "D:")) + (BareComponent "bar") + parse filePathExpr "" "${FOO:-C:\\bar}" + `shouldParse` SubstitutionWithDefault + "FOO" + (PathSeparator (Root $ Just 'C') (BareComponent "bar")) + + specify "parseFilePathExpression" $ do + parseFilePathExpression "" "foo" + `shouldBe` Right (BareComponent "foo") + parseFilePathExpression "" "/foo/$BAR" + `shouldBe` Right (Root Nothing +/+ "foo" +/+ Substitution "BAR") + parseFilePathExpression "" "C:\\foo\\$BAR" + `shouldBe` Right (Root (Just 'C') +/+ "foo" +/+ Substitution "BAR") + + specify "errorBundlePretty" $ do + let Left errorBundle = parseFilePathExpression "" "/foo/${BAR/baz" + -- FIXME: The error message is not very helpful in this case. + errorBundlePretty errorBundle + `shouldBe` unlines + [ "1:6:" + , " |" + , "1 | /foo/${BAR/baz" + , " | ^" + , "unexpected '$'" + , "expecting end of input" + ] + + +trueFalse :: (Monad m) => (Bool -> m a) -> m () +trueFalse = forM_ [False, True] diff --git a/test/Dojang/Syntax/Manifest/WriterSpec.hs b/test/Dojang/Syntax/Manifest/WriterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Syntax/Manifest/WriterSpec.hs @@ -0,0 +1,20 @@ +module Dojang.Syntax.Manifest.WriterSpec (spec) where + +import Data.Text (unpack) +import Test.Hspec (Spec, specify) +import Test.Hspec.Hedgehog (annotate, annotateShow, forAll, hedgehog, (===)) + +import Dojang.Syntax.Manifest.Parser (readManifest) +import Dojang.Syntax.Manifest.Writer (writeManifest) +import Dojang.Types.Gen as Gen (manifest) + + +spec :: Spec +spec = do + specify "writeManifest" $ hedgehog $ do + manifest' <- forAll Gen.manifest + let toml = writeManifest manifest' + annotate $ unpack toml + let Right (parsed, _) = readManifest toml + annotateShow parsed + parsed === manifest' diff --git a/test/Dojang/TestUtils.hs b/test/Dojang/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/TestUtils.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE LambdaCase #-} + +module Dojang.TestUtils (Entry (..), Tree, makeFixtureTree, withTempDir) where + +import Control.Monad (forM_, unless, void) + +import System.IO.Temp (withSystemTempDirectory) +import System.OsPath (OsPath, encodeFS, ()) + +import Data.ByteString (ByteString) +import Dojang.MonadFileSystem (MonadFileSystem (..)) + + +withTempDir :: (OsPath -> FilePath -> IO a) -> IO a +withTempDir action = do + withSystemTempDirectory "dojang-spec-" $ \tmpDir -> do + tmpDir' <- encodeFS tmpDir + action tmpDir' tmpDir + + +data Entry = F ByteString | D Tree + + +type Tree = [(OsPath, Entry)] + + +makeFixtureTree + :: (MonadFileSystem m) => OsPath -> Tree -> m () +makeFixtureTree path tree = do + pathExists <- exists path + unless pathExists $ void $ createDirectories path + forM_ tree $ \case + (p, F bytes) -> Dojang.MonadFileSystem.writeFile (path p) bytes + (p, D tree') -> makeFixtureTree (path p) tree' diff --git a/test/Dojang/Types/ContextSpec.hs b/test/Dojang/Types/ContextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/ContextSpec.hs @@ -0,0 +1,1007 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.ContextSpec (spec) where + +import Data.List (isInfixOf, sort, sortOn) +import System.IO.Error + ( ioeGetErrorString + , ioeGetErrorType + , ioeGetFileName + , ioeGetLocation + ) +import Prelude hiding (readFile, writeFile) + +import Data.ByteString qualified (length) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict (Map, fromList) +import System.FilePath (combine) +import System.OsPath (OsPath, encodeFS, ()) +import Test.Hspec (Spec, describe, it, runIO, specify) +import Test.Hspec.Expectations.Pretty (shouldBe, shouldReturn, shouldThrow) + +import Dojang.MonadFileSystem (MonadFileSystem (..)) +import Dojang.MonadFileSystem qualified (FileType (..)) +import Dojang.Syntax.Manifest.Writer (writeManifestFile) +import Dojang.TestUtils (Entry (..), makeFixtureTree, withTempDir) +import Dojang.Types.Context + ( CandidateRoute (..) + , Context (..) + , FileCorrespondence (..) + , FileDeltaKind (..) + , FileEntry (..) + , FileStat (..) + , RouteMatch (..) + , RouteState (..) + , calculateSpecificity + , filterBySpecificity + , findMatchingRoutes + , getRouteState + , listFiles + , makeCorrespond + , makeCorrespondBetweenThreeDirs + , makeCorrespondBetweenThreeFiles + , makeCorrespondBetweenTwoDirs + , makeCorrespondWithDestination + , routePaths + ) +import Dojang.Types.Environment + ( Architecture (..) + , Environment (..) + , Kernel (..) + , OperatingSystem (..) + ) +import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning (..)) +import Dojang.Types.FilePathExpression (FilePathExpression (..), (+/+)) +import Dojang.Types.FileRouteSpec (monikerMap) +import Dojang.Types.Manifest (manifest) +import Dojang.Types.MonikerName (MonikerName, parseMonikerName) +import Dojang.Types.Repository + ( Repository (..) + , RouteMapWarning (..) + , RouteResult (..) + ) +import GHC.IO.Exception (IOErrorType (InappropriateType)) + + +spec :: Spec +spec = do + src <- runIO $ encodeFS "src" + inter <- runIO $ encodeFS "inter" + dst <- runIO $ encodeFS "dst" + foo <- runIO $ encodeFS "foo" + bar <- runIO $ encodeFS "bar" + baz <- runIO $ encodeFS "baz" + qux <- runIO $ encodeFS "qux" + -- cSpell:ignore quux corge + quux <- runIO $ encodeFS "quux" + corge <- runIO $ encodeFS "corge" + intermediateDir <- runIO $ encodeFS ".dojang" + manifestFilename' <- runIO $ encodeFS "dojang.toml" + + let Right posix = parseMonikerName "posix" + let Right undefined' = parseMonikerName "undefined" + let Right windows = parseMonikerName "windows" + + let fileRoutes = + [ + ( baz + , + [ + ( undefined' + , Just $ Root Nothing +/+ BareComponent "__dojang_test_baz__" + ) + , (windows, Just $ Substitution "BAZ") + ] + ) + ] + :: Map OsPath [(MonikerName, Maybe FilePathExpression)] + let dirRoutes = + [ (foo, [(posix, Just $ Substitution "FOO"), (windows, Nothing)]) + , + ( bar + , + [ (posix, Just $ Substitution "BAR") + , (windows, Just $ Root $ Just 'B') + ] + ) + ] + :: Map OsPath [(MonikerName, Maybe FilePathExpression)] + + let manifest' = + Dojang.Types.Manifest.manifest + monikerMap + fileRoutes + dirRoutes + [(foo, ["ignore-*"])] + mempty + + let repositoryFixture repoPath = do + -- The tree of the repository fixture looks like this: + -- . + -- ├── bar/ + -- │   └── foo + -- ├── baz + -- ├── dojang.toml + -- └── foo/ + -- ├── bar/ + -- │   └── foo + -- ├── baz/ + -- └── foo + -- Total 4 directories and 5 files + writeManifestFile manifest' $ repoPath manifestFilename' + createDirectory $ repoPath foo + writeFile (repoPath foo foo) "asdf" + createDirectory $ repoPath foo bar + writeFile (repoPath foo bar foo) "asdf asdf" + createDirectory $ repoPath foo baz + createDirectory $ repoPath bar + writeFile (repoPath bar foo) "foobar" + writeFile (repoPath baz) "foo bar baz" + let repo = + Repository + repoPath + (repoPath intermediateDir) + manifest' + return repo + + let withContextFixture action = withTempDir $ \tmpDir _ -> do + createDirectory $ tmpDir src + createDirectory $ tmpDir foo + repo <- repositoryFixture $ tmpDir src + let ctx = Context + repo + (Environment Linux X86_64 $ Kernel "Linux" "5.10.0-8") + $ \e -> + return $ case e of + "FOO" -> Just $ tmpDir foo + "BAR" -> Just $ tmpDir bar + "BAZ" -> Just $ tmpDir baz + _ -> Nothing + action ctx tmpDir + + specify "routePaths" $ withContextFixture $ \ctx tmpDir -> do + (results, ws) <- routePaths ctx + ws `shouldBe` [EnvironmentPredicateWarning $ UndefinedMoniker undefined'] + sortOn (.sourcePath) results + `shouldBe` [ RouteResult + { sourcePath = tmpDir src bar + , routeName = bar + , destinationPath = tmpDir bar + , fileType = Dojang.MonadFileSystem.Directory + } + , RouteResult + { sourcePath = tmpDir src foo + , routeName = foo + , destinationPath = tmpDir foo + , fileType = Dojang.MonadFileSystem.Directory + } + ] + specify "makeCorrespondWithDestination" $ + withContextFixture $ + \ctx tmpDir -> do + (correspond, ws) <- + makeCorrespondWithDestination ctx (tmpDir bar foo) + ws `shouldBe` [EnvironmentPredicateWarning $ UndefinedMoniker undefined'] + correspond + `shouldBe` Just + ( FileCorrespondence + { source = + FileEntry + (tmpDir src bar foo) + (File 6) + , sourceDelta = Added + , intermediate = + FileEntry + (tmpDir src intermediateDir bar foo) + Missing + , destination = FileEntry (tmpDir bar foo) Missing + , destinationDelta = Unchanged + } + ) + let ctx' = ctx{environment = ctx.environment{operatingSystem = Windows}} + (correspond', ws') <- + makeCorrespondWithDestination ctx' (tmpDir baz) + ws' `shouldBe` [EnvironmentPredicateWarning $ UndefinedMoniker undefined'] + correspond' + `shouldBe` Just + ( FileCorrespondence + { source = FileEntry (tmpDir src baz) (File 11) + , sourceDelta = Added + , intermediate = + FileEntry (tmpDir src intermediateDir baz) Missing + , destination = FileEntry (tmpDir baz) Missing + , destinationDelta = Unchanged + } + ) + (correspond'', ws'') <- + makeCorrespondWithDestination ctx (tmpDir corge) + correspond'' `shouldBe` Nothing + ws'' `shouldBe` ws + + specify "makeCorrespond" $ withContextFixture $ \ctx tmpDir -> do + (corresponds, ws) <- makeCorrespond ctx + ws `shouldBe` [EnvironmentPredicateWarning $ UndefinedMoniker undefined'] + sortOn (.source.path) corresponds + `shouldBe` [ FileCorrespondence + { source = + FileEntry + (tmpDir src bar foo) + (File 6) + , sourceDelta = Added + , intermediate = + FileEntry + (tmpDir src intermediateDir bar foo) + Missing + , destination = FileEntry (tmpDir bar foo) Missing + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = + FileEntry + (tmpDir src foo bar) + Directory + , sourceDelta = Added + , intermediate = + FileEntry + (tmpDir src intermediateDir foo bar) + Missing + , destination = FileEntry (tmpDir foo bar) Missing + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = + FileEntry + (tmpDir src foo bar foo) + (File 9) + , sourceDelta = Added + , intermediate = + FileEntry + ( tmpDir + src + intermediateDir + foo + bar + foo + ) + Missing + , destination = + FileEntry (tmpDir foo bar foo) Missing + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = + FileEntry (tmpDir src foo baz) Directory + , sourceDelta = Added + , intermediate = + FileEntry + (tmpDir src intermediateDir foo baz) + Missing + , destination = FileEntry (tmpDir foo baz) Missing + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = + FileEntry (tmpDir src foo foo) (File 4) + , sourceDelta = Added + , intermediate = + FileEntry + (tmpDir src intermediateDir foo foo) + Missing + , destination = FileEntry (tmpDir foo foo) Missing + , destinationDelta = Unchanged + } + ] + + describe "listFiles" $ do + it "lists files recursively" $ withTempDir $ \tmpDir _ -> do + _ <- repositoryFixture tmpDir + files <- listFiles tmpDir [] + manifestData <- readFile $ tmpDir manifestFilename' + let manifestSize = toEnum $ Data.ByteString.length manifestData + sort files + `shouldBe` [ FileEntry bar Directory + , FileEntry (bar foo) $ File 6 + , FileEntry baz $ File 11 + , FileEntry manifestFilename' $ File manifestSize + , FileEntry foo Directory + , FileEntry (foo bar) Directory + , FileEntry (foo bar foo) $ File 9 + , FileEntry (foo baz) Directory + , FileEntry (foo foo) $ File 4 + ] + + it "filters out files by ignorePatterns" $ withTempDir $ \tmpDir _ -> do + _ <- repositoryFixture tmpDir + files <- listFiles tmpDir ["foo/b*"] + manifestData <- readFile $ tmpDir manifestFilename' + let manifestSize = toEnum $ Data.ByteString.length manifestData + sort files + `shouldBe` [ FileEntry bar Directory + , FileEntry (bar foo) $ File 6 + , FileEntry baz $ File 11 + , FileEntry manifestFilename' $ File manifestSize + , FileEntry foo Directory + , FileEntry (foo foo) $ File 4 + ] + + it "only accepts a directory path" $ withTempDir $ \tmpDir tmpDir' -> do + () <- writeFile (tmpDir foo) "foo" + listFiles (tmpDir foo) [] `shouldThrow` \e -> + (ioeGetErrorType e == InappropriateType) + && (ioeGetLocation e == "listFiles") + && (ioeGetFileName e == Just (tmpDir' `combine` "foo")) + && ("not a directory" `isInfixOf` show e) + + specify "makeCorrespondBetweenThreeFiles" $ withTempDir $ \tmpDir _ -> do + let makeCorrespond_ = + makeCorrespondBetweenThreeFiles + (tmpDir inter) + (tmpDir src) + (tmpDir dst) + + writeFile (tmpDir inter) "unchanged" + writeFile (tmpDir src) "unchanged" + writeFile (tmpDir dst) "unchanged" + makeCorrespond_ + `shouldReturn` FileCorrespondence + { source = FileEntry (tmpDir src) $ File 9 + , sourceDelta = Unchanged + , intermediate = FileEntry (tmpDir inter) $ File 9 + , destination = FileEntry (tmpDir dst) $ File 9 + , destinationDelta = Unchanged + } + + writeFile (tmpDir src) "modified!" + writeFile (tmpDir dst) "modified" + makeCorrespond_ + `shouldReturn` FileCorrespondence + { source = FileEntry (tmpDir src) $ File 9 + , sourceDelta = Modified + , intermediate = FileEntry (tmpDir inter) $ File 9 + , destination = FileEntry (tmpDir dst) $ File 8 + , destinationDelta = Modified + } + + removeFile (tmpDir inter) + writeFile (tmpDir src) "added" + writeFile (tmpDir dst) "added" + makeCorrespond_ + `shouldReturn` FileCorrespondence + { source = FileEntry (tmpDir src) $ File 5 + , sourceDelta = Added + , intermediate = FileEntry (tmpDir inter) Missing + , destination = FileEntry (tmpDir dst) $ File 5 + , destinationDelta = Added + } + + writeFile (tmpDir inter) "removed" + removeFile (tmpDir src) + removeFile (tmpDir dst) + makeCorrespond_ + `shouldReturn` FileCorrespondence + { source = FileEntry (tmpDir src) Missing + , sourceDelta = Removed + , intermediate = FileEntry (tmpDir inter) $ File 7 + , destination = FileEntry (tmpDir dst) Missing + , destinationDelta = Removed + } + + writeFile (tmpDir inter) "dir is disallowed" + createDirectory (tmpDir src) + filename <- decodePath $ tmpDir src + makeCorrespond_ `shouldThrow` \e -> + ( ioeGetErrorString e + == "makeCorrespondBetweenThreeFiles: " + ++ "expected a file, but got a directory" + ) + && (ioeGetFileName e == Just filename) + + specify "makeCorrespondBetweenThreeDirs" $ withTempDir $ \tmpDir _ -> do + () <- + makeFixtureTree + (tmpDir foo) + [ (inter, D []) + , (src, D []) + , (dst, D []) + ] + emptyCorresponds <- + makeCorrespondBetweenThreeDirs + (tmpDir foo inter) + (tmpDir foo src) + (tmpDir foo dst) + [] + sortOn (.source.path) emptyCorresponds `shouldBe` [] + + unchanged <- encodePath "unchanged" + added <- encodePath "added" + removed <- encodePath "removed" + modified <- encodePath "modified" + ignored <- encodePath "ignored" + () <- + makeFixtureTree + (tmpDir bar) + [ + ( inter + , D + [ (unchanged, D [(foo, F "foo-unchanged")]) + , (added, D []) + , + ( removed + , D + [ (foo, F "foo-src-removed") + , (bar, F "bar-dst-removed") + , (baz, F "baz-both-removed") + , (qux, D []) + ] + ) + , + ( modified + , D + [ (foo, F "foo") + , (bar, F "bar") + , (baz, F "baz") + , (qux, F "qux-file-to-dir") + , (quux, D []) + , (corge, F "same-size-but-different-content") + ] + ) + , + ( ignored + , D + [ (foo, F "foo-ignored-but-tracked") + , (baz, F "baz-ignored-but-indexed") + ] + ) + ] + ) + , + ( src + , D + [ (unchanged, D [(foo, F "foo-unchanged")]) + , + ( added + , D + [ (foo, F "foo-src-added") + , (baz, F "baz-both-added") + , (qux, D []) + ] + ) + , (removed, D [(bar, F "bar-dst-removed")]) + , + ( modified + , D + [ (foo, F "foo-src-modified") + , (bar, F "bar") + , (baz, F "baz-src-modified") + , (qux, D []) + , (quux, F "qux-dir-to-file") + , (corge, F "same-length-but--different-body") + ] + ) + , + ( ignored + , D + [ (foo, F "foo-ignored-but-tracked") + , (bar, F "bar-ignored-but-added") + ] + ) + ] + ) + , + ( dst + , D + [ (unchanged, D [(foo, F "foo-unchanged")]) + , + ( added + , D + [ (bar, F "bar-dst-added") + , (baz, F "baz-both-added") + , (qux, D []) + ] + ) + , (removed, D [(foo, F "foo-src-removed")]) + , + ( modified + , D + [ (foo, F "foo") + , (bar, F "bar-dst-modified") + , (baz, F "baz-dst-modified") + , (qux, F "qux-file-to-dir") + , (quux, D []) + , (corge, F "equivalent-length-but-different") + ] + ) + , + ( ignored + , D + [ (foo, F "foo-ignored-but-tracked") + , (bar, F "bar-ignored-but-added") + , (baz, F "baz-ignored-but-indexed") + ] + ) + ] + ) + ] + corresponds <- + makeCorrespondBetweenThreeDirs + (tmpDir bar inter) + (tmpDir bar src) + (tmpDir bar dst) + ["ignored"] + sortOn (.source.path) corresponds + `shouldBe` [ FileCorrespondence + { source = FileEntry added Directory + , sourceDelta = Unchanged + , intermediate = FileEntry added Directory + , destination = FileEntry added Directory + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = FileEntry (added bar) Missing + , sourceDelta = Unchanged + , intermediate = FileEntry (added bar) Missing + , destination = FileEntry (added bar) (File 13) + , destinationDelta = Added + } + , FileCorrespondence + { source = FileEntry (added baz) (File 14) + , sourceDelta = Added + , intermediate = FileEntry (added baz) Missing + , destination = FileEntry (added baz) (File 14) + , destinationDelta = Added + } + , FileCorrespondence + { source = FileEntry (added foo) (File 13) + , sourceDelta = Added + , intermediate = FileEntry (added foo) Missing + , destination = FileEntry (added foo) Missing + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = FileEntry (added qux) Directory + , sourceDelta = Added + , intermediate = FileEntry (added qux) Missing + , destination = FileEntry (added qux) Directory + , destinationDelta = Added + } + , FileCorrespondence + { source = FileEntry ignored Directory + , sourceDelta = Unchanged + , intermediate = FileEntry ignored Directory + , destination = FileEntry ignored Directory + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = FileEntry (ignored bar) (File 21) + , sourceDelta = Added + , intermediate = FileEntry (ignored bar) Missing + , destination = FileEntry (ignored bar) (File 21) + , destinationDelta = Added + } + , FileCorrespondence + { source = FileEntry (ignored baz) Missing + , sourceDelta = Removed + , intermediate = FileEntry (ignored baz) (File 23) + , destination = FileEntry (ignored baz) (File 23) + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = FileEntry (ignored foo) (File 23) + , sourceDelta = Unchanged + , intermediate = FileEntry (ignored foo) (File 23) + , destination = FileEntry (ignored foo) (File 23) + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = FileEntry modified Directory + , sourceDelta = Unchanged + , intermediate = FileEntry modified Directory + , destination = FileEntry modified Directory + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = FileEntry (modified bar) (File 3) + , sourceDelta = Unchanged + , intermediate = FileEntry (modified bar) (File 3) + , destination = FileEntry (modified bar) (File 16) + , destinationDelta = Modified + } + , FileCorrespondence + { source = FileEntry (modified baz) (File 16) + , sourceDelta = Modified + , intermediate = FileEntry (modified baz) (File 3) + , destination = FileEntry (modified baz) (File 16) + , destinationDelta = Modified + } + , FileCorrespondence + { source = FileEntry (modified corge) (File 31) + , sourceDelta = Modified + , intermediate = FileEntry (modified corge) (File 31) + , destination = FileEntry (modified corge) (File 31) + , destinationDelta = Modified + } + , FileCorrespondence + { source = FileEntry (modified foo) (File 16) + , sourceDelta = Modified + , intermediate = FileEntry (modified foo) (File 3) + , destination = FileEntry (modified foo) (File 3) + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = FileEntry (modified quux) (File 15) + , sourceDelta = Modified + , intermediate = FileEntry (modified quux) Directory + , destination = FileEntry (modified quux) Directory + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = FileEntry (modified qux) Directory + , sourceDelta = Modified + , intermediate = FileEntry (modified qux) (File 15) + , destination = FileEntry (modified qux) (File 15) + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = FileEntry removed Directory + , sourceDelta = Unchanged + , intermediate = FileEntry removed Directory + , destination = FileEntry removed Directory + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = FileEntry (removed bar) (File 15) + , sourceDelta = Unchanged + , intermediate = FileEntry (removed bar) (File 15) + , destination = FileEntry (removed bar) Missing + , destinationDelta = Removed + } + , FileCorrespondence + { source = FileEntry (removed baz) Missing + , sourceDelta = Removed + , intermediate = FileEntry (removed baz) (File 16) + , destination = FileEntry (removed baz) Missing + , destinationDelta = Removed + } + , FileCorrespondence + { source = FileEntry (removed foo) Missing + , sourceDelta = Removed + , intermediate = FileEntry (removed foo) (File 15) + , destination = FileEntry (removed foo) (File 15) + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = FileEntry (removed qux) Missing + , sourceDelta = Removed + , intermediate = FileEntry (removed qux) Directory + , destination = FileEntry (removed qux) Missing + , destinationDelta = Removed + } + , FileCorrespondence + { source = FileEntry unchanged Directory + , sourceDelta = Unchanged + , intermediate = FileEntry unchanged Directory + , destination = FileEntry unchanged Directory + , destinationDelta = Unchanged + } + , FileCorrespondence + { source = FileEntry (unchanged foo) (File 13) + , sourceDelta = Unchanged + , intermediate = FileEntry (unchanged foo) (File 13) + , destination = FileEntry (unchanged foo) (File 13) + , destinationDelta = Unchanged + } + ] + + specify "makeCorrespondBetweenTwoDirs" $ withTempDir $ \tmpDir _ -> do + () <- + makeFixtureTree + (tmpDir foo) + [ (foo, F "foo") + , + ( bar + , D + [ (foo, F "bar/foo") + , (bar, F "bar/bar") + , (baz, D []) + ] + ) + , (baz, F "baz") + , + ( qux + , D + [ (foo, F "qux/foo") + , (quux, F "qux/quux") + ] + ) + ] + () <- + makeFixtureTree + (tmpDir bar) + [ (foo, F "foo 2") + , + ( bar + , D + [ (foo, F "bar/foo") + , (baz, D [(bar, F "bar/baz/bar")]) + ] + ) + , (baz, F "baz") + , + ( qux + , D + [ (foo, F "qux/foo") + , (quux, F "qux/quux 2") + ] + ) + ] + makeCorrespondBetweenTwoDirs (tmpDir foo) (tmpDir bar) [] + `shouldReturn` fromList + [ (foo, (FileEntry foo $ File 3, FileEntry foo $ File 5)) + , (bar, (FileEntry bar Directory, FileEntry bar Directory)) + , + ( bar foo + , (FileEntry (bar foo) $ File 7, FileEntry (bar foo) $ File 7) + ) + , + ( bar bar + , (FileEntry (bar bar) $ File 7, FileEntry (bar bar) Missing) + ) + , + ( bar baz + , + ( FileEntry (bar baz) Directory + , FileEntry (bar baz) Directory + ) + ) + , + ( bar baz bar + , + ( FileEntry (bar baz bar) Missing + , FileEntry (bar baz bar) $ File 11 + ) + ) + , (baz, (FileEntry baz $ File 3, FileEntry baz $ File 3)) + , + ( qux + , (FileEntry qux Directory, FileEntry qux Directory) + ) + , + ( qux foo + , (FileEntry (qux foo) $ File 7, FileEntry (qux foo) $ File 7) + ) + , + ( qux quux + , + ( FileEntry (qux quux) $ File 8 + , FileEntry (qux quux) $ File 10 + ) + ) + ] + makeCorrespondBetweenTwoDirs + (tmpDir baz) -- This dir does not exist + (tmpDir bar) + [] + `shouldReturn` fromList + [ (foo, (FileEntry foo Missing, FileEntry foo $ File 5)) + , (bar, (FileEntry bar Missing, FileEntry bar Directory)) + , + ( bar foo + , + ( FileEntry (bar foo) Missing + , FileEntry (bar foo) $ File 7 + ) + ) + , + ( bar baz + , + ( FileEntry (bar baz) Missing + , FileEntry (bar baz) Directory + ) + ) + , + ( bar baz bar + , + ( FileEntry (bar baz bar) Missing + , FileEntry (bar baz bar) $ File 11 + ) + ) + , (baz, (FileEntry baz Missing, FileEntry baz $ File 3)) + , (qux, (FileEntry qux Missing, FileEntry qux Directory)) + , + ( qux foo + , (FileEntry (qux foo) Missing, FileEntry (qux foo) $ File 7) + ) + , + ( qux quux + , + ( FileEntry (qux quux) Missing + , FileEntry (qux quux) $ File 10 + ) + ) + ] + + specify "getRouteState" $ withContextFixture $ \ctx tmpDir -> do + (state, ws) <- getRouteState ctx (tmpDir src) + ws `shouldBe` [EnvironmentPredicateWarning $ UndefinedMoniker undefined'] + state `shouldBe` NotRouted + (state', ws') <- getRouteState ctx (tmpDir foo foo) + ws' `shouldBe` ws + state' `shouldBe` Routed foo + ignoreMe <- encodePath "ignore-me" + (state'', ws'') <- getRouteState ctx (tmpDir foo ignoreMe) + ws'' `shouldBe` ws + state'' `shouldBe` Ignored foo "ignore-*" + let ctx' = ctx{environment = ctx.environment{operatingSystem = FreeBSD}} + (stateOnNullRouting, ws''') <- getRouteState ctx' (tmpDir src) + ws''' `shouldBe` ws + stateOnNullRouting `shouldBe` NotRouted + + describe "calculateSpecificity" $ do + it "returns 0 for exact match" $ withTempDir $ \tmpDir _ -> do + let route = + RouteResult + { sourcePath = tmpDir foo + , routeName = foo + , destinationPath = tmpDir bar + , fileType = Dojang.MonadFileSystem.Directory + } + calculateSpecificity (tmpDir bar) route `shouldBe` 0 + + it "returns 1 for direct child" $ withTempDir $ \tmpDir _ -> do + let route = + RouteResult + { sourcePath = tmpDir foo + , routeName = foo + , destinationPath = tmpDir bar + , fileType = Dojang.MonadFileSystem.Directory + } + calculateSpecificity (tmpDir bar baz) route `shouldBe` 1 + + it "returns 2 for grandchild" $ withTempDir $ \tmpDir _ -> do + let route = + RouteResult + { sourcePath = tmpDir foo + , routeName = foo + , destinationPath = tmpDir bar + , fileType = Dojang.MonadFileSystem.Directory + } + calculateSpecificity (tmpDir bar baz qux) route `shouldBe` 2 + + describe "filterBySpecificity" $ do + it "returns empty list for empty input" $ withTempDir $ \tmpDir _ -> do + filterBySpecificity (tmpDir foo) [] `shouldBe` [] + + it "keeps only most specific routes" $ withTempDir $ \tmpDir _ -> do + let route1 = + RouteResult + { sourcePath = tmpDir src foo + , routeName = foo + , destinationPath = tmpDir bar + , fileType = Dojang.MonadFileSystem.Directory + } + let route2 = + RouteResult + { sourcePath = tmpDir src baz + , routeName = baz + , destinationPath = tmpDir bar qux + , fileType = Dojang.MonadFileSystem.Directory + } + -- route1: specificity = 2 (bar/qux/foo) + -- route2: specificity = 1 (qux/foo) + let target = tmpDir bar qux foo + filterBySpecificity target [route1, route2] `shouldBe` [route2] + + it "keeps all routes when equally specific" $ withTempDir $ \tmpDir _ -> do + let route1 = + RouteResult + { sourcePath = tmpDir src foo + , routeName = foo + , destinationPath = tmpDir dst + , fileType = Dojang.MonadFileSystem.Directory + } + let route2 = + RouteResult + { sourcePath = tmpDir src bar + , routeName = bar + , destinationPath = tmpDir dst + , fileType = Dojang.MonadFileSystem.Directory + } + -- Both routes have the same destinationPath, so same specificity + let target = tmpDir dst baz + filterBySpecificity target [route1, route2] `shouldBe` [route1, route2] + + describe "findMatchingRoutes" $ do + it "returns NoMatch when no routes match" $ withContextFixture $ \ctx tmpDir -> do + (result, _) <- findMatchingRoutes ctx (tmpDir corge) + result `shouldBe` NoMatch + + it "returns SingleMatch for unambiguous route" $ withContextFixture $ \ctx tmpDir -> do + (result, _) <- findMatchingRoutes ctx (tmpDir foo foo) + case result of + SingleMatch route -> route.routeName `shouldBe` foo + _ -> fail "Expected SingleMatch" + + it "returns SingleMatch when filtered by specificity" $ withTempDir $ \tmpDir _ -> do + -- Create a context with overlapping routes at different depths + createDirectory $ tmpDir src + createDirectory $ tmpDir dst + createDirectory $ tmpDir dst foo + writeFile (tmpDir src manifestFilename') "" + + -- route1 points to DST (via env var), route2 points to DST_FOO (via env var) + -- For target dst/foo/bar, route2 is more specific (specificity=1 vs 2) + let overlappingFileRoutes = + [ (foo, [(posix, Just $ Substitution "DST")]) + , (bar, [(posix, Just $ Substitution "DST_FOO")]) + ] + :: Map OsPath [(MonikerName, Maybe FilePathExpression)] + let overlappingManifest = + Dojang.Types.Manifest.manifest + monikerMap + [] + overlappingFileRoutes + [] + mempty + let repo = + Repository + (tmpDir src) + (tmpDir src intermediateDir) + overlappingManifest + let ctx = + Context + repo + (Environment Linux X86_64 $ Kernel "Linux" "5.10.0-8") + $ \e -> return $ case e of + "DST" -> Just $ tmpDir dst + "DST_FOO" -> Just $ tmpDir dst foo + _ -> Nothing + (result, _) <- findMatchingRoutes ctx (tmpDir dst foo baz) + case result of + SingleMatch route -> route.routeName `shouldBe` bar + _ -> fail $ "Expected SingleMatch, got " ++ show result + + it "returns AmbiguousMatch for equally specific routes" $ withTempDir $ \tmpDir _ -> do + -- Create a context with two routes pointing to the same destination + createDirectory $ tmpDir src + createDirectory $ tmpDir src foo + createDirectory $ tmpDir src bar + createDirectory $ tmpDir dst + writeFile (tmpDir src manifestFilename') "" + + -- Both foo and bar routes point to DST (via env var) + let ambiguousFileRoutes = + [ (foo, [(posix, Just $ Substitution "DST")]) + , (bar, [(posix, Just $ Substitution "DST")]) + ] + :: Map OsPath [(MonikerName, Maybe FilePathExpression)] + let ambiguousManifest = + Dojang.Types.Manifest.manifest + monikerMap + [] + ambiguousFileRoutes + [] + mempty + let repo = + Repository + (tmpDir src) + (tmpDir src intermediateDir) + ambiguousManifest + let ctx = + Context + repo + (Environment Linux X86_64 $ Kernel "Linux" "5.10.0-8") + $ \e -> return $ case e of + "DST" -> Just $ tmpDir dst + _ -> Nothing + (result, _) <- findMatchingRoutes ctx (tmpDir dst baz) + case result of + AmbiguousMatch candidates -> do + length candidates `shouldBe` 2 + -- All candidates should have same specificity + let firstSpec = (NE.head candidates).specificity + all (\c -> c.specificity == firstSpec) (NE.toList candidates) `shouldBe` True + _ -> fail $ "Expected AmbiguousMatch, got " ++ show result diff --git a/test/Dojang/Types/Environment/CurrentSpec.hs b/test/Dojang/Types/Environment/CurrentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/Environment/CurrentSpec.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.Environment.CurrentSpec (spec) where + +import Dojang.Types.Environment + ( Architecture (..) + , Environment (..) + , Kernel (..) + , OperatingSystem (..) + ) +import Dojang.Types.Environment.Current + ( currentArchitecture + , currentEnvironment + , currentKernel + , currentOperatingSystem + , parseArchitecture + , parseOperatingSystem + ) + +import Data.CaseInsensitive (original) +import Data.String (IsString (fromString)) +import Data.Text (Text) +import System.Info (arch, os) +import Test.Hspec (Spec, specify) +import Test.Hspec.Expectations.Pretty (shouldBe, shouldSatisfy) +import Text.Regex.TDFA ((=~)) + + +spec :: Spec +spec = do + specify "currentOperatingSystem" $ do + os' <- currentOperatingSystem + os' `shouldBe` expectedOS + + specify "currentArchitecture" $ do + arch' <- currentArchitecture + arch' `shouldBe` expectedArch + + specify "currentKernel" $ do + kernel <- currentKernel + expectKernel kernel + + specify "currentEnvironment" $ do + env <- currentEnvironment + env.operatingSystem `shouldBe` expectedOS + env.architecture `shouldBe` expectedArch + expectKernel env.kernel + + specify "parseOperatingSystem" $ do + parseOperatingSystem "linux-android" `shouldBe` Android + parseOperatingSystem "darwin" `shouldBe` MacOS + parseOperatingSystem "freebsd" `shouldBe` FreeBSD + parseOperatingSystem "linux" `shouldBe` Linux + parseOperatingSystem "netbsd" `shouldBe` NetBSD + parseOperatingSystem "openbsd" `shouldBe` OpenBSD + parseOperatingSystem "mingw32" `shouldBe` Windows + parseOperatingSystem "other-os" `shouldBe` OtherOS "other-os" + + specify "parseArchitecture" $ do + parseArchitecture "aarch64" `shouldBe` AArch64 + parseArchitecture "i386" `shouldBe` X86 + parseArchitecture "x86_64" `shouldBe` X86_64 + parseArchitecture "other-arch" `shouldBe` Etc "other-arch" + + +expectedOS :: OperatingSystem +expectedOS = case os of + "darwin" -> MacOS + "linux" -> Linux + "mingw32" -> Windows + "freebsd" -> FreeBSD + os' -> OtherOS $ fromString os' + + +expectedArch :: Architecture +expectedArch = case arch of + "aarch64" -> AArch64 + "x86_64" -> X86_64 + arch' -> Etc $ fromString arch' + + +expectKernel :: Kernel -> IO () +expectKernel = case os of + "darwin" -> expectMacOSKernel + "linux" -> expectLinuxKernel + "mingw32" -> expectWindowsKernel + _ -> \_ -> return () + + +expectMacOSKernel :: Kernel -> IO () +expectMacOSKernel kernel = do + original kernel.name `shouldBe` "Darwin" + original kernel.release + `shouldSatisfy` (=~ ("^[0-9]+\\.[0-9]+\\.[0-9]+$" :: Text)) + + +expectLinuxKernel :: Kernel -> IO () +expectLinuxKernel kernel = do + original kernel.name `shouldBe` "Linux" + original kernel.release + `shouldSatisfy` (=~ ("^[0-9]+\\.[0-9]+\\.?[0-9]+[.-][0-9]+(-|$)" :: Text)) + + +expectWindowsKernel :: Kernel -> IO () +expectWindowsKernel kernel = do + original kernel.name `shouldBe` "Microsoft Windows" + original kernel.release + `shouldSatisfy` (=~ ("^[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+$" :: Text)) diff --git a/test/Dojang/Types/EnvironmentPredicate/EvaluateSpec.hs b/test/Dojang/Types/EnvironmentPredicate/EvaluateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/EnvironmentPredicate/EvaluateSpec.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.EnvironmentPredicate.EvaluateSpec (spec) where + +import Data.HashMap.Strict (HashMap) +import Test.Hspec (Spec, describe, specify) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.Hedgehog (forAll, hedgehog, (/==), (===)) + +import Dojang.Gen qualified as Gen +import Dojang.Types.Environment + ( Architecture (..) + , Environment (Environment) + , Kernel (..) + , OperatingSystem (..) + ) +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..)) +import Dojang.Types.EnvironmentPredicate.Evaluate + ( EvaluationWarning (..) + , evaluate + ) +import Dojang.Types.MonikerName (MonikerName, parseMonikerName) + + +spec :: Spec +spec = do + describe "EvaluationWarning" $ do + specify "Eq" $ hedgehog $ do + warning <- forAll Gen.evaluationWarning + warning' <- forAll Gen.evaluationWarning + (warning == warning') /== (warning /= warning') + + specify "Show" $ hedgehog $ do + warning <- forAll Gen.evaluationWarning + warning' <- forAll Gen.evaluationWarning + showList [warning, warning'] "" + === ("[" ++ show warning ++ "," ++ show warning' ++ "]") + + describe "evaluate" $ do + let (Right linuxAmd64) = parseMonikerName "linux-amd64" + let (Right linuxArm64) = parseMonikerName "linux-arm64" + let (Right macosArm64) = parseMonikerName "macos-arm64" + let (Right linuxAmd64') = parseMonikerName "linux-amd64-alias" + let (Right nonExistentMoniker) = parseMonikerName "non-existent" + let monikerMap = + [ (linuxAmd64, And [OperatingSystem Linux, Architecture X86_64]) + , (linuxArm64, And [OperatingSystem Linux, Architecture AArch64]) + , (macosArm64, And [OperatingSystem MacOS, Architecture AArch64]) + , (linuxAmd64', Moniker linuxAmd64) + ] + :: HashMap MonikerName EnvironmentPredicate + let kernel = Kernel "Linux" "5.10.0-8" + let environment = Environment Linux X86_64 kernel + let eval = evaluate environment monikerMap + + specify "Always" $ + eval Always + `shouldBe` (True, []) + + specify "OperatingSystem" $ do + eval (OperatingSystem Linux) `shouldBe` (True, []) + eval (OperatingSystem MacOS) `shouldBe` (False, []) + eval (OperatingSystem $ OtherOS "other") + `shouldBe` ( False + , [UnrecognizedOperatingSystem $ OtherOS "other"] + ) + + specify "Architecture" $ do + eval (Architecture X86_64) `shouldBe` (True, []) + eval (Architecture AArch64) `shouldBe` (False, []) + eval (Architecture $ Etc "etc") + `shouldBe` ( False + , [UnrecognizedArchitecture $ Etc "etc"] + ) + + specify "Moniker" $ do + eval (Moniker linuxAmd64) `shouldBe` (True, []) + eval (Moniker linuxAmd64') `shouldBe` (True, []) + eval (Moniker linuxArm64) `shouldBe` (False, []) + eval (Moniker macosArm64) `shouldBe` (False, []) + eval (Moniker nonExistentMoniker) + `shouldBe` (False, [UndefinedMoniker nonExistentMoniker]) + + specify "Not" $ do + eval (Not $ OperatingSystem Linux) `shouldBe` (False, []) + eval (Not $ Architecture X86_64) `shouldBe` (False, []) + eval (Not $ Moniker linuxAmd64) `shouldBe` (False, []) + eval (Not $ Moniker linuxArm64) `shouldBe` (True, []) + eval (Not $ Moniker linuxAmd64') `shouldBe` (False, []) + + specify "And" $ do + eval (And [OperatingSystem Linux]) `shouldBe` (True, []) + eval (And [Architecture X86_64]) `shouldBe` (True, []) + eval (And [OperatingSystem Linux, Architecture X86_64]) + `shouldBe` (True, []) + eval + (And [OperatingSystem Linux, Architecture X86_64, Moniker linuxAmd64]) + `shouldBe` (True, []) + eval + (And [OperatingSystem Linux, Architecture AArch64, Moniker linuxArm64]) + `shouldBe` (False, []) + eval + ( And + [ OperatingSystem Linux + , Architecture X86_64 + , Moniker nonExistentMoniker + ] + ) + `shouldBe` (False, [UndefinedMoniker nonExistentMoniker]) + eval + (And [OperatingSystem Linux, Architecture AArch64]) + `shouldBe` (False, []) + eval + (And [OperatingSystem MacOS, Architecture X86_64]) + `shouldBe` (False, []) + eval + (And [OperatingSystem MacOS, Architecture AArch64]) + `shouldBe` (False, []) + + specify "Or" $ + do + eval (Or [OperatingSystem Linux]) `shouldBe` (True, []) + eval (Or [Architecture X86_64]) `shouldBe` (True, []) + eval + (Or [OperatingSystem Linux, Architecture X86_64]) + `shouldBe` (True, []) + eval + (Or [OperatingSystem Linux, Architecture X86_64, Moniker linuxAmd64]) + `shouldBe` (True, []) + eval + (Or [OperatingSystem Linux, Architecture AArch64, Moniker linuxArm64]) + `shouldBe` (True, []) + eval + ( Or + [ OperatingSystem Linux + , Architecture X86_64 + , Moniker nonExistentMoniker + ] + ) + `shouldBe` (True, [UndefinedMoniker nonExistentMoniker]) diff --git a/test/Dojang/Types/EnvironmentPredicate/SpecificitySpec.hs b/test/Dojang/Types/EnvironmentPredicate/SpecificitySpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/EnvironmentPredicate/SpecificitySpec.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.EnvironmentPredicate.SpecificitySpec (spec) where + +import Test.Hspec (Spec, describe, specify) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.Hedgehog (forAll, hedgehog, (/==), (===)) + +import Dojang.Types.Environment + ( Architecture (X86_64) + , OperatingSystem (Linux) + ) +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..)) +import Dojang.Types.EnvironmentPredicate.Specificity + ( Specificity (..) + , specificity + ) +import Dojang.Types.Gen qualified as Gen +import Dojang.Types.MonikerName (parseMonikerName) + + +spec :: Spec +spec = do + describe "Specificity" $ do + specify "Eq" $ hedgehog $ do + specificityA <- forAll Gen.specificity + specificityB <- forAll Gen.specificity + (specificityA == specificityB) /== (specificityA /= specificityB) + + describe "Ord" $ do + specify "examples" $ do + max (Specificity 0 0) (Specificity 1 0) `shouldBe` Specificity 1 0 + max (Specificity 0 0) (Specificity 0 1) `shouldBe` Specificity 0 0 + min (Specificity 1 0) (Specificity 1 1) `shouldBe` Specificity 1 1 + + specify "properties" $ hedgehog $ do + specificityA <- forAll Gen.specificity + specificityB <- forAll Gen.specificity + (specificityA `compare` specificityB) + === (specificityA.maxPredicates, specificityB.totalPredicates) + `compare` (specificityB.maxPredicates, specificityA.totalPredicates) + (specificityA < specificityB) /== (specificityA >= specificityB) + (specificityA <= specificityB) /== (specificityA > specificityB) + (specificityA > specificityB) /== (specificityA <= specificityB) + (specificityA >= specificityB) /== (specificityA < specificityB) + + specify "Read, Show" $ hedgehog $ do + specificityA <- forAll Gen.specificity + specificityB <- forAll Gen.specificity + showList [specificityA, specificityB] "" + === ("[" ++ show specificityA ++ "," ++ show specificityB ++ "]") + read (show specificityA) === specificityA + read (showList [specificityA, specificityB] "") + === ([specificityA, specificityB] :: [Specificity]) + + specify "specificity" $ do + specificity undefined (Always) `shouldBe` Specificity 0 0 + specificity undefined (OperatingSystem Linux) `shouldBe` Specificity 1 1 + specificity undefined (Architecture X86_64) `shouldBe` Specificity 1 1 + specificity undefined (Not Always) `shouldBe` Specificity 0 0 + specificity undefined (Not (Architecture X86_64)) `shouldBe` Specificity 1 1 + specificity undefined (And [Always, Architecture X86_64]) + `shouldBe` Specificity 1 1 + specificity undefined (And [OperatingSystem Linux, Architecture X86_64]) + `shouldBe` Specificity 2 2 + specificity undefined (Or [Always, Architecture X86_64]) + `shouldBe` Specificity 1 1 + specificity undefined (Or [OperatingSystem Linux, Architecture X86_64]) + `shouldBe` Specificity 1 2 + let Right foo = parseMonikerName "foo" + Right bar = parseMonikerName "bar" + Right baz = parseMonikerName "baz" + Right nonExistent = parseMonikerName "non-existent" + lookup' m + | m == foo = Just (OperatingSystem Linux) + | m == bar = Just (And [OperatingSystem Linux, Architecture X86_64]) + | m == baz = Just (Moniker foo) + | otherwise = Nothing + specificity lookup' (Moniker foo) `shouldBe` Specificity 1 1 + specificity lookup' (Moniker nonExistent) `shouldBe` Specificity 0 0 + specificity lookup' (Not $ Moniker foo) `shouldBe` Specificity 1 1 + specificity lookup' (And [Moniker foo, Moniker bar]) + `shouldBe` Specificity 3 3 + specificity lookup' (Or [Moniker foo, Moniker bar]) + `shouldBe` Specificity 2 3 + specificity lookup' (And [Moniker baz, Moniker bar]) + `shouldBe` Specificity 3 3 diff --git a/test/Dojang/Types/EnvironmentPredicateSpec.hs b/test/Dojang/Types/EnvironmentPredicateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/EnvironmentPredicateSpec.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.EnvironmentPredicateSpec (spec) where + +import Data.Hashable (Hashable (hash, hashWithSalt)) +import Test.Hspec (Spec, describe, it, specify) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.Hedgehog (forAll, hedgehog, (/==), (===)) + +import Dojang.Types.EnvironmentPredicate + ( EnvironmentPredicate (..) + , normalizePredicate + ) +import Dojang.Types.Gen qualified as Gen +import Dojang.Types.MonikerName (parseMonikerName) + + +spec :: Spec +spec = do + describe "EnvironmentPredicate" $ do + specify "Eq" $ hedgehog $ do + predicate <- forAll Gen.environmentPredicate + predicate' <- forAll Gen.environmentPredicate + (predicate == predicate') /== (predicate /= predicate') + And [predicate, predicate'] === And [predicate', predicate] + Or [predicate, predicate'] === Or [predicate', predicate] + + specify "Hashable" $ hedgehog $ do + predicate <- forAll Gen.environmentPredicate + predicate' <- forAll Gen.environmentPredicate + (hash predicate == hash predicate') === (predicate == predicate') + (hashWithSalt 0 predicate == hashWithSalt 0 predicate') + === (predicate == predicate') + + specify "Show" $ hedgehog $ do + predicate <- forAll Gen.environmentPredicate + predicate' <- forAll Gen.environmentPredicate + showList [predicate, predicate'] "" + === ("[" ++ show predicate ++ "," ++ show predicate' ++ "]") + + describe "normalizePredicate" $ do + it "reduces an unary And/Or to its child" $ do + normalizePredicate (And [Always]) `shouldBe` Always + normalizePredicate (Or [Always]) `shouldBe` Always + + it "reduces an And predicate into Not Always if it has any Not Always" $ do + normalizePredicate (And [Not Always]) `shouldBe` Not Always + normalizePredicate (And [Always, Not Always]) `shouldBe` Not Always + normalizePredicate (And [Not Always, OperatingSystem "linux"]) + `shouldBe` Not Always + normalizePredicate (And [OperatingSystem "linux", Architecture "x86_64"]) + `shouldBe` And [OperatingSystem "linux", Architecture "x86_64"] + + it "reduces an Or predicate into Always if it has any Always" $ do + normalizePredicate (Or [Always]) `shouldBe` Always + normalizePredicate (Or [Always, Not Always]) `shouldBe` Always + normalizePredicate (Or [Always, OperatingSystem "linux"]) + `shouldBe` Always + normalizePredicate (Or [OperatingSystem "linux", OperatingSystem "macos"]) + `shouldBe` Or [OperatingSystem "linux", OperatingSystem "macos"] + + it "removes all Always predicates in an And predicate" $ do + normalizePredicate (And [Always, Always, OperatingSystem "linux"]) + `shouldBe` OperatingSystem "linux" + normalizePredicate + (And [Always, Always, OperatingSystem "linux", Architecture "x86_64"]) + `shouldBe` And [OperatingSystem "linux", Architecture "x86_64"] + normalizePredicate (And [Always, Always]) `shouldBe` Always + + it "removes all Not Always predicates in an Or predicate" $ do + normalizePredicate (Or [Not Always, Not Always, OperatingSystem "linux"]) + `shouldBe` OperatingSystem "linux" + normalizePredicate + ( Or + [ Not Always + , Not Always + , OperatingSystem "linux" + , OperatingSystem "macos" + ] + ) + `shouldBe` Or [OperatingSystem "linux", OperatingSystem "macos"] + normalizePredicate (Or [Not Always, Not Always]) `shouldBe` Not Always + + it + ( "reduces an And predicate into Not Always if it has two contradicting " + ++ "predicates" + ) + $ do + normalizePredicate + (And [OperatingSystem "linux", Not $ OperatingSystem "linux"]) + `shouldBe` Not Always + normalizePredicate (And [OperatingSystem "linux", Architecture "x86_64"]) + `shouldBe` And [OperatingSystem "linux", Architecture "x86_64"] + + it + ( "reduces an Or predicate into Always if it has two contradicting " + ++ "predicates" + ) + $ do + normalizePredicate + (Or [OperatingSystem "linux", Not $ OperatingSystem "linux"]) + `shouldBe` Always + normalizePredicate + (Or [OperatingSystem "linux", OperatingSystem "macos"]) + `shouldBe` Or [OperatingSystem "linux", OperatingSystem "macos"] + + let Right foo = parseMonikerName "foo" + + it "flattens nested Ands" $ do + normalizePredicate + ( And + [ OperatingSystem "linux" + , And [Architecture "x86_64", Moniker foo] + ] + ) + `shouldBe` And + [ OperatingSystem "linux" + , Architecture "x86_64" + , Moniker foo + ] + + it "flattens nested Ors" $ do + normalizePredicate + ( Or + [ OperatingSystem "linux" + , Or [OperatingSystem "macos", Moniker foo] + ] + ) + `shouldBe` Or + [ OperatingSystem "linux" + , OperatingSystem "macos" + , Moniker foo + ] + + it "reduces double negation" $ do + normalizePredicate (Not $ Not Always) `shouldBe` Always + normalizePredicate (Not $ Not $ Not Always) `shouldBe` Not Always + normalizePredicate (Not $ Not $ OperatingSystem "linux") + `shouldBe` OperatingSystem "linux" + + it "is idempotent" $ hedgehog $ do + predicate <- forAll Gen.environmentPredicate + normalizePredicate (normalizePredicate predicate) + === normalizePredicate predicate diff --git a/test/Dojang/Types/EnvironmentSpec.hs b/test/Dojang/Types/EnvironmentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/EnvironmentSpec.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# HLINT ignore "Use min" #-} +{-# HLINT ignore "Use max" #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Dojang.Types.EnvironmentSpec (spec) where + +import Dojang.Types.Environment + ( Architecture (..) + , OperatingSystem (..) + ) +import Dojang.Types.Gen qualified as Gen + +import Data.CaseInsensitive (original) +import Data.Hashable (Hashable (hash, hashWithSalt)) +import Data.String (IsString (fromString)) +import Data.Text (unpack) +import Hedgehog.Gen (unicodeAll) +import Hedgehog.Range (constantFrom) +import Test.Hspec (Spec, describe, specify) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.Hedgehog (forAll, hedgehog, (/==), (===)) + + +spec :: Spec +spec = do + describe "OperatingSystem" $ do + specify "HasField \"identifier\"" $ do + (Linux).identifier `shouldBe` "linux" + (OtherOS "other-os").identifier `shouldBe` "other-os" + + specify "IsString" $ do + fromString "linux" `shouldBe` Linux + fromString "other-os" `shouldBe` OtherOS "other-os" + + specify "HasField \"identifier\", IsString" $ hedgehog $ do + os' <- forAll Gen.operatingSystem + fromString (unpack $ original os'.identifier) === os' + + specify "Eq" $ hedgehog $ do + os <- forAll Gen.operatingSystem + os' <- forAll Gen.operatingSystem + (os == os') /== (os /= os') + + specify "Ord" $ do + hedgehog $ do + os <- forAll Gen.operatingSystem + os' <- forAll Gen.operatingSystem + (os <= os') /== (os > os') + (os < os') /== (os >= os') + (os <= os) === True + (os >= os) === True + hedgehog $ do + a <- forAll $ Gen.ciText (constantFrom 0 0 256) unicodeAll + b <- forAll $ Gen.ciText (constantFrom 0 0 256) unicodeAll + compare (OtherOS a) (OtherOS b) === compare a b + min (OtherOS a) (OtherOS b) === OtherOS (min a b) + max (OtherOS a) (OtherOS b) === OtherOS (max a b) + + specify "Read, Show" $ hedgehog $ do + os <- forAll Gen.operatingSystem + read (show os) === os + read (showList [os] "") === [os] + + specify "Hashable" $ hedgehog $ do + os <- forAll Gen.operatingSystem + os' <- forAll Gen.operatingSystem + (hashWithSalt 0 os == hashWithSalt 0 os') === (os == os') + + describe "Architecture" $ do + specify "HasField \"identifier\"" $ do + (X86_64).identifier `shouldBe` "x86_64" + (Etc "etc").identifier `shouldBe` "etc" + + specify "IsString" $ do + fromString "x86_64" `shouldBe` X86_64 + fromString "etc" `shouldBe` Etc "etc" + + specify "HasField \"identifier\", IsString" $ hedgehog $ do + arch <- forAll Gen.architecture + fromString (unpack $ original arch.identifier) === arch + + specify "Eq" $ hedgehog $ do + arch <- forAll Gen.architecture + arch' <- forAll Gen.architecture + (arch == arch') /== (arch /= arch') + + specify "Ord" $ do + hedgehog $ do + arch <- forAll Gen.architecture + arch' <- forAll Gen.architecture + (arch <= arch') /== (arch > arch') + (arch < arch') /== (arch >= arch') + (arch <= arch) === True + (arch >= arch) === True + hedgehog $ do + a <- forAll $ Gen.ciText (constantFrom 0 0 256) unicodeAll + b <- forAll $ Gen.ciText (constantFrom 0 0 256) unicodeAll + compare (Etc a) (Etc b) === compare a b + min (Etc a) (Etc b) === Etc (min a b) + max (Etc a) (Etc b) === Etc (max a b) + + specify "Read, Show" $ hedgehog $ do + arch <- forAll Gen.architecture + read (show arch) === arch + read (showList [arch] "") === [arch] + + specify "Hashable" $ hedgehog $ do + arch <- forAll Gen.architecture + arch' <- forAll Gen.architecture + (hashWithSalt 0 arch == hashWithSalt 0 arch') === (arch == arch') + + describe "Kernel" $ do + specify "Eq" $ hedgehog $ do + kernel <- forAll Gen.kernel + kernel' <- forAll Gen.kernel + (kernel == kernel') /== (kernel /= kernel') + + specify "Ord" $ hedgehog $ do + kernel <- forAll Gen.kernel + kernel' <- forAll Gen.kernel + (kernel <= kernel') /== (kernel > kernel') + (kernel < kernel') /== (kernel >= kernel') + (kernel <= kernel) === True + (kernel >= kernel) === True + min kernel kernel' === if kernel <= kernel' then kernel else kernel' + max kernel kernel' === if kernel >= kernel' then kernel else kernel' + + specify "Read, Show" $ hedgehog $ do + kernel <- forAll Gen.kernel + read (show kernel) === kernel + read (showList [kernel] "") === [kernel] + + specify "Hashable" $ hedgehog $ do + kernel <- forAll Gen.kernel + kernel' <- forAll Gen.kernel + (hashWithSalt 0 kernel == hashWithSalt 0 kernel') === (kernel == kernel') + + describe "Environment" $ do + specify "Eq" $ hedgehog $ do + env <- forAll Gen.environment + env' <- forAll Gen.environment + (env == env') /== (env /= env') + + specify "Ord" $ hedgehog $ do + env <- forAll Gen.environment + env' <- forAll Gen.environment + (env <= env') /== (env > env') + (env < env') /== (env >= env') + (env <= env) === True + (env >= env) === True + min env env' === if env <= env' then env else env' + max env env' === if env >= env' then env else env' + + specify "Read, Show" $ hedgehog $ do + env <- forAll Gen.environment + read (show env) === env + read (showList [env] "") === [env] + + specify "Hashable" $ hedgehog $ do + env <- forAll Gen.environment + env' <- forAll Gen.environment + (hash env == hash env') === (env == env') + (hashWithSalt 0 env == hashWithSalt 0 env') === (env == env') diff --git a/test/Dojang/Types/FilePathExpression/ExpansionSpec.hs b/test/Dojang/Types/FilePathExpression/ExpansionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/FilePathExpression/ExpansionSpec.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.FilePathExpression.ExpansionSpec (spec) where + +import Dojang.Types.FilePathExpression (FilePathExpression (..), (++), (+/+)) +import Dojang.Types.FilePathExpression.Expansion + ( ExpansionWarning (..) + , expandFilePath + ) + +import Data.Text (Text, unpack) +import GHC.IO.Unsafe (unsafePerformIO) +import System.OsPath (pathSeparator, ()) +import System.OsString (OsString, encodeUtf, pack) +import Test.Hspec (Spec, describe, specify) +import Test.Hspec.Expectations.Pretty (shouldBe) + +import Prelude hiding ((++)) + + +encode :: Text -> IO OsString +encode = encodeUtf . unpack + + +os :: String -> OsString +os = unsafePerformIO . encodeUtf + + +spec :: Spec +spec = do + describe "expandFilePath" $ do + specify "BareComponent" $ do + expanded <- expandFilePath (BareComponent "foo") undefined encode + expanded `shouldBe` (os "foo", []) + + specify "Root" $ do + expanded <- expandFilePath (Root Nothing) undefined undefined + expanded `shouldBe` (pack [pathSeparator], []) + expanded' <- expandFilePath (Root $ Just 'C') undefined undefined + expanded' `shouldBe` (os "C:" <> pack [pathSeparator], []) + expandedAbs <- + expandFilePath + (Root Nothing +/+ BareComponent "foo" +/+ BareComponent "bar") + undefined + encode + expandedAbs + `shouldBe` (pack [pathSeparator] os "foo" os "bar", []) + expandedAbs' <- + expandFilePath + (Root (Just 'C') +/+ BareComponent "foo" +/+ BareComponent "bar") + undefined + encode + expandedAbs' + `shouldBe` ( os "C:" <> pack [pathSeparator] os "foo" os "bar" + , [] + ) + + specify "Concatenation" $ do + expanded <- + expandFilePath + (Substitution "FOO" ++ BareComponent "bar") + (\e -> return $ if e == "FOO" then Just (os "baz") else Nothing) + encode + expanded `shouldBe` (os "baz" <> os "bar", []) + expanded' <- + expandFilePath + (BareComponent "foo" ++ Substitution "BAR") + (\e -> return $ if e == "BAR" then Just (os "qux") else Nothing) + encode + expanded' `shouldBe` (os "foo" <> os "qux", []) + + specify "PathSeparator" $ do + expanded <- + expandFilePath + (Substitution "FOO" +/+ BareComponent "bar") + (\e -> return $ if e == "FOO" then Just (os "baz") else Nothing) + encode + expanded `shouldBe` (os "baz" os "bar", []) + expanded' <- + expandFilePath + (BareComponent "foo" +/+ Substitution "BAR") + (\e -> return $ if e == "BAR" then Just (os "qux") else Nothing) + encode + expanded' `shouldBe` (os "foo" os "qux", []) + + specify "Substitution" $ do + expanded <- + expandFilePath + (Substitution "FOO") + (\e -> return $ if e == "FOO" then Just (os "bar") else Nothing) + encode + expanded `shouldBe` (os "bar", []) + notFound <- + expandFilePath + (Substitution "FOO") + (const $ return Nothing) + encode + notFound `shouldBe` (mempty, [UndefinedEnvironmentVariable "FOO"]) + + specify "SubstitutionWithDefault" $ do + expanded <- + expandFilePath + (SubstitutionWithDefault "FOO" (BareComponent "baz")) + (\e -> return $ if e == "FOO" then Just (os "bar") else Nothing) + encode + expanded `shouldBe` (os "bar", []) + empty <- + expandFilePath + (SubstitutionWithDefault "FOO" (Substitution "BAR")) + (\e -> return $ Just $ if e == "FOO" then mempty else os "qux") + encode + empty `shouldBe` (os "qux", []) + notFound <- + expandFilePath + (SubstitutionWithDefault "FOO" (BareComponent "bar")) + (\e -> return $ if e == "FOO" then Nothing else Just $ os "qux") + encode + notFound `shouldBe` (os "bar", []) + + specify "ConditionalSubstitution" $ do + expanded <- + expandFilePath + (ConditionalSubstitution "FOO" (BareComponent "baz")) + (\e -> return $ if e == "FOO" then Just (os "bar") else Nothing) + encode + expanded `shouldBe` (os "baz", []) + expanded' <- + expandFilePath + (ConditionalSubstitution "FOO" (Substitution "BAZ")) + ( return . \case + "FOO" -> Just (os "bar") + "BAZ" -> Just (os "qux") + _ -> Nothing + ) + encode + expanded' `shouldBe` (os "qux", []) + empty <- + expandFilePath + (ConditionalSubstitution "FOO" (BareComponent "baz")) + (const $ return $ Just mempty) + encode + empty `shouldBe` (mempty, []) + notFound <- + expandFilePath + (ConditionalSubstitution "FOO" (BareComponent "baz")) + (const $ return Nothing) + encode + notFound `shouldBe` (mempty, []) diff --git a/test/Dojang/Types/FilePathExpressionSpec.hs b/test/Dojang/Types/FilePathExpressionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/FilePathExpressionSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.FilePathExpressionSpec (spec) where + +import Data.Hashable (hash) +import Data.Text (unpack) +import Test.Hspec (Spec, describe, it, specify) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.Hedgehog (annotateShow, footnote, forAll, hedgehog, (===)) + +import Dojang.Syntax.FilePathExpression.Parser + ( errorBundlePretty + , parseFilePathExpression + ) +import Dojang.Types.FilePathExpression (FilePathExpression (Root), toPathText) +import Dojang.Types.Gen qualified as Gen + + +spec :: Spec +spec = do + describe "FilePathExpression" $ do + specify "Eq" $ hedgehog $ do + x <- forAll Gen.filePathExpression + y <- forAll Gen.filePathExpression + (x == y) === (y == x) + (x /= y) === (y /= x) + + specify "Hashable" $ hedgehog $ do + x <- forAll Gen.filePathExpression + y <- forAll Gen.filePathExpression + (x == y) === (hash x == hash y) + (x /= y) === (hash x /= hash y) + + specify "Show" $ hedgehog $ do + x <- forAll Gen.filePathExpression + y <- forAll Gen.filePathExpression + showList [x, y] "" === ("[" ++ show x ++ "," ++ show y ++ "]") + + describe "toPathText" $ do + it "ends with a slash for a single Root expression" $ do + toPathText (Root Nothing) `shouldBe` "/" + toPathText (Root $ Just 'C') `shouldBe` "C:/" + + it "yields what parseFilePathExpression can parse" $ hedgehog $ do + expr <- forAll Gen.filePathExpression + let exprText = toPathText expr + annotateShow exprText + let parseResult = parseFilePathExpression "test" exprText + case parseResult of + Left err -> footnote $ unpack $ errorBundlePretty err + Right _ -> return () + let Right expr' = parseResult + expr' === expr diff --git a/test/Dojang/Types/FileRouteMap/EvaluateSpec.hs b/test/Dojang/Types/FileRouteMap/EvaluateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/FileRouteMap/EvaluateSpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.FileRouteMap.EvaluateSpec (spec) where + +import Data.Map.Strict (Map) +import System.OsPath (OsPath, encodeFS) +import Test.Hspec (Spec, runIO, specify) +import Test.Hspec.Expectations.Pretty (shouldBe) + +import Dojang.MonadFileSystem (FileType (..)) +import Dojang.Types.Environment + ( Architecture (..) + , Environment (Environment) + , Kernel (..) + , OperatingSystem (..) + ) +import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning (..)) +import Dojang.Types.FilePathExpression (FilePathExpression (..)) +import Dojang.Types.FileRoute (FileRoute, fileRoute) +import Dojang.Types.FileRouteMap.Evaluate + ( evaluateRoutes + , evaluateRoutesWithFileTypes + ) +import Dojang.Types.FileRouteSpec (monikerMap) +import Dojang.Types.MonikerName (parseMonikerName) + + +spec :: Spec +spec = do + foo <- runIO $ encodeFS "foo" + bar <- runIO $ encodeFS "bar" + baz <- runIO $ encodeFS "baz" + + let Right posix = parseMonikerName "posix" + let Right undefined' = parseMonikerName "undefined" + let Right windows = parseMonikerName "windows" + + let route = fileRoute monikerMap + let routes = + [ + ( foo + , route + [(posix, Just $ Substitution "FOO"), (windows, Nothing)] + Directory + ) + , + ( bar + , route + [ (posix, Just $ Substitution "BAR") + , (windows, Just $ Root $ Just 'B') + ] + Directory + ) + , + ( baz + , route + [ (undefined', Just $ BareComponent "baz") + , (windows, Just $ Substitution "BAZ") + ] + File + ) + ] + :: Map OsPath FileRoute + + specify "evaluateRoutes" $ do + evaluateRoutes [] (Environment Linux X86_64 $ Kernel "Linux" "5.10.0-8") + `shouldBe` ([], []) + evaluateRoutes + routes + ( Environment Windows X86_64 $ + Kernel "Microsoft Windows" "10.0.23585.1001" + ) + `shouldBe` ( + [ (bar, Root $ Just 'B') + , (baz, Substitution "BAZ") + ] + , [UndefinedMoniker undefined'] + ) + evaluateRoutes + routes + (Environment Linux AArch64 $ Kernel "Linux" "6.5.9-300.fc35.aarch64") + `shouldBe` ( + [ (foo, Substitution "FOO") + , (bar, Substitution "BAR") + ] + , [] + ) + + specify "evaluateRoutesWithFileTypes" $ do + let eval = evaluateRoutesWithFileTypes + eval [] (Environment Linux X86_64 $ Kernel "Linux" "5.10.0-8") + `shouldBe` ([], []) + eval + routes + ( Environment Windows X86_64 $ + Kernel "Microsoft Windows" "10.0.23585.1001" + ) + `shouldBe` ( + [ (bar, (Root $ Just 'B', Directory)) + , (baz, (Substitution "BAZ", File)) + ] + , [UndefinedMoniker undefined'] + ) + eval + routes + (Environment Linux AArch64 $ Kernel "Linux" "6.5.9-300.fc35.aarch64") + `shouldBe` ( + [ (foo, (Substitution "FOO", Directory)) + , (bar, (Substitution "BAR", Directory)) + ] + , [] + ) diff --git a/test/Dojang/Types/FileRouteSpec.hs b/test/Dojang/Types/FileRouteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/FileRouteSpec.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.FileRouteSpec (monikerMap, paths, spec) where + +import Data.HashMap.Strict (HashMap, fromList) +import Data.Text (Text) +import System.OsPath (encodeFS) +import Test.Hspec (Spec, describe, specify) +import Test.Hspec.Expectations.Pretty (shouldBe, shouldNotBe, shouldReturn) +import Test.Hspec.Hedgehog (forAll, hedgehog, (===)) + +import Dojang.MonadFileSystem (FileType (..)) +import Dojang.Types.Environment (Environment (Environment), Kernel (Kernel)) +import Dojang.Types.EnvironmentPredicate + ( EnvironmentPredicate (Moniker, OperatingSystem, Or) + ) +import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning (..)) +import Dojang.Types.FilePathExpression (FilePathExpression (Root, Substitution)) +import Dojang.Types.FilePathExpression.Expansion (ExpansionWarning (..)) +import Dojang.Types.FileRoute + ( FileRoute (monikerResolver, predicates) + , RouteWarning (..) + , dispatch + , fileRoute + , fileRoute' + , routePath + ) +import Dojang.Types.Gen qualified as Gen +import Dojang.Types.MonikerName (MonikerName, parseMonikerName) + + +moniker :: Text -> MonikerName +moniker name = case parseMonikerName name of + Right monikerName -> monikerName + Left _ -> error "Invalid moniker name" + + +monikerMap :: HashMap MonikerName EnvironmentPredicate +monikerMap = + fromList + [ (moniker "linux", OperatingSystem "linux") + , (moniker "macos", OperatingSystem "macos") + , (moniker "windows", OperatingSystem "windows") + , + ( moniker "posix" + , Or [Moniker $ moniker "linux", Moniker $ moniker "macos"] + ) + ] + + +paths :: [(MonikerName, Maybe FilePathExpression)] +paths = + [ (moniker "posix", Just $ Substitution "HOME") + , + ( moniker "windows" + , Just $ Substitution "USERPROFILE" -- cSpell:disable-line + ) + ] + + +spec :: Spec +spec = do + let route = fileRoute monikerMap paths Directory + describe "FileRoute" $ do + specify "monikerResolver" $ do + route.monikerResolver (moniker "linux") + `shouldBe` Just (OperatingSystem "linux") + route.monikerResolver (moniker "non-existent") `shouldBe` Nothing + + describe "Eq" $ do + specify "properties" $ hedgehog $ do + x <- forAll Gen.fileRoute + y <- forAll Gen.fileRoute + (x == x) === True + (x == y) === (y == x) + (x /= y) === (y /= x) + + specify "examples" $ do + route `shouldBe` route + route + `shouldBe` fileRoute + monikerMap + [ (moniker "posix", Just $ Substitution "HOME") + , + ( moniker "windows" + , Just $ Substitution "USERPROFILE" -- cSpell:disable-line + ) + ] + Directory + route + `shouldNotBe` fileRoute + monikerMap + [ (moniker "posix", Just $ Substitution "HOME") + , (moniker "windows", Just $ Substitution "HOME") + ] + Directory + route + `shouldNotBe` fileRoute' + (const Nothing) + [ (Moniker $ moniker "posix", Just $ Substitution "HOME") + , + ( Moniker $ moniker "windows" + , Just $ Substitution "USERPROFILE" -- cSpell:disable-line + ) + ] + Directory + + specify "predicates" $ do + route.predicates + `shouldBe` ( [ + ( Moniker $ moniker "windows" + , Just $ Substitution "USERPROFILE" -- cSpell:disable-line + ) + , (Moniker $ moniker "posix", Just $ Substitution "HOME") + ] + :: [(EnvironmentPredicate, Maybe FilePathExpression)] + ) + + specify "Show" $ do + show route + `shouldBe` ("FileRoute " ++ show (route.predicates) ++ " Directory") + showList [route] "" + `shouldBe` ("[FileRoute " ++ show (route.predicates) ++ " Directory]") + + specify "dispatch" $ do + dispatch (Environment "linux" "x86_64" $ Kernel "Linux" "5.10.0-8") route + `shouldBe` ([Just $ Substitution "HOME"], []) + dispatch (Environment "macos" "aarch64" $ Kernel "Darwin" "23.1.0") route + `shouldBe` ([Just $ Substitution "HOME"], []) + dispatch + ( Environment "windows" "x86_64" $ + Kernel "Microsoft Windows" "10.0.23585.1001" + ) + route + `shouldBe` ([Just $ Substitution "USERPROFILE"], []) -- cSpell:disable-line + dispatch + ( Environment "windows" "x86_64" $ + Kernel "Microsoft Windows" "10.0.23585.1001" + ) + route + `shouldBe` ([Just $ Substitution "USERPROFILE"], []) -- cSpell:disable-line + let withWarnings = + fileRoute + monikerMap + (paths ++ [(moniker "non-existent", Just $ Root Nothing)]) + Directory + dispatch + (Environment "linux" "x86_64" $ Kernel "Linux" "5.10.0-8") + withWarnings + `shouldBe` ( [Just $ Substitution "HOME"] + , [UndefinedMoniker (moniker "non-existent")] + ) + + specify "routePath" $ do + routePath + route + (Environment "freebsd" "x86_64" $ Kernel "FreeBSD" "13.2-RELEASE-p4") + (const $ return Nothing) + `shouldReturn` (Nothing, []) + routePath + route + (Environment "linux" "x86_64" $ Kernel "Linux" "5.10.0-8") + (const $ return Nothing) + `shouldReturn` ( Just mempty + , + [ FilePathExpressionWarning + (UndefinedEnvironmentVariable "HOME") + ] + ) + home <- encodeFS "/home/hong" + routePath + route + (Environment "linux" "aarch64" $ Kernel "Linux" "5.10.0-8") + (const $ return $ Just $ home) + `shouldReturn` (Just home, []) diff --git a/test/Dojang/Types/Gen.hs b/test/Dojang/Types/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/Gen.hs @@ -0,0 +1,442 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Dojang.Types.Gen + ( architecture + , ciText + , fileRoute + , fileRoute' + , fileRouteMap + , emptyMonikerNameText + , environment + , environmentPredicate + , environmentVariable + , filePathExpression + , hook + , hookMap + , invalidMonikerNameText + , kernel + , manifest + , manifest' + , monikerMap + , monikerMap' + , monikerName + , monikerNameText + , monikerNameTextHavingInvalidCharacterWithIndex + , monikerNameTextStartingWithNonLetter + , monikerNameWithCIText + , monikerNameError + , operatingSystem + , osPath + , osString + , specificity + ) where + +import Data.Char (isAlpha, isAlphaNum, isAscii, isControl, toUpper) +import Data.List (nub) +import System.IO.Unsafe (unsafePerformIO) +import Prelude hiding (lookup) + +import Data.CaseInsensitive (CI, mk) +import Data.HashMap.Strict (HashMap, fromList, keys, lookup) +import Data.Map.Strict (empty) +import Data.Text (Text, cons, length, pack) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range (Range, constant, constantFrom, singleton) +import System.OsPath (OsPath, encodeFS, joinPath) +import System.OsString (OsString) +import Test.Hspec.Hedgehog (MonadGen) + +import Data.Map.Strict qualified as Map +import Dojang.MonadFileSystem (FileType (..)) +import Dojang.Types.Environment + ( Architecture (..) + , Environment (Environment) + , Kernel (..) + , OperatingSystem (..) + ) +import Dojang.Types.EnvironmentPredicate + ( EnvironmentPredicate (..) + , normalizePredicate + ) +import Dojang.Types.EnvironmentPredicate.Specificity (Specificity (..)) +import Dojang.Types.FilePathExpression + ( EnvironmentVariable + , FilePathExpression (..) + ) +import Dojang.Types.FileRoute qualified as FileRoute +import Dojang.Types.FileRouteMap (FileRouteMap) +import Dojang.Types.Hook (Hook (..), HookMap, HookType (..)) +import Dojang.Types.Manifest (Manifest (..)) +import Dojang.Types.MonikerMap (MonikerMap) +import Dojang.Types.MonikerName + ( MonikerName + , MonikerNameError (..) + , parseMonikerName + ) + + +ciText :: (MonadGen m) => Range Int -> m Char -> m (CI Text) +ciText range char = mk <$> Gen.text range char + + +monikerNameText :: (MonadGen m) => m Text +monikerNameText = do + firstChar <- Gen.text (constant 1 1) Gen.alpha + rest <- Gen.text (constantFrom 0 0 256) Gen.alphaNum + return $ firstChar <> rest + + +monikerNameWithCIText :: (MonadGen m) => m (MonikerName, CI Text) +monikerNameWithCIText = do + name <- monikerNameText + let Right monikerName' = parseMonikerName name + return (monikerName', mk name) + + +monikerName :: (MonadGen m) => m MonikerName +monikerName = fst <$> monikerNameWithCIText + + +invalidMonikerNameText :: (MonadGen m) => m Text +invalidMonikerNameText = + Gen.choice + [ emptyMonikerNameText + , monikerNameTextStartingWithNonLetter + , fst <$> monikerNameTextHavingInvalidCharacterWithIndex + ] + + +emptyMonikerNameText :: (MonadGen m) => m Text +emptyMonikerNameText = Gen.text (constant 0 0) Gen.unicodeAll + + +monikerNameTextStartingWithNonLetter :: (MonadGen m) => m Text +monikerNameTextStartingWithNonLetter = do + firstChar <- Gen.text (constant 1 1) Gen.digit + rest <- Gen.text (constantFrom 0 0 256) Gen.unicodeAll + return $ firstChar <> rest + + +monikerNameTextHavingInvalidCharacterWithIndex :: (MonadGen m) => m (Text, Int) +monikerNameTextHavingInvalidCharacterWithIndex = do + a <- Gen.text (constantFrom 1 1 256) Gen.alpha + b <- + Gen.text (constant 1 1) $ + Gen.filterT (\c -> c /= '-' && c /= '_' && not (isAlphaNum c)) Gen.unicodeAll + c <- Gen.text (constantFrom 0 0 256) Gen.alphaNum + return (a <> b <> c, Data.Text.length a) + + +monikerNameError :: (MonadGen m) => m MonikerNameError +monikerNameError = + Gen.choice + [ return Empty + , return StartingWithNonLetter + , HavingInvalidCharacter <$> Gen.integral (constantFrom 0 0 256) + ] + + +operatingSystem :: (MonadGen m) => m OperatingSystem +operatingSystem = + Gen.choice + [ return Android + , return FreeBSD + , return Linux + , return MacOS + , return NetBSD + , return OpenBSD + , return Windows + , OtherOS <$> ciText (constant 0 256) Gen.unicodeAll + ] + + +architecture :: (MonadGen m) => m Architecture +architecture = + Gen.choice + [ return AArch64 + , return X86 + , return X86_64 + , Etc <$> ciText (constant 0 256) Gen.unicodeAll + ] + + +kernelName :: (MonadGen m) => m (CI Text) +kernelName = ciText (constant 1 50) Gen.unicodeAll + + +kernelRelease :: (MonadGen m) => m (CI Text) +kernelRelease = ciText (constant 1 50) Gen.unicodeAll + + +kernel :: (MonadGen m) => m Kernel +kernel = Kernel <$> kernelName <*> kernelRelease + + +environment :: (MonadGen m) => m Environment +environment = Environment <$> operatingSystem <*> architecture <*> kernel + + +environmentPredicate :: (MonadGen m) => m EnvironmentPredicate +environmentPredicate = environmentPredicate' 5 + + +environmentPredicate' :: (MonadGen m) => Int -> m EnvironmentPredicate +environmentPredicate' maxDepth = + Gen.choice $ + [ return Always + , Moniker <$> monikerName + , OperatingSystem <$> operatingSystem + , Architecture <$> architecture + , KernelName <$> kernelName + , KernelRelease <$> kernelRelease + , KernelReleasePrefix <$> (ciText (constant 0 50) Gen.unicodeAll) + , KernelReleaseSuffix <$> (ciText (constant 0 50) Gen.unicodeAll) + ] + ++ if maxDepth < 1 + then [] + else + [ Not <$> environmentPredicate' nextMaxDepth + , And + <$> Gen.nonEmpty + (constant 0 nextMaxDepth) + (environmentPredicate' nextMaxDepth) + , Or + <$> Gen.nonEmpty + (constant 0 nextMaxDepth) + (environmentPredicate' nextMaxDepth) + ] + where + nextMaxDepth :: Int + nextMaxDepth = maxDepth - 1 + + +specificity :: (MonadGen m) => m Specificity +specificity = + Specificity + <$> Gen.integral (constantFrom 0 0 8) + <*> Gen.integral (constantFrom 0 0 8) + + +osChar :: (MonadGen m) => m Char +osChar = + Gen.filterT (not . isControl) $ + Gen.frequency [(5, Gen.alphaNum), (3, Gen.latin1), (2, Gen.unicode)] + + +environmentVariable :: (MonadGen m) => m EnvironmentVariable +environmentVariable = + Gen.frequency + [ (8, typicalEnvVar) + , (2, Gen.text (constantFrom 1 1 256) osChar) + ] + where + typicalEnvVar :: (MonadGen m) => m EnvironmentVariable + typicalEnvVar = do + firstChar <- Gen.upper + rest <- + Gen.text + (constantFrom 1 1 50) + $ Gen.frequency [(8, Gen.upper), (1, Gen.digit), (1, return '_')] + return $ cons firstChar rest + + +filePathExpression :: (MonadGen m) => m FilePathExpression +filePathExpression = filePathExpression' 5 + + +filePathExpression' :: (MonadGen m) => Int -> m FilePathExpression +filePathExpression' maxDepth = + Gen.choice $ + [ bareComponent + , root + , substitution + ] + ++ if maxDepth > 0 + then + [ concatenation + , pathSeparator + , substitutionWithDefault + , conditionalSubstitution + ] + else [] + where + filePathExpr :: (MonadGen m) => m FilePathExpression + filePathExpr = filePathExpression' (maxDepth - 1) + bareComponent :: (MonadGen m) => m FilePathExpression + bareComponent = + BareComponent + <$> Gen.text + (constantFrom 1 1 256) + ( Gen.filterT + (`notElem` ['/', '\\', '$', '{', '}', ':', '\r', '\n']) + osChar + ) + root :: (MonadGen m) => m FilePathExpression + root = Root . fmap toUpper <$> Gen.maybe Gen.alpha + concatenation :: (MonadGen m) => m FilePathExpression + concatenation = + Gen.filterT + ( \case + Concatenation (Concatenation _ _) _ -> False + Concatenation _ (Concatenation _ _) -> False + Concatenation (PathSeparator _ _) _ -> False + Concatenation _ (PathSeparator _ _) -> False + c@(Concatenation (BareComponent _) b) -> + not (startsWithBareComponent b) && not (containsRoot c) + c -> not $ containsRoot c + ) + $ Concatenation + <$> filePathExpr + <*> filePathExpr + pathSeparator :: (MonadGen m) => m FilePathExpression + pathSeparator = + PathSeparator + <$> filePathExpr + <*> Gen.filterT + (\case PathSeparator _ _ -> False; e -> not $ containsRoot e) + filePathExpr + envVar :: (MonadGen m) => m EnvironmentVariable + envVar = do + first <- Gen.filterT (\c -> isAscii c && isAlpha c || c == '_') osChar + rest <- + Gen.text (constantFrom 0 0 256) $ + Gen.filterT (\c -> isAscii c && isAlphaNum c || c == '_') osChar + return $ first `cons` rest + substitution :: (MonadGen m) => m FilePathExpression + substitution = Substitution <$> envVar + substitutionWithDefault :: (MonadGen m) => m FilePathExpression + substitutionWithDefault = + SubstitutionWithDefault + <$> envVar + <*> Gen.filterT (\case Root _ -> False; _ -> True) filePathExpr + conditionalSubstitution :: (MonadGen m) => m FilePathExpression + conditionalSubstitution = + ConditionalSubstitution + <$> envVar + <*> Gen.filterT (\case Root _ -> False; _ -> True) filePathExpr + startsWithBareComponent :: FilePathExpression -> Bool + startsWithBareComponent (BareComponent _) = True + startsWithBareComponent (Concatenation a _) = startsWithBareComponent a + startsWithBareComponent (PathSeparator a _) = startsWithBareComponent a + startsWithBareComponent _ = False + containsRoot :: FilePathExpression -> Bool + containsRoot (Root _) = True + containsRoot (Concatenation a b) = containsRoot a || containsRoot b + containsRoot (PathSeparator a b) = containsRoot a || containsRoot b + containsRoot (SubstitutionWithDefault _ expr) = containsRoot expr + containsRoot (ConditionalSubstitution _ expr) = containsRoot expr + containsRoot _ = False + + +monikerMap :: (MonadGen m) => m (HashMap MonikerName EnvironmentPredicate) +monikerMap = monikerMap' (constantFrom 0 0 10) + + +monikerMap' + :: (MonadGen m) => Range Int -> m (HashMap MonikerName EnvironmentPredicate) +monikerMap' sizeRange = do + keys' <- Gen.list sizeRange monikerName + let cardinality = Prelude.length keys' + values <- + Gen.list (constant cardinality cardinality) $ + normalizePredicate + <$> environmentPredicate + return $ fromList $ zip keys' values + + +fileRoute :: (MonadGen m) => m FileRoute.FileRoute +fileRoute = do + mm <- monikerMap' (constant 0 5) + fileRoute' (constant 0 5) mm environmentPredicate + + +fileRoute' + :: (MonadGen m) + => Range Int + -> MonikerMap + -> m EnvironmentPredicate + -> m FileRoute.FileRoute +fileRoute' predicatesNumberRange mm predGen = do + predicates <- + nub . map normalizePredicate <$> Gen.list predicatesNumberRange predGen + let cardinality = Prelude.length predicates + paths <- + Gen.list (constant cardinality cardinality) $ Gen.maybe filePathExpression + fileOrDir <- Gen.element [File, Directory] + return $ FileRoute.fileRoute' (`lookup` mm) (predicates `zip` paths) fileOrDir + + +osString :: (MonadGen m) => Range Int -> m Char -> m OsString +osString range = fmap (unsafePerformIO . encodeFS) . Gen.string range + + +osPath :: (MonadGen m) => Range Int -> m OsPath +osPath range = + joinPath + <$> Gen.list + range + ( osString + (constant 1 100) + ( Gen.filterT + (\c -> c `notElem` "/\\:" && not (isControl c)) + Gen.unicode + ) + ) + + +fileRouteMap :: (MonadGen m) => Range Int -> MonikerMap -> m FileRouteMap +fileRouteMap range monikers = + Gen.map range $ do + key <- osPath (singleton 1) + value <- + fileRoute' (constant 0 5) monikers $ + Gen.choice $ + map return $ + fmap Moniker $ + case keys monikers of + [] -> + let Right undefined' = parseMonikerName $ pack "undefined" + in [undefined'] + names -> names + return (key, value) + + +manifest' :: forall m. (MonadGen m) => Range Int -> Range Int -> m Manifest +manifest' monikerMapRange fileRouteMapRange = do + monikers <- monikerMap' monikerMapRange + fileRoutes <- fileRouteMap fileRouteMapRange monikers + hooks <- hookMap (constant 0 3) + return $ Manifest monikers fileRoutes Data.Map.Strict.empty hooks + + +manifest :: (MonadGen m) => m Manifest +manifest = manifest' (constantFrom 0 0 5) (constantFrom 0 0 5) + + +hook :: (MonadGen m) => m Hook +hook = do + cmd <- osPath (constant 1 3) + argsCount <- Gen.integral (constant 0 5) + args' <- Gen.list (singleton argsCount) $ Gen.text (constant 1 20) Gen.alphaNum + cond <- normalizePredicate <$> environmentPredicate' 2 + workDir <- Gen.maybe $ osPath (constant 1 3) + ignoreFail <- Gen.bool + return + Hook + { command = cmd + , args = args' + , condition = cond + , workingDirectory = workDir + , ignoreFailure = ignoreFail + } + + +hookMap :: (MonadGen m) => Range Int -> m HookMap +hookMap range = do + -- Generate a list of hook types to include (0 to 4 types) + hookTypes <- + Gen.subsequence [PreApply, PreFirstApply, PostFirstApply, PostApply] + pairs <- mapM (\ht -> (,) ht <$> Gen.list range hook) hookTypes + return $ Map.fromList [(ht, hs) | (ht, hs) <- pairs, not (null hs)] diff --git a/test/Dojang/Types/HookSpec.hs b/test/Dojang/Types/HookSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/HookSpec.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.HookSpec (spec) where + +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Expectations.Pretty (shouldBe) + +import Dojang.Types.Hook (HookType (..), allHookTypes) + + +spec :: Spec +spec = do + describe "HookType" $ do + it "has correct ordering (execution order)" $ do + allHookTypes `shouldBe` [PreApply, PreFirstApply, PostFirstApply, PostApply] + + it "PreApply < PreFirstApply < PostFirstApply < PostApply" $ do + (PreApply < PreFirstApply) `shouldBe` True + (PreFirstApply < PostFirstApply) `shouldBe` True + (PostFirstApply < PostApply) `shouldBe` True + + it "Eq works correctly" $ do + (PreApply == PreApply) `shouldBe` True + (PreApply == PostApply) `shouldBe` False + + it "Show works correctly" $ do + show PreApply `shouldBe` "PreApply" + show PreFirstApply `shouldBe` "PreFirstApply" + show PostFirstApply `shouldBe` "PostFirstApply" + show PostApply `shouldBe` "PostApply" diff --git a/test/Dojang/Types/MonikerNameSpec.hs b/test/Dojang/Types/MonikerNameSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/MonikerNameSpec.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Dojang.Types.MonikerNameSpec (spec) where + +import Dojang.Types.Gen + ( emptyMonikerNameText + , invalidMonikerNameText + , monikerName + , monikerNameError + , monikerNameText + , monikerNameTextHavingInvalidCharacterWithIndex + , monikerNameTextStartingWithNonLetter + , monikerNameWithCIText + ) +import Dojang.Types.MonikerName + ( MonikerNameError (Empty, HavingInvalidCharacter, StartingWithNonLetter) + , parseMonikerName + ) + +import Data.CaseInsensitive (foldCase, mk) +import Data.Either (isLeft) +import Data.Hashable (Hashable (hashWithSalt)) +import Test.Hspec (Spec, describe, specify) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.Hedgehog + ( assert + , forAll + , hedgehog + , (===) + ) + + +spec :: Spec +spec = do + describe "parseMonikerName" $ do + specify "examples" $ do + let Right a = parseMonikerName "foo-bar" + a.name `shouldBe` "foo-bar" + let Right b = parseMonikerName "甲乙_丙丁" + b.name `shouldBe` "甲乙_丙丁" + parseMonikerName "" `shouldBe` Left Empty + parseMonikerName "1" `shouldBe` Left StartingWithNonLetter + parseMonikerName "*" `shouldBe` Left StartingWithNonLetter + parseMonikerName "$foo" `shouldBe` Left StartingWithNonLetter + parseMonikerName "foo\tbar" `shouldBe` Left (HavingInvalidCharacter 3) + + specify "properties" $ hedgehog $ do + forAll monikerNameText >>= \name -> + let Right parsed = parseMonikerName name + in parsed.name === mk name + forAll invalidMonikerNameText >>= \name -> + assert $ isLeft $ parseMonikerName name + forAll emptyMonikerNameText >>= \name -> + parseMonikerName name === Left Empty + forAll monikerNameTextStartingWithNonLetter >>= \name -> + parseMonikerName name === Left StartingWithNonLetter + forAll monikerNameTextHavingInvalidCharacterWithIndex >>= \(name, idx) -> + parseMonikerName name === Left (HavingInvalidCharacter idx) + + describe "MonikerName" $ do + specify "Eq" $ hedgehog $ do + name <- forAll monikerName + name' <- forAll monikerName + (name == name') === (foldCase name.name == foldCase name'.name) + (name /= name') === (foldCase name.name /= foldCase name'.name) + + specify "Ord" $ hedgehog $ do + name <- forAll monikerName + name' <- forAll monikerName + let foldedName = foldCase name.name + let foldedName' = foldCase name'.name + name `compare` name' === foldedName `compare` foldedName' + (name < name') === (foldedName < foldedName') + (name <= name') === (foldedName <= foldedName') + (name > name') === (foldedName > foldedName') + (name >= name') === (foldedName >= foldedName') + (min name name').name === min foldedName foldedName' + (max name name').name === max foldedName foldedName' + + specify "Hashable" $ hedgehog $ do + (name, nameText) <- forAll monikerNameWithCIText + hashWithSalt 0 name === hashWithSalt 0 (foldCase nameText) + + specify "HasField \"name\"" $ hedgehog $ do + (name, nameText) <- forAll monikerNameWithCIText + name.name === nameText + + specify "Show" $ hedgehog $ do + (name, nameText) <- forAll monikerNameWithCIText + show name === "MonikerName " ++ show nameText + shows name "" === "MonikerName " ++ shows nameText "" + showList [name] "" === "[MonikerName " ++ show nameText ++ "]" + + describe "MonikerNameError" $ do + specify "Eq" $ hedgehog $ do + e <- forAll monikerNameError + e' <- forAll monikerNameError + (e == e') === (show e == show e') + (e /= e') === (show e /= show e') + + specify "Show" $ hedgehog $ do + e <- forAll monikerNameError + read (show e) === e + read (shows e "") === e + read (showList [e] "") === [e] diff --git a/test/Dojang/Types/RegistrySpec.hs b/test/Dojang/Types/RegistrySpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/RegistrySpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.RegistrySpec (spec) where + +import System.Info (os) + +import System.OsPath (encodeFS, ()) +import Test.Hspec (Spec, describe, it, runIO) +import Test.Hspec.Expectations.Pretty (shouldBe) + +import Dojang.MonadFileSystem (MonadFileSystem (..)) +import Dojang.TestUtils (withTempDir) +import Dojang.Types.Registry + ( Registry (..) + , readRegistry + , registryFilename + , writeRegistry + ) + + +win :: Bool +win = os == "mingw32" + + +spec :: Spec +spec = do + dotDojang <- runIO $ encodeFS ".dojang" + repoPath <- + runIO $ encodeFS $ if win then "C:\\dotfiles" else "/home/test/dotfiles" + + describe "registryFilename" $ do + it "is .dojang" $ do + registryFilename `shouldBe` dotDojang + + describe "readRegistry" $ do + it "returns Nothing if file does not exist" $ withTempDir $ \tmpDir _ -> do + result <- readRegistry (tmpDir dotDojang) + result `shouldBe` Nothing + + it "parses valid registry file" $ withTempDir $ \tmpDir _ -> do + let registryPath = tmpDir dotDojang + Dojang.MonadFileSystem.writeFile registryPath $ + "repository = \"" + <> (if win then "C:\\\\dotfiles" else "/home/test/dotfiles") + <> "\"\n" + result <- readRegistry registryPath + result `shouldBe` Just (Registry repoPath) + + it "returns Nothing for invalid TOML" $ withTempDir $ \tmpDir _ -> do + let registryPath = tmpDir dotDojang + Dojang.MonadFileSystem.writeFile registryPath "invalid toml content" + result <- readRegistry registryPath + result `shouldBe` Nothing + + describe "writeRegistry" $ do + it "creates registry file with repository path" $ withTempDir $ \tmpDir _ -> do + let registryPath = tmpDir dotDojang + writeRegistry registryPath (Registry repoPath) + result <- readRegistry registryPath + result `shouldBe` Just (Registry repoPath) + + it "overwrites existing registry file" $ withTempDir $ \tmpDir _ -> do + let registryPath = tmpDir dotDojang + oldPath <- encodeFS $ if win then "C:\\old" else "/old" + newPath <- encodeFS $ if win then "C:\\new" else "/new" + writeRegistry registryPath (Registry oldPath) + writeRegistry registryPath (Registry newPath) + result <- readRegistry registryPath + result `shouldBe` Just (Registry newPath) diff --git a/test/Dojang/Types/RepositorySpec.hs b/test/Dojang/Types/RepositorySpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Types/RepositorySpec.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Types.RepositorySpec (spec) where + +import System.Info (os) + +import System.OsPath (encodeFS, ()) +import Test.Hspec (Spec, runIO, specify) +import Test.Hspec.Expectations.Pretty + ( shouldBe + , shouldNotSatisfy + , shouldReturn + , shouldSatisfy + ) + +import Dojang.MonadFileSystem (FileType (..)) +import Dojang.Types.Environment (Environment (..), Kernel (..)) +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (Always)) +import Dojang.Types.FileRoute (fileRoute) +import Dojang.Types.Manifest (Manifest (..)) +import Dojang.Types.MonikerMap (MonikerMap) +import Dojang.Types.MonikerName (parseMonikerName) +import Dojang.Types.Repository + ( Repository (..) + , RouteMapWarning (OverlapDestinationPathsWarning) + , RouteResult (..) + , findOverlappingRouteResults + , overlaps + , routePaths + ) + + +win :: Bool +win = os == "mingw32" + + +spec :: Spec +spec = do + root <- runIO $ encodeFS $ if win then "C:\\" else "/" + foo <- runIO $ encodeFS "foo" + bar <- runIO $ encodeFS "bar" + baz <- runIO $ encodeFS "baz" + qux <- runIO $ encodeFS "qux" + src <- runIO $ encodeFS "src" + dst <- runIO $ encodeFS "dst" + inter <- runIO $ encodeFS ".dojang" + + specify "routePaths" $ do + let Right any' = parseMonikerName "any" + let monikers = [(any', Always)] :: MonikerMap + let dirRoute expr = fileRoute monikers [(any', Just expr)] Directory + let manifest = + Manifest + { monikers = monikers + , fileRoutes = + [ (foo, dirRoute $ if win then "C:\\dst\\foo" else "/dst/foo") + , + ( bar + , dirRoute $ + if win then "C:\\dst\\foo\\bar" else "/dst/foo/bar" + ) + , + ( baz + , dirRoute $ + if win + then "C:\\dst\\foo\\bar\\baz" + else "/dst/foo/bar/baz" + ) + , + ( qux + , dirRoute $ + if win then "C:\\dst\\foo\\qux" else "/dst/foo/qux" + ) + ] + , ignorePatterns = + [ (foo, ["bar"]) + ] + , hooks = mempty + } + let repo = + Repository + { sourcePath = root src + , intermediatePath = root src inter + , manifest = manifest + } + let env = Environment "linux" "x86_64" $ Kernel "Linux" "4.19.0-16-amd64" + routePaths repo env (const $ return Nothing) + `shouldReturn` ( + [ RouteResult + (root src bar) + bar + (root dst foo bar) + Directory + , RouteResult + (root src baz) + baz + (root dst foo bar baz) + Directory + , RouteResult + (root src foo) + foo + (root dst foo) + Directory + , RouteResult + (root src qux) + qux + (root dst foo qux) + Directory + ] + , + [ OverlapDestinationPathsWarning + bar + (root dst foo bar) + [(baz, root dst foo bar baz)] + , OverlapDestinationPathsWarning + foo + (root dst foo) + [(qux, root dst foo qux)] + ] + ) + + specify "findOverlappingRouteResults" $ do + findOverlappingRouteResults + [ RouteResult (root src foo) foo (root foo) Directory + , RouteResult (root src bar) bar (root bar) Directory + , RouteResult (root src baz) baz (root foo baz) Directory + , RouteResult + (root src qux) + qux + (root foo baz qux) + File + ] + `shouldBe` [ + ( (baz, root foo baz) + , [(qux, root foo baz qux)] + ) + , + ( (foo, root foo) + , + [ (baz, root foo baz) + , (qux, root foo baz qux) + ] + ) + ] + + specify "overlaps" $ do + foo `shouldSatisfy` overlaps foo + foo `shouldSatisfy` (`overlaps` (foo bar)) + foo `shouldSatisfy` (`overlaps` (foo bar baz)) + foo `shouldNotSatisfy` (`overlaps` bar) + foo `shouldNotSatisfy` (`overlaps` (bar foo)) + (foo bar) `shouldNotSatisfy` (`overlaps` foo) + (foo bar) `shouldSatisfy` (`overlaps` (foo bar)) + (foo bar) `shouldSatisfy` (`overlaps` (foo bar baz)) + (foo bar) `shouldNotSatisfy` (`overlaps` (foo baz)) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import qualified Spec + +import Test.Hspec.Api.Formatters.V1 (specdoc, useFormatter) +import Test.Hspec.JUnit.Formatter () +import Test.Hspec.Runner (defaultConfig, hspecWith) + + +main :: IO () +main = hspecWith (useFormatter ("specdoc", specdoc) defaultConfig) Spec.spec + +-- cSpell:ignore specdoc diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} + diff --git a/test/SpecHook.hs b/test/SpecHook.hs new file mode 100644 --- /dev/null +++ b/test/SpecHook.hs @@ -0,0 +1,7 @@ +module SpecHook where + +import Test.Hspec (Spec, parallel) + + +hook :: Spec -> Spec +hook = parallel