diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,16 @@ +# changelog + +## 0.1.0.0 + +first release. + +- checks: `build-lag`, `drift`, `duplicate-name`, `fedora-overlap`, + `no-autoupdate`, `stale`, `unparsed-rhai`, `upstream-error` +- text, markdown and json output, with a versioned json envelope +- `--fail-on` and distinct exit codes for automation +- ignore files and `oglyad_ignore` labels in anda.hcl +- caching of spec evaluations, repodata, commit times and upstream answers + +## 0.1.1.0 + +prepare for release on Hackage 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,191 @@ +# oglyad + +repository metadata and health checker for [Terra](https://terra.fyralabs.com). +"огляд" is Ukrainian for "review" or "inspection". + +```sh +git clone https://github.com/terrapkg/packages ../packages +oglyad -m ../packages # warnings and errors +oglyad -m ../packages -v # plus info findings +oglyad -m ../packages -u # plus upstream version drift +oglyad -m ../packages --fedora # plus overlap with Fedora +oglyad -m ../packages --only drift --format json +``` + +from a checkout, `cabal run oglyad -- ` and `cabal test`. it needs +`rpmspec` (rpm-build), `git`, and the `zstd`, `gzip` and `xz` commands. +upstream lookups use `GITHUB_TOKEN`, or `gh auth token` when that's unset. + +## output and exit codes + +`--format` picks `text` (default), `markdown` (made for GitHub job +summaries) or `json`. the json is a versioned envelope: + +```json +{"schema": 1, "oglyad": "0.1.0.0", "generated": "...", "monorepo_head": "...", + "summary": {"error": 0, "warn": 0, "info": 0, "ignored": 0}, + "findings": [{"check": "...", "package": "...", "path": "...", "severity": "...", "message": "..."}], + "ignored": [...]} +``` + +`schema` changes on any breaking change to the json. + +| exit | meaning | +|---|---| +| 0 | ran, nothing at or above `--fail-on` (default `error`, or `warn`, `info`, `never`) | +| 1 | ran, and found something at or above `--fail-on` | +| 2 | couldn't run: bad flags, unreadable ignore file, not a monorepo | + +## ignoring known findings + +some findings are intentional, like a bootstrap package sharing its real +package's name. there are two ways to silence one, and ignored findings +don't count toward the exit code. + +an ignore file, passed with `--ignore-file`. every entry needs a reason, and +names one check plus a monorepo `path` or a `package` name: + +```json +{ + "ignore": [ + {"check": "duplicate-name", "path": "anda/langs/zig/master-bootstrap", + "reason": "bootstrap build of zig-master"} + ] +} +``` + +or a label in the package's own `anda.hcl`: + +```hcl +labels { + oglyad_ignore = "duplicate-name, stale" +} +``` + +file entries that no longer match anything are reported as `unused-ignore`, +so exceptions don't outlive their reason. `--no-ignores` shows everything. +[`ignores.json`](ignores.json) is the file the nightly report uses. + +## checks + +| check | severity | what it means | +|---|---|---| +| `build-lag` | error / warn / info | never published, merged but not built, or the repo is newer than your checkout | +| `drift` | warn | upstream released something newer than the spec (`-u`) | +| `duplicate-name` | warn | two directories build the same package name into the same repo, so they overwrite each other | +| `stale` | info, warn with `-u` | last build is older than `--stale-days`, warn if upstream also moved on | +| `upstream-error` | warn | the upstream from update.rhai 404s or fails, so `anda update` is failing too | +| `fedora-overlap` | warn | Fedora ships the same source package (`--fedora`). subrepos are exempt | +| `no-autoupdate` | info | no update.rhai | +| `unparsed-rhai` | info | update.rhai does something oglyad can't follow, like custom scraping | +| `collect` | error | rpmspec failed, a repo couldn't be fetched, or an upstream rate-limited us (warn) | +| `unused-ignore` | info / warn | an ignore entry matches nothing, or an `oglyad_ignore` label names an unknown check | + +## how it works + +``` + ┌──────────── IO shell (Collect) ──┐ ┌──── pure core ────┐ ┌─ IO ─┐ + monorepo: rpmspec, git ──┐ + Terra repodata + subrepos├─► Snapshot ───► [Check] ─► [Finding] ─► Report + Fedora repodata ─────────┤ + upstream APIs ───────────┘ +``` + +checks are `Snapshot -> Package -> [Finding]` and never do IO, so each one is +tested with a fake `Snapshot` in `test/Spec.hs`. + +- **specs** are evaluated with `rpmspec` +- **update.rhai** is lexed and pattern-matched, not run. it follows `let` + bindings into `rpm.version(...)` / `rpm.global("ver", ...)` and recognizes + the andax helpers (`gh`, `pypi`, `crates`, `gitlab`, ...) +- **upstream lookups** hit the same endpoints anda does, so oglyad sees what + `anda update` would +- **versions** compare with a port of rpm's `rpmvercmp`, plus some forgiveness + for respelled tags (`v1.2`, `1.2-rc1` vs `1.2~rc1`, `2026-07-27` vs `20260727`) + +## caching + +everything lives in `~/.cache/oglyad`. + +| file | reused while | +|---|---| +| `specs.fcNN.json` | the package dir's files, the dist tag, and rpm's whole macro state (`rpm --showrc`) are unchanged | +| `commits.json` | HEAD hasn't moved | +| `repodata-*.json` | the repo's primary.xml checksum is unchanged | +| `upstream.json` | younger than `--cache-hours` (default 6), successes only. entries unused for 30 days are dropped | + +a run with warm caches takes about 0.4s. a cold run takes about 5s, almost +all of it in rpmspec. `--fedora` adds about 8s and peaks around 200MB of +memory the first time, since Fedora's repodata is 260MB decompressed. after +that it's cached until Fedora publishes again. + +## security + +`rpmspec` runs the shell code in specs (`%(...)`, `%{lua:...}`), so running +oglyad on a checkout means running that checkout's code as you. child +processes get an allowlisted environment, so `GITHUB_TOKEN` and other +secrets in oglyad's environment never reach them, but code running as your +user can still read your files. + +**don't run oglyad on untrusted code, like an unmerged pull request, with +credentials around.** the nightly report only checks out terrapkg/packages' +default branch, and its token is read-only and expires with the job. + +the GitHub token is only ever sent to `api.github.com`, and is dropped if a +request gets redirected anywhere else. + +## nightly report + +[`report.yml`](.github/workflows/report.yml) runs every night in Terra's +builder image (`ghcr.io/terrapkg/builder:f45`), so specs evaluate with the +same macros Terra builds with. it builds `oglyad-git` with anda, checks +terrapkg/packages' default branch with `-u --fedora`, writes the markdown +report to the run's summary, and keeps the markdown and json for 30 days. +caches carry over between nights. + +## packaging + +built the same way as anda itself. [`anda.hcl`](anda.hcl) has two projects: + +| project | spec | builds | +|---|---|---| +| `oglyad` | [`oglyad.spec`](oglyad.spec) | the `v` release tag | +| `oglyad-git` | [`oglyad-git.spec`](oglyad-git.spec) | the checked-out commit, versioned `^.` | + +```sh +anda build oglyad-git --package rpm -c terra-45-x86_64 +``` + +both build in mock, offline, against Fedora's Haskell libraries with +`%ghc_bin_build`, run the test suite in `%check`, and ship one self-contained +binary. [`package-git.yml`](.github/workflows/package-git.yml) builds +`oglyad-git` on x86_64 and aarch64 for every push to main and every pull +request that touches the code. + +## releasing + +1. bump `version` in `oglyad.cabal` and `oglyad.spec`, and add a + `CHANGELOG.md` entry +2. push a `v` tag, e.g. `v0.1.0.0` + +[`hackage.yml`](.github/workflows/hackage.yml) checks the tag matches the +cabal version, builds and tests the sdist, and publishes it to Hackage. the +same tag is what `oglyad.spec` downloads. to preview a release first, run the +workflow by hand, which uploads a Hackage package candidate instead. + +it needs a `HACKAGE_TOKEN` secret (an API token from your Hackage account) in +a GitHub environment named `hackage`. + +## formatting + +code is formatted with [ormolu](https://github.com/tweag/ormolu) 0.9.0.0, and +CI fails on unformatted files. install the matching version from its +[release page](https://github.com/tweag/ormolu/releases/tag/0.9.0.0), then: + +```sh +ormolu --mode inplace $(git ls-files '*.hs') +``` + +## license + +GPL-3.0-or-later. see [LICENSE](LICENSE). diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE ApplicativeDo #-} + +-- ApplicativeDo lets configP use do-notation even though optparse's Parser +-- is only an Applicative, not a Monad +module Main (main) where + +import Control.Exception (SomeException, try) +import Control.Monad (unless, when) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (getCurrentTime) +import GHC.Conc (getNumProcessors) +import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding, utf8) +import Oglyad.App (oglyadVersion, runApp) +import Oglyad.Check (checkNames, parseCheckName, runChecks) +import Oglyad.Collect (buildSnapshot) +import Oglyad.Ignore (Applied (..), IgnoreFile (..), applyIgnores, parseIgnoreFile) +import Oglyad.Process (run) +import Oglyad.Report (Format (..), Report (..), render) +import Oglyad.Types +import Options.Applicative +import System.Directory (doesDirectoryExist) +import System.Environment (getArgs, getProgName, lookupEnv) +import System.Exit (ExitCode (..), exitWith) +import System.FilePath (()) +import System.IO (hPutStrLn, hSetEncoding, stderr, stdout) + +-- | exit codes, so cron jobs and CI can tell "found problems" apart from +-- "couldn't run" +exitFindings, exitUsage :: ExitCode +exitFindings = ExitFailure 1 +exitUsage = ExitFailure 2 + +data Opts = Opts + { optConfig :: Maybe Text -> Int -> Config, + optOnly :: [Text], + optFormat :: Format, + optMinSev :: Severity, + -- | Nothing means never fail on findings + optFailOn :: Maybe Severity, + optIgnoreFile :: Maybe FilePath, + optNoIgnores :: Bool + } + +optsP :: Parser Opts +optsP = do + optConfig <- configP + optOnly <- many (option (eitherReader parseCheckName) (long "only" <> metavar "CHECK" <> help ("run only this check, repeatable. one of: " <> names))) + optFormat <- + option (eitherReader format) (long "format" <> short 'f' <> metavar "FORMAT" <> help "text (default), json, or markdown") + <|> flag' Json (long "json" <> help "same as --format json") + <|> pure Text + optMinSev <- + flag' Info (long "verbose" <> short 'v' <> help "show info findings too") + <|> pure Warn + optFailOn <- option (eitherReader failOn) (long "fail-on" <> metavar "LEVEL" <> value (Just Error) <> help "exit 1 if any finding is at least this severe: error (default), warn, info, or never") + optIgnoreFile <- optional (strOption (long "ignore-file" <> metavar "FILE" <> help "json file of known findings to ignore, see README")) + optNoIgnores <- switch (long "no-ignores" <> help "report everything, ignoring the ignore file and anda.hcl oglyad_ignore labels") + pure Opts {..} + where + names = T.unpack (T.intercalate ", " checkNames) + format = \case + "text" -> Right Text + "json" -> Right Json + "markdown" -> Right Markdown + other -> Left ("unknown format " <> show other <> ", expected text, json or markdown") + failOn = \case + "error" -> Right (Just Error) + "warn" -> Right (Just Warn) + "info" -> Right (Just Info) + "never" -> Right Nothing + other -> Left ("unknown level " <> show other <> ", expected error, warn, info or never") + +configP :: Parser (Maybe Text -> Int -> Config) +configP = do + cfgMonorepo <- strOption (long "monorepo" <> short 'm' <> metavar "DIR" <> value "." <> showDefault <> help "checkout of terrapkg/packages") + release <- option auto (long "release" <> short 'r' <> metavar "N" <> value (44 :: Int) <> showDefault <> help "Fedora/Terra release to check") + terraRepo <- optional (strOption (long "repo" <> metavar "URL" <> help "Terra repo base url (default: https://repos.fyralabs.com/terraN)")) + fedora <- switch (long "fedora" <> help "also check for overlap with Fedora's release and updates repos (downloads ~60MB)") + extraFedora <- many (strOption (long "fedora-repo" <> metavar "URL" <> help "extra repo base url to check for overlap, repeatable")) + staleDays <- option auto (long "stale-days" <> metavar "N" <> value (180 :: Int) <> showDefault <> help "builds older than this count as stale") + cfgUpstream <- switch (long "upstream" <> short 'u' <> help "query upstream APIs for version drift") + cacheHours <- option auto (long "cache-hours" <> metavar "N" <> value (6 :: Int) <> showDefault <> help "reuse upstream answers younger than this, 0 to always refetch") + jobs <- optional (option auto (long "jobs" <> short 'j' <> metavar "N" <> help "parallel jobs (default: number of cores)")) + pure $ \cfgGitHubToken cores -> + let r = T.pack (show release) + fedoraRepos = + [ "https://dl.fedoraproject.org/pub/fedora/linux/releases/" <> r <> "/Everything/x86_64/os", + "https://dl.fedoraproject.org/pub/fedora/linux/updates/" <> r <> "/Everything/x86_64" + ] + in Config + { cfgTerraRepo = maybe ("https://repos.fyralabs.com/terra" <> r) id terraRepo, + cfgFedoraRepos = (if fedora then fedoraRepos else []) <> extraFedora, + cfgRelease = release, + cfgDist = ".fc" <> r, + cfgStaleAfter = fromIntegral (staleDays * 86400), + cfgCacheFor = fromIntegral (cacheHours * 3600), + cfgConcurrency = maybe cores id jobs, + .. + } + +-- | GITHUB_TOKEN, or whatever the gh cli is logged in with. the token is only +-- ever sent to api.github.com, and never passed to child processes +githubToken :: IO (Maybe Text) +githubToken = + lookupEnv "GITHUB_TOKEN" >>= \case + Just t | not (null t) -> pure (Just (T.pack t)) + _ -> either (const Nothing) (nonEmpty . T.strip) <$> run "gh" ["auth", "token"] + where + nonEmpty t = if T.null t then Nothing else Just t + +-- | like execParser, but bad arguments exit with 'exitUsage' instead of 1 +parseOpts :: IO Opts +parseOpts = do + args <- getArgs + prog <- getProgName + let pinfo = + info + (optsP <**> helper <**> simpleVersioner ("oglyad " <> T.unpack oglyadVersion)) + (fullDesc <> progDesc "repository metadata and health checker for Terra") + case execParserPure defaultPrefs pinfo args of + Failure f -> do + let (msg, code) = renderFailure f prog + hPutStrLn stderr msg + exitWith (if code == ExitSuccess then ExitSuccess else exitUsage) + other -> handleParseResult other + +usageError :: String -> IO a +usageError msg = hPutStrLn stderr ("oglyad: " <> msg) >> exitWith exitUsage + +main :: IO () +main = do + -- cron and CI often run under LANG=C. specs, anda.hcl and rpmspec errors + -- contain non-ascii text, which would crash text IO in a C locale + mapM_ ($ utf8) [setLocaleEncoding, setFileSystemEncoding, setForeignEncoding] + mapM_ (`hSetEncoding` utf8) [stdout, stderr] + + Opts {..} <- parseOpts + ignores <- case optIgnoreFile of + Nothing -> pure (IgnoreFile []) + Just path -> do + raw <- try (BS.readFile path) + case raw of + Left (e :: SomeException) -> usageError ("can't read ignore file " <> path <> ": " <> show e) + Right bytes -> either (\e -> usageError (path <> ": " <> e)) pure (parseIgnoreFile checkNames bytes) + token <- githubToken + cores <- getNumProcessors + let cfg = optConfig token cores + hasAnda <- doesDirectoryExist (cfgMonorepo cfg "anda") + unless hasAnda $ + usageError (cfgMonorepo cfg <> " doesn't look like a terrapkg/packages checkout (no anda/ directory). point -m at one") + + (snap, collectFindings) <- runApp cfg buildSnapshot + now <- getCurrentTime + let ran = if null optOnly then checkNames else optOnly + findings = collectFindings <> runChecks optOnly snap + Applied {..} + | optNoIgnores = Applied findings [] [] + | otherwise = applyIgnores checkNames ran ignores (snapIgnoreLabels snap) findings + report = + Report + { rVersion = oglyadVersion, + rGenerated = now, + rMonorepoHead = snapHead snap, + rTerraRepo = cfgTerraRepo cfg, + rUpstream = cfgUpstream cfg, + rFindings = apKept <> apProblems, + rIgnored = apIgnored + } + LBS.putStr (render optFormat optMinSev report) + when (maybe False (\level -> any ((>= level) . fSeverity) (rFindings report)) optFailOn) $ + exitWith exitFindings diff --git a/oglyad.cabal b/oglyad.cabal new file mode 100644 --- /dev/null +++ b/oglyad.cabal @@ -0,0 +1,117 @@ +cabal-version: 3.0 +name: oglyad +version: 0.1.1.0 +synopsis: repository metadata and health checker for Terra +description: + oglyad checks a terrapkg/packages checkout against Terra's published + repodata and upstream releases. it reports packages that never got built, + stale builds, upstream version drift, broken update.rhai scripts, and + overlap with Fedora. + +category: Distribution +homepage: https://github.com/terrapkg/oglyad +bug-reports: https://github.com/terrapkg/oglyad/issues +license: GPL-3.0-or-later +license-file: LICENSE +author: Cypress Reed +maintainer: cypress@fyralabs.com +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +-- the lower bounds are what Fedora ships, which CI builds against. the upper +-- bounds follow the PVP from the newest versions that have been built +tested-with: GHC ==9.10.3 + +source-repository head + type: git + location: https://github.com/terrapkg/oglyad.git + +common shared + default-language: GHC2021 + default-extensions: + DerivingStrategies + DeriveAnyClass + LambdaCase + MultiWayIf + OverloadedStrings + RecordWildCards + + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints + + build-depends: + , base >=4.20 && <4.21 + , containers >=0.7 && <0.8 + , deepseq >=1.5 && <1.6 + , text >=2.1.3 && <2.2 + , time >=1.12.2 && <1.13 + +-- the modules shared by the binary and the test suite. there's deliberately +-- no library: packaged with Fedora's ghc-rpm-macros, an internal library +-- turns into a private .so that also links the test suite's dependencies +common modules + hs-source-dirs: src + other-modules: + Oglyad.App + Oglyad.Check + Oglyad.Check.BuildLag + Oglyad.Check.Drift + Oglyad.Check.DuplicateName + Oglyad.Check.FedoraOverlap + Oglyad.Check.NoAutoupdate + Oglyad.Check.Stale + Oglyad.Check.UnparsedRhai + Oglyad.Check.UpstreamError + Oglyad.Collect + Oglyad.Ignore + Oglyad.Process + Oglyad.Report + Oglyad.Source.Cache + Oglyad.Source.Monorepo + Oglyad.Source.Repodata + Oglyad.Source.Rhai + Oglyad.Source.Upstream + Oglyad.Types + Oglyad.Version + Paths_oglyad + + autogen-modules: Paths_oglyad + build-depends: + , aeson >=2.2.3 && <2.4 + , async >=2.2.6 && <2.3 + , base16-bytestring >=1.0.2 && <1.1 + , bytestring >=0.12.2 && <0.13 + , conduit >=1.3.6 && <1.4 + , cryptohash-sha256 >=0.11.102 && <0.12 + , directory >=1.3.8 && <1.4 + , filepath >=1.5.4 && <1.6 + , http-client >=0.7.19 && <0.8 + , http-client-tls >=0.3.6 && <0.5 + , http-types >=0.12.4 && <0.13 + , megaparsec >=9.7 && <9.9 + , mtl >=2.3.1 && <2.4 + , typed-process >=0.2.13 && <0.3 + , vector >=0.13.2 && <0.14 + , xml-conduit >=1.10.1 && <1.11 + , xml-types >=0.3.8 && <0.4 + +executable oglyad + import: shared, modules + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts "-with-rtsopts=-N4" + build-depends: optparse-applicative >=0.18.1 && <0.20 + +test-suite oglyad-test + import: shared, modules + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + ghc-options: -threaded + build-depends: + , hspec >=2.11.16 && <2.12 + , QuickCheck >=2.15 && <2.20 + , temporary >=1.3 && <1.4 diff --git a/src/Oglyad/App.hs b/src/Oglyad/App.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/App.hs @@ -0,0 +1,185 @@ +-- | the app monad. plain ReaderT over IO is the boring, correct starting point. +-- reach for mtl classes or an effect library only once this actually hurts +module Oglyad.App + ( Env (..), + App, + HttpError (..), + runApp, + httpGetE, + forConcurrentlyN, + note, + oglyadVersion, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (forConcurrently) +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Control.Concurrent.QSem (QSem, newQSem, signalQSem, waitQSem) +import Control.Exception (bracket_, throwIO, try) +import Control.Monad.Reader (ReaderT, ask, asks, liftIO, runReaderT) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy qualified as LBS +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Version (showVersion) +import Network.HTTP.Client + ( HttpException (..), + HttpExceptionContent (..), + Manager, + Request (requestHeaders, shouldStripHeaderOnRedirect), + Response, + brReadSome, + parseUrlThrow, + responseBody, + responseHeaders, + responseStatus, + withResponse, + ) +import Network.HTTP.Client.TLS (newTlsManager) +import Network.HTTP.Types (hAuthorization, statusCode) +import Oglyad.Types (Config (..)) +import Paths_oglyad (version) +import System.IO (hPutStrLn, stderr) + +data Env = Env + { envConfig :: Config, + envHttp :: Manager, + -- | crates.io allows one request per second + envCratesLock :: MVar (), + -- | GitHub's secondary rate limits punish lots of concurrent requests + envGitHubSem :: QSem, + -- | set once GitHub rate-limits us, so the remaining lookups are skipped + -- instead of each failing (and being reported) separately + envGitHubLimited :: IORef (Maybe Text), + -- | serializes progress messages so concurrent jobs can't interleave lines + envLogLock :: MVar () + } + +type App = ReaderT Env IO + +data HttpError + = -- | the server said slow down. not the upstream's fault, so not cached + -- and not reported per package + RateLimited Text + | HttpFailed Text + deriving stock (Eq, Show) + +oglyadVersion :: Text +oglyadVersion = T.pack (showVersion version) + +-- | identifies us to upstream APIs (crates.io's policy asks for this) +userAgent :: ByteString +userAgent = TE.encodeUtf8 ("oglyad/" <> oglyadVersion <> " (+https://github.com/terrapkg/oglyad)") + +-- | no single response may be larger than this. Fedora's compressed +-- primary.xml is the biggest thing we fetch, at around 30MB +maxBody :: Int +maxBody = 256 * 1024 * 1024 + +runApp :: Config -> App a -> IO a +runApp cfg act = do + mgr <- newTlsManager + lock <- newMVar () + ghSem <- newQSem 6 + limited <- newIORef Nothing + logLock <- newMVar () + runReaderT act (Env cfg mgr lock ghSem limited logLock) + +-- | progress messages go to stderr so stdout stays clean for --json +note :: String -> App () +note msg = do + lock <- asks envLogLock + liftIO (withMVar lock (\_ -> hPutStrLn stderr ("oglyad: " <> msg))) + +isGitHubApi :: Text -> Bool +isGitHubApi = T.isPrefixOf "https://api.github.com/" + +-- | GET a url, throwing on non-2xx +httpGet :: Text -> App LBS.ByteString +httpGet url = do + Env {..} <- ask + req <- liftIO (parseUrlThrow (T.unpack url)) + let auth = case cfgGitHubToken envConfig of + Just t | isGitHubApi url -> [(hAuthorization, "Bearer " <> TE.encodeUtf8 t)] + _ -> [] + req' = + req + { requestHeaders = ("User-Agent", userAgent) : auth <> requestHeaders req, + -- never forward the token if a redirect goes somewhere else + shouldStripHeaderOnRedirect = (== hAuthorization) + } + fetch = withResponse req' envHttp $ \resp -> do + body <- brReadSome (responseBody resp) (maxBody + 1) + if LBS.length body > fromIntegral maxBody + then throwIO (userError ("response from " <> T.unpack url <> " is over 256MiB")) + else pure body + liftIO $ + if + | "https://crates.io/" `T.isPrefixOf` url -> withMVar envCratesLock (\_ -> fetch <* threadDelay 1_000_000) + | isGitHubApi url -> bracket_ (waitQSem envGitHubSem) (signalQSem envGitHubSem) fetch + | otherwise -> fetch + +-- | GET a url, with failures as a short readable Left instead of an +-- exception. a rate limit with a short Retry-After gets one retry. a GitHub +-- rate limit beyond that stops all further GitHub requests for this run +httpGetE :: Text -> App (Either HttpError LBS.ByteString) +httpGetE url = do + env@Env {..} <- ask + limited <- liftIO (readIORef envGitHubLimited) + case limited of + Just why | isGitHubApi url -> pure (Left (RateLimited why)) + _ -> liftIO (attempt env (1 :: Int)) + where + attempt env@Env {..} n = do + r <- try (runReaderT (httpGet url) env) + case r of + Right body -> pure (Right body) + Left (HttpExceptionRequest _ (StatusCodeException resp _)) -> do + wait <- rateLimitWait resp + case wait of + Just secs | n == 1 && secs <= 60 -> do + threadDelay ((secs + 1) * 1_000_000) + attempt env (n + 1) + Just _ -> do + let why = "rate limited by " <> host + if isGitHubApi url then writeIORef envGitHubLimited (Just why) else pure () + pure (Left (RateLimited why)) + Nothing -> pure (Left (HttpFailed ("HTTP " <> T.pack (show (statusCode (responseStatus resp))) <> " from " <> url))) + Left (HttpExceptionRequest _ content) -> pure (Left (HttpFailed (T.pack (show content) <> " from " <> url))) + Left (InvalidUrlException u why) -> pure (Left (HttpFailed ("invalid url " <> T.pack u <> ": " <> T.pack why))) + host = T.takeWhile (/= '/') (T.drop 8 url) + +-- | if this response is a rate limit, how many seconds until it lifts. +-- GitHub signals its primary limit with a 403 and x-ratelimit-remaining: 0, +-- and its secondary limit (too many concurrent requests) with a 403 or 429 +-- plus retry-after +rateLimitWait :: Response () -> IO (Maybe Int) +rateLimitWait resp = do + now <- floor <$> getPOSIXTime + let header k = lookup k (responseHeaders resp) + num = fmap fst . (BS8.readInt =<<) + status = statusCode (responseStatus resp) + retryAfter = num (header "retry-after") + untilReset = (\t -> max 0 (t - now)) <$> num (header "x-ratelimit-reset") + exhausted = header "x-ratelimit-remaining" == Just "0" + pure $ + if + | status == 429 || (status == 403 && (exhausted || retryAfter /= Nothing)) -> + Just (maybe (maybe 3600 id untilReset) id retryAfter) + | otherwise -> Nothing + +-- | run an action over a list with at most n in flight at once. +-- 'forConcurrently' lives in IO, so we grab the env and re-run App inside each +-- thread. that dance is exactly what MonadUnliftIO (from unliftio) automates +forConcurrentlyN :: Int -> [a] -> (a -> App b) -> App [b] +forConcurrentlyN n xs f = do + env <- ask + liftIO $ do + sem <- newQSem (max 1 n) + forConcurrently xs $ \x -> + bracket_ (waitQSem sem) (signalQSem sem) (runReaderT (f x) env) diff --git a/src/Oglyad/Check.hs b/src/Oglyad/Check.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Check.hs @@ -0,0 +1,56 @@ +-- | the check registry. adding a check = write a module, add a line here +module Oglyad.Check + ( allChecks, + checkNames, + parseCheckName, + runChecks, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Oglyad.Check.BuildLag qualified as BuildLag +import Oglyad.Check.Drift qualified as Drift +import Oglyad.Check.DuplicateName qualified as DuplicateName +import Oglyad.Check.FedoraOverlap qualified as FedoraOverlap +import Oglyad.Check.NoAutoupdate qualified as NoAutoupdate +import Oglyad.Check.Stale qualified as Stale +import Oglyad.Check.UnparsedRhai qualified as UnparsedRhai +import Oglyad.Check.UpstreamError qualified as UpstreamError +import Oglyad.Types + +allChecks :: [(Text, Check)] +allChecks = + [ ("build-lag", BuildLag.check), + ("drift", Drift.check), + ("duplicate-name", DuplicateName.check), + ("fedora-overlap", FedoraOverlap.check), + ("no-autoupdate", NoAutoupdate.check), + ("stale", Stale.check), + ("unparsed-rhai", UnparsedRhai.check), + ("upstream-error", UpstreamError.check) + ] + +checkNames :: [Text] +checkNames = map fst allChecks + +-- | validate a check name from the command line. a typo has to be an error, +-- otherwise `--only buildlag` quietly runs nothing and reports all clear +parseCheckName :: String -> Either String Text +parseCheckName raw + | name `elem` checkNames = Right name + | otherwise = + Left ("unknown check " <> show raw <> ", expected one of: " <> T.unpack (T.intercalate ", " checkNames)) + where + name = T.pack raw + +-- | run the named checks (all of them when the list is empty) over every package +runChecks :: [Text] -> Snapshot -> [Finding] +runChecks only snap = + [ f + | (name, chk) <- allChecks, + null only || name `elem` only, + pkg <- Map.elems (snapPackages snap), + f <- chk snap pkg + ] diff --git a/src/Oglyad/Check/BuildLag.hs b/src/Oglyad/Check/BuildLag.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Check/BuildLag.hs @@ -0,0 +1,25 @@ +-- | what's merged in git doesn't match what's published +module Oglyad.Check.BuildLag (check) where + +import Oglyad.Types +import Oglyad.Version (compareEVR, renderEVR) + +check :: Check +check _ p@Package {..} = case (pkgSpecEVR, pkgRepoBuild) of + -- the repo fetch failed, which is already a collect error. claiming every + -- package in it was never published would bury that under noise + _ | not pkgRepoChecked -> [] + (Just spec, Nothing) -> + [finding' Error ("never published (spec is at " <> renderEVR spec <> ")")] + (Just spec, Just RepoBuild {rbEVR = repo}) + | spec == repo -> [] + | otherwise -> case compareEVR spec repo of + -- merged but not built: the build failed or is still queued + GT -> [finding' Warn ("spec is at " <> renderEVR spec <> " but repo has " <> renderEVR repo)] + -- the repo is newer than git, so the monorepo checkout is behind + LT -> [finding' Info ("repo has " <> renderEVR repo <> " but spec is at " <> renderEVR spec <> ", is the checkout up to date?")] + -- same version spelled differently, e.g. 1.05 vs 1.5 + EQ -> [] + _ -> [] + where + finding' = finding "build-lag" p diff --git a/src/Oglyad/Check/Drift.hs b/src/Oglyad/Check/Drift.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Check/Drift.hs @@ -0,0 +1,29 @@ +-- | upstream has a newer version than the spec +module Oglyad.Check.Drift (check, drift) where + +import Data.Text (Text) +import Data.Text qualified as T +import Oglyad.Types +import Oglyad.Version (compareUpstream) + +-- | (upstream version, spec version, how upstream compares) +drift :: Package -> Maybe (Text, Text, Ordering) +drift Package {..} = do + up <- T.strip <$> pkgUpstreamVer + spec <- evrVersion <$> pkgSpecEVR + pure (up, spec, compareUpstream up spec) + +-- pkgUpstreamVer is only populated with --upstream, so this check is silent +-- by default +check :: Check +check _ p = case drift p of + Just (up, spec, GT) -> [finding' Warn ("upstream has " <> up <> ", spec is at " <> spec)] + Just (up, spec, LT) + -- spec ahead of upstream. snapshots (Version: 1.2^20251101git...) built + -- after the 1.2 release always look like this and are fine. anything else + -- usually means a tag that normalizes badly + | T.any (== '^') spec -> [] + | otherwise -> [finding' Info ("spec " <> spec <> " is ahead of upstream " <> up <> ", check tag normalization")] + _ -> [] + where + finding' = finding "drift" p diff --git a/src/Oglyad/Check/DuplicateName.hs b/src/Oglyad/Check/DuplicateName.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Check/DuplicateName.hs @@ -0,0 +1,28 @@ +-- | two monorepo directories building the same source package into the same +-- repo. only one build can be live in a repo, so they overwrite each other, +-- and nothing (including build-lag) can tell which one a published rpm came +-- from. sometimes deliberate (a bootstrap build, a 32-bit variant), sometimes +-- a copy-pasted Name: that was never changed +module Oglyad.Check.DuplicateName (check) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Oglyad.Types + +check :: Check +check snap p = case others of + [] -> [] + _ -> + [ finding "duplicate-name" p Warn $ + "also built by " + <> T.intercalate ", " (map (T.pack . pkgPath) others) + <> ", and both publish to the same repo" + ] + where + others = + [ q + | q <- Map.elems (snapPackages snap), + pkgName q == pkgName p, + pkgSubrepo q == pkgSubrepo p, + pkgPath q /= pkgPath p + ] diff --git a/src/Oglyad/Check/FedoraOverlap.hs b/src/Oglyad/Check/FedoraOverlap.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Check/FedoraOverlap.hs @@ -0,0 +1,14 @@ +-- | a package should live in Terra or Fedora, not both +module Oglyad.Check.FedoraOverlap (check) where + +import Data.Set qualified as Set +import Oglyad.Types + +-- | subrepos (extras, mesa, multimedia, nvidia) exist to ship replacements +-- for Fedora packages, so overlap there is the whole point +check :: Check +check Snapshot {..} p@Package {..} + | Just _ <- pkgSubrepo = [] + | pkgName `Set.member` snapFedora = + [finding "fedora-overlap" p Warn "also shipped by Fedora"] + | otherwise = [] diff --git a/src/Oglyad/Check/NoAutoupdate.hs b/src/Oglyad/Check/NoAutoupdate.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Check/NoAutoupdate.hs @@ -0,0 +1,9 @@ +-- | packages with no update.rhai have to be bumped by hand +module Oglyad.Check.NoAutoupdate (check) where + +import Oglyad.Types + +check :: Check +check _ p@Package {..} = case pkgUpstream of + Nothing -> [finding "no-autoupdate" p Info "no update.rhai, updates are manual"] + Just _ -> [] diff --git a/src/Oglyad/Check/Stale.hs b/src/Oglyad/Check/Stale.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Check/Stale.hs @@ -0,0 +1,31 @@ +-- | packages that haven't been built in a long time +module Oglyad.Check.Stale (check) where + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (UTCTime, diffUTCTime, nominalDay) +import Oglyad.Check.Drift (drift) +import Oglyad.Types + +-- | a stable package nobody touched for a year might be totally fine, so an +-- old build alone is Info. it only becomes a Warn when upstream has moved on +-- (needs --upstream) and the package is still sitting on the old version +check :: Check +check Snapshot {..} p@Package {..} = case pkgRepoBuild of + Nothing -> [] -- never published is build-lag's job + Just RepoBuild {..} + | diffUTCTime snapNow rbBuildTime < cfgStaleAfter snapConfig -> [] + | otherwise -> [finding "stale" p sev msg] + where + upstreamMoved = case drift p of + Just (_, _, GT) -> True + _ -> False + sev = if upstreamMoved then Warn else Info + msg = + "last built " + <> ago rbBuildTime + <> maybe "" (\c -> ", last commit " <> ago c) pkgLastCommit + <> (if upstreamMoved then ", and upstream has a newer version" else "") + where + ago :: UTCTime -> Text + ago t = T.pack (show (floor (diffUTCTime snapNow t / nominalDay) :: Int)) <> " days ago" diff --git a/src/Oglyad/Check/UnparsedRhai.hs b/src/Oglyad/Check/UnparsedRhai.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Check/UnparsedRhai.hs @@ -0,0 +1,15 @@ +-- | reports update.rhai shapes our parser doesn't understand yet. this is your +-- to-do list for Oglyad.Source.Rhai +module Oglyad.Check.UnparsedRhai (check) where + +import Data.Text qualified as T +import Oglyad.Types + +check :: Check +check _ p@Package {..} = case pkgUpstream of + Just (Unknown raw) -> + [finding "unparsed-rhai" p Info ("can't parse update.rhai: " <> T.take 80 (head' (T.lines raw)))] + _ -> [] + where + head' (l : _) = l + head' [] = "" diff --git a/src/Oglyad/Check/UpstreamError.hs b/src/Oglyad/Check/UpstreamError.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Check/UpstreamError.hs @@ -0,0 +1,10 @@ +-- | the update.rhai source parsed fine but asking upstream failed. usually a +-- renamed or deleted repo, which means `anda update` is failing on it too +module Oglyad.Check.UpstreamError (check) where + +import Oglyad.Types + +check :: Check +check _ p@Package {..} = case pkgUpstreamErr of + Just err -> [finding "upstream-error" p Warn err] + Nothing -> [] diff --git a/src/Oglyad/Collect.hs b/src/Oglyad/Collect.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Collect.hs @@ -0,0 +1,241 @@ +-- | the imperative shell: gather every data source into one 'Snapshot' +module Oglyad.Collect + ( buildSnapshot, + ) +where + +import Control.Concurrent.Async (concurrently) +import Control.Monad (forM, when) +import Control.Monad.Reader (ask, asks, liftIO, runReaderT) +import Data.Either (partitionEithers) +import Data.List (nub, partition) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (UTCTime, diffUTCTime, getCurrentTime, nominalDay) +import Oglyad.App (App, Env (..), HttpError (..), forConcurrentlyN, note) +import Oglyad.Source.Cache (CacheEntry (..), UpstreamCache, loadJson, lookupFresh, saveJson) +import Oglyad.Source.Monorepo +import Oglyad.Source.Repodata (fetchRepo) +import Oglyad.Source.Rhai (parseUpdateRhai) +import Oglyad.Source.Upstream (latestVersion) +import Oglyad.Types +import System.Directory (findExecutable, makeAbsolute) +import System.FilePath (()) + +-- | collect everything. problems along the way become findings instead of +-- crashes, so one broken spec doesn't take down the whole run. +-- +-- the monorepo work (rpmspec, git) is all local cpu and the repodata work is +-- all network, so the two halves run at the same time +buildSnapshot :: App (Snapshot, [Finding]) +buildSnapshot = do + cfg@Config {..} <- asks envConfig + now <- liftIO getCurrentTime + (dirErrs, dirs) <- partitionEithers <$> liftIO (findPackageDirs cfgMonorepo) + hd <- liftIO (headCommit cfgMonorepo) + + -- the main repo, every subrepo some package asked for, and Fedora + let terraRepos = + (Nothing, cfgTerraRepo) + : [(Just s, cfgTerraRepo <> "-" <> s) | s <- nub (mapMaybe pdSubrepo dirs)] + env <- ask + ((specErrs, pkgs0), (terra, fedora)) <- + liftIO $ + concurrently + (runReaderT (readPackages dirs) env) + (runReaderT (fetchRepos terraRepos cfgFedoraRepos) env) + + let (repoErrs, repos) = partitionEithers terra + fetched = Map.fromList repos + pkgs1 = + [ p + { pkgRepoBuild = Map.lookup (pkgSubrepo p) fetched >>= Map.lookup (pkgName p), + pkgRepoChecked = Map.member (pkgSubrepo p) fetched + } + | p <- pkgs0 + ] + (upErrs, pkgs) <- if cfgUpstream then withUpstreams now pkgs1 else pure ([], pkgs1) + + let snap = + Snapshot + { snapPackages = Map.fromList [(pkgPath p, p) | p <- pkgs], + snapFedora = foldMap Map.keysSet fedora, + snapNow = now, + snapConfig = cfg, + snapHead = hd, + snapIgnoreLabels = Map.fromList [(pdPath d, pdIgnores d) | d <- dirs, not (null (pdIgnores d))] + } + unreadable = + [ (collectErr (T.pack path) ("can't read package dir: " <> err)) {fPath = Just (T.pack path)} + | (path, err) <- dirErrs + ] + pure (snap, unreadable <> specErrs <> repoErrs <> upErrs) + +-- | every repo at once. Terra failures become findings, Fedora ones just mean +-- no overlap data +fetchRepos :: + [(Maybe Text, Text)] -> + [Text] -> + App ([Either Finding (Maybe Text, Map Text RepoBuild)], [Map Text RepoBuild]) +fetchRepos terraRepos fedoraRepos = do + let jobs = map Left terraRepos <> map Right fedoraRepos + results <- forConcurrentlyN (length jobs) jobs $ \case + Left (sub, url) -> Left . either (Left . collectErr url . T.pack) (\b -> Right (sub, b)) <$> fetchRepo url + Right url -> Right . either (const Map.empty) id <$> fetchRepo url + pure (partitionEithers results) + +-- | evaluate every spec, reusing cached evaluations for unchanged packages +readPackages :: [PkgDir] -> App ([Finding], [Package]) +readPackages dirs = do + Config {..} <- asks envConfig + root <- liftIO (makeAbsolute cfgMonorepo) + -- one cache file per dist, so cron jobs checking different releases don't + -- keep evicting each other's entries + let cacheFile = "specs" <> T.unpack cfgDist <> ".json" + (commits, (macros, cache)) <- + liftIO $ + concurrently + (commitTimes cfgMonorepo (map pdPath dirs)) + ((,) <$> macroFingerprint <*> (fromMaybe Map.empty <$> loadJson cacheFile)) + keyed <- forConcurrentlyN cfgConcurrency dirs $ \d -> liftIO $ do + key <- specFingerprint macros cfgDist root (pdPath d) + pure (key, d) + let misses = length [() | (k, _) <- keyed, isNothing (Map.lookup k (cache :: Map Text (Either Text SpecInfo)))] + note ("evaluating " <> show (length dirs) <> " specs, " <> show (length dirs - misses) <> " unchanged since last run") + -- without rpmspec, cached evaluations still work. everything else is + -- skipped and reported once, rather than as one error per package + hasRpmspec <- liftIO (isJust <$> findExecutable "rpmspec") + results <- forConcurrentlyN cfgConcurrency keyed $ \(key, d) -> liftIO $ do + case (Map.lookup key cache, pdSpec d) of + (Just cached, _) -> pure (Evaluated key d cached) + (Nothing, Just spec) + | hasRpmspec -> Evaluated key d <$> querySpec cfgRelease cfgDist (root spec) + | otherwise -> pure Skipped + (Nothing, Nothing) -> pure (NoSpec d) + -- keep only entries for packages that still exist, so the file can't grow forever + liftIO (saveJson cacheFile (Map.fromList [(k, i) | Evaluated k _ i <- results])) + let skipped = length [() | Skipped <- results] + missing = + [ collectErr "rpmspec" ("rpmspec not found, install rpm-build. skipped " <> T.pack (show skipped) <> " specs with no cached result") + | skipped > 0 + ] + (errs, pkgs) = + partitionEithers $ + [toPackage commits d (Just i) | Evaluated _ d i <- results] + <> [toPackage commits d Nothing | NoSpec d <- results] + pure (missing <> errs, pkgs) + +-- | what happened to one package dir's spec +data SpecResult + = Evaluated Text PkgDir (Either Text SpecInfo) + | NoSpec PkgDir + | Skipped + +-- | last commit per package dir, reused as long as HEAD hasn't moved. +-- uncommitted changes can't change any "last commit", so HEAD is the whole key +commitTimes :: FilePath -> [FilePath] -> IO (Map FilePath UTCTime) +commitTimes root dirs = do + hd <- headCommit root + cached <- loadJson "commits.json" + case (hd, cached) of + (Just h, Just (h', m)) | h == h', all (`Map.member` m) dirs -> pure m + _ -> do + m <- lastCommits root dirs + mapM_ (\h -> saveJson "commits.json" (h, m)) hd + pure m + +toPackage :: Map FilePath UTCTime -> PkgDir -> Maybe (Either Text SpecInfo) -> Either Finding Package +toPackage commits PkgDir {..} = \case + Nothing -> Left (pathErr "no spec file found") + Just (Left err) -> Left (pathErr ("rpmspec failed: " <> firstLine err)) + Just (Right SpecInfo {..}) -> + Right + Package + { pkgName = siName, + pkgPath = pdPath, + pkgSubrepo = pdSubrepo, + pkgSpecEVR = Just siEVR, + pkgRepoBuild = Nothing, + pkgLastCommit = Map.lookup pdPath commits, + pkgUpstream = parseUpdateRhai <$> pdUpdateRhai, + pkgUpstreamVer = Nothing, + pkgUpstreamErr = Nothing, + pkgRepoChecked = False + } + where + firstLine t = let l = T.takeWhile (/= '\n') t in if T.null l then "(no output)" else l + pathErr msg = (collectErr (T.pack pdPath) msg) {fPath = Just (T.pack pdPath)} + +-- | fill in upstream versions, from the cache when it's fresh enough. +-- +-- crates.io allows one request a second, so its lookups run in their own +-- serial queue next to everything else. inside the shared job pool, a cluster +-- of crates packages would hold every slot while waiting their turn +withUpstreams :: UTCTime -> [Package] -> App ([Finding], [Package]) +withUpstreams now pkgs = do + Config {..} <- asks envConfig + when (isNothing cfgGitHubToken) $ + note "no GITHUB_TOKEN (or `gh auth token`), GitHub lookups will hit the 60/hour limit fast" + cache <- liftIO (fromMaybe Map.empty <$> loadJson "upstream.json") :: App UpstreamCache + let wanted = [p | p <- pkgs, Just src <- [pkgUpstream p], lookable src] + fresh p = pkgUpstream p >>= \src -> lookupFresh cfgCacheFor now src cache + (crates, others) = partition (isCrates . pkgUpstream) wanted + lookup1 p = case (fresh p, pkgUpstream p) of + (Just e, _) -> pure (pkgPath p, either (Left . HttpFailed) Right (ceResult e)) + (Nothing, Just src) -> (pkgPath p,) <$> latestVersion src + (Nothing, Nothing) -> pure (pkgPath p, Left (HttpFailed "no source")) + note ("querying upstreams for " <> show (length wanted) <> " packages, " <> show (length (filter (isJust . fresh) wanted)) <> " cached") + env <- ask + (r1, r2) <- + liftIO $ + concurrently + (runReaderT (forConcurrentlyN cfgConcurrency others lookup1) env) + (runReaderT (forM crates lookup1) env) + -- keyed by path, not name: two dirs can share a package name + let byPath = Map.fromList (r1 <> r2) + -- only cache successes. errors are often transient (rate limits, timeouts) + new = + Map.fromList + [ (T.pack (show src), CacheEntry now (Right v)) + | p <- wanted, + isNothing (fresh p), + Just src <- [pkgUpstream p], + Just (Right v) <- [Map.lookup (pkgPath p) byPath] + ] + -- forget answers nobody has asked for in a month + recent = Map.filter (\e -> diffUTCTime now (ceFetched e) < 30 * nominalDay) cache + limited = [why | Left (RateLimited why) <- Map.elems byPath] + rateErr = case limited of + [] -> [] + why : _ -> + [ (collectErr "upstream" (why <> ", skipped " <> T.pack (show (length limited)) <> " lookups. set GITHUB_TOKEN, or try again later")) + { fSeverity = Warn + } + ] + liftIO (saveJson "upstream.json" (new <> recent)) + pure + ( rateErr, + [ case Map.lookup (pkgPath p) byPath of + Just (Right v) -> p {pkgUpstreamVer = Just v} + Just (Left (HttpFailed e)) -> p {pkgUpstreamErr = Just e} + -- rate limits are reported once above, not as a broken upstream + Just (Left (RateLimited _)) -> p + Nothing -> p + | p <- pkgs + ] + ) + where + lookable = \case + CommitTracked -> False + Derived _ -> False + Unknown _ -> False + _ -> True + isCrates = \case + Just (Crates _ _) -> True + _ -> False + +collectErr :: Text -> Text -> Finding +collectErr what msg = Finding {fCheck = "collect", fPackage = what, fPath = Nothing, fSeverity = Error, fMessage = msg} diff --git a/src/Oglyad/Ignore.hs b/src/Oglyad/Ignore.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Ignore.hs @@ -0,0 +1,132 @@ +-- | silencing findings that are known and intentional. +-- +-- two sources, both matched by check name: +-- +-- * an ignore file (--ignore-file), where every entry names a package by +-- monorepo path or package name and must give a reason +-- * an `oglyad_ignore = "check, other-check"` label in a package's +-- anda.hcl, so the exception lives next to the package +-- +-- ignored findings don't count toward the exit code. ignore-file entries that +-- no longer match anything are reported, so stale exceptions get cleaned up +module Oglyad.Ignore + ( IgnoreRule (..), + Target (..), + IgnoreFile (..), + parseIgnoreFile, + Applied (..), + applyIgnores, + ) +where + +import Data.Aeson (FromJSON (..), Value, eitherDecodeStrict, withObject, (.:), (.:?)) +import Data.Aeson.Types (Parser) +import Data.ByteString (ByteString) +import Data.List (partition) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Oglyad.Types + +-- | what an ignore rule points at +data Target + = -- | a monorepo directory, e.g. anda/langs/zig/master-bootstrap + ByPath Text + | -- | every directory building this package name + ByName Text + deriving stock (Eq, Show) + +data IgnoreRule = IgnoreRule + { irCheck :: Text, + irTarget :: Target, + irReason :: Text + } + deriving stock (Eq, Show) + +newtype IgnoreFile = IgnoreFile [IgnoreRule] + deriving stock (Eq, Show) + +instance FromJSON IgnoreFile where + parseJSON = withObject "ignore file" $ \o -> IgnoreFile <$> (o .: "ignore" >>= traverse rule) + where + rule :: Value -> Parser IgnoreRule + rule = withObject "ignore entry" $ \o -> do + check <- o .: "check" + path <- o .:? "path" + name <- o .:? "package" + reason <- o .: "reason" + target <- case (path, name) of + (Just p, Nothing) -> pure (ByPath p) + (Nothing, Just n) -> pure (ByName n) + _ -> fail ("entry for " <> T.unpack check <> " needs exactly one of \"path\" or \"package\"") + if T.null (T.strip reason) + then fail ("entry for " <> T.unpack check <> " has an empty reason. say why it's ok") + else pure (IgnoreRule check target reason) + +-- | parse and validate an ignore file against the known check names +parseIgnoreFile :: [Text] -> ByteString -> Either String IgnoreFile +parseIgnoreFile known raw = do + f@(IgnoreFile rules) <- eitherDecodeStrict raw + case [irCheck r | r <- rules, irCheck r `notElem` known] of + [] -> Right f + bad -> Left ("unknown checks in ignore file: " <> T.unpack (T.intercalate ", " bad)) + +data Applied = Applied + { -- | findings that still count + apKept :: [Finding], + -- | findings an ignore matched + apIgnored :: [Finding], + -- | problems with the ignores themselves: unused file entries, unknown + -- check names in anda.hcl labels + apProblems :: [Finding] + } + +-- | split findings into kept and ignored. known is every check name, ran is +-- the ones that ran this time (an entry for a check that didn't run isn't +-- unused, just idle). labels maps a monorepo path to the check names its +-- anda.hcl ignores +applyIgnores :: [Text] -> [Text] -> IgnoreFile -> Map FilePath [Text] -> [Finding] -> Applied +applyIgnores known ran (IgnoreFile rules) labels findings = + Applied + { apKept = kept, + apIgnored = ignored, + apProblems = unused <> badLabels + } + where + (ignored, kept) = partition isIgnored findings + isIgnored f = byLabel f || any (`matches` f) rules + byLabel f = case fPath f of + Just path -> fCheck f `elem` Map.findWithDefault [] (T.unpack path) labels + Nothing -> False + matches r f = + irCheck r == fCheck f && case irTarget r of + ByPath p -> fPath f == Just p + ByName n -> fPackage f == n + unused = + [ Finding + { fCheck = "unused-ignore", + fPackage = describe (irTarget r), + fPath = case irTarget r of ByPath p -> Just p; ByName _ -> Nothing, + fSeverity = Info, + fMessage = "ignore file entry for " <> irCheck r <> " matches nothing anymore, remove it" + } + | r <- rules, + irCheck r `elem` ran, + not (any (matches r) findings) + ] + badLabels = + [ Finding + { fCheck = "unused-ignore", + fPackage = T.pack path, + fPath = Just (T.pack path), + fSeverity = Warn, + fMessage = "oglyad_ignore in anda.hcl names unknown check " <> c + } + | (path, cs) <- Map.toList labels, + c <- cs, + c `notElem` known + ] + describe = \case + ByPath p -> p + ByName n -> n diff --git a/src/Oglyad/Process.hs b/src/Oglyad/Process.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Process.hs @@ -0,0 +1,48 @@ +-- | running external tools (rpmspec, git) without ever throwing, hanging, or +-- leaking secrets +module Oglyad.Process + ( run, + childEnv, + ) +where + +import Control.Exception (IOException, try) +import Data.ByteString.Lazy qualified as LBS +import Data.Char (isUpper) +import Data.List (isPrefixOf) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..)) +import System.Process.Typed (nullStream, proc, readProcess, setEnv, setStdin) +import System.Timeout (timeout) + +-- | run a command and return its stdout. a missing executable, a non-zero +-- exit, or a timeout becomes a Left, so callers can report it as a finding +-- instead of crashing the whole run. +-- +-- rpmspec runs shell code from specs (%(...) and %{lua:...}), so children get +-- an allowlisted environment: GITHUB_TOKEN and anything else secret in ours +-- never reaches them. stdin is closed so nothing can wait on a prompt +run :: FilePath -> [String] -> IO (Either Text Text) +run cmd args = do + env <- childEnv <$> getEnvironment + r <- try (timeout (5 * 60 * 1_000_000) (readProcess (setEnv env (setStdin nullStream (proc cmd args))))) + pure $ case r of + Left (e :: IOException) -> Left (T.pack cmd <> ": " <> T.pack (show e)) + Right Nothing -> Left (T.pack cmd <> " timed out after 5 minutes") + Right (Just (ExitSuccess, out, _)) -> Right (decode out) + Right (Just (ExitFailure _, _, err)) -> Left (T.strip (decode err)) + where + decode = TE.decodeUtf8Lenient . LBS.toStrict + +-- | the environment children get: only what rpm and git need to find their +-- config and behave, plus GIT_TERMINAL_PROMPT=0 so a git remote asking for +-- credentials fails fast instead of hanging +childEnv :: [(String, String)] -> [(String, String)] +childEnv parent = ("GIT_TERMINAL_PROMPT", "0") : filter (allowed . fst) parent + where + allowed k = + k `elem` ["PATH", "HOME", "USER", "LOGNAME", "LANG", "TZ", "TMPDIR", "XDG_CONFIG_HOME", "XDG_CACHE_HOME", "XDG_DATA_HOME", "XDG_RUNTIME_DIR"] + || ("LC_" `isPrefixOf` k && all (\c -> isUpper c || c == '_') k) diff --git a/src/Oglyad/Report.hs b/src/Oglyad/Report.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Report.hs @@ -0,0 +1,175 @@ +-- | rendering findings as terminal text, json for scripts, or markdown for +-- GitHub job summaries +module Oglyad.Report + ( Report (..), + Format (..), + render, + renderText, + renderJson, + renderMarkdown, + ) +where + +import Data.Aeson (ToJSON (..), encode, object, (.=)) +import Data.ByteString.Lazy qualified as LBS +import Data.List (sortOn) +import Data.Map.Strict qualified as Map +import Data.Ord (Down (..)) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Time (UTCTime, defaultTimeLocale, formatTime) +import Oglyad.Types + +data Format = Text | Json | Markdown + deriving stock (Eq, Show) + +-- | everything a report needs besides the findings themselves +data Report = Report + { rVersion :: Text, + rGenerated :: UTCTime, + rMonorepoHead :: Maybe Text, + rTerraRepo :: Text, + rUpstream :: Bool, + rFindings :: [Finding], + rIgnored :: [Finding] + } + +render :: Format -> Severity -> Report -> LBS.ByteString +render fmt minSev r = case fmt of + Text -> utf8 (renderText minSev r) + Markdown -> utf8 (renderMarkdown minSev r) + Json -> renderJson r <> "\n" + where + utf8 = LBS.fromStrict . TE.encodeUtf8 + +-- * text + +renderText :: Severity -> Report -> Text +renderText minSev Report {..} = + T.unlines (map line (shown minSev rFindings) <> ["", summaryLine rFindings rIgnored]) + where + amb = ambiguousNames rFindings + line f@Finding {..} = + T.justifyLeft 6 ' ' (sevText fSeverity) + <> T.justifyLeft 16 ' ' fCheck + <> label amb f + <> ": " + <> fMessage + +summaryLine :: [Finding] -> [Finding] -> Text +summaryLine fs ignored = + count Error <> " errors, " <> count Warn <> " warnings, " <> count Info <> " info" <> ignoredPart + where + count s = tshow (length (filter ((== s) . fSeverity) fs)) + ignoredPart = if null ignored then "" else " (" <> tshow (length ignored) <> " ignored)" + +-- * json + +-- | a stable envelope. bump schema on any breaking change to field names or +-- meanings, so scripts reading this can tell +renderJson :: Report -> LBS.ByteString +renderJson Report {..} = + encode $ + object + [ "schema" .= (1 :: Int), + "oglyad" .= rVersion, + "generated" .= rGenerated, + "monorepo_head" .= rMonorepoHead, + "terra_repo" .= rTerraRepo, + "upstream" .= rUpstream, + "summary" + .= object + [ "error" .= count Error, + "warn" .= count Warn, + "info" .= count Info, + "ignored" .= length rIgnored + ], + "findings" .= map findingJson rFindings, + "ignored" .= map findingJson rIgnored + ] + where + count s = length (filter ((== s) . fSeverity) rFindings) + findingJson Finding {..} = + object + [ "check" .= fCheck, + "package" .= fPackage, + "path" .= fPath, + "severity" .= toJSON fSeverity, + "message" .= fMessage + ] + +-- * markdown + +-- | sized for a GitHub job summary: counts first, errors and warnings in +-- full, info folded away +renderMarkdown :: Severity -> Report -> Text +renderMarkdown minSev Report {..} = + T.unlines $ + [ "# oglyad report", + "", + T.intercalate + " · " + [ T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" rGenerated), + "terrapkg/packages " <> maybe "(unknown commit)" (\h -> "`" <> T.take 10 h <> "`") rMonorepoHead, + rTerraRepo, + if rUpstream then "upstream checks on" else "upstream checks off", + "oglyad " <> rVersion + ], + "", + "**" <> summaryLine rFindings rIgnored <> "**", + "", + "| check | errors | warnings | info |", + "|---|---:|---:|---:|" + ] + <> [ "| `" <> c <> "` | " <> n Error c <> " | " <> n Warn c <> " | " <> n Info c <> " |" + | c <- Set.toList (Set.fromList (map fCheck rFindings)) + ] + <> section Error "Errors" False + <> section Warn "Warnings" False + <> (if minSev <= Info then section Info "Info" True else []) + where + amb = ambiguousNames rFindings + n s c = tshow (length [() | f <- rFindings, fSeverity f == s, fCheck f == c]) + section sev title folded = + case [f | f <- shown minSev rFindings, fSeverity f == sev] of + [] -> [] + fs -> + let heading = title <> " (" <> tshow (length fs) <> ")" + table = + ["", "| package | check | message |", "|---|---|---|"] + <> [ "| " <> cell (label amb f) <> " | `" <> fCheck f <> "` | " <> cell (fMessage f) <> " |" + | f <- fs + ] + in if folded + then ["", "
" <> heading <> ""] <> table <> ["", "
"] + else ["", "## " <> heading] <> table + -- table cells can't contain raw pipes or newlines + cell = T.replace "|" "\\|" . T.replace "\n" " " + +-- * shared + +shown :: Severity -> [Finding] -> [Finding] +shown minSev = + sortOn (\f -> (Down (fSeverity f), fCheck f, fPackage f)) . filter ((>= minSev) . fSeverity) + +-- | the package name, plus its directory when the name belongs to several +label :: Set.Set Text -> Finding -> Text +label ambiguous Finding {..} = + fPackage <> maybe "" (\path -> if fPackage `Set.member` ambiguous then " (" <> path <> ")" else "") fPath + +-- | names that show up with more than one directory +ambiguousNames :: [Finding] -> Set.Set Text +ambiguousNames fs = + Map.keysSet . Map.filter ((> 1) . Set.size) $ + Map.fromListWith (<>) [(fPackage f, Set.fromList (maybe [] pure (fPath f))) | f <- fs] + +sevText :: Severity -> Text +sevText = \case + Info -> "info" + Warn -> "warn" + Error -> "error" + +tshow :: (Show a) => a -> Text +tshow = T.pack . show diff --git a/src/Oglyad/Source/Cache.hs b/src/Oglyad/Source/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Source/Cache.hs @@ -0,0 +1,68 @@ +-- | small json caches under $XDG_CACHE_HOME/oglyad, so reruns skip work that +-- can't have changed: spec evaluation, repodata parsing and upstream lookups +module Oglyad.Source.Cache + ( loadJson, + saveJson, + CacheEntry (..), + UpstreamCache, + lookupFresh, + ) +where + +import Control.Exception (SomeException, finally, try) +import Data.Aeson (FromJSON, ToJSON, eitherDecodeFileStrict, encode) +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (NominalDiffTime, UTCTime, diffUTCTime) +import GHC.Generics (Generic) +import Oglyad.Types (UpstreamSource) +import System.Directory (XdgDirectory (XdgCache), createDirectoryIfMissing, getXdgDirectory, renameFile) +import System.FilePath (()) +import System.IO (hClose, openBinaryTempFile) + +cacheDir :: IO FilePath +cacheDir = getXdgDirectory XdgCache "oglyad" + +-- | a missing or corrupt cache file is just a cache miss +loadJson :: forall a. (FromJSON a) => FilePath -> IO (Maybe a) +loadJson name = do + path <- ( name) <$> cacheDir + r <- try (eitherDecodeFileStrict path) :: IO (Either SomeException (Either String a)) + pure (either (const Nothing) (either (const Nothing) Just) r) + +-- | write to a temp file then rename, so a ctrl-c mid-write can't corrupt it. +-- caching is best effort: if the write fails (full disk, read-only home) the +-- run carries on and just won't be faster next time +saveJson :: (ToJSON a) => FilePath -> a -> IO () +saveJson name x = do + r <- try $ do + dir <- cacheDir + createDirectoryIfMissing True dir + let path = dir name + -- a unique temp name, so two runs at once can't interleave their writes. + -- rename is atomic, so readers see the old file or the new one, never half + (tmp, h) <- openBinaryTempFile dir (name <> ".tmp") + LBS.hPut h (encode x) `finally` hClose h + renameFile tmp path + case r of + Left (_ :: SomeException) -> pure () + Right () -> pure () + +data CacheEntry = CacheEntry + { ceFetched :: UTCTime, + ceResult :: Either Text Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | upstream answers, keyed by the rendered 'UpstreamSource' so json keys +-- stay plain strings +type UpstreamCache = Map Text CacheEntry + +lookupFresh :: NominalDiffTime -> UTCTime -> UpstreamSource -> UpstreamCache -> Maybe CacheEntry +lookupFresh maxAge now src c = do + e <- Map.lookup (T.pack (show src)) c + if diffUTCTime now (ceFetched e) <= maxAge then Just e else Nothing diff --git a/src/Oglyad/Source/Monorepo.hs b/src/Oglyad/Source/Monorepo.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Source/Monorepo.hs @@ -0,0 +1,248 @@ +-- | reads a local checkout of terrapkg/packages +module Oglyad.Source.Monorepo + ( PkgDir (..), + SpecInfo (..), + findPackageDirs, + hclString, + querySpec, + lastCommits, + headCommit, + specFingerprint, + macroFingerprint, + ) +where + +import Control.Exception (IOException, try) +import Control.Monad (filterM, foldM, forM) +import Crypto.Hash.SHA256 qualified as SHA256 +import Data.Aeson (FromJSON, ToJSON) +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as B16 +import Data.List (sort) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (listToMaybe) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Text.Read qualified as TR +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import GHC.Generics (Generic) +import Oglyad.Process (run) +import Oglyad.Version (EVR, parseEVR) +import System.Directory (doesDirectoryExist, doesFileExist, getSymbolicLinkTarget, listDirectory, pathIsSymbolicLink) +import System.FilePath (takeDirectory, takeExtension, ()) + +-- | a directory with an anda.hcl in it +data PkgDir = PkgDir + { -- | relative to the monorepo root + pdPath :: FilePath, + -- | relative to the monorepo root + pdSpec :: Maybe FilePath, + -- | `subrepo = "extras"` from the labels block + pdSubrepo :: Maybe Text, + -- | file contents + pdUpdateRhai :: Maybe Text, + -- | `oglyad_ignore = "check, other-check"` from the labels block + pdIgnores :: [Text] + } + deriving stock (Eq, Show) + +data SpecInfo = SpecInfo + { siName :: Text, + siEVR :: EVR + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | walk anda/ and return every project directory +-- | walk anda/ and return every project directory. a directory that can't be +-- read comes back as a Left with the reason, instead of ending the walk. +-- symlinked directories aren't followed, so a link loop can't hang the walk +findPackageDirs :: FilePath -> IO [Either (FilePath, Text) PkgDir] +findPackageDirs root = go "anda" + where + go rel = do + let abs' = root rel + listed <- try (listDirectory abs') + case listed of + Left (e :: IOException) -> pure [Left (rel, T.pack (show e))] + Right entries -> do + hasHcl <- doesFileExist (abs' "anda.hcl") + here <- if hasHcl then pure <$> readPkgDir rel entries else pure [] + subdirs <- filterM (realDir . (abs' )) [e | e <- sort entries, take 1 e /= "."] + nested <- concat <$> forM subdirs (go . (rel )) + pure (here <> nested) + + readPkgDir rel entries = do + r <- try (readPkgDir' rel entries) + pure (either (\(e :: IOException) -> Left (rel, T.pack (show e))) Right r) + + readPkgDir' rel entries = do + let abs' = root rel + hcl <- readText (abs' "anda.hcl") + let fromHcl = T.unpack <$> hclString "spec" hcl + fallback = listToMaybe [e | e <- entries, takeExtension e == ".spec"] + hasRhai <- doesFileExist (abs' "update.rhai") + rhai <- if hasRhai then Just <$> readText (abs' "update.rhai") else pure Nothing + pure + PkgDir + { pdPath = rel, + pdSpec = (rel ) <$> maybe fallback Just fromHcl, + pdSubrepo = hclString "subrepo" hcl, + pdUpdateRhai = rhai, + pdIgnores = maybe [] (filter (not . T.null) . map T.strip . T.splitOn ",") (hclString "oglyad_ignore" hcl) + } + +-- | pull the first `key = "value"` out of anda.hcl without a real HCL parser. +-- every anda.hcl in the monorepo is simple enough for this to hold up +hclString :: Text -> Text -> Maybe Text +hclString key hcl = + listToMaybe + [ T.takeWhile (/= '"') (T.drop 1 (T.dropWhile (/= '"') rest)) + | l <- map T.strip (T.lines hcl), + Just rest <- [T.stripPrefix key l], + "=" `T.isPrefixOf` T.stripStart rest, + "\"" `T.isInfixOf` rest + ] + +-- | a directory that isn't a symlink +realDir :: FilePath -> IO Bool +realDir path = do + isDir <- doesDirectoryExist path + isLink <- either (\(_ :: IOException) -> False) id <$> try (pathIsSymbolicLink path) + pure (isDir && not isLink) + +-- | read a text file as utf-8 no matter the locale, replacing invalid bytes +-- instead of failing +readText :: FilePath -> IO Text +readText path = TE.decodeUtf8Lenient <$> BS.readFile path + +-- | let rpm evaluate the spec for us. hand-parsing specs means reimplementing +-- the macro engine, which is a terrible idea +querySpec :: Int -> Text -> FilePath -> IO (Either Text SpecInfo) +querySpec release dist spec = do + let qf = "%{NAME}\t%|EPOCH?{%{EPOCH}}:{0}|:%{VERSION}-%{RELEASE}\n" + out <- + run "rpmspec" $ + [ "-q", + "--srpm", + "--define", + "dist " <> T.unpack dist, + -- %fedora comes from the host otherwise, so -r 43 on an F44 box would + -- take the wrong side of every %if 0%{?fedora} >= 44 + "--define", + "fedora " <> show release, + -- some specs load macro files from their own dir via %{_sourcedir} + "--define", + "_sourcedir " <> takeDirectory spec, + "--qf", + qf, + spec + ] + pure $ do + o <- out + case T.splitOn "\t" <$> take 1 (T.lines o) of + [[name, evr]] | Just e <- parseEVR evr -> Right (SpecInfo name e) + _ -> Left ("unexpected rpmspec output: " <> o) + +-- | time of the last commit touching each package dir, from a single +-- `git log` over the whole history. +-- +-- asking git once per directory (`git log -1 -- dir`) makes it walk and diff +-- history from the top every time, which for 1300 dirs and 20k commits burned +-- ~25s of cpu. one pass listing every changed file per commit takes ~0.5s, +-- and since git lists newest commits first, the first time we see a path +-- under a dir is that dir's last commit +lastCommits :: FilePath -> [FilePath] -> IO (Map FilePath UTCTime) +lastCommits root dirs = do + out <- + run "git" $ + ["-C", root, "-c", "core.quotePath=false", "log", "--format=@%ct", "--name-only", "--no-renames", "HEAD", "--", "anda"] + -- not a git checkout (or no git at all) just means no commit times + pure (either (const Map.empty) (go Nothing Map.empty . T.lines) out) + where + wanted = Set.fromList (map T.pack dirs) + total = Set.size wanted + go _ acc _ | Map.size acc == total = acc -- every dir seen, stop reading + go _ acc [] = acc + go cur acc (l : ls) = case T.stripPrefix "@" l of + -- unix seconds. iso dates would need care since git writes UTC as "Z", + -- which the ZonedTime parser rejects + Just stamp -> go (posixSecondsToUTCTime . fromInteger . fst <$> either (const Nothing) Just (TR.decimal stamp)) acc ls + Nothing -> case cur of + Just t | not (T.null l) -> go cur (foldl' (claim t) acc (ancestors l)) ls + _ -> go cur acc ls + -- a file counts for every package dir above it, like `git log -- dir` does + claim t acc d + | d `Set.member` wanted, not (Map.member (T.unpack d) acc) = Map.insert (T.unpack d) t acc + | otherwise = acc + ancestors f = case T.breakOnEnd "/" f of + ("", _) -> [] + (parentSlash, _) -> let parent = T.dropEnd 1 parentSlash in parent : ancestors parent + +-- | the commit HEAD points at, if this is a git checkout +headCommit :: FilePath -> IO (Maybe Text) +headCommit root = either (const Nothing) (Just . T.strip) <$> run "git" ["-C", root, "rev-parse", "HEAD"] + +-- | a hash of everything that can change what rpmspec says about a package: +-- the files in its directory and any subdirectories like patches/ (but not +-- nested packages, which have their own fingerprint), the dist tag, and the +-- rpm macros in effect (see 'macroFingerprint') +specFingerprint :: Text -> Text -> FilePath -> FilePath -> IO Text +specFingerprint macros dist root rel = do + files <- packageFiles (root rel) + let header = TE.encodeUtf8 (macros <> "\0" <> dist <> "\0" <> T.pack rel <> "\0") + -- feed each file to the hash as its own chunk instead of concatenating + -- them, which would copy every byte of the package dir once more + ctx <- + foldM + ( \c (f, entry) -> do + body <- case entry of + -- hash where a symlink points, never what's behind it + Link target -> pure (" " <> TE.encodeUtf8 (T.pack target)) + File -> + either (\(e :: IOException) -> " " <> TE.encodeUtf8 (T.pack (show e))) id + <$> try (BS.readFile (root rel f)) + pure $! SHA256.updates c [TE.encodeUtf8 (T.pack f), "\0", body, "\0"] + ) + (SHA256.update SHA256.init header) + files + pure (TE.decodeUtf8 (B16.encode (SHA256.finalize ctx))) + +data Entry = File | Link FilePath + +-- | every file under a package dir, relative to it and sorted, skipping +-- subdirectories that are packages of their own. symlinks are recorded with +-- their target and never followed, so a dangling link or a link loop can't +-- crash or hang the walk +packageFiles :: FilePath -> IO [(FilePath, Entry)] +packageFiles dir = go "" + where + go sub = do + listed <- try (listDirectory (dir sub)) + let entries = either (\(_ :: IOException) -> []) sort listed + fmap concat . forM entries $ \e -> do + let rel = if null sub then e else sub e + link <- try (getSymbolicLinkTarget (dir rel)) + case link of + Right target -> pure [(rel, Link target)] + Left (_ :: IOException) -> do + isDir <- doesDirectoryExist (dir rel) + isPkg <- doesFileExist (dir rel "anda.hcl") + case (isDir, isPkg) of + (True, True) -> pure [] + (True, False) -> go rel + _ -> pure [(rel, File)] + +-- | fingerprint of the whole rpm macro state, so updating rpm, +-- redhat-rpm-config or anda-srpm-macros, or editing ~/.rpmmacros, invalidates +-- cached evaluations. `rpm --showrc` dumps every macro rpm loaded, from every +-- path in its search list, which is more complete than listing files by hand +macroFingerprint :: IO Text +macroFingerprint = do + showrc <- either ("no rpm: " <>) id <$> run "rpm" ["--showrc"] + version <- either ("no rpmspec: " <>) id <$> run "rpmspec" ["--version"] + pure (TE.decodeUtf8 (B16.encode (SHA256.hash (TE.encodeUtf8 (version <> "\0" <> showrc))))) diff --git a/src/Oglyad/Source/Repodata.hs b/src/Oglyad/Source/Repodata.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Source/Repodata.hs @@ -0,0 +1,287 @@ +-- | reads published dnf repodata: repomd.xml → primary.xml.{zst,gz,xz} → packages +module Oglyad.Source.Repodata + ( RpmEntry (..), + fetchRepo, + decompressAndParse, + parseRepomd, + parsePrimary, + srpmName, + latestBySource, + ) +where + +import Conduit (foldlC, runConduit, sourceHandle, sourceLazy, (.|)) +import Control.DeepSeq (deepseq) +import Control.Exception (SomeException, try) +import Control.Monad ((<$!>), (>=>)) +import Control.Monad.Reader (liftIO) +import Data.Bifunctor (first) +import Data.ByteString.Lazy qualified as LBS +import Data.Char (isAlphaNum) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Read qualified as TR +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.XML.Types (Content (..), Event (..)) +import Oglyad.App (App, HttpError (..), httpGetE, note) +import Oglyad.Process (childEnv) +import Oglyad.Source.Cache (loadJson, saveJson) +import Oglyad.Types (RepoBuild (..)) +import Oglyad.Version (EVR (..)) +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..)) +import System.IO (Handle) +import System.Process.Typed (byteStringInput, createPipe, getStdout, nullStream, proc, setEnv, setStderr, setStdin, setStdout, waitExitCode, withProcessTerm) +import Text.XML (Name (..), def, parseLBS) +import Text.XML.Cursor (attribute, attributeIs, element, fromDocument, ($//), (&/)) +import Text.XML.Stream.Parse (parseBytes) + +-- | one binary (or source) rpm from primary.xml +-- | strict fields, filled with copied text (see 'finish' in 'parsePrimary'), +-- so a parsed entry never keeps the decompressed file alive +data RpmEntry = RpmEntry + { rpmName :: !Text, + rpmArch :: !Text, + rpmEVR :: !EVR, + -- | e.g. zed-0.190.0-1.fc44.src.rpm, absent on src rpms + rpmSourceRpm :: !(Maybe Text), + rpmBuildTime :: !UTCTime + } + deriving stock (Eq, Show) + +-- | builds per source package for a repo, reusing the last parse when the +-- repo hasn't changed. repomd.xml is tiny, and the primary.xml href in it +-- embeds a checksum, so an unchanged href means unchanged contents +fetchRepo :: Text -> App (Either String (Map Text RepoBuild)) +fetchRepo base = do + let file = "repodata-" <> T.unpack (T.map (\c -> if isAlphaNum c then c else '_') base) <> ".json" + repomd <- httpGetE (base <> "/repodata/repomd.xml") + case first httpErr repomd >>= parseRepomd of + Left err -> pure (Left err) + Right href -> + liftIO (loadJson file) >>= \case + Just (cachedHref, builds) | cachedHref == href -> pure (Right builds) + _ -> do + note ("downloading " <> T.unpack base <> "/" <> T.unpack href) + r <- fmap latestBySource <$> fetchPrimaryAt base href + case r of + Right builds -> liftIO (saveJson file (href, builds)) + Left _ -> pure () + pure r + +-- | fetch and parse the primary.xml at a href from repomd.xml +fetchPrimaryAt :: Text -> Text -> App (Either String [RpmEntry]) +fetchPrimaryAt base href = do + download <- httpGetE (base <> "/" <> href) + case first httpErr download of + Left err -> pure (Left err) + Right compressed -> liftIO (decompressAndParse href compressed) + +httpErr :: HttpError -> String +httpErr = \case + RateLimited why -> T.unpack why + HttpFailed why -> T.unpack why + +-- | decompress a primary.xml by its file extension and parse it, streaming +-- from the decompressor's pipe so even Fedora's ~250MB file never sits in +-- memory. +-- +-- decompression goes through the zstd, gzip and xz commands, which every +-- Fedora install has. Fedora doesn't package a Haskell zstd binding, and +-- oglyad should build from Fedora's own libraries +decompressAndParse :: Text -> LBS.ByteString -> IO (Either String [RpmEntry]) +decompressAndParse href compressed + | ".zst" `T.isSuffixOf` href = viaCommand "zstd" ["--decompress", "--stdout", "--quiet"] + | ".gz" `T.isSuffixOf` href = viaCommand "gzip" ["--decompress", "--stdout", "--quiet"] + | ".xz" `T.isSuffixOf` href = viaCommand "xz" ["--decompress", "--stdout", "--quiet"] + | ".xml" `T.isSuffixOf` href = pure (parsePrimary compressed) + | otherwise = pure (Left ("don't know how to decompress " <> T.unpack href)) + where + -- feed the download to the command's stdin and parse its stdout as it + -- arrives. a corrupt archive makes the command fail, which shows up as + -- a parse error or a non-zero exit, never a crash + viaCommand cmd args = do + env <- childEnv <$> getEnvironment + let cfg = setEnv env (setStdin (byteStringInput compressed) (setStdout createPipe (setStderr nullStream (proc cmd args)))) + r <- try $ withProcessTerm cfg $ \p -> do + parsed <- parsePrimaryHandle (getStdout p) + code <- waitExitCode p + pure $ case (code, parsed) of + (ExitFailure n, _) -> Left (cmd <> " exited with " <> show n <> " decompressing " <> T.unpack href) + (ExitSuccess, _) -> parsed + pure (either (\e -> Left (cmd <> ": " <> show (e :: SomeException))) id r) + +repoNs, commonNs, rpmNs :: Text -> Name +repoNs n = Name n (Just "http://linux.duke.edu/metadata/repo") Nothing +commonNs n = Name n (Just "http://linux.duke.edu/metadata/common") Nothing +rpmNs n = Name n (Just "http://linux.duke.edu/metadata/rpm") Nothing + +-- | find the location of primary.xml in repomd.xml. +-- this uses the xml-conduit Cursor api, which builds the whole document in +-- memory. that's fine for a 2KB file: +-- $// = all descendants matching +-- &/ = children matching +-- >=> = compose two axes (it's just Kleisli composition on lists) +parseRepomd :: LBS.ByteString -> Either String Text +parseRepomd bs = do + doc <- first show (parseLBS def bs) + let hrefs = + fromDocument doc + $// (element (repoNs "data") >=> attributeIs "type" "primary") + &/ (element (repoNs "location") >=> attribute "href") + case hrefs of + (h : _) -> Right h + [] -> Left "no primary entry in repomd.xml" + +-- | what we've seen so far of the we're currently inside +data PkgAcc = PkgAcc + { accName :: Text, + accArch :: Text, + accEVR :: Maybe EVR, + accTime :: Maybe UTCTime, + accSrpm :: Maybe Text + } + +emptyAcc :: PkgAcc +emptyAcc = PkgAcc "" "" Nothing Nothing Nothing + +-- | which element's text we're currently collecting +data Capture = CapName | CapArch | CapSrpm | CapNone + deriving stock (Eq) + +data St = St + { stAcc :: !PkgAcc, + stCap :: !Capture, + -- | finished packages, newest first + stOut :: [RpmEntry], + -- | open elements, nonzero at the end means a truncated file + stDepth :: !Int + } + +-- | parse decompressed primary.xml from memory. the real runs stream from a +-- pipe with 'parsePrimaryHandle'. this one is for small inputs and tests. +-- +-- unlike repomd.xml this file is big (Terra's is ~20MB, Fedora's is ~200MB) +-- so we never build a DOM. instead the XML is turned into a stream of events +-- (element opened, text, element closed, ...) and folded over with a small +-- state machine. memory use stays proportional to the results, not the file +parsePrimary :: LBS.ByteString -> Either String [RpmEntry] +parsePrimary bs = + first (\e -> show (e :: SomeException)) (runConduit (sourceLazy bs .| parseBytes def .| foldlC stepPrimary st0)) + >>= finishPrimary + +-- | parse primary.xml straight from a handle. +-- +-- reading the handle chunk by chunk matters: handing the parser a lazy +-- ByteString instead lets the thunk evaluating it hold on to the start of the +-- stream, which keeps the whole decompressed file (250MB for Fedora) alive +-- until parsing ends +parsePrimaryHandle :: Handle -> IO (Either String [RpmEntry]) +parsePrimaryHandle h = do + r <- try (runConduit (sourceHandle h .| parseBytes def .| foldlC stepPrimary st0)) + pure (either (\e -> Left (show (e :: SomeException))) finishPrimary r) + +st0 :: St +st0 = St emptyAcc CapNone [] 0 + +finishPrimary :: St -> Either String [RpmEntry] +finishPrimary final + | stDepth final /= 0 = Left "primary.xml ends in the middle of an element, truncated download?" + | otherwise = Right (reverse (stOut final)) + +-- | one xml event. tracks element depth so truncation can be detected +stepPrimary :: St -> Event -> St +stepPrimary cur ev = case ev of + EventBeginElement _ _ -> step cur {stDepth = stDepth cur + 1} ev + EventEndElement _ -> step cur {stDepth = stDepth cur - 1} ev + _ -> step cur ev + where + step st = \case + EventBeginElement name attrs + | name == commonNs "package" -> st {stAcc = emptyAcc, stCap = CapNone} + | name == commonNs "name" -> st {stCap = CapName} + | name == commonNs "arch" -> st {stCap = CapArch} + | name == rpmNs "sourcerpm" -> st {stCap = CapSrpm} + | name == commonNs "version" -> + let attr k = lookupAttr k attrs + evr = EVR <$> (attr "epoch" >>= readInt) <*> attr "ver" <*> attr "rel" + in st {stAcc = (stAcc st) {accEVR = evr}} + | name == commonNs "time" -> + let t = posixSecondsToUTCTime . fromIntegral <$> (lookupAttr "build" attrs >>= readInt) + in st {stAcc = (stAcc st) {accTime = t}} + | otherwise -> st + EventContent (ContentText t) -> case stCap st of + CapName -> st {stAcc = (stAcc st) {accName = accName (stAcc st) <> t}} + CapArch -> st {stAcc = (stAcc st) {accArch = accArch (stAcc st) <> t}} + CapSrpm -> st {stAcc = (stAcc st) {accSrpm = Just (maybe t (<> t) (accSrpm (stAcc st)))}} + CapNone -> st + EventEndElement name + | name == commonNs "package" -> case finish (stAcc st) of + Just e -> st {stOut = e : stOut st, stCap = CapNone} + Nothing -> st {stCap = CapNone} + | otherwise -> st {stCap = CapNone} + _ -> st + + -- the text we collected is sliced out of the parser's buffers, and a + -- slice keeps its whole buffer alive. copying is what stops 75k Fedora + -- entries from pinning the entire decompressed file in memory + -- + -- the build time needs the same care. UTCTime's fields are lazy, so + -- without a deep force it stays a thunk pointing at the xml attribute it + -- came from, which pins that attribute's whole decoder chunk + finish PkgAcc {..} = do + EVR e v r <- accEVR + t <- accTime + if T.null accName + then Nothing + else t `deepseq` (Just $! RpmEntry (T.copy accName) (T.copy accArch) (EVR e (T.copy v) (T.copy r)) (T.copy <$!> accSrpm) t) + + lookupAttr :: Name -> [(Name, [Content])] -> Maybe Text + lookupAttr k attrs = do + cs <- lookup k attrs + pure (T.concat (mapMaybe contentText cs)) + + contentText = \case + ContentText t -> Just t + ContentEntity _ -> Nothing + + readInt :: Text -> Maybe Int + readInt t = case TR.decimal t of + Right (n, "") -> Just n + _ -> Nothing + +-- | source package name from a srpm filename: strip ".src.rpm", then the last +-- two dash-separated fields (version and release) +srpmName :: Text -> Maybe Text +srpmName file = do + base <- T.stripSuffix ".src.rpm" file + let parts = T.splitOn "-" base + if length parts < 3 + then Nothing + else Just (T.intercalate "-" (take (length parts - 2) parts)) + +-- | collapse binary rpms down to one build per source package, keeping the +-- newest build time. this is what lets us line repodata up with the monorepo +latestBySource :: [RpmEntry] -> Map Text RepoBuild +latestBySource = foldr step Map.empty + where + step e acc = case srcOf e of + Nothing -> acc + Just src -> Map.insertWith newer src (RepoBuild (srcEVR e) (rpmBuildTime e)) acc + srcOf e = maybe (Just (rpmName e)) srpmName (rpmSourceRpm e) + newer a b = if rbBuildTime a >= rbBuildTime b then a else b + -- binary subpackages can carry their own Version/Release, so prefer the + -- EVR spelled out in the srpm filename when there is one + srcEVR e = case rpmSourceRpm e >>= srpmEVR of + Just evr -> evr {evrEpoch = evrEpoch (rpmEVR e)} + Nothing -> rpmEVR e + srpmEVR file = do + base <- T.stripSuffix ".src.rpm" file + let parts = T.splitOn "-" base + case reverse parts of + rel : ver : _ : _ -> Just (EVR 0 ver rel) + _ -> Nothing diff --git a/src/Oglyad/Source/Rhai.hs b/src/Oglyad/Source/Rhai.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Source/Rhai.hs @@ -0,0 +1,218 @@ +-- | figures out where an update.rhai gets its version from, without running it. +-- +-- evaluating Rhai would mean reimplementing andax, so instead we: +-- +-- 1. lex the script into tokens with megaparsec (strings, identifiers, +-- punctuation, comments dropped) +-- 2. find what's passed to `rpm.version(...)` or `rpm.global("ver", ...)` +-- 3. if that's a variable, follow its `let` binding +-- 4. if it's (or starts with) a known andax helper like gh("owner/repo"), +-- that's the source +-- +-- versions that follow another distro or package (bodhi, madoguchi, nvidia) +-- become 'Derived'. anything fancier, like custom get_json scraping, ends up as +-- 'Unknown', and the unparsed-rhai check lists those +module Oglyad.Source.Rhai + ( parseUpdateRhai, + Token (..), + tokenize, + ) +where + +import Data.Char (isAlphaNum, isDigit, isSpace) +import Data.List (nub) +import Data.Maybe (listToMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void (Void) +import Oglyad.Types (CrateField (..), UpstreamSource (..)) +import Text.Megaparsec hiding (Token) +import Text.Megaparsec.Char (char, space1) +import Text.Megaparsec.Char.Lexer qualified as L + +data Token + = TIdent Text + | TStr Text + | TNum Text + | TSym Char + deriving stock (Eq, Show) + +type Parser = Parsec Void Text + +parseUpdateRhai :: Text -> UpstreamSource +parseUpdateRhai src = case tokenize src of + Nothing -> Unknown (T.strip src) + Just toks -> case resolveVersion toks of + Just s -> s + Nothing + | hasCommitCall toks -> CommitTracked + -- no rpm.version we could follow, but the script only ever calls one + -- source helper, so that's almost certainly it + | [s] <- nub (allSources toks) -> s + | otherwise -> Unknown (T.strip src) + +-- * lexing + +tokenize :: Text -> Maybe [Token] +tokenize = either (const Nothing) Just . parse (sc *> many tokenP <* eof) "update.rhai" + +sc :: Parser () +sc = L.space space1 (L.skipLineComment "//") (L.skipBlockComment "/*" "*/") + +tokenP :: Parser Token +tokenP = + L.lexeme sc $ + choice + [ TStr <$> quoted '"', + TStr <$> raw, -- template strings, ${} left as-is + TStr <$> quoted '\'', -- char literals + TIdent <$> takeWhile1P (Just "identifier") (\c -> isAlphaNum c || c == '_'), + TNum <$> takeWhile1P (Just "number") isDigit, + TSym <$> satisfy (not . isSpace) + ] + where + -- backtick strings are raw in Rhai, so regexes like `[\d.]+` stay intact + raw = char '`' *> takeWhileP Nothing (/= '`') <* char '`' + -- in quoted strings a backslash escapes whatever follows it. we only care + -- about the text being roughly right, so unknown escapes are kept as-is + quoted q = T.pack <$> (char q *> manyTill (escaped <|> anySingle) (char q)) + escaped = char '\\' *> fmap unescape anySingle + unescape = \case + 'n' -> '\n' + 't' -> '\t' + c -> c + +-- * analysis + +-- | follow rpm.version(...) / rpm.global("ver", ...) back to a source helper +resolveVersion :: [Token] -> Maybe UpstreamSource +resolveVersion toks = listToMaybe (mapMaybe (resolveExpr toks 5) (versionExprs toks)) + +-- | every expression handed to something that sets the package version +versionExprs :: [Token] -> [[Token]] +versionExprs = \case + [] -> [] + TIdent "rpm" : TSym '.' : TIdent "version" : TSym '(' : rest -> + argsOf rest <> versionExprs rest + TIdent "rpm" : TSym '.' : TIdent f : TSym '(' : TStr key : TSym ',' : rest + | f `elem` ["global", "define"], + key `elem` ["ver", "version"] -> + argsOf' rest <> versionExprs rest + _ : rest -> versionExprs rest + where + -- rpm.version(EXPR) + argsOf rest = [takeBalanced rest] + -- rpm.global("ver", EXPR), we're already past the comma + argsOf' rest = [takeBalanced rest] + +-- | tokens up to the ')' that closes the call we're inside +takeBalanced :: [Token] -> [Token] +takeBalanced = go (0 :: Int) + where + go _ [] = [] + go depth (t : ts) = case t of + TSym c + | c `elem` ("([{" :: String) -> t : go (depth + 1) ts + | c `elem` (")]}" :: String) -> if depth == 0 then [] else t : go (depth - 1) ts + | c == ',' && depth == 0 -> [] + _ -> t : go depth ts + +-- | what does this expression get its value from? fuel stops let-cycles +resolveExpr :: [Token] -> Int -> [Token] -> Maybe UpstreamSource +resolveExpr toks fuel expr + | fuel <= 0 = Nothing + | otherwise = case expr of + -- a helper call, possibly with a method chain after it + _ | Just (s, _) <- sourceCall expr -> Just s + -- a helper from one of the shared andax/*.rhai modules, e.g. + -- bump::madoguchi(...) or nvidia::nvidia_driver_version() + TIdent m : TSym ':' : TSym ':' : TIdent f : TSym '(' : _ -> Just (Derived (m <> "::" <> f)) + TIdent f : TSym '(' : _ | f `elem` derivedHelpers -> Just (Derived f) + -- some other call like find(`regex`, tag, 1): the version comes from + -- whichever argument we can trace back to a source + TIdent _ : TSym '(' : rest -> + listToMaybe (mapMaybe (resolveExpr toks (fuel - 1)) (splitArgs rest)) + -- a variable, possibly with methods: `v` or `v.crop(1)` + TIdent v : _ -> do + bound <- letBinding v toks + resolveExpr toks (fuel - 1) bound + _ -> Nothing + +-- | split the arguments of a call we're inside, up to its closing ')' +splitArgs :: [Token] -> [[Token]] +splitArgs toks = case takeBalanced toks of + [] -> [] + arg -> + arg : case drop (length arg) toks of + TSym ',' : rest -> splitArgs rest + _ -> [] + +-- | the right-hand side of `let v = ...;` (first binding wins) +letBinding :: Text -> [Token] -> Maybe [Token] +letBinding v = \case + [] -> Nothing + TIdent "let" : TIdent v' : TSym '=' : rest | v == v' -> Just (takeWhile (/= TSym ';') rest) + _ : rest -> letBinding v rest + +-- | recognize an andax source helper at the start of a token list +sourceCall :: [Token] -> Maybe (UpstreamSource, [Token]) +sourceCall = \case + TIdent f : TSym '(' : TStr a : TSym ',' : TStr b : TSym ')' : rest + | Just s <- twoArg f a b -> Just (s, rest) + TIdent f : TSym '(' : TStr a : TSym ')' : rest + | Just s <- oneArg f a -> Just (s, rest) + _ -> Nothing + where + oneArg f a = case f of + "gh" -> Just (GitHub a) + "gh_tag" -> Just (GitHubTag a) + "gitlab" -> Just (GitLab "gitlab.com" a) + "gitlab_tag" -> Just (GitLabTag "gitlab.com" a) + "codeberg" -> Just (Gitea "codeberg.org" a) + "sourcehut" -> Just (GitTags ("https://git.sr.ht/" <> a)) + "tangled" -> Just (GitTags ("https://tangled.org/" <> a)) + "codeberg_tag" -> Just (GiteaTag "codeberg.org" a) + "pypi" -> Just (PyPI a) + "crates" -> Just (Crates MaxStable a) + "crates_max" -> Just (Crates Max a) + "crates_newest" -> Just (Crates Newest a) + "npm" -> Just (Npm a) + "hackage" -> Just (Hackage a) + "gems" -> Just (Gems a) + "hex" -> Just (Hex a) + "cran" -> Just (Cran a) + "opam" -> Just (Opam a) + _ -> Nothing + twoArg f a b = case f of + "gitlab" -> Just (GitLab a b) + "gitlab_tag" -> Just (GitLabTag a b) + "gitea" -> Just (Gitea a b) + "gitea_tag" -> Just (GiteaTag a b) + "forgejo" -> Just (Gitea a b) + "forgejo_tag" -> Just (GiteaTag a b) + "ansible_galaxy" -> Just (AnsibleGalaxy a b) + _ -> Nothing + +-- | helpers whose version follows something other than an upstream release +derivedHelpers :: [Text] +derivedHelpers = + [ "bodhi", + "bodhi_vr", + "madoguchi", + "alma", + "nvidia_driver_version", + "nvidia_legacy_version", + "nvidia_component_version" + ] + +allSources :: [Token] -> [UpstreamSource] +allSources = \case + [] -> [] + ts@(_ : rest) -> maybe id ((:) . fst) (sourceCall ts) (allSources rest) + +-- | does the script call any *_commit helper (gh_commit, gitlab_commit, ...)? +hasCommitCall :: [Token] -> Bool +hasCommitCall = \case + TIdent f : TSym '(' : _ | "_commit" `T.isSuffixOf` f -> True + _ : rest -> hasCommitCall rest + [] -> False diff --git a/src/Oglyad/Source/Upstream.hs b/src/Oglyad/Source/Upstream.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Source/Upstream.hs @@ -0,0 +1,102 @@ +-- | asks upstreams what their latest version is, using the same endpoints and +-- json fields as anda's andax helpers (andax/fns/tsunagu.rs in FyraLabs/anda) +-- so oglyad sees exactly what `anda update` would see +module Oglyad.Source.Upstream + ( latestVersion, + ) +where + +import Control.Monad.Reader (liftIO) +import Data.Aeson (Value (..), eitherDecode) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KM +import Data.Bifunctor (first) +import Data.List (maximumBy) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector qualified as V +import Oglyad.App (App, HttpError (..), httpGetE) +import Oglyad.Process (run) +import Oglyad.Types (CrateField (..), UpstreamSource (..)) +import Oglyad.Version (normalizeVersion, rpmvercmp) + +-- | a step into a json document: an object key or an array index +data Step = K Text | I Int + +-- | latest upstream version, or a reason we couldn't get it +latestVersion :: UpstreamSource -> App (Either HttpError Text) +latestVersion = \case + GitHub repo -> json ("https://api.github.com/repos/" <> repo <> "/releases/latest") [K "tag_name"] + GitHubTag repo -> json ("https://api.github.com/repos/" <> repo <> "/tags?per_page=1") [I 0, K "name"] + GitLab host i -> json ("https://" <> host <> "/api/v4/projects/" <> i <> "/releases/") [I 0, K "tag_name"] + GitLabTag host i -> json ("https://" <> host <> "/api/v4/projects/" <> i <> "/repository/tags") [I 0, K "name"] + Gitea host repo -> json ("https://" <> host <> "/api/v1/repos/" <> repo <> "/releases/latest") [K "tag_name"] + GiteaTag host repo -> json ("https://" <> host <> "/api/v1/repos/" <> repo <> "/tags") [I 0, K "name"] + PyPI name -> json ("https://pypi.org/pypi/" <> name <> "/json") [K "info", K "version"] + Crates field name -> json ("https://crates.io/api/v1/crates/" <> name) [K "crate", K (crateKey field)] + Npm name -> json ("https://registry.npmjs.org/" <> name <> "/latest") [K "version"] + Hackage name -> json ("https://hackage.haskell.org/package/" <> name <> "/preferred.json") [K "normal-version", I 0] + Gems name -> json ("https://rubygems.org/api/v1/versions/" <> name <> "/latest.json") [K "version"] + Hex name -> json ("https://hex.pm/api/packages/" <> name) [K "latest_stable_version"] + Cran name -> json ("https://crandb.r-pkg.org/" <> name) [K "Version"] + Opam name -> opam name + AnsibleGalaxy ns coll -> + json + ("https://galaxy.ansible.com/api/v3/plugin/ansible/content/published/collections/index/" <> ns <> "/" <> coll <> "/versions/?limit=1&ordering=-version") + [K "data", I 0, K "version"] + GitTags url -> first HttpFailed <$> liftIO (gitTags url) + Derived how -> pure (Left (HttpFailed ("follows " <> how <> ", not an upstream release"))) + CommitTracked -> pure (Left (HttpFailed "tracks a commit, not a version")) + Unknown _ -> pure (Left (HttpFailed "unparsed update.rhai")) + where + crateKey = \case + MaxStable -> "max_stable_version" + Max -> "max_version" + Newest -> "newest_version" + +-- | GET a url and walk a path into the json it returns +json :: Text -> [Step] -> App (Either HttpError Text) +json url path = do + body <- httpGetE url + pure $ do + v <- body >>= either (\e -> Left (HttpFailed ("bad json from " <> url <> ": " <> T.pack e))) Right . eitherDecode + case walk path v of + Just (String s) | not (T.null s) -> Right s + _ -> Left (HttpFailed ("no version at expected spot in " <> url)) + +walk :: [Step] -> Value -> Maybe Value +walk [] v = Just v +walk (K k : rest) (Object o) = KM.lookup (Key.fromText k) o >>= walk rest +walk (I i : rest) (Array a) = a V.!? i >>= walk rest +walk _ _ = Nothing + +-- | opam has no "latest" endpoint. anda lists the package's directory in +-- ocaml/opam-repository and picks the highest `name.version` entry +opam :: Text -> App (Either HttpError Text) +opam name = do + let url = "https://api.github.com/repos/ocaml/opam-repository/contents/packages/" <> name + body <- httpGetE url + pure $ do + v <- body >>= either (Left . HttpFailed . T.pack) Right . eitherDecode + let versions = case v of + Array entries -> + [ ver + | Object o <- V.toList entries, + Just (String n) <- [KM.lookup "name" o], + Just ver <- [T.stripPrefix (name <> ".") n] + ] + _ -> [] + case versions of + [] -> Left (HttpFailed ("no versions listed at " <> url)) + _ -> Right (maximumBy rpmvercmp versions) + +-- | newest tag on a git remote, for forges without a releases api. +-- `git ls-remote` speaks the smart http protocol, so nothing gets cloned +gitTags :: Text -> IO (Either Text Text) +gitTags url = do + out <- run "git" ["ls-remote", "--tags", "--refs", T.unpack url] + pure $ case out of + Left err -> Left ("git ls-remote failed for " <> url <> ": " <> err) + Right o -> case [t | l <- T.lines o, Just t <- [T.stripPrefix "refs/tags/" (T.takeWhileEnd (/= '\t') l)]] of + [] -> Left ("no tags at " <> url) + tags -> Right (maximumBy (\a b -> rpmvercmp (normalizeVersion a) (normalizeVersion b)) tags) diff --git a/src/Oglyad/Types.hs b/src/Oglyad/Types.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Types.hs @@ -0,0 +1,173 @@ +module Oglyad.Types + ( EVR (..), + UpstreamSource (..), + CrateField (..), + Package (..), + RepoBuild (..), + Severity (..), + Finding (..), + finding, + Snapshot (..), + Config (..), + Check, + ) +where + +import Data.Aeson (FromJSON, ToJSON (..), Value (String)) +import Data.Map.Strict (Map) +import Data.Set (Set) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (NominalDiffTime, UTCTime) +import GHC.Generics (Generic) +import Oglyad.Version (EVR (..)) + +-- | which version field of a crate anda reads +data CrateField + = -- | crates() + MaxStable + | -- | crates_max() + Max + | -- | crates_newest() + Newest + deriving stock (Eq, Ord, Show, Read, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | where a package's upstream version comes from, recovered from update.rhai. +-- constructors mirror the andax helpers in FyraLabs/anda (andax/fns/tsunagu.rs) +data UpstreamSource + = -- | gh("owner/repo"), latest release + GitHub Text + | -- | gh_tag("owner/repo"), newest tag + GitHubTag Text + | -- | gitlab([domain,] id), latest release + GitLab Text Text + | -- | gitlab_tag([domain,] id) + GitLabTag Text Text + | -- | gitea(host, repo) and codeberg(repo) + Gitea Text Text + | -- | gitea_tag(host, repo) and codeberg_tag(repo) + GiteaTag Text Text + | PyPI Text + | Crates CrateField Text + | Npm Text + | Hackage Text + | Gems Text + | Hex Text + | Cran Text + | Opam Text + | -- | namespace, collection + AnsibleGalaxy Text Text + | -- | newest tag of any git remote (sourcehut, tangled) + GitTags Text + | -- | follows another distro or package (bodhi, madoguchi, nvidia), not upstream + Derived Text + | -- | follows a branch head (gh_commit and friends), no version to compare + CommitTracked + | -- | raw update.rhai we couldn't make sense of + Unknown Text + deriving stock (Eq, Ord, Show, Read, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | what Terra's published repodata says about a source package +data RepoBuild = RepoBuild + { rbEVR :: EVR, + rbBuildTime :: UTCTime + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | one source package, merged from every data source we know about +data Package = Package + { pkgName :: Text, + -- | relative to the monorepo, e.g. anda/devs/zed/stable + pkgPath :: FilePath, + -- | Terra subrepo from anda.hcl labels, e.g. "extras" + pkgSubrepo :: Maybe Text, + -- | what's merged in git + pkgSpecEVR :: Maybe EVR, + -- | what's actually published + pkgRepoBuild :: Maybe RepoBuild, + pkgLastCommit :: Maybe UTCTime, + -- | Nothing means no update.rhai + pkgUpstream :: Maybe UpstreamSource, + -- | only filled in when upstream lookups ran + pkgUpstreamVer :: Maybe Text, + -- | why the upstream lookup failed, if it did + pkgUpstreamErr :: Maybe Text, + -- | whether the repo this package publishes to was fetched. when it + -- wasn't, pkgRepoBuild = Nothing means "unknown", not "never published" + pkgRepoChecked :: Bool + } + deriving stock (Eq, Show) + +data Severity = Info | Warn | Error + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +instance ToJSON Severity where + toJSON = \case + Info -> String "info" + Warn -> String "warn" + Error -> String "error" + +data Finding = Finding + { fCheck :: Text, + fPackage :: Text, + -- | the package's directory in the monorepo. package names aren't unique + -- (see the duplicate-name check), so this is what identifies it + fPath :: Maybe Text, + fSeverity :: Severity, + fMessage :: Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON) + +-- | a finding about a package +finding :: Text -> Package -> Severity -> Text -> Finding +finding check p sev msg = + Finding + { fCheck = check, + fPackage = pkgName p, + fPath = Just (T.pack (pkgPath p)), + fSeverity = sev, + fMessage = msg + } + +data Config = Config + { -- | local checkout of terrapkg/packages + cfgMonorepo :: FilePath, + -- | e.g. https://repos.fyralabs.com/terra44 + cfgTerraRepo :: Text, + -- | repo base urls to check for overlap + cfgFedoraRepos :: [Text], + -- | %{dist} used when evaluating specs, e.g. .fc44 + -- | Fedora/Terra release number, e.g. 44 + cfgRelease :: Int, + cfgDist :: Text, + cfgStaleAfter :: NominalDiffTime, + -- | whether to hit upstream APIs at all + cfgUpstream :: Bool, + -- | reuse cached upstream answers younger than this + cfgCacheFor :: NominalDiffTime, + -- | parallel jobs, defaults to the number of cores + cfgConcurrency :: Int, + cfgGitHubToken :: Maybe Text + } + deriving stock (Show) + +-- | everything a check is allowed to look at, already collected. +-- checks never do IO, which is what keeps them trivially testable +data Snapshot = Snapshot + { -- | keyed by monorepo path, since names can repeat + snapPackages :: Map FilePath Package, + -- | source package names present in Fedora + snapFedora :: Set Text, + snapNow :: UTCTime, + snapConfig :: Config, + -- | the monorepo commit this run looked at + snapHead :: Maybe Text, + -- | check names each package dir's anda.hcl asks to ignore + snapIgnoreLabels :: Map FilePath [Text] + } + +type Check = Snapshot -> Package -> [Finding] diff --git a/src/Oglyad/Version.hs b/src/Oglyad/Version.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Version.hs @@ -0,0 +1,161 @@ +-- | RPM version handling: EVR parsing and the rpmvercmp algorithm +-- +-- reference implementation: rpmio/rpmvercmp.c in rpm-software-management/rpm +-- test vectors: tests/rpmvercmp.at in the same repo +module Oglyad.Version + ( EVR (..), + parseEVR, + renderEVR, + rpmvercmp, + compareEVR, + normalizeVersion, + compareUpstream, + ) +where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, isDigit) +import Data.List (find) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) +import Text.Read (readMaybe) + +-- | epoch:version-release +-- +-- note: 'Eq' is structural but 'Ord' goes through rpmvercmp, so "1.05" and +-- "1.5" compare EQ while being /=. build-lag relies on the structural Eq on +-- purpose, since any textual difference between git and the repo is worth +-- reporting +data EVR = EVR + { evrEpoch :: !Int, + evrVersion :: !Text, + evrRelease :: !Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance Ord EVR where + compare = compareEVR + +-- | parse "[epoch:]version-release". a missing epoch or "(none)" means 0 +parseEVR :: Text -> Maybe EVR +parseEVR raw = do + let (epochPart, rest) = case T.breakOn ":" raw of + (vr, "") -> ("0", vr) + (e, r) -> (e, T.drop 1 r) + epoch <- if epochPart == "(none)" then Just 0 else readMaybe (T.unpack epochPart) + -- release is everything after the *last* dash, versions can't contain dashes + let (verDash, rel) = T.breakOnEnd "-" rest + ver <- T.stripSuffix "-" verDash + if T.null ver || T.null rel then Nothing else Just (EVR epoch ver rel) + +renderEVR :: EVR -> Text +renderEVR (EVR 0 v r) = v <> "-" <> r +renderEVR (EVR e v r) = T.pack (show e) <> ":" <> v <> "-" <> r + +compareEVR :: EVR -> EVR -> Ordering +compareEVR (EVR e1 v1 r1) (EVR e2 v2 r2) = + compare e1 e2 <> rpmvercmp v1 v2 <> rpmvercmp r1 r2 + +-- | compare two version (or release) strings exactly the way rpm does. +-- this is a line-by-line port of rpmvercmp.c +-- +-- * anything that isn't an ascii letter, digit, '~' or '^' is a separator +-- * '~' sorts before everything, even the end of the string (1.0~rc1 < 1.0) +-- * '^' sorts after the end of the string but before anything else +-- (1.0 < 1.0^git1 < 1.0.1) +-- * otherwise compare segment by segment, where a segment is a run of +-- digits or a run of letters. numbers beat letters, numbers compare +-- numerically, letters compare lexically +-- * when one side runs out, the side with stuff left is newer +rpmvercmp :: Text -> Text -> Ordering +rpmvercmp a b + | a == b = EQ + | otherwise = go a b + where + go one0 two0 + | T.null one0 && T.null two0 = EQ + | otherwise = + let one = T.dropWhile isSep one0 + two = T.dropWhile isSep two0 + in case (T.uncons one, T.uncons two) of + -- tilde: whoever has it is older + (Just ('~', one'), Just ('~', two')) -> go one' two' + (Just ('~', _), _) -> LT + (_, Just ('~', _)) -> GT + -- caret: older than anything except the end of the string + (Just ('^', one'), Just ('^', two')) -> go one' two' + (Nothing, Just ('^', _)) -> LT + (Just ('^', _), Nothing) -> GT + (Just ('^', _), Just _) -> LT + (Just _, Just ('^', _)) -> GT + -- one side ran out + (Nothing, Nothing) -> EQ + (Just _, Nothing) -> GT + (Nothing, Just _) -> LT + (Just (c, _), Just _) + | isDigit c -> segment True (T.span isDigit one) (T.span isDigit two) + | otherwise -> segment False (T.span isAlpha one) (T.span isAlpha two) + + segment isNum (seg1, rest1) (seg2, rest2) + -- the other side has a different kind of segment here. + -- numeric beats alpha + | T.null seg2 = if isNum then GT else LT + | isNum = + let n1 = T.dropWhile (== '0') seg1 + n2 = T.dropWhile (== '0') seg2 + in compare (T.length n1) (T.length n2) <> compare n1 n2 <> go rest1 rest2 + | otherwise = compare seg1 seg2 <> go rest1 rest2 + + isAlpha c = isAsciiLower c || isAsciiUpper c + isSep c = not (isDigit c || isAlpha c || c == '~' || c == '^') + +-- | turn an upstream tag (or a sloppy spec Version) into something +-- rpmvercmp can compare. starts from what anda's rpm.version() does (trim, +-- drop a leading v, dashes become dots) and adds: +-- +-- * monorepo tags like "pkg/v1.2" keep only the part after the last slash +-- * non-numeric prefixes go, so "release-1.2" and "jq-1.7" line up +-- * prerelease markers become tildes like Fedora spells them, +-- so "6.0.0-alpha1" becomes "6.0.0~alpha1" +normalizeVersion :: Text -> Text +normalizeVersion raw = + let t = T.takeWhileEnd (/= '/') (T.strip raw) + noV = maybe t id (T.stripPrefix "v" t) + fromDigit = case T.dropWhile (not . isDigit) noV of + "" -> noV + d -> d + in T.replace "-" "." (tildePre fromDigit) + +-- | "-rc1" / ".beta" / "_alpha2" → "~rc1" / "~beta" / "~alpha2" +tildePre :: Text -> Text +tildePre t = case T.uncons t of + Nothing -> "" + Just (c, rest) + | c `elem` ("-._" :: String), Just _ <- marker rest -> T.cons '~' (tildePre rest) + | otherwise -> T.cons c (tildePre rest) + where + marker r = find (`T.isPrefixOf` T.toLower r) ["alpha", "beta", "rc", "pre", "dev"] + +-- | compare an upstream version with a spec Version, forgiving the usual +-- ways packagers respell a version. returns how upstream compares to the spec +-- +-- * same letters and digits, different punctuation is the same version +-- (0.4.2 vs 0.4~2, 2026.07.27 vs 20260727) +-- * the same leading dotted number with junk after it is the same version +-- (2.005R vs 2.005, 3.17.0-ogc1 vs 3.17.0^1), unless one side is a +-- prerelease, since 6.0.0 vs 6.0.0~alpha1 is real drift +-- * otherwise rpmvercmp decides +compareUpstream :: Text -> Text -> Ordering +compareUpstream up spec + | squash u == squash s = EQ + | not (T.null (core u)) && core u == core s && not (isPre u || isPre s) = EQ + | otherwise = rpmvercmp u s + where + u = normalizeVersion up + s = normalizeVersion spec + squash = T.toLower . T.filter isAlphaNum + core = T.dropWhileEnd (== '.') . T.takeWhile (\c -> isDigit c || c == '.') + -- a prerelease is never "the same version with junk after it" + isPre v = "~" `T.isPrefixOf` T.drop (T.length (core v)) (T.dropWhileEnd (== '.') v) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,451 @@ +module Main (main) where + +import Control.Exception (bracket) +import Control.Monad (forM_) +import Data.Aeson (Value (..), decode) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (UTCTime (..), addUTCTime, fromGregorian, nominalDay) +import Oglyad.App (runApp) +import Oglyad.Check (checkNames, parseCheckName) +import Oglyad.Check.BuildLag qualified as BuildLag +import Oglyad.Check.Drift qualified as Drift +import Oglyad.Check.DuplicateName qualified as DuplicateName +import Oglyad.Check.FedoraOverlap qualified as FedoraOverlap +import Oglyad.Check.Stale qualified as Stale +import Oglyad.Ignore +import Oglyad.Process (childEnv, run) +import Oglyad.Report (Report (..), renderJson, renderMarkdown, renderText) +import Oglyad.Source.Monorepo (PkgDir (..), findPackageDirs, hclString, lastCommits, macroFingerprint, specFingerprint) +import Oglyad.Source.Repodata (RpmEntry (..), decompressAndParse, fetchRepo, latestBySource, parsePrimary, srpmName) +import Oglyad.Source.Rhai (parseUpdateRhai) +import Oglyad.Types +import Oglyad.Version +import System.Directory (createDirectoryIfMissing, createDirectoryLink, createFileLink) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process.Typed (byteStringInput, proc, readProcess, runProcess_, setEnv, setStdin) +import Test.Hspec +import Test.QuickCheck + +main :: IO () +main = hspec $ do + describe "parseEVR" $ do + it "parses version-release" $ + parseEVR "1.2.3-1.fc44" `shouldBe` Just (EVR 0 "1.2.3" "1.fc44") + it "parses an epoch" $ + parseEVR "2:1.0-3" `shouldBe` Just (EVR 2 "1.0" "3") + it "treats (none) as epoch 0" $ + parseEVR "(none):1.0-3" `shouldBe` Just (EVR 0 "1.0" "3") + it "rejects a missing release" $ + parseEVR "1.0" `shouldBe` Nothing + + -- vectors from rpm's tests/rpmvercmp.at + describe "rpmvercmp" $ do + mapM_ + vercmpCase + [ ("1.0", "1.0", EQ), + ("1.0", "2.0", LT), + ("2.0.1", "2.0", GT), + ("2.0.1a", "2.0.1", GT), + ("5.5p1", "5.5p2", LT), + ("5.5p10", "5.5p1", GT), + ("10xyz", "10.1xyz", LT), + ("xyz10", "xyz10.1", LT), + ("xyz.4", "8", LT), + ("1.05", "1.5", EQ), + ("2.0", "2_0", EQ), + ("2a", "2.0", LT), + ("1.0~rc1", "1.0", LT), + ("1.0~rc1", "1.0~rc2", LT), + ("1.0~rc1~git123", "1.0~rc1", LT), + ("1.0^", "1.0", GT), + ("1.0^git1", "1.01", LT), + ("1.0^git1~pre", "1.0^git1", LT), + ("1.0~rc1^git1", "1.0~rc1", GT), + ("1.0^git1", "1.0^git2", LT), + ("1.0^20160101", "1.0.1", LT) + ] + it "is reflexive" $ property $ \(V a) -> rpmvercmp a a == EQ + it "is antisymmetric" $ property $ \(V a) (V b) -> + rpmvercmp a b == flipOrd (rpmvercmp b a) + + describe "normalizeVersion" $ do + it "drops a leading v" $ normalizeVersion "v1.2.3" `shouldBe` "1.2.3" + it "drops a name prefix" $ normalizeVersion "jq-1.7.1" `shouldBe` "1.7.1" + it "drops a monorepo tag prefix" $ normalizeVersion "v2/v1.0.28" `shouldBe` "1.0.28" + it "turns dashes into dots like anda" $ normalizeVersion "2024-01-05" `shouldBe` "2024.01.05" + it "spells prereleases with a tilde" $ normalizeVersion "6.0.0-alpha1" `shouldBe` "6.0.0~alpha1" + + describe "compareUpstream" $ do + mapM_ + (\(up, spec, o) -> it (T.unpack up <> " vs spec " <> T.unpack spec) $ compareUpstream up spec `shouldBe` o) + [ ("v1.3.0", "1.2.0", GT), + ("v1.2.0", "1.2.0", EQ), + ("1.2.0", "1.3.0", LT), + ("6.0.0-alpha1", "6.0.0~alpha1", EQ), + ("6.0.0", "6.0.0~alpha1", GT), + ("0.4.2", "0.4~2", EQ), + ("2026-07-27", "20260727", EQ), + ("2.005R", "2.005", EQ), + ("3.17.0-ogc1", "3.17.0^1", EQ), + ("6.7.3", "v6.7.3", EQ), + ("0.42.0", "0.41.0^20261031.9e2ed65", GT), + -- a snapshot taken after the release it's based on isn't drift + ("0.41.0", "0.41.0^20261031.9e2ed65", EQ) + ] + + describe "srpmName" $ do + it "strips version and release" $ + srpmName "zed-0.190.0-1.fc44.src.rpm" `shouldBe` Just "zed" + it "keeps dashes in the name" $ + srpmName "python-foo-bar-1.0-2.fc44.src.rpm" `shouldBe` Just "python-foo-bar" + + describe "parsePrimary" $ do + let entries = either (const []) id (parsePrimary primaryFixture) + firstOf f = map f (take 1 entries) + it "finds every package" $ map rpmName entries `shouldBe` ["zed", "zed-cli"] + it "reads the EVR" $ firstOf rpmEVR `shouldBe` [EVR 0 "0.190.0" "1.fc44"] + it "reads the build time" $ firstOf rpmBuildTime `shouldBe` [posix 1794200000] + it "reads the source rpm" $ firstOf rpmSourceRpm `shouldBe` [Just "zed-0.190.0-1.fc44.src.rpm"] + it "groups binaries by source package" $ + Map.keys (latestBySource entries) `shouldBe` ["zed"] + it "rejects garbage" $ parsePrimary "" `shouldSatisfy` isLeft + it "decompresses zstd through the zstd command" $ do + -- the same fixture, compressed by the real zstd tool + (_, compressed, _) <- readProcess (setStdin (byteStringInput primaryFixture) (proc "zstd" ["-c", "-q"])) + r <- decompressAndParse "repodata/abc-primary.xml.zst" compressed + fmap (map rpmName) r `shouldBe` Right ["zed", "zed-cli"] + forM_ [("gzip", ".gz"), ("xz", ".xz")] $ \(tool, ext) -> + it ("decompresses " <> tool <> " through the " <> tool <> " command") $ do + (_, compressed, _) <- readProcess (setStdin (byteStringInput primaryFixture) (proc tool ["-c", "-q"])) + r <- decompressAndParse ("repodata/abc-primary.xml" <> T.pack ext) compressed + fmap (map rpmName) r `shouldBe` Right ["zed", "zed-cli"] + it "reports corrupt zstd instead of crashing" $ do + r <- decompressAndParse "repodata/abc-primary.xml.zst" "definitely not zstd" + r `shouldSatisfy` isLeft + + describe "hclString" $ do + let hcl = "project pkg {\n rpm {\n spec = \"zed.spec\"\n }\n labels {\n subrepo = \"extras\"\n }\n}\n" + it "finds the spec" $ hclString "spec" hcl `shouldBe` Just "zed.spec" + it "finds the subrepo" $ hclString "subrepo" hcl `shouldBe` Just "extras" + it "doesn't match key prefixes" $ hclString "sub" hcl `shouldBe` Nothing + + describe "parseUpdateRhai" $ do + it "understands gh()" $ + parseUpdateRhai "rpm.version(gh(\"zed-industries/zed\"));\n" `shouldBe` GitHub "zed-industries/zed" + it "understands two-arg helpers" $ + parseUpdateRhai "rpm.version(gitea(\"gitea.com\", \"gitea/tea\"));" `shouldBe` Gitea "gitea.com" "gitea/tea" + it "maps codeberg to gitea" $ + parseUpdateRhai "rpm.version(codeberg(\"a/b\"))" `shouldBe` Gitea "codeberg.org" "a/b" + it "follows let bindings" $ + parseUpdateRhai "let v = gh_tag(\"x/y\");\nif v.len > 0 {\n rpm.version(v);\n}" `shouldBe` GitHubTag "x/y" + it "follows rpm.global(\"ver\", ...)" $ + parseUpdateRhai nightly `shouldBe` GitHub "OpenTabletDriver/OpenTabletDriver" + it "spots commit tracking" $ + parseUpdateRhai "rpm.global(\"commit\", gh_commit(\"a/b\"));\nif rpm.changed() { rpm.release(); }" `shouldBe` CommitTracked + it "keeps raw backtick regexes intact" $ + parseUpdateRhai "let v = gh_tag(\"a/b\");\nif `[\\d.]+-beta\\.\\d+`.find_all(v).len == 0 {\n rpm.version(v);\n}" `shouldBe` GitHubTag "a/b" + it "follows variables through other calls" $ + parseUpdateRhai "let tag = gh_tag(\"x/ghidra\");\nlet v = find(`Ghidra_([\\d.]+)_build`, tag, 1);\nrpm.version(v);" `shouldBe` GitHubTag "x/ghidra" + it "marks distro-following versions as derived" $ + parseUpdateRhai "import \"andax/bump_extras.rhai\" as bump;\nrpm.version(bump::madoguchi(\"zig-master\", labels.branch));" `shouldBe` Derived "bump::madoguchi" + it "ignores comments" $ + parseUpdateRhai "// gh(\"wrong/one\")\nrpm.version(pypi(\"west\"));" `shouldBe` PyPI "west" + it "falls back to Unknown" $ + parseUpdateRhai "let x = get(\"https://example.com\").json();\nrpm.version(x.version);" `shouldSatisfy` isUnknown + + describe "drift check" $ do + it "warns when upstream is newer" $ + severities (Drift.check snapshot (pkg {pkgUpstreamVer = Just "v1.3.0"})) `shouldBe` [Warn] + it "is quiet when versions match" $ + Drift.check snapshot (pkg {pkgUpstreamVer = Just "v1.2.0"}) `shouldBe` [] + it "ignores snapshots ahead of the last release" $ + Drift.check snapshot (pkg {pkgSpecEVR = Just (EVR 0 "1.2.0^20261101git1234abc" "1.fc44"), pkgUpstreamVer = Just "1.2.0"}) `shouldBe` [] + it "is quiet without upstream data" $ + Drift.check snapshot pkg `shouldBe` [] + + describe "fedora-overlap check" $ do + let withFedora = snapshot {snapFedora = Set.singleton "zed"} + it "warns when Fedora ships the same package" $ + severities (FedoraOverlap.check withFedora pkg) `shouldBe` [Warn] + it "ignores packages in subrepos" $ + FedoraOverlap.check withFedora (pkg {pkgSubrepo = Just "multimedia"}) `shouldBe` [] + it "is quiet when Fedora doesn't have it" $ + FedoraOverlap.check snapshot pkg `shouldBe` [] + + describe "duplicate-name check" $ do + let other = pkg {pkgPath = "anda/devs/zed/nightly"} + twoOf a b = snapshot {snapPackages = Map.fromList [(pkgPath a, a), (pkgPath b, b)]} + it "flags two dirs building the same name into one repo" $ + severities (DuplicateName.check (twoOf pkg other) pkg) `shouldBe` [Warn] + it "allows the same name in different subrepos" $ + DuplicateName.check (twoOf pkg other {pkgSubrepo = Just "extras"}) pkg `shouldBe` [] + it "is quiet for unique names" $ + DuplicateName.check snapshot pkg `shouldBe` [] + + describe "report" $ do + let f path = Finding "build-lag" "zed" (Just path) Warn "x" + it "shows the directory when a name is ambiguous" $ + renderText Info (report [f "anda/a", f "anda/b"]) `shouldSatisfy` T.isInfixOf "zed (anda/a): x" + it "keeps it short otherwise" $ + renderText Info (report [f "anda/a"]) `shouldSatisfy` T.isInfixOf "zed: x" + it "counts ignored findings in the summary" $ + renderText Info ((report [f "anda/a"]) {rIgnored = [f "anda/b"]}) `shouldSatisfy` T.isInfixOf "(1 ignored)" + it "wraps json in a versioned envelope" $ do + let o = case decode (renderJson (report [f "anda/a"])) of + Just (Object x) -> x + _ -> KM.empty + KM.lookup "schema" o `shouldBe` Just (Number 1) + KM.lookup "summary" o `shouldSatisfy` maybe False (\case Object s -> KM.lookup "warn" s == Just (Number 1); _ -> False) + KM.lookup "findings" o `shouldSatisfy` maybe False (\case Array a -> length a == 1; _ -> False) + it "escapes pipes in markdown tables" $ + renderMarkdown Info (report [(f "anda/a") {fMessage = "a|b"}]) `shouldSatisfy` T.isInfixOf "a\\|b" + it "folds info findings away in markdown" $ + renderMarkdown Info (report [(f "anda/a") {fSeverity = Info}]) `shouldSatisfy` T.isInfixOf "
Info (1)" + + describe "ignores" $ do + let f check path name = Finding check name (Just path) Warn "x" + dup = f "duplicate-name" "anda/langs/zig/master-bootstrap" "zig-master" + lag = f "build-lag" "anda/devs/zed/stable" "zed" + file rules = IgnoreFile rules + rule check target = IgnoreRule check target "because" + apply rules labels = applyIgnores checkNames checkNames (file rules) (Map.fromList labels) + it "parses a valid file" $ + parseIgnoreFile checkNames "{\"ignore\": [{\"check\": \"stale\", \"package\": \"zed\", \"reason\": \"fine\"}]}" + `shouldBe` Right (file [IgnoreRule "stale" (ByName "zed") "fine"]) + forM_ + [ ("an empty reason", "{\"ignore\": [{\"check\": \"stale\", \"package\": \"zed\", \"reason\": \" \"}]}"), + ("an unknown check", "{\"ignore\": [{\"check\": \"stael\", \"package\": \"zed\", \"reason\": \"x\"}]}"), + ("both path and package", "{\"ignore\": [{\"check\": \"stale\", \"package\": \"zed\", \"path\": \"anda/x\", \"reason\": \"x\"}]}") + ] + $ \(what, raw) -> it ("rejects " <> what) $ parseIgnoreFile checkNames raw `shouldSatisfy` either (const True) (const False) + it "ignores by path" $ do + let Applied {..} = apply [rule "duplicate-name" (ByPath "anda/langs/zig/master-bootstrap")] [] [dup, lag] + (apKept, apIgnored, apProblems) `shouldBe` ([lag], [dup], []) + it "ignores by package name" $ do + let Applied {..} = apply [rule "build-lag" (ByName "zed")] [] [dup, lag] + (apKept, apIgnored) `shouldBe` ([dup], [lag]) + it "ignores by anda.hcl label" $ do + let Applied {..} = apply [] [("anda/langs/zig/master-bootstrap", ["duplicate-name"])] [dup, lag] + (apKept, apIgnored) `shouldBe` ([lag], [dup]) + it "only matches the named check" $ do + let Applied {..} = apply [rule "stale" (ByName "zed")] [] [lag] + apKept `shouldBe` [lag] + it "reports entries that match nothing" $ do + let Applied {..} = apply [rule "stale" (ByName "gone")] [] [lag] + map fCheck apProblems `shouldBe` ["unused-ignore"] + it "doesn't call entries unused when their check didn't run" $ do + let Applied {..} = applyIgnores checkNames ["build-lag"] (file [rule "stale" (ByName "gone")]) Map.empty [lag] + apProblems `shouldBe` [] + it "flags unknown check names in labels" $ do + let Applied {..} = apply [] [("anda/x", ["stael"])] [] + map fSeverity apProblems `shouldBe` [Warn] + + describe "build-lag check" $ do + it "says never published when the repo was fetched" $ + severities (BuildLag.check snapshot pkg) `shouldBe` [Error] + it "stays quiet when the repo fetch failed" $ + BuildLag.check snapshot pkg {pkgRepoChecked = False} `shouldBe` [] + + describe "child processes" $ do + it "never get secrets from our environment" $ do + let env = childEnv [("PATH", "/usr/bin"), ("HOME", "/home/x"), ("GITHUB_TOKEN", "secret"), ("GH_TOKEN", "secret"), ("AWS_SECRET_ACCESS_KEY", "s"), ("LC_ALL", "C")] + map fst env `shouldMatchList` ["GIT_TERMINAL_PROMPT", "PATH", "HOME", "LC_ALL"] + it "can't read GITHUB_TOKEN even when spec-like code asks for it" $ + withEnv "GITHUB_TOKEN" "oglyad-test-secret" $ do + r <- run "sh" ["-c", "env"] + r `shouldSatisfy` either (const False) (not . T.isInfixOf "oglyad-test-secret") + + describe "filesystem edge cases" $ do + it "fingerprints a package with a dangling symlink instead of crashing" $ + withSystemTempDirectory "oglyad-fp" $ \root -> do + createDirectoryIfMissing True (root "anda/a") + writeFile (root "anda/a/a.spec") "Name: a" + createFileLink "does-not-exist" (root "anda/a/broken") + key <- specFingerprint "m" ".fc44" root "anda/a" + T.length key `shouldBe` 64 + it "doesn't follow a symlink loop" $ + withSystemTempDirectory "oglyad-loop" $ \root -> do + createDirectoryIfMissing True (root "anda/a") + writeFile (root "anda/a/anda.hcl") "project pkg {}" + createDirectoryLink ".." (root "anda/a/loop") + dirs <- findPackageDirs root + map (fmap pdPath) dirs `shouldBe` [Right "anda/a"] + _ <- specFingerprint "m" ".fc44" root "anda/a" + pure () + + describe "parseCheckName" $ do + it "accepts known checks" $ parseCheckName "build-lag" `shouldBe` Right "build-lag" + it "rejects typos instead of silently running nothing" $ + parseCheckName "buildlag" `shouldSatisfy` either (const True) (const False) + + describe "failure handling" $ do + it "turns a missing executable into a Left" $ do + r <- run "oglyad-definitely-not-a-real-command" [] + r `shouldSatisfy` either (const True) (const False) + it "turns an unreachable repo into a Left instead of throwing" $ do + -- port 9 (discard) on loopback: refused immediately, no network needed + r <- runApp (snapConfig snapshot) (fetchRepo "http://127.0.0.1:9/repo") + r `shouldSatisfy` either (const True) (const False) + + describe "macroFingerprint" $ + it "changes when ~/.rpmmacros changes" $ + withSystemTempDirectory "oglyad-home" $ \home -> + withEnv "HOME" home $ withEnv "XDG_CONFIG_HOME" (home ".config") $ do + fpBefore <- macroFingerprint + writeFile (home ".rpmmacros") "%dist .fc99\n" + fpAfter <- macroFingerprint + fpAfter `shouldNotBe` fpBefore + + describe "lastCommits" $ + it "reads commit times, including UTC ones git prints with a Z" $ + withSystemTempDirectory "oglyad-git" $ \repo -> do + let git env args = + runProcess_ . System.Process.Typed.setEnv (env <> [("GIT_CONFIG_GLOBAL", "/dev/null"), ("GIT_CONFIG_NOSYSTEM", "1")]) $ + proc "git" (["-C", repo, "-c", "user.name=t", "-c", "user.email=t@t", "-c", "commit.gpgsign=false"] <> args) + commitAt date dir = do + createDirectoryIfMissing True (repo dir) + writeFile (repo dir "anda.hcl") date + git [] ["add", "-A"] + git [("GIT_COMMITTER_DATE", date), ("GIT_AUTHOR_DATE", date)] ["commit", "-q", "-m", dir] + git [] ["init", "-q"] + commitAt "2026-01-02T03:04:05Z" "anda/a" + commitAt "2026-02-03T04:05:06+08:00" "anda/b" + m <- lastCommits repo ["anda/a", "anda/b"] + Map.lookup "anda/a" m `shouldBe` Just (UTCTime (fromGregorian 2026 1 2) (3 * 3600 + 4 * 60 + 5)) + Map.lookup "anda/b" m `shouldBe` Just (UTCTime (fromGregorian 2026 2 2) (20 * 3600 + 5 * 60 + 6)) + + describe "stale check" $ do + let built daysAgo = Just (RepoBuild (EVR 0 "1.2.0" "1.fc44") (addUTCTime (negate (daysAgo * nominalDay)) now)) + it "is quiet for recent builds" $ + Stale.check snapshot (pkg {pkgRepoBuild = built 10}) `shouldBe` [] + it "notes old builds" $ + severities (Stale.check snapshot (pkg {pkgRepoBuild = built 400})) `shouldBe` [Info] + it "warns when old and upstream moved on" $ + severities (Stale.check snapshot (pkg {pkgRepoBuild = built 400, pkgUpstreamVer = Just "1.3.0"})) `shouldBe` [Warn] + where + nightly = + "rpm.global(\"commit\", gh_commit(\"OpenTabletDriver/OpenTabletDriver\"));\n\ + \if rpm.changed() {\n\ + \ let v = gh(\"OpenTabletDriver/OpenTabletDriver\");\n\ + \ v.crop(1);\n\ + \ rpm.global(\"ver\", v);\n\ + \}\n" + isLeft = either (const True) (const False) + isUnknown = \case Unknown _ -> True; _ -> False + +vercmpCase :: (Text, Text, Ordering) -> Spec +vercmpCase (a, b, o) = + it (T.unpack a <> " vs " <> T.unpack b) $ do + rpmvercmp a b `shouldBe` o + rpmvercmp b a `shouldBe` flipOrd o + +flipOrd :: Ordering -> Ordering +flipOrd = compare EQ + +severities :: [Finding] -> [Severity] +severities = map fSeverity + +-- * fixtures + +now :: UTCTime +now = UTCTime (fromGregorian 2026 11 9) 0 + +posix :: Integer -> UTCTime +posix s = addUTCTime (fromIntegral s) (UTCTime (fromGregorian 1970 1 1) 0) + +pkg :: Package +pkg = + Package + { pkgName = "zed", + pkgPath = "anda/devs/zed/stable", + pkgSubrepo = Nothing, + pkgSpecEVR = Just (EVR 0 "1.2.0" "1.fc44"), + pkgRepoBuild = Nothing, + pkgLastCommit = Nothing, + pkgUpstream = Just (GitHub "zed-industries/zed"), + pkgUpstreamVer = Nothing, + pkgUpstreamErr = Nothing, + pkgRepoChecked = True + } + +snapshot :: Snapshot +snapshot = + Snapshot + { snapPackages = Map.singleton (pkgPath pkg) pkg, + snapFedora = Set.empty, + snapNow = now, + snapConfig = + Config + { cfgMonorepo = ".", + cfgTerraRepo = "", + cfgFedoraRepos = [], + cfgRelease = 44, + cfgDist = ".fc44", + cfgStaleAfter = 180 * nominalDay, + cfgUpstream = False, + cfgCacheFor = 0, + cfgConcurrency = 1, + cfgGitHubToken = Nothing + }, + snapHead = Nothing, + snapIgnoreLabels = Map.empty + } + +report :: [Finding] -> Report +report fs = + Report + { rVersion = "0", + rGenerated = now, + rMonorepoHead = Just "abc", + rTerraRepo = "https://repos.fyralabs.com/terra44", + rUpstream = False, + rFindings = fs, + rIgnored = [] + } + +primaryFixture :: LBS8.ByteString +primaryFixture = + "\n\ + \\n\ + \\n\ + \ zed\n\ + \ x86_64\n\ + \ \n\ + \ an editor & more\n\ + \ \n\ + \\n\ + \ zed-cli\n\ + \ x86_64\n\ + \ \n\ + \ \n\ + \\n" + +-- | version-ish strings: digits, letters and the separators rpm cares about +newtype V = V Text deriving stock (Show) + +instance Arbitrary V where + arbitrary = V . T.pack <$> listOf (elements "0123456789abz.~^_") + shrink (V t) = V . T.pack <$> shrink (T.unpack t) + +-- | set an environment variable for the duration of an action +withEnv :: String -> String -> IO a -> IO a +withEnv key val act = + bracket + (lookupEnv key <* System.Environment.setEnv key val) + (maybe (unsetEnv key) (System.Environment.setEnv key)) + (const act)