diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## 0.1.0 + +* Initial release. diff --git a/Dockerfile b/Dockerfile new file mode 100644 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,6 @@ +FROM welder/bdcs-api-build-img:latest + +COPY entrypoint.sh /usr/local/bin/entrypoint.sh +ENTRYPOINT ["/usr/local/bin/entrypoint.sh"] + +COPY dist/build/bdcs-api-server/bdcs-api-server /usr/local/bin diff --git a/Dockerfile.build b/Dockerfile.build new file mode 100644 --- /dev/null +++ b/Dockerfile.build @@ -0,0 +1,13 @@ +FROM fedora:28 + +RUN dnf -y install make sudo git cabal-install ostree-devel xz-devel \ + gobject-introspection-devel libcurl-devel \ + ghc-haskell-gi-devel libgit2-glib-devel which hlint happy && \ + cabal update && \ + cabal install --global hpc-coveralls + +# source is already bind-mounted here +WORKDIR /bdcs-api + +# build the application +ENTRYPOINT ["make", "hlint", "tests"] 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/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,60 @@ +default: all + +all: bdcs-api-server + +sandbox: + # Delete the sandbox if it already exists - The build-and-test target mounts + # the source directory into the container. If a sandbox already exists, it + # can result in some pretty bizarre errors when trying to install deps. + -if [ -z "$$TRAVIS" ] && [ -d .cabal-sandbox ]; then \ + rm -r .cabal-sandbox cabal.sandbox.config; \ + fi + cabal clean + cabal sandbox init + +bdcs-api-server: sandbox + cabal update + cabal install --dependencies-only --reorder-goals --force-reinstalls + cabal configure + cabal build + +clean: + cabal clean + +hlint: + if [ -z "$$(which hlint)" ]; then \ + echo hlint not found in PATH - install it; \ + exit 1; \ + else \ + hlint .; \ + fi + +tests: sandbox + cabal update + cabal install --dependencies-only --enable-tests --reorder-goals --force-reinstalls + cabal configure --enable-tests --enable-coverage + cabal build + cabal test --show-details=always + +build-and-test: Dockerfile.build + sudo docker build -t welder/bdcs-api-build-img -f $< . + sudo docker run --rm --security-opt label=disable -v `pwd`:/bdcs-api/ welder/bdcs-api-build-img + +bdcs-api-img: build-and-test + sudo docker build -t welder/bdcs-api-img . + +ci: bdcs-api-img + +ci_after_success: + sudo docker run --rm --security-opt label=disable -v `pwd`:/bdcs-api/ \ + --env "TRAVIS=$$TRAVIS" --env "TRAVIS_JOB_ID=$$TRAVIS_JOB_ID" --entrypoint /usr/bin/make welder/bdcs-api-build-img coveralls + +coveralls: + if [ -z "$$(which hpc-coveralls)" ]; then \ + echo hpc-coveralls not found in PATH - install it; \ + exit 1; \ + else \ + hpc-coveralls --display-report spec; \ + fi + +.PHONY: sandbox bdcs-api-server clean tests hlint ci ci_after_success coveralls diff --git a/README.tests b/README.tests new file mode 100644 --- /dev/null +++ b/README.tests @@ -0,0 +1,23 @@ +bdcs-api testing +================ + +The depsolve part of the ServerSpec.hs test requires a metadata.db with packages. We ship a +test database in ./tests/mddb/metadata.db along with the fake rpms used to create it. + +From time to time the test metadata.db may need to be regenerated. This will usually happen +when bdcs has changed the database schema. This is currently a manual process because the +schema.sql file is only shipped with the bdcs source, not installed anywhere. + + * rm ./tests/mddb/metadata.db + * sqlite3 ./tests/mddb/metadata.db < /PATH/TO/schema.sql + * for f in ./tests/mddb/*rpm; do /PATH/TO/bdcs-import ${PWD}/tests/mddb/metadata.db /tmp/cs.repo file://${f}; done + * rm -rf /tmp/cs.repo + +You can then commit the updated metadata.db into git. + +The fake rpms used for the tests shouldn't need to be re-generated, but if they are you can do that by +installing rpmfluff (python3-rpmfluff if you are running Fedora) and running: + +python3 ./tests/mkTestRPMs.py + +And then committing the new rpms to git. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bdcs-api.cabal b/bdcs-api.cabal new file mode 100644 --- /dev/null +++ b/bdcs-api.cabal @@ -0,0 +1,142 @@ +name: bdcs-api +version: 0.1.0 +synopsis: BDCS API Server +description: This module provides an API server and library component that works with the BDCS + project. It provides a web interface for clients to create, edit, and delete + blueprints; to list the contents of the content store; to request composes from + existing blueprints; and to fetch the results of composes. +homepage: https://github.com/weldr/bdcs-api +license: GPL-3 +license-file: LICENSE +author: Brian C. Lane +maintainer: bcl@redhat.com +category: Network +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: ChangeLog.md, + Dockerfile, + Dockerfile.build, + entrypoint.sh, + Makefile, + README.tests, + tests/*.py, + tests/*.hs, + tests/mddb/*.db, + tests/mddb/bdcs-fake-bart-1.3.1-12.x86_64.rpm, + tests/mddb/bdcs-fake-homer-2.0.1-4.x86_64.rpm, + tests/mddb/bdcs-fake-lisa-1.0.0-1.x86_64.rpm, + tests/mddb/bdcs-fake-sax-3.8.1-1.x86_64.rpm, + tests/recipes/*.toml + +source-repository head + type: git + location: https://github.com/weldr/bdcs-api + +library + exposed-modules: BDCS.API.Compose, + BDCS.API.Config, + BDCS.API.ComposeConfig, + BDCS.API.Customization, + BDCS.API.Depsolve, + BDCS.API.Error, + BDCS.API.QueueStatus, + BDCS.API.Recipe, + BDCS.API.Recipes, + BDCS.API.Server, + BDCS.API.TOMLMediaType, + BDCS.API.Utils, + BDCS.API.V0, + BDCS.API.Version, + BDCS.API.Workspace + + build-depends: aeson >= 1.0.0.0 && < 1.4.0.0, + async, + base >= 4.9 && < 5.0, + bdcs >= 0.6.0, + bifunctors, + bytestring >= 0.10 && < 0.11, + concurrent-extra >= 0.7.0 && < 0.8, + cond >= 0.4.1.1 && < 0.5.0.0, + containers >= 0.5.7.1 && < 0.6, + directory >= 1.3.0.0 && < 1.4.0.0, + extra >= 1.6.5 && < 1.7.0, + filepath >= 1.4.1.1 && < 1.5.0.0, + gi-gio >= 2.0.14 && < 2.1.0, + gi-ggit >= 1.0.1 && < 1.1, + gi-glib >= 2.0.14 && < 2.1.0, + gitrev >= 1.3.1 && < 1.4, + haskell-gi-base >= 0.20.3 && < 0.22, + htoml >= 1.0.0 && < 1.1, + http-media >= 0.7.1 && < 0.8, + http-types >= 0.9.1 && < 0.10, + monad-logger >= 0.3.20.2 && < 0.3.28.2, + monad-loops >= 0.4.0 && < 0.5, + mtl >= 2.2.1 && < 2.3, + network, + persistent >= 2.7.0 && < 2.8.0, + persistent-sqlite >= 2.6.0 && < 2.7.0, + resourcet >= 1.1.9 && < 1.2, + safe-exceptions < 0.2.0.0, + semver >= 0.3.3 && < 0.4, + servant-options >= 0.1.0 && < 0.2, + servant-server >= 0.12 && < 0.14, + split >= 0.2.3 && < 0.3, + stm, + string-conversions >= 0.4.0 && < 0.5, + tar >= 0.5 && < 0.6, + temporary >= 1.2.0.4 && < 1.3.0.0, + text >= 1.2.2.0 && < 1.3, + time, + transformers, + unix >= 2.7.2.1 && < 2.8.0.0, + uuid >= 1.2.6 && < 1.4, + wai >= 3.2.1 && < 3.3, + wai-cors >= 0.2.5 && < 0.3, + warp >= 3.2.11 && < 3.3 + pkgconfig-depends: libgit2-glib-1.0 >= 0.26.2 + other-modules: Paths_bdcs_api + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +executable bdcs-api-server + main-is: bdcs-api-server.hs + hs-source-dirs: tools + build-depends: base >= 4.9 && < 5.0, + bdcs-api, + safe-exceptions < 0.2.0.0 + other-modules: Cmdline + default-language: Haskell2010 + ghc-options: -Wall -threaded + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: tests + build-depends: base >= 4.9 && < 5.0, + aeson >= 1.0.0.0 && < 1.4.0.0, + bdcs >= 0.6.0, + bdcs-api, + bytestring >= 0.10 && < 0.11, + cond >= 0.4.1.1 && < 0.5.0.0, + directory >= 1.3.0.0 && < 1.4.0.0, + filepath >= 1.4.1.1 && < 1.5.0.0, + hspec == 2.*, + http-client >= 0.5.7.0 && < 0.6.0.0, + monad-loops >= 0.4.0 && < 0.5, + safe-exceptions < 0.2.0.0, + servant-client >= 0.12.0.1 && < 0.14.0, + servant-server >= 0.12 && < 0.14, + string-conversions >= 0.4.0 && < 0.5, + string-qq >= 0.0.2 && < 0.1.0, + temporary >= 1.2.0.4 && < 1.3.0.0, + text >= 1.2.2.0 && < 1.3, + time, + wai >= 3.2.1 && < 3.3, + warp >= 3.2.11 && < 3.3 + default-language: Haskell2010 + + -- Ignore warnings about unlisted modules, so we don't have to list every new test + ghc-options: -Wall -Wno-unrecognised-warning-flags -Wno-missing-home-modules diff --git a/entrypoint.sh b/entrypoint.sh new file mode 100644 --- /dev/null +++ b/entrypoint.sh @@ -0,0 +1,7 @@ +#!/bin/bash + +STORE=$(realpath /mddb/"${STORE:-cs.repo}") +MDDB="/mddb/${MDDB:-metadata.db}" +RECIPES="${RECIPES:-/recipes/}" + +/usr/local/bin/bdcs-api-server --bdcs "$STORE" "$MDDB" "$RECIPES" diff --git a/src/BDCS/API/Compose.hs b/src/BDCS/API/Compose.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/Compose.hs @@ -0,0 +1,211 @@ +-- Copyright (C) 2018 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| BDCS API Compose-related types and functions +-} +module BDCS.API.Compose(ComposeInfo(..), + ComposeMsgAsk(..), + ComposeMsgResp(..), + ComposeStatus(..), + UuidStatus(..), + compose, + deleteCompose, + getComposesWithStatus, + mkComposeStatus) + where + +import BDCS.API.Depsolve(PackageNEVRA(..), depsolveRecipe) +import BDCS.API.Error(tryIO) +import BDCS.API.QueueStatus(QueueStatus(..), queueStatusEnded, queueStatusText, queueStatusFromText) +import BDCS.API.Recipe(Recipe(..), RecipeModule(..), parseRecipe) +import BDCS.Export(exportAndCustomize) +import BDCS.Export.Customize(Customization) +import BDCS.Export.Types(ExportType(..)) +import BDCS.Utils.Either(maybeToEither) +import Control.Conditional(ifM) +import qualified Control.Exception.Safe as CES +import Control.Monad(filterM) +import Control.Monad.Except(ExceptT(..), runExceptT) +import Control.Monad.Logger(MonadLoggerIO, logErrorN, logInfoN) +import Control.Monad.IO.Class(liftIO) +import Control.Monad.Trans.Resource(MonadBaseControl, MonadThrow, runResourceT) +import Data.Aeson((.:), (.=), FromJSON(..), ToJSON(..), object, withObject) +import Data.Time.Clock(UTCTime, getCurrentTime) +import Data.Either(rights) +import Data.String.Conversions(cs) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Database.Persist.Sql(ConnectionPool, runSqlPool) +import System.Directory(doesFileExist, getModificationTime, listDirectory, removePathForcibly) +import System.FilePath.Posix(()) + +data ComposeInfo = ComposeInfo + { ciDest :: FilePath -- ^ Path to the compose artifact + , ciId :: T.Text -- ^ Build UUID + , ciRecipe :: Recipe -- ^ The recipe being built + , ciResultsDir :: FilePath -- ^ Directory containing the compose and other files + , ciCustom :: [Customization] -- ^ Customizations to perform on the items in the compose + , ciType :: ExportType -- ^ Build type (tar, etc.) + } deriving (Eq, Show) + +data ComposeStatus = ComposeStatus { + csBuildId :: T.Text, + csName :: T.Text, + csQueueStatus :: QueueStatus, + csTimestamp :: UTCTime, + csVersion :: T.Text +} deriving (Show, Eq) + +instance ToJSON ComposeStatus where + toJSON ComposeStatus{..} = object [ + "id" .= csBuildId + , "blueprint" .= csName + , "queue_status" .= csQueueStatus + , "timestamp" .= csTimestamp + , "version" .= csVersion ] + +instance FromJSON ComposeStatus where + parseJSON = withObject "compose type" $ \o -> + ComposeStatus <$> o .: "id" + <*> o .: "blueprint" + <*> o .: "queue_status" + <*> o .: "timestamp" + <*> o .: "version" + +data UuidStatus = UuidStatus { + usStatus :: Bool, + usUuid :: T.Text +} deriving (Show, Eq) + +instance ToJSON UuidStatus where + toJSON UuidStatus{..} = object [ + "status" .= usStatus, + "uuid" .= usUuid ] + +instance FromJSON UuidStatus where + parseJSON = withObject "UUID type" $ \o -> + UuidStatus <$> o .: "status" + <*> o .: "uuid" + +data ComposeMsgAsk = AskBuildsWaiting + | AskBuildsInProgress + | AskCancelBuild T.Text + | AskCompose ComposeInfo + | AskDequeueBuild T.Text + +data ComposeMsgResp = RespBuildCancelled Bool + | RespBuildDequeued Bool + | RespBuildsWaiting [T.Text] + | RespBuildsInProgress [T.Text] + +compose :: (MonadBaseControl IO m, MonadLoggerIO m, MonadThrow m) => FilePath -> ConnectionPool -> ComposeInfo -> m () +compose bdcs pool ComposeInfo{..} = do + logStatus QRunning "Compose started on" + + -- If these packages weren't in the recipe to begin with, the user doesn't really care + -- about which version they get. Add these required packages before depsolving and + -- move on. + let recipe = case ciType of + ExportOstree -> foldl addRequiredPkg ciRecipe ["dracut", "kernel"] + _ -> ciRecipe + + depsolveRecipe pool recipe >>= \case + Left e -> logErrorN (cs e) >> logStatus QFailed "Compose failed on" + Right (nevras, _) -> do let things = map pkgString nevras + logInfoN $ "Exporting packages: " `T.append` T.intercalate " " things + + runExceptT (runResourceT $ runSqlPool (exportAndCustomize bdcs ciDest ciType things ciCustom) pool) >>= \case + Left e -> logErrorN (cs e) >> logStatus QFailed "Compose failed on" + Right _ -> do liftIO $ TIO.writeFile (ciResultsDir "ARTIFACT") (cs ciDest) + logStatus QFinished "Compose finished on" + where + addRequiredPkg :: Recipe -> String -> Recipe + addRequiredPkg recipe pkg = + if not (any (\x -> pkg == rmName x) (rModules recipe)) + then recipe { rModules=RecipeModule pkg "" : rModules recipe } + else recipe + + -- This function needs to spit out strings that BDCS.RPM.Utils.splitFilename + -- knows how to take apart. Be especially careful with the epoch part. Otherwise, + -- we won't be able to find packages in the database and will get depsolving errors. + pkgString :: PackageNEVRA -> T.Text + pkgString PackageNEVRA{pnEpoch=Nothing, ..} = T.concat [pnName, "-", pnVersion, "-", pnRelease, ".", pnArch] + pkgString PackageNEVRA{pnEpoch=Just e, ..} = T.concat [pnName, "-", cs (show e), ":", pnVersion, "-", pnRelease, ".", pnArch] + + logStatus :: MonadLoggerIO m => QueueStatus -> T.Text -> m () + logStatus status msg = do + time <- liftIO $ do + TIO.writeFile (ciResultsDir "STATUS") (queueStatusText status) + getCurrentTime + + logInfoN $ T.concat [msg, " ", cs (show time)] + +deleteCompose :: FilePath -> T.Text -> IO (Either String UuidStatus) +deleteCompose dir uuid = + liftIO (runExceptT $ mkComposeStatus dir uuid) >>= \case + Left _ -> return $ Left $ cs uuid ++ " is not a valid build uuid" + Right ComposeStatus{..} -> + if not (queueStatusEnded csQueueStatus) + then return $ Left $ "Build " ++ cs uuid ++ " not in FINISHED or FAILED" + else do + let path = dir cs uuid + CES.catch (do removePathForcibly path + return $ Right UuidStatus { usStatus=True, usUuid=uuid }) + (\(e :: CES.IOException) -> return $ Left $ cs uuid ++ ": " ++ cs (show e)) + +getComposesWithStatus :: FilePath -> QueueStatus -> IO [ComposeStatus] +getComposesWithStatus resultsDir status = do + -- First, gather up all the subdirectories of resultsDir. Each of these is a UUID for + -- some compose, wher that one has finished or is in progress or is in the queue. + contents <- listDirectory resultsDir + -- Next, filter that list down to just those that have a STATUS file containing the + -- sought after status. + uuids <- filterM matches (map cs contents) + -- Finally, convert those into ComposeStatus records. + rights <$> mapM (runExceptT . mkComposeStatus resultsDir) uuids + where + matches :: T.Text -> IO Bool + matches uuid = do + let statusFile = resultsDir cs uuid "STATUS" + ifM (doesFileExist statusFile) + (do line <- CES.catch (TIO.readFile statusFile) + (\(_ :: CES.IOException) -> return "") + return $ queueStatusFromText line == Just status) + (return False) + +mkComposeStatus :: FilePath -> T.Text -> ExceptT String IO ComposeStatus +mkComposeStatus baseDir buildId = do + let path = baseDir cs buildId + + contents <- tryIO $ TIO.readFile (path "blueprint.toml") + Recipe{..} <- ExceptT $ return $ parseRecipe contents + mtime <- tryIO $ getModificationTime (path "STATUS") + status <- tryIO $ TIO.readFile (path "STATUS") + + status' <- maybeToEither "Unknown queue status for compose" (queueStatusFromText status) + + return ComposeStatus { csBuildId = buildId, + csName = cs rName, + csQueueStatus = status', + csTimestamp = mtime, + csVersion = maybe "0.0.1" cs rVersion } diff --git a/src/BDCS/API/ComposeConfig.hs b/src/BDCS/API/ComposeConfig.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/ComposeConfig.hs @@ -0,0 +1,71 @@ +-- Copyright (C) 2018 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module BDCS.API.ComposeConfig( + ComposeConfig(..), + + parseComposeConfig, + composeConfigTOML +) where + +import BDCS.Export.Types(ExportType(..), exportTypeFromText, exportTypeText) +import Data.Aeson +import Data.Maybe(fromMaybe) +import qualified Data.Text as T +import Text.Printf(printf) +import Text.Toml(parseTomlDoc) + + + -- | Information about the compose configuration not available in other results files +data ComposeConfig = ComposeConfig { + ccCommit :: T.Text, -- ^ Commit hash for Blueprint + ccExportType :: ExportType -- ^ Export type +} deriving (Show, Eq) + +instance ToJSON ComposeConfig where + toJSON ComposeConfig{..} = object + [ "commit" .= ccCommit + , "export_type" .= exportTypeText ccExportType + ] + +instance FromJSON ComposeConfig where + parseJSON = withObject "Compose configuration data" $ \o -> do + ccCommit <- o .: "commit" + ccExportType <- (o .: "export_type") >>= \et -> return $ fromMaybe ExportTar $ exportTypeFromText et + return ComposeConfig{..} + +-- | Parse a TOML formatted compose config string and return a ComposeConfig +-- +-- If there is an error the details will be returned in the Left +parseComposeConfig :: T.Text -> Either String ComposeConfig +parseComposeConfig xs = + case parseTomlDoc "" xs of + Left err -> Left ("Parsing TOML document failed. " ++ show err) + Right table -> do + let jsonValue = toJSON table + case (fromJSON jsonValue :: Result ComposeConfig) of + Error err -> Left ("Converting from JSON to ComposeConfig failed. " ++ show err) + Success r -> Right r + +-- | Return a TOML string from a ComposeConfig record +composeConfigTOML :: ComposeConfig -> T.Text +composeConfigTOML ComposeConfig{..} = T.concat [commitText, exportText] + where + commitText = T.pack $ printf "commit = \"%s\"\n" ccCommit + exportText = T.pack $ printf "export_type = \"%s\"\n" (exportTypeText ccExportType) diff --git a/src/BDCS/API/Config.hs b/src/BDCS/API/Config.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/Config.hs @@ -0,0 +1,41 @@ +-- Copyright (C) 2018 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . + +{-| BDCS API Server Configuration +-} +module BDCS.API.Config(AskTuple, + ServerConfig(..)) + where + +import BDCS.API.Utils(GitLock(..)) +import BDCS.API.Compose(ComposeMsgAsk, ComposeMsgResp) +import Control.Concurrent.STM.TChan(TChan) +import Control.Concurrent.STM.TMVar(TMVar) +import Database.Persist.Sql(ConnectionPool) + +type AskTuple = (ComposeMsgAsk, Maybe (TMVar ComposeMsgResp)) + +data ServerConfig = ServerConfig + { cfgRepoLock :: GitLock -- ^ Lock required for accessing recipe repo + , cfgChan :: TChan AskTuple -- ^ Channel for the API server to ask things of + -- the compose server. The tuple is the message + -- that needs a response and a location for where + -- the response should be written to. + , cfgPool :: ConnectionPool -- ^ SQL connection pool for accessing MDDB + , cfgBdcs :: FilePath -- ^ Location of the content store + , cfgResultsDir :: FilePath -- ^ Base location for writing results + } diff --git a/src/BDCS/API/Customization.hs b/src/BDCS/API/Customization.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/Customization.hs @@ -0,0 +1,120 @@ +-- Copyright (C) 2018 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-| Customizations applies to the content of an export -} +module BDCS.API.Customization(RecipeCustomization(..), + RecipeSshKey(..), + emptyCustomization, + processCustomization) + where + +import BDCS.DB +import BDCS.Export.Customize(Customization(..)) +import Control.Monad.IO.Class(MonadIO, liftIO) +import Data.Aeson +import Data.Bits((.|.)) +import qualified Data.ByteString.Char8 as C8 +import Data.Maybe(catMaybes) +import qualified Data.Text as T +import Data.Time.Clock(getCurrentTime) +import Data.Time.Clock.POSIX(POSIXTime, utcTimeToPOSIXSeconds) +import System.FilePath.Posix(()) +import System.Posix.Files(directoryMode, regularFileMode) + +-- | Recipe customization commands +data RecipeCustomization = + RecipeCustomization { rcHostName :: Maybe String -- ^ System hostname + , rcSshKeys :: [RecipeSshKey] -- ^ Ssh keys to install + } deriving (Eq, Show) + +instance FromJSON RecipeCustomization where + parseJSON = withObject "recipe customization" $ \o -> do + rcHostName <- o .:? "hostname" + rcSshKeys <- o .:? "sshkey".!= [] + return RecipeCustomization{..} + +instance ToJSON RecipeCustomization where + toJSON RecipeCustomization{..} = let + maybeHostname = ("hostname" .=) <$> rcHostName + maybeSshKeys = if null rcSshKeys then Nothing + else Just ("sshkey" .= toJSONList rcSshKeys) + in object $ catMaybes [maybeHostname, maybeSshKeys] + +emptyCustomization :: RecipeCustomization +emptyCustomization = RecipeCustomization Nothing [] + +-- | A sshkey customization +data RecipeSshKey = + RecipeSshKey { rcSshUser :: String -- ^ User to which to apply the key + , rcSshKey :: String -- ^ Key to install + } deriving (Eq, Show) + +instance FromJSON RecipeSshKey where + parseJSON = withObject "ssh key" $ \o -> do + rcSshUser <- o .: "user" + rcSshKey <- o .: "key" + return RecipeSshKey{..} + +instance ToJSON RecipeSshKey where + toJSON RecipeSshKey{..} = object [ + "user" .= rcSshUser + , "key" .= rcSshKey ] + + +-- | Convert a 'RecipeCustomization' block into a list of bdcs 'Customization' directives +processCustomization :: MonadIO m => RecipeCustomization -> m [Customization] +processCustomization RecipeCustomization{..} = do + currentTime <- utcTimeToPOSIXSeconds <$> liftIO getCurrentTime + let hostnameCustomization = maybe [] (\h -> [processHostname currentTime h]) rcHostName + sshKeyCustomizations = concatMap (processSshKey currentTime) rcSshKeys + return $ hostnameCustomization ++ sshKeyCustomizations + where + processHostname :: POSIXTime -> String -> Customization + processHostname currentTime hostname = + let hostnameData = C8.pack $ hostname ++ "\n" + hostnameFile = Files "/etc/hostname" + "root" + "root" + (floor currentTime) + Nothing + (fromIntegral $ regularFileMode .|. 0o0644) + (C8.length hostnameData) + Nothing + in WriteFile hostnameFile (Just hostnameData) + + processSshKey :: POSIXTime -> RecipeSshKey -> [Customization] + processSshKey currentTime RecipeSshKey{..} = + let keyData = C8.pack $ rcSshKey ++ "\n" + keyDir = Files (T.pack $ "/home" rcSshUser ".ssh") + (T.pack rcSshUser) + (T.pack rcSshUser) + (floor currentTime) + Nothing + (fromIntegral $ directoryMode .|. 0o0700) + 0 + Nothing + keyFile = Files (T.pack $ "/home" rcSshUser ".ssh" "authorized_keys") + (T.pack rcSshUser) + (T.pack rcSshUser) + (floor currentTime) + Nothing + (fromIntegral $ regularFileMode .|. 0o0644) + (C8.length keyData) + Nothing + in [WriteFile keyDir Nothing, WriteFile keyFile (Just keyData)] diff --git a/src/BDCS/API/Depsolve.hs b/src/BDCS/API/Depsolve.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/Depsolve.hs @@ -0,0 +1,109 @@ +-- Copyright (C) 2018 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module BDCS.API.Depsolve(PackageNEVRA(..), + mkPackageNEVRA, + depsolveProjects, + depsolveRecipe) + where + +import BDCS.Depclose(depcloseNames) +import BDCS.Depsolve(formulaToCNF, solveCNF) +import BDCS.Groups(groupIdToNevra) +import BDCS.RPM.Utils(splitFilename) +import BDCS.Utils.Monad(mapMaybeM) +import Control.Monad.Except(runExceptT) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Trans.Resource(MonadBaseControl) +import Data.Aeson((.=), (.:), FromJSON(..), ToJSON(..), object, withObject) +import Data.List(find) +import Data.Maybe(fromMaybe, mapMaybe) +import Data.String.Conversions(cs) +import qualified Data.Text as T +import Database.Persist.Sql(ConnectionPool, runSqlPool) + +import BDCS.API.Recipe(Recipe(..), getAllRecipeProjects) + +-- | Package build details +data PackageNEVRA = PackageNEVRA { + pnName :: T.Text + , pnEpoch :: Maybe Int + , pnVersion :: T.Text + , pnRelease :: T.Text + , pnArch :: T.Text +} deriving (Show, Eq) + +instance ToJSON PackageNEVRA where + toJSON PackageNEVRA{..} = object [ + "name" .= pnName + , "epoch" .= fromMaybe 0 pnEpoch + , "version" .= pnVersion + , "release" .= pnRelease + , "arch" .= pnArch ] + +instance FromJSON PackageNEVRA where + parseJSON = withObject "package NEVRA" $ \o -> + PackageNEVRA <$> o .: "name" + <*> o .: "epoch" + <*> o .: "version" + <*> o .: "release" + <*> o .: "arch" + +-- Make a PackageNEVRA from a tuple of NEVRA info. +mkPackageNEVRA :: (T.Text, Maybe T.Text, T.Text, T.Text, T.Text) -> PackageNEVRA +mkPackageNEVRA (name, epoch, version, release, arch) = PackageNEVRA name (epoch' epoch) version release arch + where + epoch' Nothing = Nothing + epoch' (Just e) = Just ((read $ T.unpack e) :: Int) + +-- | Depsolve a list of project names, returning a list of PackageNEVRA +-- If there is an error it returns an empty list +depsolveProjects :: (MonadBaseControl IO m, MonadIO m) => ConnectionPool -> [T.Text] -> m (Either String [PackageNEVRA]) +depsolveProjects pool project_name_list = do + result <- runExceptT $ flip runSqlPool pool $ do + -- XXX Need to properly deal with arches + formula <- depcloseNames ["x86_64"] project_name_list + solution <- solveCNF (formulaToCNF formula) + mapMaybeM groupIdToNevra $ map fst $ filter snd solution + case result of + Left e -> return $ Left (show e) + Right assignments -> return $ Right (map (mkPackageNEVRA . splitFilename) assignments) + +depsolveRecipe :: (MonadBaseControl IO m, MonadIO m) => ConnectionPool -> Recipe -> m (Either T.Text ([PackageNEVRA], [PackageNEVRA])) +depsolveRecipe pool recipe@Recipe{..} = do + -- Make a list of the packages and modules (a set) and sort it by lowercase names + let projects_name_list = map cs $ getAllRecipeProjects recipe + -- depsolve this list + depsolveProjects pool projects_name_list >>= \case + Left err -> return $ Left (cs err) + Right dep_nevras -> do + -- Make a list of the NEVRAs for the names in the step above (frozen list of packages) + -- NOTE It may not include everything, if the dependency is satisfied by a project with + -- a different name it will not be included in the list. + let project_nevras = getProjectNEVRAs projects_name_list dep_nevras + return $ Right (dep_nevras, project_nevras) + where + -- Get the NEVRAs for all the projects used to feed the depsolve step + getProjectNEVRAs :: [T.Text] -> [PackageNEVRA] -> [PackageNEVRA] + getProjectNEVRAs project_names all_nevras = mapMaybe lookupProject project_names + where + lookupProject project_name = find (\e -> pnName e == project_name) all_nevras diff --git a/src/BDCS/API/Error.hs b/src/BDCS/API/Error.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/Error.hs @@ -0,0 +1,80 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| Error functions for use with "BDCS.API" +-} +module BDCS.API.Error(createAPIError, + tryIO, + APIResponse(..)) + where + +import qualified Control.Exception.Safe as CES +import Control.Monad.Except(ExceptT(..)) +import Control.Monad.IO.Class(liftIO) +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as C8 +import Network.HTTP.Types(Header) +import Servant hiding (Header) + +-- | API Status response with possible error messages +-- used to report errors with API requests +-- +-- This is converted to a JSON error response that is used in the API responses +-- +-- > { +-- > "status": false, +-- > "errors": ["compose: Unsupported output type"] +-- > } +-- > } +data APIResponse = APIResponse + { arjStatus :: Bool + , arjErrors :: [String] + } deriving (Show, Eq) + +instance FromJSON APIResponse where + parseJSON = withObject "API Response JSON" $ \o -> do + arjStatus <- o .: "status" + arjErrors <- o .: "errors" + return APIResponse{..} + +instance ToJSON APIResponse where + toJSON APIResponse{..} = object + [ "status" .= arjStatus + , "errors" .= arjErrors + ] + +-- | Create a 'ServantErr' with an error id and a message +-- +-- [@base@]: The default 'ServantErr' response +-- [@status@]: The response status +-- [@messages@]: A list of human readable messages to include with the error +createAPIError :: ServantErr -> Bool -> [String] -> ServantErr +createAPIError base status messages = base { errBody=apiError, errHeaders=[jsonContentHdr] } + where + apiError :: C8.ByteString + apiError = encode $ toJSON $ APIResponse status messages + + jsonContentHdr :: Header + jsonContentHdr = ("Content-Type", "application/json") + +-- | Convert IO Exceptions into an ExceptT. +tryIO :: IO a -> ExceptT String IO a +tryIO fn = ExceptT $ liftIO $ CES.catch (Right <$> fn) + (\(e :: CES.IOException) -> return $ Left (show e)) diff --git a/src/BDCS/API/QueueStatus.hs b/src/BDCS/API/QueueStatus.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/QueueStatus.hs @@ -0,0 +1,71 @@ +-- Copyright (C) 2018 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . + +{-# LANGUAGE OverloadedStrings #-} + +module BDCS.API.QueueStatus(QueueStatus(..), + queueStatusEnded, + queueStatusFromText, + queueStatusInProgress, + queueStatusText) + where + +import Control.Monad(mzero) +import Data.Aeson(FromJSON(..), ToJSON(..), Value(..)) +import qualified Data.Text as T + +-- | What is the state of a compose in the queue? +data QueueStatus = QWaiting -- ^ The compose has not yet started. + | QRunning -- ^ The compose is in progress. + | QFinished -- ^ The compose finished successfully. + | QFailed -- ^ The compose finished unsuccessfully. + deriving(Eq, Show) + +instance ToJSON QueueStatus where + toJSON QWaiting = "WAITING" + toJSON QRunning = "RUNNING" + toJSON QFinished = "FINISHED" + toJSON QFailed = "FAILED" + +instance FromJSON QueueStatus where + parseJSON (String s) = case queueStatusFromText s of + Just qs -> pure qs + Nothing -> mzero + parseJSON _ = mzero + +queueStatusEnded :: QueueStatus -> Bool +queueStatusEnded QFinished = True +queueStatusEnded QFailed = True +queueStatusEnded _ = False + +queueStatusFromText :: T.Text -> Maybe QueueStatus +queueStatusFromText t = case T.strip t of + "WAITING" -> Just QWaiting + "RUNNING" -> Just QRunning + "FINISHED" -> Just QFinished + "FAILED" -> Just QFailed + _ -> Nothing + +queueStatusInProgress :: QueueStatus -> Bool +queueStatusInProgress QRunning = True +queueStatusInProgress _ = False + +queueStatusText :: QueueStatus -> T.Text +queueStatusText QWaiting = "WAITING" +queueStatusText QRunning = "RUNNING" +queueStatusText QFinished = "FINISHED" +queueStatusText QFailed = "FAILED" diff --git a/src/BDCS/API/Recipe.hs b/src/BDCS/API/Recipe.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/Recipe.hs @@ -0,0 +1,199 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-| Recipe is used to store information about what packages are included in a composition. + + It can be converted to and from TOML and JSON when needed. +-} +module BDCS.API.Recipe(bumpVersion, + getAllRecipeProjects, + parseRecipe, + recipeTOML, + recipeTomlFilename, + recipeBumpVersion, + Recipe(..), + RecipeModule(..)) + where + +import BDCS.API.Customization(RecipeCustomization(..), RecipeSshKey(..), emptyCustomization) +import BDCS.API.TOMLMediaType +import BDCS.API.Utils(caseInsensitive) +import Data.Aeson +import Data.Aeson.Types(Result(..)) +import Data.List(nub, sortBy) +import Data.Maybe(fromMaybe) +import qualified Data.SemVer as SV +import Data.String.Conversions(cs) +import qualified Data.Text as T +import Text.Printf(printf) +import Text.Toml(parseTomlDoc) + + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +-- | Recipe data structure +-- +-- Note that at this time there is no real distinction between package and modules. +data Recipe = + Recipe { rName :: String -- ^ Human readable recipe name + , rVersion :: Maybe String -- ^ Version, following [semver](http://www.semver.org) rules. + , rDescription :: String -- ^ Human readable description of the Recipe + , rPackages :: [RecipeModule] -- ^ List of Packages in the Recipe + , rModules :: [RecipeModule] -- ^ List of Modules in the Recipe + , rCustomization :: RecipeCustomization -- ^ Post-export customization block + } deriving (Eq, Show) + +instance FromJSON Recipe where + parseJSON = withObject "recipe" $ \o -> do + rName <- o .: "name" + rVersion <- o .:? "version" + rDescription <- o .: "description" + rPackages <- o .:? "packages" .!= [] + rModules <- o .:? "modules" .!= [] + rCustomization <- o .:? "customizations" .!= emptyCustomization + return Recipe{..} + +instance ToJSON Recipe where + toJSON Recipe{..} = object [ + "name" .= rName + , "version" .= fromMaybe "" rVersion + , "description" .= rDescription + , "packages" .= rPackages + , "modules" .= rModules + , "customizations" .= rCustomization ] + +instance ToTOML Recipe where + toTOML recipe = cs $ recipeTOML recipe + +instance FromTOML Recipe where + parseTOML toml = parseRecipe $ cs toml + + +-- | Name and Version glob of a package or module +data RecipeModule = + RecipeModule { rmName :: String -- ^ Name of the package/module + , rmVersion :: String -- ^ Version glob describing the package + } deriving (Eq, Show) + +instance FromJSON RecipeModule where + parseJSON = withObject "recipe module" $ \o -> do + rmName <- o .: "name" + rmVersion <- o .: "version" + return RecipeModule{..} + +instance ToJSON RecipeModule where + toJSON RecipeModule{..} = object [ + "name" .= rmName + , "version" .= rmVersion ] + +-- | Parse a TOML formatted recipe string and return a Recipe +-- +-- If there is an error the details will be returned in the Left +parseRecipe :: T.Text -> Either String Recipe +parseRecipe xs = + case parseTomlDoc "" xs of + Left err -> Left ("Parsing TOML document failed. " ++ show err) + Right table -> do + let jsonValue = toJSON table + case (fromJSON jsonValue :: Result Recipe) of + Error err -> Left ("Converting from JSON to Recipe failed. " ++ show err) + Success r -> Right r + +-- | Convert a Recipe to a TOML string +recipeTOML :: Recipe -> T.Text +recipeTOML Recipe{..} = T.concat [nameText, versionText, descriptionText, modulesText, packagesText, customText] + where + nameText = T.pack $ printf "name = \"%s\"\n" rName + versionText = T.pack $ printf "version = \"%s\"\n" $ fromMaybe "" rVersion + descriptionText = T.pack $ printf "description = \"%s\"\n\n" rDescription + + moduleText :: T.Text -> RecipeModule -> T.Text + moduleText name RecipeModule{..} = T.pack $ printf "[[%s]]\nname = \"%s\"\nversion = \"%s\"\n\n" name rmName rmVersion + packagesText = T.concat $ map (moduleText "packages") rPackages + modulesText = T.concat $ map (moduleText "modules") rModules + + customText = T.concat [hostnameText, sshKeysText] + hostnameText = maybe "" (T.pack . printf "[customizations]\nhostname = \"%s\"\n\n") $ rcHostName rCustomization + sshKeysText = T.concat $ map sshKeyText $ rcSshKeys rCustomization + + sshKeyText :: RecipeSshKey -> T.Text + sshKeyText RecipeSshKey{..} = T.pack $ printf "[[customizations.sshkey]]\nuser = \"%s\"\nkey = \"%s\"\n\n" rcSshUser rcSshKey + +-- | Convert a recipe name to a toml filename +-- +-- [@name@]: The recipe name (not filename) +-- +-- Replaces spaces with - and append .toml +recipeTomlFilename :: String -> T.Text +recipeTomlFilename name = T.append (T.replace " " "-" (T.pack name)) ".toml" + +-- | [semver](http://www.semver.org) recipe version number bump +-- +-- [@prev_ver@]: Previous version +-- [@new_ver@]: New version +-- +-- * If neither have a version 0.0.1 is returned +-- * If there is no previous version the new version is checked and returned +-- * If there is no new version, but there is a previous one, bump its patch level +-- * If the previous and new versions are the same, bump the patch level +-- * If they are different, check and return the new version +-- +-- Errors will be returned in the Left +bumpVersion :: Maybe String -> Maybe String -> Either String String +bumpVersion Nothing Nothing = Right "0.0.1" +-- Only a new version, make sure the new version can be parsed +bumpVersion Nothing (Just new_ver) = + case SV.fromText (T.pack new_ver) of + Right _ -> Right new_ver + Left _ -> Left ("Failed to parse version: " ++ new_ver) +-- If there was a previous version and no new one, bump the patch level +bumpVersion (Just prev_ver) Nothing = + case SV.fromText (T.pack prev_ver) of + Right version -> Right $ SV.toString $ SV.incrementPatch version + Left _ -> Left ("Failed to parse version: " ++ prev_ver) +bumpVersion (Just prev_ver) (Just new_ver) + | prev_ver == new_ver = bumpNewVer + | otherwise = checkNewVer + where + bumpNewVer = + case SV.fromText (T.pack new_ver) of + Right version -> Right $ SV.toString $ SV.incrementPatch version + Left _ -> Left ("Failed to parse version: " ++ new_ver) + checkNewVer = + case SV.fromText (T.pack new_ver) of + Right _ -> Right new_ver + Left _ -> Left ("Failed to parse version: " ++ new_ver) + +-- | Bump or replace a Recipe Version with a new one +-- +-- [@recipe@]: The Recipe to bump +-- [@prev_version@]: Previous version of the recipe +-- +-- Pass the new recipe and the version from the previous recipe +-- Returns a new recipe with the correct version +-- +-- Errors will be returned in the Left +recipeBumpVersion :: Recipe -> Maybe String -> Either String Recipe +recipeBumpVersion recipe prev_version = case bumpVersion prev_version (rVersion recipe) of + Right version -> Right recipe { rVersion = Just version } + Left err -> Left err + +-- | Return a sorted list of the unique module+packages in a recipe +getAllRecipeProjects :: Recipe -> [String] +getAllRecipeProjects recipe = sortBy caseInsensitive $ nub $ map rmName (rModules recipe ++ rPackages recipe) diff --git a/src/BDCS/API/Recipes.hs b/src/BDCS/API/Recipes.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/Recipes.hs @@ -0,0 +1,1151 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-| Git Recipe storage functions + + Recipes are stored in a bare git repository. The repository is created with + 'openOrCreateRepo' which returns the Repository which is passed to all of + the other functions. + +-} +module BDCS.API.Recipes(openOrCreateRepo, + findOrCreateBranch, + getBranchOIdFromObject, + writeCommit, + readCommit, + readCommitSpec, + listBranchFiles, + listCommitFiles, + deleteFile, + deleteRecipe, + revertFile, + revertFileCommit, + revertRecipe, + listRecipeCommits, + listCommits, + findCommitTag, + getRevisionFromTag, + tagFileCommit, + tagRecipeCommit, + commitRecipeFile, + commitRecipe, + commitRecipeDirectory, + readRecipeCommit, + recipeDiff, + runGitRepoTests, + runWorkspaceTests, + CommitDetails(..), + RecipeDiffEntry(..), + RecipeDiffType(..), + GitError(..), + printOId) + where + +import BDCS.API.Customization +import BDCS.API.Recipe +import BDCS.API.Utils(caseInsensitive, maybeThrow) +import BDCS.API.Workspace +import Control.Conditional(ifM, whenM) +import qualified Control.Exception.Safe as CES +import Control.Monad(filterM, unless, void) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Loops(allM) +import Data.Aeson(FromJSON(..), ToJSON(..), (.=), (.:), object, withObject, Value(..)) +import qualified Data.ByteString as BS +import Data.Either(rights) +import Data.Foldable(asum) +import Data.List(elemIndices, find, isSuffixOf, sortBy) +import Data.Maybe(fromJust, isJust) +import Data.Set(difference, fromList, intersection, Set, toList) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Text.Encoding(decodeUtf8, encodeUtf8) +import Data.Word(Word32) +import GI.Gio +import qualified GI.Ggit as Git +import qualified GI.GLib as GLib +import System.Directory(doesFileExist, doesPathExist, listDirectory) +import System.FilePath.Posix(()) +import System.IO.Temp(withTempDirectory) +import Text.Printf(printf) +import Text.Read(readMaybe) + + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +-- | Errors that can be thrown by the BDCS.API.Recipes functions. +data GitError = + OpenRepoError -- ^ Repo open error + | CreateRepoError -- ^ Problem creating a new repo + | CreateBlobError -- ^ New Blob error + | CreateCommitError -- ^ Error creating a commit + | CreateBranchError -- ^ New Branch error + | BranchNameError -- ^ Branch name error, eg. doesn't exist + | WriteTreeError -- ^ Tree writing error + | GetIndexError -- ^ Error getting the repository error + | GetHeadError -- ^ Error getting the repository head + | RefLookupError -- ^ Error looking up a ref. eg. doesn't exist + | TreeBuilderError -- ^ Problem creating a Tree Builder for a Tree. + | GetByNameError -- ^ Problem getting a Tree by name + | GetNameError -- ^ Problem getting a Tree Entry by name + | GetTargetError -- ^ Error getting ref. target + | GetTimeError -- ^ Problem getting the time from the Signature + | GetTimeZoneError -- ^ Problem getting the timezone from the Signature + | GetTreeError -- ^ Error getting Commit Tree + | GetTreeIdError -- ^ Error getting commit Tree Id + | GetCommitterError -- ^ Error getting the committer's Signature + | GetMessageError -- ^ Error getting commit message + | GetParentsError -- ^ Problem getting commit's parents + | LookupError -- ^ Error looking up a commit + | LookupBlobError -- ^ Error looking up a Blob OId + | LookupBranchError -- ^ Branch error, eg. doesn't exist + | LookupCommitError -- ^ Commit error, eg. commit doesn't exist + | LookupTagError -- ^ Error looking up a Tag. eg. doesn't exist + | LookupTreeError -- ^ Tree Lookup error. eg. tree id doesn't exist + | LookupReferenceError -- ^ Problem looking up a reference + | RevparseError -- ^ Problem parsing a revision spec + | BuilderWriteError -- ^ Tree Builder write error + | BuilderInsertError -- ^ Tree Builder insert error + | GetEntryIdError -- ^ Error getting a tree entry id + | GetIdError -- ^ Problem getting object's id + | GetRawBlobError -- ^ Error getting the raw Blob content + | GetTargetIdError -- ^ Error getting Tag Id from a tag object + | NewOIdError -- ^ Problem creating a new OId from a string + | NewOptionsError -- ^ Error creating a new Options object + | NewTimeValError -- ^ Error creating a new TimeVal object + | NewTreeError -- ^ Problem creating a new diff Tree + | NewSignatureError -- ^ Error creating a new Signature + | NewWalkerError -- ^ Error creating a new revision Walker object + | OIdError -- ^ Error creating a String from an OId + deriving (Eq, Show) + +instance CES.Exception GitError + +-- | Get the branch's HEAD Commit +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- +-- Can throw 'LookupBranchError' or 'LookupCommitError' +headCommit :: Git.Repository -> T.Text -> IO Git.Commit +headCommit repo branch = do + branch_obj <- Git.repositoryLookupBranch repo branch Git.BranchTypeLocal >>= maybeThrow LookupBranchError + branch_id <- getBranchOIdFromObject repo branch_obj + Git.repositoryLookupCommit repo branch_id >>= maybeThrow LookupCommitError + +-- | Prepare for a commit +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@builder@]: Tree to add the commit to +-- +-- Returns a tuple of information used when making a commit +-- +-- Can throw 'BuilderWriteError', 'LookupTreeError', 'NewSignatureError' +prepareCommit :: Git.Repository -> T.Text -> Git.TreeBuilder -> IO (Git.Tree, Git.Signature, Maybe T.Text, Maybe T.Text) +prepareCommit repo branch builder = do + tree_id <- Git.treeBuilderWrite builder >>= maybeThrow BuilderWriteError + tree <- Git.repositoryLookupTree repo tree_id >>= maybeThrow LookupTreeError + sig <- Git.signatureNewNow "bdcs-api" "user-email" >>= maybeThrow NewSignatureError + let ref = Just $ T.pack $ printf "refs/heads/%s" branch + let encoding = Just "UTF-8" + return (tree, sig, ref, encoding) + +-- | Open a Git repository, or create the initial repository if one doesn't exist +-- +-- [@path@]: Path to the git repository +-- +-- The bare git repository is created in ./git underneath path +-- If the directory doesn't look like an existing git repo (no ./git/HEAD file) then a new +-- bare repository is created. +-- +-- Can throw 'OpenRepoError', 'CreateRepoError', 'NewSignatureError', 'GetIndexError', +-- 'WriteTreeError', 'LookupTreeError', or 'CreateCommitError' +openOrCreateRepo :: FilePath -> IO Git.Repository +openOrCreateRepo path = do + gfile <- fileNewForPath (path ++ "/git") + ifM (doesPathExist $ path ++ "/git/HEAD") + (openRepo gfile) + (createWithInitialCommit gfile) + where + openRepo gfile = Git.repositoryOpen gfile >>= maybeThrow OpenRepoError + + createWithInitialCommit gfile = do + repo <- Git.repositoryInitRepository gfile True >>= maybeThrow CreateRepoError + + -- Make an empty initial commit + sig <- Git.signatureNewNow "bdcs-api" "user-email" >>= maybeThrow NewSignatureError + index <- Git.repositoryGetIndex repo >>= maybeThrow GetIndexError + tree_id <- Git.indexWriteTree index >>= maybeThrow WriteTreeError + tree <- Git.repositoryLookupTree repo tree_id >>= maybeThrow LookupTreeError + let ref = Just "HEAD" + let encoding = Just "UTF-8" + void $ Git.repositoryCreateCommit repo ref sig sig encoding "Initial Recipe repository commit" tree [] >>= maybeThrow CreateCommitError + + return repo + +-- | Lookup the Branch name or create a new branch and return a Git.Branch +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- +-- Can throw 'GetHeadError', 'RefLookupError', or 'CreateBranchError' +findOrCreateBranch :: Git.Repository -> T.Text -> IO Git.Branch +findOrCreateBranch repo branch = do + mbranch <- Git.repositoryLookupBranch repo branch Git.BranchTypeLocal + maybe createBranch return mbranch + where + createBranch = do + head_ref <- Git.repositoryGetHead repo >>= maybeThrow GetHeadError + parent_obj <- Git.refLookup head_ref >>= maybeThrow RefLookupError + Git.repositoryCreateBranch repo branch parent_obj [Git.CreateFlagsNone] >>= maybeThrow CreateBranchError + +-- | Convert a Branch object to an OId +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- +-- Can throw 'BranchNameError', 'LookupReferenceError', or 'GetTargetError' +getBranchOIdFromObject :: Git.Repository -> Git.Branch -> IO Git.OId +getBranchOIdFromObject repo branch_obj = do + branch_name <- Git.branchGetName branch_obj >>= maybeThrow BranchNameError + let branch_ref = T.pack $ printf "refs/heads/%s" branch_name + ref <- Git.repositoryLookupReference repo branch_ref >>= maybeThrow LookupReferenceError + Git.refGetTarget ref >>= maybeThrow GetTargetError + +-- | Make a new commit to a repository's branch +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@filename@]: Filename of the commit +-- [@message@]: Commit message +-- [@content@]: Data to be written to the commit +-- +-- Returns the OId of the new commit. +-- +-- Can throw 'CreateBlobError', 'GetTreeError', 'TreeBuilderError', 'BuilderInsertError', or 'CreateCommitError' +writeCommit :: Git.Repository -> T.Text -> T.Text -> T.Text -> BS.ByteString -> IO Git.OId +writeCommit repo branch filename message content = do + -- TODO Create the branch if it doesn't already exist (using findOrCreateBranch) + parent_commit <- headCommit repo branch + blob_id <- Git.repositoryCreateBlobFromBuffer repo content >>= maybeThrow CreateBlobError + + -- Use treebuilder to make a new entry for this filename and blob: repositoryCreateTreeBuilderFromTree + parent_tree <- Git.commitGetTree parent_commit >>= maybeThrow GetTreeError + builder <- Git.repositoryCreateTreeBuilderFromTree repo parent_tree >>= maybeThrow TreeBuilderError + void $ Git.treeBuilderInsert builder filename blob_id Git.FileModeBlob >>= maybeThrow BuilderInsertError + (tree, sig, ref, encoding) <- prepareCommit repo branch builder + Git.repositoryCreateCommit repo ref sig sig encoding message tree [parent_commit] >>= maybeThrow CreateCommitError + +-- | Read a commit and return a ByteString of the content +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@filename@]: Filename of the commit +-- [@commit@]: Commit hash to read, or Nothing to read the HEAD +-- +-- TODO Return the commit message too +readCommit :: Git.Repository -> T.Text -> T.Text -> Maybe T.Text -> IO (T.Text, BS.ByteString) +readCommit repo branch filename Nothing = do + commits <- listCommits repo branch filename + let spec = T.pack $ printf "%s:%s" (cdCommit $ head commits) filename + raw <- readCommitSpec repo spec + return (cdCommit $ head commits, raw) +readCommit repo _ filename (Just commit) = do + let spec = T.pack $ printf "%s:%s" commit filename + raw <- readCommitSpec repo spec + return (commit, raw) + +-- | Read a commit using a revspec, return the ByteString content +-- +-- [@repo@]: Open git repository +-- [@spec@]: revspec to read. +-- +-- eg. \:\ or \:\ +-- +-- Can throw 'RevparseError', 'GetIdError', 'LookupBlobError', or 'GetRawBlobError' +readCommitSpec :: Git.Repository -> T.Text -> IO BS.ByteString +readCommitSpec repo spec = do + obj <- Git.repositoryRevparse repo spec >>= maybeThrow RevparseError + oid <- Git.objectGetId obj >>= maybeThrow GetIdError + blob <- Git.repositoryLookupBlob repo oid >>= maybeThrow LookupBlobError + Git.blobGetRawContent blob >>= maybeThrow GetRawBlobError + +-- | Get the filename for a Blob tree entry +-- +-- [@tree@]: The commit's Tree object +-- [@idx@]: Entry index to get +-- +-- Can throw 'GetTreeError', or 'GetNameError' +getFilename :: Git.Tree -> Word32 -> IO (Maybe T.Text) +getFilename tree idx = do + entry <- Git.treeGet tree idx >>= maybeThrow GetTreeError + + -- Only allow Blob and BlobExecutable + ifM (isFileBlob entry) + (Just <$> Git.treeEntryGetName entry >>= maybeThrow GetNameError) + (return Nothing) + where + isFileBlob entry = Git.treeEntryGetFileMode entry >>= \case + Git.FileModeBlob -> return True + Git.FileModeBlobExecutable -> return True + _ -> return False + +{-# ANN getFilenames ("HLint: ignore Eta reduce"::String) #-} +-- | Get a list of the Blob tree entry filenames +-- +-- [@tree@]: The commit's Tree object +-- [@idx@]: Entry index to get +-- +-- This is limited to entries of type Blob and BlobExecutable +getFilenames :: Git.Tree -> Word32 -> IO [T.Text] +getFilenames tree idx = getFilenames' tree [] idx + +-- | Build the list of filenames from the tree entries +-- +-- [@tree@]: The commit's Tree object +-- [@filenames@]: The accumulated list of filenames +-- [@idx@]: Entry index to get +getFilenames' :: Git.Tree -> [T.Text] -> Word32 -> IO [T.Text] +getFilenames' _ filenames 0 = return filenames +getFilenames' tree filenames idx = getFilename tree (idx-1) >>= \case + Just name -> getFilenames' tree (name:filenames) (idx-1) + Nothing -> getFilenames' tree filenames (idx-1) + +-- | List the files on a branch +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +listBranchFiles :: Git.Repository -> T.Text -> IO [T.Text] +listBranchFiles repo branch = + headCommit repo branch >>= listCommitFiles repo + +-- | List the files in a commit +-- +-- [@repo@]: Open git repository +-- [@commit@]: The commit to get the files from +-- +-- Can throw 'GetTreeIdError', or 'LookupTreeError' +listCommitFiles :: Git.Repository -> Git.Commit -> IO [T.Text] +listCommitFiles repo commit = do + parent_tree_id <- Git.commitGetTreeId commit >>= maybeThrow GetTreeIdError + tree <- Git.repositoryLookupTree repo parent_tree_id >>= maybeThrow LookupTreeError + sz <- Git.treeSize tree + getFilenames tree sz + +-- | Delete a recipe from a branch +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@recipe_name@]: The recipe name to delete (not the filename) +deleteRecipe :: Git.Repository -> T.Text -> T.Text -> IO Git.OId +deleteRecipe repo branch recipe_name = deleteFile repo branch (recipeTomlFilename $ T.unpack recipe_name) + +-- | Delete a file from a branch +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@filename@]: The recipe filename to delete +-- +-- Can throw `GetTreeError`, 'TreeBuilderError', or 'CreateCommitError' +deleteFile :: Git.Repository -> T.Text -> T.Text -> IO Git.OId +deleteFile repo branch filename = do + parent_commit <- headCommit repo branch + + -- Use treebuilder to modify the tree + parent_tree <- Git.commitGetTree parent_commit >>= maybeThrow GetTreeError + builder <- Git.repositoryCreateTreeBuilderFromTree repo parent_tree >>= maybeThrow TreeBuilderError + Git.treeBuilderRemove builder filename + (tree, sig, ref, encoding) <- prepareCommit repo branch builder + let message = T.pack $ printf "Recipe %s deleted" filename + Git.repositoryCreateCommit repo ref sig sig encoding message tree [parent_commit] >>= maybeThrow CreateCommitError + +{-# ANN revertRecipe ("HLint: ignore Eta reduce"::String) #-} +-- | Revert a recipe to a previous commit +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@recipe_name@]: The recipe name to revert (not the filename) +-- [@commit@]: The commit hash string to revert to +revertRecipe :: Git.Repository -> T.Text -> T.Text -> T.Text -> IO Git.OId +revertRecipe repo branch recipe_name commit = revertFile repo branch (recipeTomlFilename $ T.unpack recipe_name) commit + +-- | Revert a recipe file to a previous commit +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@filename@]: The recipe filename to revert +-- [@commit@]: The commit hash string to revert to +-- +-- Can throw 'NewOIdError' +revertFile :: Git.Repository -> T.Text -> T.Text -> T.Text -> IO Git.OId +revertFile repo branch filename commit = do + commit_id <- Git.oIdNewFromString commit >>= maybeThrow NewOIdError + revertFileCommit repo branch filename commit_id + +-- | Revert a recipe file to a previous commit +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@filename@]: The recipe filename to revert +-- [@commit@]: The commit object to revert to +-- +-- Can throw 'LookupCommitError', 'GetTreeError', 'GetByNameError', 'GetEntryIdError', 'GetTreeError', +-- '', 'OIdError', 'CreateCommitError' +revertFileCommit :: Git.Repository -> T.Text -> T.Text -> Git.OId -> IO Git.OId +revertFileCommit repo branch filename commit_id = do + commit_obj <- Git.repositoryLookupCommit repo commit_id >>= maybeThrow LookupCommitError + revert_tree <- Git.commitGetTree commit_obj >>= maybeThrow GetTreeError + entry <- Git.treeGetByName revert_tree filename >>= maybeThrow GetByNameError + blob_id <- Git.treeEntryGetId entry >>= maybeThrow GetEntryIdError + parent_commit <- headCommit repo branch + + -- Use treebuilder to modify the tree + parent_tree <- Git.commitGetTree parent_commit >>= maybeThrow GetTreeError + builder <- Git.repositoryCreateTreeBuilderFromTree repo parent_tree >>= maybeThrow TreeBuilderError + void $ Git.treeBuilderInsert builder filename blob_id Git.FileModeBlob + (tree, sig, ref, encoding) <- prepareCommit repo branch builder + commit <- Git.oIdToString commit_id >>= maybeThrow OIdError + let message = T.pack $ printf "%s reverted to commit %s" filename commit + Git.repositoryCreateCommit repo ref sig sig encoding message tree [parent_commit] >>= maybeThrow CreateCommitError + +-- | File commit details +data CommitDetails = + CommitDetails { cdCommit :: T.Text -- ^ Hash string + , cdTime :: T.Text -- ^ Timestamp in ISO 8601 format + , cdMessage :: T.Text -- ^ Commit message, separated by \n + , cdRevision :: Maybe Int -- ^ Recipe revision number + } deriving (Show, Eq) + +-- JSON instances for CommitDetails +instance ToJSON CommitDetails where + toJSON CommitDetails{..} = object [ + "commit" .= cdCommit + , "time" .= cdTime + , "message" .= cdMessage + , "revision" .= cdRevision ] + +instance FromJSON CommitDetails where + parseJSON = withObject "/recipes/info response" $ \o -> do + cdCommit <- o .: "commit" + cdTime <- o .: "time" + cdMessage <- o .: "message" + cdRevision <- o .: "revision" + return CommitDetails{..} + +-- | List the commits for a recipe +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@recipe_name@]: Recipe name (not filename) +-- +-- Returns a list of 'CommitDetails' +listRecipeCommits :: Git.Repository -> T.Text -> T.Text -> IO [CommitDetails] +listRecipeCommits repo branch recipe_name = listCommits repo branch (recipeTomlFilename $ T.unpack recipe_name) + +-- | List the commits for a filename +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@filename@]: Recipe filename +-- +-- Returns a list of 'CommitDetails' +-- +-- Can throw 'NewWalkerError' +listCommits :: Git.Repository -> T.Text -> T.Text -> IO [CommitDetails] +listCommits repo branch filename = do + revwalk <- Git.revisionWalkerNew repo >>= maybeThrow NewWalkerError + Git.revisionWalkerSetSortMode revwalk [Git.SortModeReverse] + let branch_ref = T.pack $ printf "refs/heads/%s" branch + Git.revisionWalkerPushRef revwalk branch_ref + + mfirst_id <- Git.revisionWalkerNext revwalk + commitDetails repo revwalk branch filename [] mfirst_id + +-- | Get the commit details for a filename +-- +-- [@repo@]: Open git repository +-- [@revwalk@]: Git revwalk object +-- [@branch@]: Branch name +-- [@filename@]: Recipe filename +-- [@details@]: Accumulated 'CommitDetails' for the filename +-- [@next_id@]: Next commit OId +-- +-- This is a recursive function that accumulates the details for the filename, +-- returning when there are no more commits to examine. +-- +-- Can throw 'LookupCommitError', 'GetParentsError', 'GetTreeError', 'GetMessageError', +-- 'OIdError', 'GetCommitterError', 'GetTimeError' +commitDetails :: Git.Repository -> Git.RevisionWalker -> T.Text -> T.Text -> [CommitDetails] -> Maybe Git.OId -> IO [CommitDetails] +commitDetails _ _ _ _ details Nothing = return details +commitDetails repo revwalk branch filename details next_id = do + let commit_id = fromJust next_id + commit_obj <- Git.repositoryLookupCommit repo commit_id >>= maybeThrow LookupCommitError + + parents <- Git.commitGetParents commit_obj >>= maybeThrow GetParentsError + num_parents <- Git.commitParentsGetSize parents + + tree <- Git.commitGetTree commit_obj >>= maybeThrow GetTreeError + + is_diff <- if num_parents > 0 + then do + commits <- mapM (getCommitParent parents) [0..num_parents-1] + allM (parentDiff repo filename tree) commits + else + return False + + mnext_id <- Git.revisionWalkerNext revwalk + mentry <- Git.treeGetByName tree filename + if isJust mentry && is_diff + then getCommitDetails commit_id commit_obj mnext_id + else commitDetails repo revwalk branch filename details mnext_id + + where + getCommitParent :: Git.CommitParents -> Word32 -> IO Git.Commit + getCommitParent parents idx = Git.commitParentsGet parents idx >>= maybeThrow GetParentsError + + getCommitDetails :: Git.OId -> Git.Commit -> Maybe Git.OId -> IO [CommitDetails] + getCommitDetails commit_id commit_obj mnext_id = do + mtag <- findCommitTag repo branch filename commit_id + let revision = getRevisionFromTag mtag + -- Fill in a commit record + message <- Git.commitGetMessage commit_obj >>= maybeThrow GetMessageError + commit_str <- Git.oIdToString commit_id >>= maybeThrow OIdError + sig <- Git.commitGetCommitter commit_obj >>= maybeThrow GetCommitterError + + time_str <- Git.signatureGetTime sig >>= maybeThrow GetTimeError >>= formatDateTime + + let commit = CommitDetails {cdCommit=commit_str, cdTime=time_str, cdMessage=message, cdRevision=revision} + commitDetails repo revwalk branch filename (commit:details) mnext_id + + formatDateTime :: MonadIO m => GLib.DateTime -> m T.Text + formatDateTime datetime = do + -- convert the datetime to UTC + utctime <- GLib.dateTimeToUtc datetime + + -- Here are two other obvious ways of + -- Pull the values out of the datetime directly instead of converting + -- to a timeval, because + -- 1) converting to/from a timeval can fail (!!) + -- 2) the annotations for g_date_time_to_timeval are busted so + -- the binding ends up relying on side effects + -- + -- g_date_time_format doesn't cut it either, since it can't print microseconds + year <- GLib.dateTimeGetYear utctime + month <- GLib.dateTimeGetMonth utctime + day <- GLib.dateTimeGetDayOfMonth utctime + hour <- GLib.dateTimeGetHour utctime + minute <- GLib.dateTimeGetMinute utctime + second <- GLib.dateTimeGetSecond utctime + micro <- GLib.dateTimeGetMicrosecond utctime + + -- Print it out in the same format as g_time_val_to_iso8601 + let secondsStr = (if micro /= 0 then printf "%02d.%06d" second micro + else printf "%02d" second) :: String + + return $ T.pack $ printf "%d-%02d-%02dT%02d:%02d:%sZ" year month day hour minute secondsStr + +-- | Determine if there were changes between a file's commit and its parent +-- +-- [@repo@]: Open git repository +-- [@filename@]: Filename to check +-- [@commit_tree@]: The filename's commit Tree +-- [@parent_commit@]: The parent commit to check +-- +-- Return True if there were changes, False otherwise +parentDiff :: Git.Repository -> T.Text -> Git.Tree -> Git.Commit -> IO Bool +parentDiff repo filename commit_tree parent_commit = do + diff_opts <- Git.diffOptionsNew >>= maybeThrow NewOptionsError + Git.diffOptionsSetPathspec diff_opts (Just [filename]) + + parent_tree <- Git.commitGetTree parent_commit >>= maybeThrow GetTreeError + diff <- Git.diffNewTreeToTree repo (Just commit_tree) (Just parent_tree) (Just diff_opts) >>= maybeThrow NewTreeError + num_deltas <- Git.diffGetNumDeltas diff + return $ num_deltas > 0 + +-- | Find the revision tag pointing to a specific commit +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@filename@]: Recipe filename +-- [@commit_id@]: The commit OId +-- +-- The Tag is of the form refs/tags/\/\/r\ +-- There should only be one result. +findCommitTag :: Git.Repository -> T.Text -> T.Text -> Git.OId -> IO (Maybe T.Text) +findCommitTag repo branch filename commit_id = do + let tag_pattern = T.pack $ printf "%s/%s/r*" branch filename + Git.repositoryListTagsMatch repo (Just tag_pattern) >>= \case + Just [] -> return Nothing + Just tags -> filterTags tags + Nothing -> return Nothing + where + filterTags tags = + maybeOneTag <$> filterM isCommitTag tags + + maybeOneTag :: [T.Text] -> Maybe T.Text + maybeOneTag [] = Nothing + maybeOneTag [tag] = Just tag + maybeOneTag _ = Nothing + + -- | Return True if the tag is on the commit + isCommitTag :: T.Text -> IO Bool + isCommitTag tag = do + -- Find the commit for this tag and check that it matches commit_id + -- If so, return the branch/filename/r* part of the tag + let ref_tag = T.pack $ printf "refs/tags/%s" tag + ref <- Git.repositoryLookupReference repo ref_tag >>= maybeThrow LookupReferenceError + tag_oid <- Git.refGetTarget ref >>= maybeThrow GetTargetError + tag_obj <- Git.repositoryLookupTag repo tag_oid >>= maybeThrow LookupTagError + oid <- Git.tagGetTargetId tag_obj >>= maybeThrow GetTargetIdError + + cmp <- Git.oIdCompare oid commit_id + return $ cmp == 0 + +-- | Get the revision number from a git tag +-- +-- [@mtag@]: The tag string to extract the revision from +-- +-- The Tag is of the form refs/tags/\/\/r\ +-- +-- Returns the revision from the tag, or Nothing +getRevisionFromTag :: Maybe T.Text -> Maybe Int +getRevisionFromTag mtag = case mtag of + Nothing -> Nothing + Just tag -> getRevision $ T.unpack tag + where + getRevision :: String -> Maybe Int + getRevision tag = do + -- Get the digits after the final r + let rs = elemIndices 'r' tag + if null rs + then Nothing + else readMaybe $ drop (last rs + 1) tag + +-- | Tag a recipe's most recent commit +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@recipe_name@]: Recipe name (not filename) +-- +-- Returns True if it is successful +tagRecipeCommit :: Git.Repository -> T.Text -> T.Text -> IO Bool +tagRecipeCommit repo branch recipe_name = tagFileCommit repo branch (recipeTomlFilename $ T.unpack recipe_name) + +-- | Tag a file's most recent commit +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@filename@]: Recipe filename +-- +-- This uses git tags, of the form refs/tags/\/\/r\ +-- Only the most recent recipe commit can be tagged to prevent out of order tagging. +-- Revisions start at 1 and increment for each new commit that is tagged. +-- If the commit has already been tagged it will return False. +-- +-- Can throw 'NewSignatureError', 'NewOIdError', 'LookupError' +tagFileCommit :: Git.Repository -> T.Text -> T.Text -> IO Bool +tagFileCommit repo branch filename = do + commits <- listCommits repo branch filename + let rev_commit = findLastRev commits + -- If there are no commits, or the most recent one has already been tagged, return False + if null commits || isFirstCommit commits rev_commit + then return False + else tagNewestCommit (head commits) rev_commit + where + -- | Tag the most recent commit + tagNewestCommit :: CommitDetails -> Maybe CommitDetails -> IO Bool + tagNewestCommit last_commit rev_commit = do + -- What revision is this? rev_commit may be Nothing, or cdRevision may be Nothing. Use 1 for those cases + let rev = if isJust rev_commit && isJust (cdRevision (fromJust rev_commit)) + then fromJust (cdRevision (fromJust rev_commit)) + 1 + else 1 + + let name = T.pack $ printf "%s/%s/r%d" branch filename rev + sig <- Git.signatureNewNow "bdcs-api" "user-email" >>= maybeThrow NewSignatureError + commit_id <- Git.oIdNewFromString (cdCommit last_commit) >>= maybeThrow NewOIdError + commit_type <- gobjectType (undefined :: Git.Commit) + commit_obj <- Git.repositoryLookup repo commit_id commit_type >>= maybeThrow LookupError + mtag_id <- Git.repositoryCreateTag repo name commit_obj sig name [Git.CreateFlagsNone] + return $ isJust mtag_id + + -- | Find the last revision in the commits and return it + findLastRev :: [CommitDetails] -> Maybe CommitDetails + findLastRev []= Nothing + findLastRev (x:xs) = case cdRevision x of + Nothing -> findLastRev xs + Just _ -> Just x + + -- | Is the revision commit the most recent one? + -- + -- If it is, then we cannot make a new tag. + -- If it is not, or there is no rev_commit, we can tag a new one. + isFirstCommit :: [CommitDetails] -> Maybe CommitDetails -> Bool + isFirstCommit _ Nothing = False + isFirstCommit [] _ = False + isFirstCommit (c:_) (Just commit) = commit == c + + +-- | Commit a Recipe TOML file +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@filename@]: Recipe filename +-- +-- Returns the OId of the new commit +commitRecipeFile :: Git.Repository -> T.Text -> FilePath -> IO Git.OId +commitRecipeFile repo branch filename = do + toml_in <- TIO.readFile filename + let erecipe = parseRecipe toml_in + -- XXX Handle errors + let recipe = head $ rights [erecipe] + commitRecipe repo branch recipe + +-- | Commit a Recipe record to a branch +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@recipe@]: Recipe record +-- +-- If there is already an existing recipe this will bump or replace the +-- version number depending on what the new recipe contains. See the rules +-- in 'bumpVersion' +commitRecipe :: Git.Repository -> T.Text -> Recipe -> IO Git.OId +commitRecipe repo branch recipe = do + old_version <- getOldVersion (T.pack $ rName recipe) + -- Bump the recipe's version + let erecipe = recipeBumpVersion recipe old_version + -- XXX Handle errors + let recipe' = head $ rights [erecipe] + -- Update the workspace with the new commit + workspaceWrite repo branch recipe' + let version = fromJust (rVersion recipe') + let toml_out = encodeUtf8 $ recipeTOML recipe' + let filename = recipeTomlFilename (rName recipe') + let message = T.pack $ printf "Recipe %s, version %s saved" filename version + writeCommit repo branch filename message toml_out + where + getOldVersion :: T.Text -> IO (Maybe String) + getOldVersion recipe_name = do + eold_recipe <- readRecipeCommit repo branch recipe_name Nothing + case eold_recipe of + Left _ -> return Nothing + Right (_, old_recipe) -> return $ rVersion old_recipe + +-- | Commit recipes from a directory, if they don't already exist +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@directory@]: Directory to read the recipes from +-- +-- This reads all files ending in .toml from the directory, skipping recipes that +-- are already in the branch. +commitRecipeDirectory :: Git.Repository -> T.Text -> FilePath -> IO [Git.OId] +commitRecipeDirectory repo branch directory = do + branch_files <- listBranchFiles repo branch + files <- map (directory ) . filter (skipFiles branch_files) <$> listDirectory directory + mapM (commitRecipeFile repo branch) files + where + skipFiles :: [T.Text] -> String -> Bool + skipFiles branch_files file = T.pack file `notElem` branch_files && ".toml" `isSuffixOf` file + +-- | Read a Recipe from a commit +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@recipe_name@]: Recipe name (not filename) +-- [@commit@]: The commit hash string to read +-- +-- If the recipe isn't found it returns a Left +readRecipeCommit :: Git.Repository -> T.Text -> T.Text -> Maybe T.Text -> IO (Either String (T.Text, Recipe)) +readRecipeCommit repo branch recipe_name commit = do + -- Is this file in the branch? + branch_files <- listBranchFiles repo branch + if filename `notElem` branch_files + then return $ Left (printf "%s is not present on branch %s" filename branch) + else do + (commit_id, recipe_toml) <- readCommit repo branch filename commit + case (parseRecipe . decodeUtf8) recipe_toml of + Left err -> return $ Left err + Right recipe -> return $ Right (commit_id, recipe) + where + filename = recipeTomlFilename $ T.unpack recipe_name + +-- | print the OId +-- +-- [@oid@]: The OId to print +-- +-- Used for debugging +printOId :: Git.OId -> IO () +printOId oid = + Git.oIdToString oid >>= print + + +-- | Type of Diff Entry +-- +-- Used by RecipeDiffEntry's old and new fields +data RecipeDiffType = + Name {rdtName :: String} -- ^ Name changed + | Description {rdtDescription :: String} -- ^ Description changed + | Version {rdtVersion :: Maybe String} -- ^ Version changed + | Module {rdtModule :: RecipeModule} -- ^ Module version changed, added, or removed + | Package {rdtPackage :: RecipeModule} -- ^ Package version changed, added, or removed + | None -- ^ Used for added and removed + deriving (Eq, Show) + +instance ToJSON RecipeDiffType where + toJSON Name{..} = object ["Name" .= rdtName] + toJSON Description{..} = object ["Description" .= rdtDescription] + toJSON Version{..} = object ["Version" .= rdtVersion] + toJSON Module{..} = object ["Module" .= toJSON rdtModule] + toJSON Package{..} = object ["Package" .= toJSON rdtPackage] + toJSON None = toJSON Null + +instance FromJSON RecipeDiffType where + parseJSON = withObject "Recipe diff type" $ \o -> asum [ + Name <$> o .: "Name", + Description <$> o .: "Description", + Version <$> o .: "Version", + Module <$> parseJSON (Object o), + Package <$> parseJSON (Object o) ] + +-- | A difference entry +-- +-- This uses RecipeDiffType to indicate the type of difference between +-- recipe fields. +-- +-- If old is set and new is None it means the entry was removed +-- If old is None and new is set it means the entry was added +-- If both are set then old the the old content and new is the new content +data RecipeDiffEntry = + RecipeDiffEntry { + rdeOld :: RecipeDiffType, + rdeNew :: RecipeDiffType + } deriving (Eq, Show) + +instance ToJSON RecipeDiffEntry where + toJSON RecipeDiffEntry{..} = object [ + "old" .= rdeOld + , "new" .= rdeNew ] + +instance FromJSON RecipeDiffEntry where + parseJSON = withObject "Recipe diff entry" $ \o -> do + rdeOld <- o .: "old" + rdeNew <- o .: "new" + return RecipeDiffEntry{..} + +-- | Find the differences between two recipes +-- +-- [@oldRecipe@]: The old version of the Recipe +-- [@newRecipe@]: The new version of the Recipe +-- +-- This calculates the differences between the recipes, returning a list of 'RecipeDiffEntry'. +-- The order is always the same, Name, Description, Version, removed Modules, added Modules, +-- removed Packages, added Packages, and then packages with different versions. +recipeDiff :: Recipe -> Recipe -> [RecipeDiffEntry] +recipeDiff oldRecipe newRecipe = do + let removed_modules = removed_diff module_removed (rModules oldRecipe) (rModules newRecipe) + let removed_packages = removed_diff package_removed (rPackages oldRecipe) (rPackages newRecipe) + let added_modules = added_diff module_added (rModules oldRecipe) (rModules newRecipe) + let added_packages = added_diff package_added (rPackages oldRecipe) (rPackages newRecipe) + let same_modules = same_diff module_diff (rModules oldRecipe) (rModules newRecipe) + let same_packages = same_diff package_diff (rPackages oldRecipe) (rPackages newRecipe) + let diffs = [name_diff oldRecipe newRecipe, + description_diff oldRecipe newRecipe, + version_diff oldRecipe newRecipe + ] ++ removed_modules ++ added_modules ++ same_modules + ++ removed_packages ++ added_packages ++ same_packages + + map fromJust (filter isJust diffs) + where + -- | Return a list of the modules/packages that have been added + -- + -- diff_f is a function that returns a RecipeDiffEntry (eg. module_added, package_added) + -- o and m are lists of the old and new RecipeModules + added_diff :: (RecipeModule -> Maybe RecipeDiffEntry) -> [RecipeModule] -> [RecipeModule] -> [Maybe RecipeDiffEntry] + added_diff diff_f o n = map (diff_f . new_m) added_m + where + -- | Return a list of the added module names + added_m :: [String] + added_m = sortBy caseInsensitive $ toList $ module_names n `difference` module_names o + -- | Lookup a recipe module name in the list of new modules + new_m :: String -> RecipeModule + new_m m = get_module m n + + -- | Return a list of the modules/packages that have been removed + -- + -- diff_f is a function that returns a RecipeDiffEntry (eg. module_removed, package_removed) + -- o and m are lists of the old and new RecipeModules + removed_diff :: (RecipeModule -> Maybe RecipeDiffEntry) -> [RecipeModule] -> [RecipeModule] -> [Maybe RecipeDiffEntry] + removed_diff diff_f o n = map (diff_f . old_m) removed_m + where + -- | Return a list of the removed module names + removed_m :: [String] + removed_m = sortBy caseInsensitive $ toList $ module_names o `difference` module_names n + -- | Lookup a recipe module name in the list of old modules + old_m :: String -> RecipeModule + old_m m = get_module m o + + -- | Return a list of changes to modules/packages that are in both old and new lists + -- + -- diff_f is a function that returns a RecipeDiffEntry (eg. module_diff, package_diff) + -- o and m are lists of the old and new RecipeModules + same_diff :: (RecipeModule -> RecipeModule -> Maybe RecipeDiffEntry) -> [RecipeModule] -> [RecipeModule] -> [Maybe RecipeDiffEntry] + same_diff diff_f o n = map (\m -> diff_f (old_m m) (new_m m)) same_m + where + -- | Return a list of the module names that are in both lists + same_m :: [String] + same_m = sortBy caseInsensitive $ toList $ module_names o `intersection` module_names n + -- | Lookup a recipe module name in the list of old modules + old_m :: String -> RecipeModule + old_m m = get_module m o + -- | Lookup a recipe module name in the list of old modules + new_m :: String -> RecipeModule + new_m m = get_module m n + + -- | Check the recipe name for a change + name_diff :: Recipe -> Recipe -> Maybe RecipeDiffEntry + name_diff o n = + if rName o == rName n then Nothing else + Just $ RecipeDiffEntry (Name (rName o)) (Name (rName n)) + + -- | Check the recipe description for a change + description_diff :: Recipe -> Recipe -> Maybe RecipeDiffEntry + description_diff o n = + if rDescription o == rDescription n then Nothing else + Just $ RecipeDiffEntry (Description (rDescription o)) (Description (rDescription n)) + + -- | Check the recipe version for a change + version_diff :: Recipe -> Recipe -> Maybe RecipeDiffEntry + version_diff o n = + if rVersion o == rVersion n then Nothing else + Just $ RecipeDiffEntry (Version $ rVersion o) (Version $ rVersion n) + + -- | Check the module for a different version + -- + -- Returns a Module RecipeDiffType with the module details + module_diff :: RecipeModule -> RecipeModule -> Maybe RecipeDiffEntry + module_diff o n = + if rmVersion o == rmVersion n then Nothing else + Just $ RecipeDiffEntry (Module o) (Module n) + + -- | Check the package for a different version + -- + -- Returns a Package RecipeDiffType with the module details + package_diff :: RecipeModule -> RecipeModule -> Maybe RecipeDiffEntry + package_diff o n = + if rmVersion o == rmVersion n then Nothing else + Just $ RecipeDiffEntry (Package o) (Package n) + + -- | Return an entry with a removed module + module_removed :: RecipeModule -> Maybe RecipeDiffEntry + module_removed o = Just $ RecipeDiffEntry (Module o) None + + -- | Return an entry with a removed package + package_removed :: RecipeModule -> Maybe RecipeDiffEntry + package_removed o = Just $ RecipeDiffEntry (Package o) None + + -- | Return an entry with an added module + module_added :: RecipeModule -> Maybe RecipeDiffEntry + module_added n = Just $ RecipeDiffEntry None (Module n) + + -- | Return an entry with an added package + package_added :: RecipeModule -> Maybe RecipeDiffEntry + package_added n = Just $ RecipeDiffEntry None (Package n) + + -- ! Return a Set of the module/package names + module_names :: [RecipeModule] -> Set String + module_names modules = fromList $ map rmName modules + + -- | Get the recipe module from the list + -- + -- Only call this with module names that are known to be in the list + get_module :: String -> [RecipeModule] -> RecipeModule + get_module module_name module_list = fromJust $ find (\e -> rmName e == module_name) module_list + + +-- ========================= +-- Test Functions Below Here +-- +-- These functions exist here because there is no way (that I know of) to setup a framework in +-- Spec and run a series of tests in order that depend on a temporary Git repository. +testRecipe :: Recipe +testRecipe = + Recipe {rName = "test-server", + rVersion = Just "0.1.2", + rDescription = "Testing git commit of a Recipe record", + rPackages = [RecipeModule {rmName = "tmux", rmVersion = "2.2"}, + RecipeModule {rmName = "openssh-server", rmVersion = "6.6.*"}, + RecipeModule {rmName = "rsync", rmVersion = "3.0.*"}], + rModules = [RecipeModule {rmName = "httpd", rmVersion = "2.4.*"}, + RecipeModule {rmName = "mod_auth_kerb", rmVersion = "5.4"}, + RecipeModule {rmName = "mod_ssl", rmVersion = "2.4.*"}, + RecipeModule {rmName = "php", rmVersion = "5.4.*"}, + RecipeModule {rmName = "php-mysql", rmVersion = "5.4.*"}], + rCustomization = emptyCustomization + } + +testFiles :: [T.Text] +testFiles = ["glusterfs.toml","http-server.toml","kubernetes.toml","test-fake.toml","test-server.toml"] +testFiles2 :: [T.Text] +testFiles2 = ["glusterfs.toml","kubernetes.toml","test-fake.toml","test-server.toml"] + +data TestError = + FileListError [T.Text] + | ListCommitsError + | HttpCommitError [CommitDetails] + | TagCommitError + | CommitRevisionError [CommitDetails] + | DeleteFailedError FilePath + | RecipeReadError + | RecipeMismatchError [Recipe] + | ChangesOrderError + deriving (Eq, Show) + +instance CES.Exception TestError + +-- | Run the Git repository tests with a temporary directory +runGitRepoTests :: IO Bool +runGitRepoTests = withTempDirectory "/var/tmp/" "bdcsgit-test" testGitRepo + +-- | Test the Git repository functions +testGitRepo :: FilePath -> IO Bool +testGitRepo tmpdir = do + Git.init + repo <- openOrCreateRepo tmpdir + + -- Commit a file to the repo + putStrLn " - Committing http-server.toml" + void $ commitRecipeFile repo "master" "./tests/recipes/http-server.toml" + + -- Commit a directory to the repo + putStrLn " - Committing a directory of recipes" + void $ commitRecipeDirectory repo "master" "./tests/recipes/" + + -- Commit a Recipe record to the repo + putStrLn " - Committing a Recipe record" + void $ commitRecipe repo "master" testRecipe + + -- Check that the testRecipe's version was not bumped on 1st save + putStrLn " - Checking Recipe Version" + erecipe <- readRecipeCommit repo "master" "test-server" Nothing + let recipe = snd $ head $ rights [erecipe] + unless (testRecipe == recipe) (CES.throwIO $ RecipeMismatchError [testRecipe, recipe]) + + -- Check that saving a changed recipe, with the same version, bumps it. + let new_recipe1 = testRecipe { rDescription = "Second commit with same version, should bump" } + putStrLn " - Committing a Recipe record with changed description" + void $ commitRecipe repo "master" new_recipe1 + + -- Check that the version was bumped on the 2nd save + putStrLn " - Checking Modified Recipe's Version" + erecipe' <- readRecipeCommit repo "master" "test-server" Nothing + let recipe' = snd $ head $ rights [erecipe'] + unless (new_recipe1 {rVersion = Just "0.1.3"} == recipe') (CES.throwIO $ RecipeMismatchError [new_recipe1, recipe']) + + -- Check that saving a changed recipe, with a completely different version, uses it without bumping. + let new_recipe2 = testRecipe {rDescription = "Third commit with new version, should just use it", + rVersion = Just "0.3.1"} + putStrLn " - Committing a Recipe record with changed description and different version" + void $ commitRecipe repo "master" new_recipe2 + + -- Check that the version was used as-is + putStrLn " - Checking Modified Recipe's Version" + erecipe'' <- readRecipeCommit repo "master" "test-server" Nothing + let recipe'' = snd $ head $ rights [erecipe''] + unless (new_recipe2 == recipe'') (CES.throwIO $ RecipeMismatchError [new_recipe2, recipe'']) + + -- List the files on master + putStrLn " - Listing the committed files" + files <- listBranchFiles repo "master" + unless (files == testFiles) (CES.throwIO $ FileListError files) + + -- Get the commits to http-server.toml + putStrLn " - List commits to http-server.toml" + http_commits <- listCommits repo "master" "http-server.toml" + -- Should be 1 commit + let expected_msg_1 = "Recipe http-server.toml, version 0.2.0 saved" + let msg_1 = cdMessage (head http_commits) + unless (msg_1 == expected_msg_1) (CES.throwIO $ HttpCommitError http_commits) + + -- delete http-server.toml file + putStrLn " - Delete the http-server.toml file" + void $ deleteRecipe repo "master" "http-server" + + -- List the files on master + putStrLn " - Check that http-server.toml has been deleted" + files2 <- listBranchFiles repo "master" + unless (files2 == testFiles2) (CES.throwIO $ FileListError files2) + + -- Revert the delete + commit_id <- Git.oIdNewFromString (cdCommit $ head http_commits) >>= maybeThrow NewOIdError + revert_id <- revertFileCommit repo "master" "http-server.toml" commit_id + + -- List the files on master + putStrLn " - Check that http-server.toml has been restored" + files3 <- listBranchFiles repo "master" + unless (files3 == testFiles) (CES.throwIO $ FileListError files3) + + -- tag a commit + putStrLn " - Tag most recent commit of http-server.toml" + ok <- tagRecipeCommit repo "master" "http-server" + unless ok (CES.throwIO TagCommitError) + + -- list the commits and check for the tag + putStrLn " - Check the Tag" + commits <- listCommits repo "master" "http-server.toml" + let revision = cdRevision (head commits) + unless (revision == Just 1) (CES.throwIO $ CommitRevisionError commits) + + -- Make sure the first listed commit is the reverted commit + let top_commit = cdCommit $ head commits + revert_hash <- fromJust <$> Git.oIdToString revert_id + unless (top_commit == revert_hash) (CES.throwIO ChangesOrderError) + + return True + + +-- | Run the Workspace tests with a temporary directory +runWorkspaceTests :: IO Bool +runWorkspaceTests = withTempDirectory "/var/tmp/" "bdcsws-test" testWorkspace + +-- | Test the Workspace functions +testWorkspace :: FilePath -> IO Bool +testWorkspace tmpdir = do + Git.init + repo <- openOrCreateRepo tmpdir + + -- Write the Recipe to workspace for master branch + putStrLn " - Write testRecipe to Workspace for master branch" + workspaceWrite repo "master" testRecipe + + -- Read the Recipe, does it match? + putStrLn " - Read Recipe from Workspace for master branch" + recipe <- workspaceRead repo "master" "test-server" >>= maybeThrow RecipeReadError + unless (testRecipe == recipe) (CES.throwIO $ RecipeMismatchError [testRecipe, recipe]) + + -- Delete the Recipe, is it gone? + putStrLn " - Delete Recipe from Workspace for master branch" + workspaceDelete repo "master" "test-server" + dir <- workspaceDir repo "master" + let filename = dir T.unpack (recipeTomlFilename $ T.unpack "test-server") + whenM (doesFileExist filename) (CES.throwIO $ DeleteFailedError filename) + + return True diff --git a/src/BDCS/API/Server.hs b/src/BDCS/API/Server.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/Server.hs @@ -0,0 +1,329 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +{-| BDCS API Server + + This starts a server and answers the API requests. +-} +module BDCS.API.Server(mkApp, + proxyAPI, + runServer, + ServerStatus(..), + SocketException(..)) + where + +import BDCS.API.Compose(ComposeInfo(..), ComposeMsgAsk(..), ComposeMsgResp(..), compose) +import BDCS.API.Config(ServerConfig(..)) +import BDCS.API.Recipes(openOrCreateRepo, commitRecipeDirectory) +import BDCS.API.Utils(GitLock(..)) +import BDCS.API.V0(V0API, v0ApiServer) +import BDCS.API.Version(buildVersion) +import BDCS.DB(schemaVersion, getDbVersion) +import Control.Concurrent.Async(Async, async, cancel, replicateConcurrently_, waitCatch) +import qualified Control.Concurrent.ReadWriteLock as RWL +import Control.Concurrent.STM.TChan(newTChan, readTChan) +import Control.Concurrent.STM.TMVar(TMVar, newTMVar, putTMVar, readTMVar, takeTMVar) +import Control.Conditional(whenM) +import qualified Control.Exception.Safe as CES +import Control.Monad(forever, void) +import Control.Monad.Except(runExceptT) +import Control.Monad.Logger(runFileLoggingT, runStderrLoggingT) +import Control.Monad.STM(atomically) +import Data.Aeson +import Data.IORef(IORef, atomicModifyIORef', newIORef, readIORef) +import qualified Data.Map as Map +import Data.Sequence((|>), Seq(..), deleteAt, empty, findIndexL, index) +import Data.String.Conversions(cs) +import qualified Data.Text as T +import Database.Persist.Sqlite +import GHC.Conc(retry) +import GHC.Exts(toList) +import qualified GI.Ggit as Git +import Network.Socket +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Middleware.Cors +import Servant +import System.Directory(createDirectoryIfMissing, doesPathExist, removePathForcibly) +import System.Environment(lookupEnv) +import System.FilePath.Posix(()) +import System.Posix.Files(setFileMode, setOwnerAndGroup) +import System.Posix.User(GroupEntry(..), getGroupEntryForName) +import Text.Read(readMaybe) + +data SocketException = BadFileDescriptor + | BadGroup String + | NoSocketError + deriving(Show) + +instance CES.Exception SocketException + +type InProgressMap = Map.Map T.Text (Async (), ComposeInfo) + +-- | The status of the server, the database, and the API. +data ServerStatus = ServerStatus + { srvApi :: String -- ^ Supported API version + , srvBackend :: String -- ^ Backend implementation (weldr, lorax-composer) + , srvBuild :: String -- ^ Server build version + , srvSchemaVersion :: String -- ^ Supported Database Schema version + , srvDbVersion :: String -- ^ Database version + , srvDbSupported :: Bool -- ^ True if the Database is supported by the Server + } deriving (Eq, Show) + +instance ToJSON ServerStatus where + toJSON ServerStatus{..} = object + [ "api" .= srvApi + , "backend" .= srvBackend + , "build" .= srvBuild + , "schema_version" .= srvSchemaVersion + , "db_version" .= srvDbVersion + , "db_supported" .= srvDbSupported ] + +instance FromJSON ServerStatus where + parseJSON = withObject "server status" $ \o -> do + srvApi <- o .: "api" + srvBackend <- o .: "backend" + srvBuild <- o .: "build" + srvSchemaVersion <- o .: "schema_version" + srvDbVersion <- o .: "db_version" + srvDbSupported <- o .: "db_supported" + return ServerStatus{..} + +-- | The /status route +type CommonAPI = "api" :> "status" :> Get '[JSON] ServerStatus + +-- The maximum number of composes that can run simultaneously. Modify this for your site's +-- requirements and capabilities. +maxComposes :: Int +maxComposes = 1 + +serverStatus :: ServerConfig -> Handler ServerStatus +serverStatus ServerConfig{..} = do + version <- dbVersion + return (ServerStatus "0" "weldr" buildVersion (show schemaVersion) (show version) (schemaVersion == version)) + where + dbVersion = do + result <- runExceptT $ runSqlPool getDbVersion cfgPool + case result of + Left _ -> return 0 + Right version -> return version + +commonServer :: ServerConfig -> Server CommonAPI +commonServer cfg = serverStatus cfg + +-- | The combined API routes, /status and /api/v0/* +type CombinedAPI = CommonAPI + :<|> "api" :> "v0" :> V0API + +combinedServer :: ServerConfig -> Server CombinedAPI +combinedServer cfg = commonServer cfg + :<|> v0ApiServer cfg + +-- | CORS policy +appCors :: Middleware +appCors = cors (const $ Just policy) + where + policy = simpleCorsResourcePolicy + { corsRequestHeaders = ["Content-Type"] + , corsMethods = "DELETE" : "PUT" : simpleMethods } + +-- | Servant 'Proxy' +-- +-- This connects the API to everything else +proxyAPI :: Proxy CombinedAPI +proxyAPI = Proxy + +application :: ServerConfig -> Application +application cfg = appCors + $ serve proxyAPI + $ combinedServer cfg + +-- | Create the server app +-- +-- Create a SQLite connection pool, open/create the Git repo, and return the app +mkApp :: FilePath -> FilePath -> FilePath -> IO Application +mkApp bdcsPath gitRepoPath sqliteDbPath = do + pool <- runStderrLoggingT $ createSqlitePool (cs sqliteDbPath) 5 +-- runSqlPool (runMigration migrateAll) pool + + Git.init + repo <- openOrCreateRepo gitRepoPath + void $ commitRecipeDirectory repo "master" gitRepoPath + lock <- RWL.new + + chan <- atomically newTChan + + let cfg = ServerConfig { cfgRepoLock = GitLock lock repo, + cfgChan = chan, + cfgPool = pool, + cfgBdcs = bdcsPath, + cfgResultsDir = "/var/lib/composer" } + + createDirectoryIfMissing True (cfgResultsDir cfg) + + -- Fork off another process that does the composes in the background, + -- which means the client immediately gets a response with a build ID. + -- The compose (which could take a while) proceeds independently. The + -- client uses a different route to check and fetch the results. + void $ async $ composeServer cfg + + return $ application cfg + +-- | Run the API server +runServer :: FilePath -> String -> FilePath -> FilePath -> FilePath -> IO () +runServer socketPath socketGroup bdcsPath gitRepoPath sqliteDbPath = void $ withSocketsDo $ do + sock <- getSocket socketPath + app <- mkApp bdcsPath gitRepoPath sqliteDbPath + runSettingsSocket defaultSettings sock app + where + getSocket :: FilePath -> IO Socket + getSocket fp = lookupEnv "LISTEN_FDS" >>= \case + Nothing -> if fp == "" then CES.throw NoSocketError else newSocket fp + Just s -> case readMaybe s of + Nothing -> CES.throw BadFileDescriptor + Just fd -> mkSocket fd AF_UNIX Stream defaultProtocol Bound + + newSocket :: FilePath -> IO Socket + newSocket path = do + whenM (doesPathExist path) $ + removePathForcibly path + + gid <- CES.catchIO (groupID <$> getGroupEntryForName socketGroup) + (\_ -> CES.throw $ BadGroup socketGroup) + + s <- socket AF_UNIX Stream defaultProtocol + bind s (SockAddrUnix path) + listen s 1 + setFileMode path 0o660 + setOwnerAndGroup path 0 gid + return s + +composeServer :: ServerConfig -> IO () +composeServer ServerConfig{..} = do + -- A mutable variable that lets us keep track about currently running composes. + -- This is a map from UUID of the compose underway to the ThreadId doing that + -- compose. This lets us kill threads if needed. If this is empty, no compose + -- is currently running. + inProgressRef <- newIORef Map.empty + + -- A list of all composes currently waiting to be run. + worklist <- atomically $ newTMVar empty + + -- From here, we run several separate threads forever. + -- + -- One thread reads messages out of the channel and responds to them. This includes + -- things like "what is waiting in the queue?" and "what is currently composing?". + -- It also includes requests to start new composes. + -- + -- All the other threads are worker threads that run composes. We run as many threads + -- as we are allowed maximum simultaneous composes. Each thread does one compose at + -- a time - reading the first item out of the worklist, starting the compose, and + -- waiting for it to finish. When one compose is finished, it can look at the list to + -- see about starting the next one. + void $ async $ messagesThread inProgressRef worklist + replicateConcurrently_ maxComposes (workerThread inProgressRef worklist) + where + -- Add a newly started compose to the in progress map. + addCompose :: IORef InProgressMap -> ComposeInfo -> Async () -> IO () + addCompose ref ci@ComposeInfo{..} thread = + void $ atomicModifyIORef' ref (\m -> (Map.insert ciId (thread, ci) m, ())) + + -- Remove a completed (or killed?) compose from the in progress map. + removeCompose :: IORef InProgressMap -> T.Text -> IO () + removeCompose ref uuid = + void $ atomicModifyIORef' ref (\m -> (Map.delete uuid m, ())) + + workerThread :: IORef InProgressMap -> TMVar (Seq ComposeInfo) -> IO () + workerThread inProgressRef worklist = forever $ do + -- Attempt to grab the first ComposeInfo out of the worklist. This call blocks the + -- worker thread until something appears in the list and we can get it. + ci <- atomically $ takeTMVar worklist >>= \case + (x :<| xs) -> putTMVar worklist xs >> return x + -- This retry call is critical - without it, the worker threads and messages + -- thread will deadlock trying to read the worklist. + _ -> retry + + -- We got a ComposeInfo. Start the compose in a separate thread and wait + -- for it to finish (which could be due to success, failure, or cancellation). + thread <- async $ runFileLoggingT (ciResultsDir ci "compose.log") + (compose cfgBdcs cfgPool ci) + + addCompose inProgressRef ci thread + void $ waitCatch thread + removeCompose inProgressRef (ciId ci) + + messagesThread :: IORef InProgressMap -> TMVar (Seq ComposeInfo) -> IO () + messagesThread inProgressRef worklist = forever $ atomically (readTChan cfgChan) >>= \case + (AskBuildsWaiting, Just r) -> do + lst <- atomically $ readTMVar worklist + atomically $ putTMVar r (RespBuildsWaiting $ map ciId (toList lst)) + + (AskBuildsInProgress, Just r) -> do + -- Get just the ComposeInfo records for all the in-progress composes. + inProgress <- map snd . Map.elems <$> readIORef inProgressRef + -- And then extract the UUIDs of each, and that's the answer. + atomically $ putTMVar r (RespBuildsInProgress $ map ciId inProgress) + + (AskCancelBuild buildId, Just r) -> do + inProgress <- readIORef inProgressRef + case Map.lookup buildId inProgress of + Just (thread, ci) -> do cancel thread + removeCompose inProgressRef buildId + removePathForcibly (ciResultsDir ci) + atomically $ putTMVar r (RespBuildCancelled True) + + _ -> atomically $ putTMVar r (RespBuildCancelled False) + + (AskCompose ci, _) -> atomically $ do + -- Add the new compose to the end of the work queue. It will eventually + -- get around to being run by composesThread. + lst <- takeTMVar worklist + putTMVar worklist (lst |> ci) + + (AskDequeueBuild buildId, Just r) -> do + -- The worklist stores ComposeInfo records, but we only get the UUID from the + -- client. So first we have to find the right element in the worklist. Some + -- element with that UUID should be present, but we can't guarantee that given + -- all the multiprocessing stuff. Hence the Maybe. + ci <- atomically $ do + lst <- takeTMVar worklist + case findIndexL (\e -> ciId e == buildId) lst of + Nothing -> return Nothing + Just ndx -> do let ele = index lst ndx + putTMVar worklist (deleteAt ndx lst) + return $ Just ele + + -- If we found a ComposeInfo, clean it up - remove the results directory + -- (that doesn't yet have an artifact, but should have some toml files) and + -- inform the client. We already removed it from the worklist in the block + -- above. + case ci of + Just ComposeInfo{..} -> do + removePathForcibly ciResultsDir + atomically $ putTMVar r (RespBuildDequeued True) + + Nothing -> atomically $ putTMVar r (RespBuildDequeued False) + + _ -> return () diff --git a/src/BDCS/API/TOMLMediaType.hs b/src/BDCS/API/TOMLMediaType.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/TOMLMediaType.hs @@ -0,0 +1,58 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| Implement a ContentType for 'TOML' so that POSTing text/x-toml with Servant will parse it. + Add [TOML] to the Servant API to enable handling of it. See "BDCS.API.V0" for an example. +-} +module BDCS.API.TOMLMediaType(TOML, + ToTOML(..), + FromTOML(..)) + where + +import qualified Data.ByteString.Lazy as BSL +import Network.HTTP.Media((//)) +import Servant + +-- | Used in the Servant ReqBody +data TOML + +-- | Use Content-Type: text/x-toml +instance Accept TOML where + contentType _ = "text" // "x-toml" + +-- | toTOML needs to be implemented for the type being converted. +-- See "BDCS.API.Recipe" for an example. +class ToTOML a where + toTOML :: a -> BSL.ByteString + +-- | parseTOML needs to be implemented for the type being converted. +-- See "BDCS.API.Recipe" for an example. +class FromTOML a where + parseTOML :: BSL.ByteString -> Either String a + +-- | mimeRender is what Servant uses to connect its handling +-- of ContentType to the actual parsing into the destination type +instance ToTOML a => MimeRender TOML a where + mimeRender _ = toTOML + +-- | mimeUnrender is what Servant uses to connect its handling +-- of ContentType to the actual parsing into the destination type +instance FromTOML a => MimeUnrender TOML a where + mimeUnrender _ = parseTOML diff --git a/src/BDCS/API/Utils.hs b/src/BDCS/API/Utils.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/Utils.hs @@ -0,0 +1,74 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE ScopedTypeVariables #-} + +{-| Utility functions for "BDCS.API" +-} +module BDCS.API.Utils(applyLimits, + argify, + caseInsensitive, + caseInsensitiveT, + GitLock(..), + maybeIO, + maybeThrow) + where + +import qualified Control.Concurrent.ReadWriteLock as RWL +import qualified Control.Exception.Safe as CES +import Control.Monad (liftM) +import Data.List.Split (splitOn) +import qualified Data.Text as T +import qualified GI.Ggit as Git + +-- | Git Repository and its RWLock +-- +-- This is used to control access to the Git repository. Users should take the lock like this: +-- +-- > RWL.withRead (gitRepoLock repoLock) +data GitLock = GitLock + { gitRepoLock :: RWL.RWLock + , gitRepo :: Git.Repository + } + +-- | Turn exceptions from an action into 'Nothing' +maybeIO :: IO a -> IO (Maybe a) +maybeIO act = CES.handle (\(_ :: CES.SomeException) -> (return Nothing)) (Just `liftM` act) + +-- | Throw an IO error when a 'Maybe' is 'Nothing' +maybeThrow :: CES.Exception e => e -> Maybe a -> IO a +maybeThrow err Nothing = CES.throwIO err +maybeThrow _ (Just v) = return v + +-- | Take a list of possiby comma, or comma-space, separated options and turn it into a list of options +argify :: Foldable t => t String -> [String] +argify xs = filter (/= "") $ concatMap (splitOn ",") xs + +-- | Compare 2 strings case-insensitively +-- +-- Takes into account unicode +caseInsensitive :: String -> String -> Ordering +caseInsensitive a b = T.toCaseFold (T.pack a) `compare` T.toCaseFold (T.pack b) + +-- | Compare 2 T.Text's case-insensitively +-- +-- Takes into account unicode +caseInsensitiveT :: T.Text -> T.Text -> Ordering +caseInsensitiveT a b = T.toCaseFold a `compare` T.toCaseFold b + +-- | Apply limit and offset to a list. +applyLimits :: Int -> Int -> [a] -> [a] +applyLimits limit offset = take limit . drop offset diff --git a/src/BDCS/API/V0.hs b/src/BDCS/API/V0.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/V0.hs @@ -0,0 +1,2218 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK ignore-exports, prune #-} + +{-| API v0 routes +-} +module BDCS.API.V0(BuildInfo(..), + ComposeBody(..), + ComposeDeleteResponse(..), + ComposeFailedResponse(..), + ComposeFinishedResponse(..), + ComposeInfoResponse(..), + ComposeQueueResponse(..), + ComposeResponse(..), + ComposeStatusResponse(..), + ComposeType(..), + ComposeTypesResponse(..), + Metadata(..), + ModuleName(..), + ModulesListResponse(..), + PackageNEVRA(..), + ProjectInfo(..), + ProjectsDepsolveResponse(..), + ProjectsInfoResponse(..), + ProjectsListResponse(..), + RecipesListResponse(..), + RecipesInfoResponse(..), + RecipesChangesResponse(..), + RecipesDiffResponse(..), + RecipesDepsolveResponse(..), + RecipesFreezeResponse(..), + RecipeChanges(..), + RecipeDependencies(..), + SourceInfo(..), + WorkspaceChanges(..), + V0API, + v0ApiServer) +where + +import BDCS.API.Compose(ComposeInfo(..), ComposeMsgAsk(..), ComposeMsgResp(..), ComposeStatus(..), UuidStatus(..), deleteCompose, getComposesWithStatus, mkComposeStatus) +import BDCS.API.Config(ServerConfig(..)) +import BDCS.API.ComposeConfig(ComposeConfig(..), composeConfigTOML, parseComposeConfig) +import BDCS.API.Customization(processCustomization) +import BDCS.API.Depsolve +import BDCS.API.Error(APIResponse(..), createAPIError, tryIO) +import BDCS.API.QueueStatus(QueueStatus(..), queueStatusEnded, queueStatusText) +import BDCS.API.Recipe +import BDCS.API.Recipes +import BDCS.API.TOMLMediaType +import BDCS.API.Utils(GitLock(..), applyLimits, argify, caseInsensitive, caseInsensitiveT) +import BDCS.API.Workspace +import BDCS.DB +import BDCS.Builds(findBuilds, getBuild) +import BDCS.Export.Types(ExportType(..), exportTypeFromText, exportTypeText, supportedExportTypes) +import BDCS.Groups(getGroupsLike) +import BDCS.Projects(findProject, getProject, getProjectsLike) +import BDCS.Sources(findSources, getSource) +import BDCS.Utils.Either(maybeToEither) +import BDCS.Utils.Monad(concatMapM, mapMaybeM) +import qualified Codec.Archive.Tar as Tar +import qualified Control.Concurrent.ReadWriteLock as RWL +import Control.Concurrent.STM.TChan(writeTChan) +import Control.Concurrent.STM.TMVar(newEmptyTMVar, readTMVar) +import qualified Control.Exception.Safe as CES +import Control.Monad.STM(atomically) +import Control.Monad.Except +import Data.Aeson +import Data.Bifunctor(bimap) +import qualified Data.ByteString.Lazy as LBS +import Data.Either(partitionEithers, rights) +import Data.Int(Int64) +import Data.List(find, sortBy) +import Data.List.Extra(nubOrd) +import Data.Maybe(fromMaybe, mapMaybe) +import Data.String(IsString) +import Data.String.Conversions(ConvertibleStrings, cs) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Time.Clock(UTCTime) +import Database.Persist.Sql +import Data.GI.Base(GError(..)) +import Data.UUID.V4(nextRandom) +import GHC.TypeLits(KnownSymbol) +import qualified GI.Ggit as Git +import Servant +import System.Directory(createDirectoryIfMissing) +import System.FilePath.Posix((), takeFileName) + + +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +defaultBranch :: Maybe String -> T.Text +defaultBranch = maybe "master" cs + +unsupportedOutputMsg :: T.Text -> T.Text +unsupportedOutputMsg ty = T.concat [ + "Invalid compose type (", + ty, + "), must be one of ", + T.intercalate ", " (map exportTypeText supportedExportTypes)] + +-- Given a list of UUIDs, run mkComposeStatus on all of them and return only the results that +-- did not have any errors (like, from file IO). +filterMapComposeStatus :: MonadIO m => FilePath -> [T.Text] -> m [ComposeStatus] +filterMapComposeStatus dir lst = rights <$> mapM (liftIO . runExceptT . mkComposeStatus dir) lst + +-- These are the API routes. This is not documented in haddock because it doesn't format it correctly +type V0API = "projects" :> "list" :> QueryParam "offset" Int + :> QueryParam "limit" Int :> Get '[JSON] ProjectsListResponse + :<|> "projects" :> "info" :> Capture "project_names" String :> Get '[JSON] ProjectsInfoResponse + :<|> "projects" :> "depsolve" :> Capture "project_names" String :> Get '[JSON] ProjectsDepsolveResponse + :<|> "blueprints" :> "list" :> QueryParam "offset" Int + :> QueryParam "limit" Int + :> QueryParam "branch" String + :> Get '[JSON] RecipesListResponse + :<|> "blueprints" :> "info" :> Capture "recipes" String + :> QueryParam "branch" String + :> Get '[JSON] RecipesInfoResponse + :<|> "blueprints" :> "changes" :> Capture "recipes" String + :> QueryParam "offset" Int + :> QueryParam "limit" Int + :> QueryParam "branch" String + :> Get '[JSON] RecipesChangesResponse + :<|> "blueprints" :> "new" :> ReqBody '[JSON, TOML] Recipe + :> QueryParam "branch" String + :> Post '[JSON] APIResponse + :<|> "blueprints" :> "delete" :> Capture "recipe" String + :> QueryParam "branch" String + :> Delete '[JSON] APIResponse + :<|> "blueprints" :> "undo" :> Capture "recipe" String + :> Capture "commit" String + :> QueryParam "branch" String + :> Post '[JSON] APIResponse + :<|> "blueprints" :> "workspace" :> ReqBody '[JSON, TOML] Recipe + :> QueryParam "branch" String + :> Post '[JSON] APIResponse + :<|> "blueprints" :> "workspace" :> Capture "recipe" String + :> QueryParam "branch" String + :> Delete '[JSON] APIResponse + :<|> "blueprints" :> "tag" :> Capture "recipe" String + :> QueryParam "branch" String + :> Post '[JSON] APIResponse + :<|> "blueprints" :> "diff" :> Capture "recipe" String + :> Capture "from_commit" String + :> Capture "to_commit" String + :> QueryParam "branch" String + :> Get '[JSON] RecipesDiffResponse + :<|> "blueprints" :> "depsolve" :> Capture "recipes" String + :> QueryParam "branch" String + :> Get '[JSON] RecipesDepsolveResponse + :<|> "blueprints" :> "freeze" :> Capture "recipes" String + :> QueryParam "branch" String + :> Get '[JSON] RecipesFreezeResponse + :<|> "modules" :> "list" :> QueryParam "offset" Int + :> QueryParam "limit" Int + :> Get '[JSON] ModulesListResponse + :<|> "modules" :> "list" :> Capture "module_names" String + :> QueryParam "offset" Int + :> QueryParam "limit" Int + :> Get '[JSON] ModulesListResponse + :<|> "compose" :> ReqBody '[JSON] ComposeBody + :> QueryParam "test" Int + :> Post '[JSON] ComposeResponse + :<|> "compose" :> "types" :> Get '[JSON] ComposeTypesResponse + :<|> "compose" :> "queue" :> Get '[JSON] ComposeQueueResponse + :<|> "compose" :> "finished" :> Get '[JSON] ComposeFinishedResponse + :<|> "compose" :> "failed" :> Get '[JSON] ComposeFailedResponse + :<|> "compose" :> "status" :> Capture "uuids" String + :> Get '[JSON] ComposeStatusResponse + :<|> "compose" :> "info" :> Capture "uuid" String + :> Get '[JSON] ComposeInfoResponse + :<|> "compose" :> "cancel" :> Capture "uuid" String + :> Delete '[JSON] APIResponse + :<|> "compose" :> "delete" :> Capture "uuids" String + :> Delete '[JSON] ComposeDeleteResponse + :<|> "compose" :> "logs" :> Capture "uuid" String + :> Get '[OctetStream] (Headers '[Header "Content-Disposition" String] LBS.ByteString) + :<|> "compose" :> "image" :> Capture "uuid" String + :> Get '[OctetStream] (Headers '[Header "Content-Disposition" String] LBS.ByteString) + +-- | Connect the V0API type to all of the handlers +v0ApiServer :: ServerConfig -> Server V0API +v0ApiServer cfg = projectsListH + :<|> projectsInfoH + :<|> projectsDepsolveH + :<|> recipesListH + :<|> recipesInfoH + :<|> recipesChangesH + :<|> recipesNewH + :<|> recipesDeleteH + :<|> recipesUndoH + :<|> recipesWorkspaceH + :<|> recipesWorkspaceDeleteH + :<|> recipesTagH + :<|> recipesDiffH + :<|> recipesDepsolveH + :<|> recipesFreezeH + :<|> modulesListH + :<|> modulesListFilteredH + :<|> composeH + :<|> composeTypesH + :<|> composeQueueH + :<|> composeFinishedH + :<|> composeFailedH + :<|> composeStatusH + :<|> composeInfoH + :<|> composeCancelH + :<|> composeDeleteH + :<|> composeLogsH + :<|> composeImageH + where + projectsListH offset limit = projectsList cfg offset limit + projectsInfoH project_names = projectsInfo cfg project_names + projectsDepsolveH project_names = projectsDepsolve cfg project_names + recipesListH offset limit branch = recipesList cfg branch offset limit + recipesInfoH recipes branch = recipesInfo cfg branch recipes + recipesChangesH recipes offset limit branch = recipesChanges cfg branch recipes offset limit + recipesNewH recipe branch = recipesNew cfg branch recipe + recipesDeleteH recipe branch = recipesDelete cfg branch recipe + recipesUndoH recipe commit branch = recipesUndo cfg branch recipe commit + recipesWorkspaceH recipe branch = recipesWorkspace cfg branch recipe + recipesWorkspaceDeleteH recipe branch = recipesWorkspaceDelete cfg branch recipe + recipesTagH recipe branch = recipesTag cfg branch recipe + recipesDiffH recipe from_commit to_commit branch = recipesDiff cfg branch recipe from_commit to_commit + recipesDepsolveH recipes branch = recipesDepsolve cfg branch recipes + recipesFreezeH recipes branch = recipesFreeze cfg branch recipes + modulesListH offset limit = modulesList cfg offset limit "*" + modulesListFilteredH module_names offset limit = modulesList cfg offset limit module_names + composeH body test = compose cfg body test + composeTypesH = composeTypes + composeQueueH = composeQueue cfg + composeFinishedH = composeQueueFinished cfg + composeFailedH = composeQueueFailed cfg + composeStatusH uuids = composeStatus cfg (T.splitOn "," $ cs uuids) + composeInfoH uuid = composeInfo cfg uuid + composeCancelH uuid = composeCancel cfg uuid + composeDeleteH uuids = composeDelete cfg (T.splitOn "," $ cs uuids) + composeLogsH uuid = composeLogs cfg uuid + composeImageH uuid = composeImage cfg (cs uuid) + +-- | The JSON response for /blueprints/list +data RecipesListResponse = RecipesListResponse { + rlrRecipes :: [T.Text], -- ^ List of blueprint names + rlrOffset :: Int, -- ^ Pagination offset into results + rlrLimit :: Int, -- ^ Pagination limit of results + rlrTotal :: Int -- ^ Total number of blueprint names +} deriving (Show, Eq) + +instance ToJSON RecipesListResponse where + toJSON RecipesListResponse{..} = object [ + "blueprints" .= rlrRecipes + , "offset" .= rlrOffset + , "limit" .= rlrLimit + , "total" .= rlrTotal ] + +instance FromJSON RecipesListResponse where + parseJSON = withObject "/blueprints/list response" $ \o -> do + rlrRecipes <- o .: "blueprints" + rlrOffset <- o .: "offset" + rlrLimit <- o .: "limit" + rlrTotal <- o .: "total" + return RecipesListResponse{..} + +errorMessage :: (ConvertibleStrings a String, ConvertibleStrings b String) => a -> b -> String +errorMessage name msg = cs name ++ ": " ++ cs msg + +-- | /api/v0/blueprints/list +-- List the names of the available blueprints +-- +-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object +-- [@mbranch@]: The branch name +-- +-- > { +-- > "blueprints": [ +-- > "development", +-- > "glusterfs", +-- > "http-server", +-- > "jboss", +-- > "kubernetes", +-- > "octave", +-- > ], +-- > "offset": 0, +-- > "limit": 20, +-- > "total": 6 +-- > } +recipesList :: ServerConfig -> Maybe String -> Maybe Int -> Maybe Int -> Handler RecipesListResponse +recipesList ServerConfig{..} mbranch moffset mlimit = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do + -- TODO Figure out how to catch GitError and throw a ServantErr + filenames <- listBranchFiles (gitRepo cfgRepoLock) (defaultBranch mbranch) + let recipes = sortBy caseInsensitiveT $ map (T.dropEnd 5) filenames + return $ RecipesListResponse (applyLimits limit offset recipes) offset limit (length recipes) + where + -- handleGitErrors :: GitError -> ServantErr + -- handleGitErrors e = createAPIError err500 false ["recipes_list: Git Error: " ++ show e] + + -- | Return the offset or the default + offset :: Int + offset = fromMaybe 0 moffset + + -- | Return the limit or the default + limit :: Int + limit = fromMaybe 20 mlimit + + +-- | Status of a blueprint's workspace +data WorkspaceChanges = WorkspaceChanges { + wcName :: T.Text, -- ^ Blueprint name + wcChanged :: Bool -- ^ True when it is newer than the last commit +} deriving (Show, Eq) +instance ToJSON WorkspaceChanges where + toJSON WorkspaceChanges{..} = object [ + "name" .= wcName + , "changed" .= wcChanged ] + +instance FromJSON WorkspaceChanges where + parseJSON = withObject "workspace changes" $ \o -> do + wcName <- o .: "name" + wcChanged <- o .: "changed" + return WorkspaceChanges{..} + + +-- | The JSON response for /blueprints/info +data RecipesInfoResponse = RecipesInfoResponse { + rirChanges :: [WorkspaceChanges], -- ^ Workspace status for each blueprint + rirRecipes :: [Recipe], -- ^ The Recipe record + rirErrors :: [String] -- ^ Errors reading the blueprint +} deriving (Show, Eq) + +instance ToJSON RecipesInfoResponse where + toJSON RecipesInfoResponse{..} = object [ + "changes" .= rirChanges + , "blueprints" .= rirRecipes + , "errors" .= rirErrors ] + +instance FromJSON RecipesInfoResponse where + parseJSON = withObject "/blueprints/info response" $ \o -> do + rirChanges <- o .: "changes" + rirRecipes <- o .: "blueprints" + rirErrors <- o .: "errors" + return RecipesInfoResponse{..} + + +-- | /api/v0/blueprints/info/\ +-- Return the contents of the blueprint, or a list of recipes +-- +-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object +-- [@mbranch@]: The branch name +-- [@recipes_names@]: A comma separated list of blueprint names +-- +-- The errors list may be empty, or may include blueprint-specific errors if +-- there was a problem retrieving it. +-- +-- > { +-- > "changes": [ +-- > { +-- > "name": "blueprint-test", +-- > "changed": true +-- > }, +-- > ], +-- > "blueprints": [ +-- > { +-- > "name": "http-server", +-- > "description": "An example http server with PHP and MySQL support.", +-- > "version": "0.0.1", +-- > "modules": [ +-- > { +-- > "name": "httpd", +-- > "version": "2.4.*" +-- > }, +-- > { +-- > "name": "mod_auth_kerb", +-- > "version": "5.4" +-- > }, +-- > { +-- > "name": "mod_ssl", +-- > "version": "2.4.*" +-- > }, +-- > { +-- > "name": "php", +-- > "version": "5.4.*" +-- > }, +-- > { +-- > "name": "php-mysql", +-- > "version": "5.4.*" +-- > } +-- > ], +-- > "packages": [ +-- > { +-- > "name": "tmux", +-- > "version": "2.2" +-- > }, +-- > { +-- > "name": "openssh-server", +-- > "version": "6.6.*" +-- > }, +-- > { +-- > "name": "rsync", +-- > "version": "3.0.*" +-- > } +-- > ] +-- > }, +-- > "errors": ["a-missing-blueprint: Error retrieving a-missing-blueprint.toml"] +-- > } +-- +recipesInfo :: ServerConfig -> Maybe String -> String -> Handler RecipesInfoResponse +recipesInfo ServerConfig{..} branch recipe_names = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do + let recipe_name_list = map T.pack (argify [recipe_names]) + (changes, recipes, errors) <- allRecipeInfo recipe_name_list [] [] [] + return $ RecipesInfoResponse changes recipes errors + where + allRecipeInfo :: [T.Text] -> [WorkspaceChanges] -> [Recipe] -> [String] -> IO ([WorkspaceChanges], [Recipe], [String]) + allRecipeInfo [] _ _ _ = return ([], [], []) + allRecipeInfo [recipe_name] changes_list recipes_list errors_list = + oneRecipeInfo recipe_name changes_list recipes_list errors_list + allRecipeInfo (recipe_name:xs) changes_list recipes_list errors_list = do + (new_changes, new_recipes, new_errors) <- oneRecipeInfo recipe_name changes_list recipes_list errors_list + allRecipeInfo xs new_changes new_recipes new_errors + + oneRecipeInfo :: T.Text -> [WorkspaceChanges] -> [Recipe] -> [String] -> IO ([WorkspaceChanges], [Recipe], [String]) + oneRecipeInfo recipe_name changes_list recipes_list errors_list = do + result <- getRecipeInfo cfgRepoLock (defaultBranch branch) recipe_name + return (new_changes result, new_recipes result, new_errors result) + where + new_errors :: Either String (Bool, Recipe) -> [String] + new_errors (Left err) = errorMessage recipe_name err:errors_list + new_errors (Right _) = errors_list + + new_changes :: Either String (Bool, Recipe) -> [WorkspaceChanges] + new_changes (Right (changed, _)) = WorkspaceChanges recipe_name changed:changes_list + new_changes (Left _) = changes_list + + new_recipes :: Either String (Bool, Recipe) -> [Recipe] + new_recipes (Right (_, recipe)) = recipe:recipes_list + new_recipes (Left _) = recipes_list + +-- | Get the recipe from the workspace or from git +-- If there is neither workspace or git recipes then an error is returned. +getRecipeInfo :: GitLock -> T.Text -> T.Text -> IO (Either String (Bool, Recipe)) +getRecipeInfo repoLock branch recipe_name = do + result <- getRecipeAndCommit repoLock branch recipe_name + case result of + Left e -> return $ Left e + Right (changed, (_, recipe)) -> return $ Right (changed, recipe) + +getRecipeAndCommit :: GitLock -> T.Text -> T.Text -> IO (Either String (Bool, (T.Text, Recipe))) +getRecipeAndCommit repoLock branch recipe_name = do + -- read the workspace recipe if it exists, errors are mapped to Nothing + ws_recipe <- catch_ws_recipe + -- read the git recipe (if it exists), Errors are mapped to Left + git_recipe <- catch_git_recipe + + case (ws_recipe, git_recipe) of + (Nothing, Left e) -> return $ Left e + (Just recipe, Left _) -> return $ Right (True, ("WORKSPACE", recipe)) + (Nothing, Right (commit_id, recipe)) -> return $ Right (False, (commit_id, recipe)) + (Just ws_r, Right (commit_id, git_r)) -> return $ commit_result ws_r commit_id git_r + where + commit_result ws_r commit_id git_r = Right (changed, (commit, ws_r)) + where + changed = ws_r /= git_r + commit = if changed + then "WORKSPACE" + else commit_id + + -- | Read the recipe from the workspace, and convert WorkspaceErrors into Nothing + catch_ws_recipe :: IO (Maybe Recipe) + catch_ws_recipe = + CES.catch (workspaceRead (gitRepo repoLock) branch recipe_name) + (\(_ :: WorkspaceError) -> return Nothing) + + -- | Read the recipe from git, and convert errors into Left descriptions of what went wrong. + catch_git_recipe :: IO (Either String (T.Text, Recipe)) + catch_git_recipe = + CES.catches (readRecipeCommit (gitRepo repoLock) branch recipe_name Nothing) + [CES.Handler (\(e :: GitError) -> return $ Left (show e)), + CES.Handler (\(e :: GError) -> return $ Left (show e))] + + +-- | Details about commits to a blueprint +data RecipeChanges = RecipeChanges { + rcName :: T.Text, -- ^ Blueprint name + rcChange :: [CommitDetails], -- ^ Details of the commit + rcTotal :: Int -- ^ Total number of commits +} deriving (Show, Eq) + +instance ToJSON RecipeChanges where + toJSON RecipeChanges{..} = object [ + "name" .= rcName + , "change" .= rcChange + , "total" .= rcTotal ] + +instance FromJSON RecipeChanges where + parseJSON = withObject "blueprint changes" $ \o -> do + rcName <- o .: "name" + rcChange <- o .: "change" + rcTotal <- o .: "total" + return RecipeChanges{..} + + +-- The JSON response for /blueprints/changes +data RecipesChangesResponse = RecipesChangesResponse { + rcrRecipes :: [RecipeChanges], -- ^ Changes for each blueprint + rcrErrors :: [String], -- ^ Any errors for the requested changes + rcrOffset :: Int, -- ^ Pagination offset + rcrLimit :: Int -- ^ Pagination limit +} deriving (Show, Eq) + +instance ToJSON RecipesChangesResponse where + toJSON RecipesChangesResponse{..} = object [ + "blueprints" .= rcrRecipes + , "errors" .= rcrErrors + , "offset" .= rcrOffset + , "limit" .= rcrLimit ] + +instance FromJSON RecipesChangesResponse where + parseJSON = withObject "/blueprints/changes/ response" $ \o -> do + rcrRecipes <- o .: "blueprints" + rcrErrors <- o .: "errors" + rcrOffset <- o .: "offset" + rcrLimit <- o .: "limit" + return RecipesChangesResponse{..} + + +-- | /api/v0/blueprints/changes/\ +-- Return the commit history of the blueprints +-- +-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object +-- [@mbranch@]: The branch name +-- [@recipes_name@]: The blueprint name +-- [@moffset@]: The offset from the start of the results. Defaults to 0 +-- [@mlimit@]: Limit to the number of results to be returned. Defaults to 20 +-- +-- The changes for each listed blueprint will have offset and limit applied to them. +-- This means that there will be cases where changes will be empty, when offset > total +-- for the blueprint. +-- +-- If a blueprint commit has been tagged as a new revision the changes will include a +-- `revision` field set to the revision number. If the commit has not been tagged it +-- will not have this field included. +-- +-- > { +-- > "blueprints": [ +-- > { +-- > "name": "nfs-server", +-- > "changes": [ +-- > { +-- > "commit": "97d483e8dd0b178efca9a805e5fd8e722c48ac8e", +-- > "time": "Wed, 1 Mar 2017 13:29:37 -0800", +-- > "summary": "Recipe nfs-server saved" +-- > }, +-- > { +-- > "commit": "857e1740f983bf033345c3242204af0ed7b81f37", +-- > "time": "Wed, 1 Mar 2017 09:28:53 -0800", +-- > "summary": "Recipe nfs-server saved", +-- > "revision" : 1 +-- > } +-- > ], +-- > "total": 2 +-- > }, +-- > { +-- > "name": "ruby", +-- > "changes": [ +-- > { +-- > "commit": "4b84f072befc3f4debbe1348d6f4b166f7c83d78", +-- > "time": "Wed, 1 Mar 2017 13:32:09 -0800", +-- > "summary": "Recipe ruby saved" +-- > }, +-- > { +-- > "commit": "85999253c1790367a860a344ea622971b7e0a050", +-- > "time": "Wed, 1 Mar 2017 13:31:19 -0800", +-- > "summary": "Recipe ruby saved" +-- > } +-- > ], +-- > "total": 2 +-- > } +-- > ], +-- > "errors": ["a-missing-recipe: Error retrieving a-missing-blueprint.toml"] +-- > "offset": 0, +-- > "limit": 20 +-- > } +recipesChanges :: ServerConfig -> Maybe String -> String -> Maybe Int -> Maybe Int -> Handler RecipesChangesResponse +recipesChanges ServerConfig{..} mbranch recipe_names moffset mlimit = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do + let recipe_name_list = map T.pack (argify [recipe_names]) + (changes, errors) <- allRecipeChanges recipe_name_list [] [] + return $ RecipesChangesResponse changes errors offset limit + where + allRecipeChanges :: [T.Text] -> [RecipeChanges] -> [String] -> IO ([RecipeChanges], [String]) + allRecipeChanges [] _ _ = return ([], []) + allRecipeChanges [recipe_name] changes_list errors_list = + oneRecipeChange recipe_name changes_list errors_list + allRecipeChanges (recipe_name:xs) changes_list errors_list = do + (new_changes, new_errors) <- oneRecipeChange recipe_name changes_list errors_list + allRecipeChanges xs new_changes new_errors + + oneRecipeChange :: T.Text -> [RecipeChanges] -> [String] -> IO ([RecipeChanges], [String]) + oneRecipeChange recipe_name changes_list errors_list = do + result <- catch_recipe_changes recipe_name + return (new_changes result, new_errors result) + where + new_changes :: Either String [CommitDetails] -> [RecipeChanges] + new_changes (Right changes) = RecipeChanges recipe_name (applyLimits limit offset changes) (length $ applyLimits limit offset changes):changes_list + new_changes (Left _) = changes_list + + new_errors :: Either String [CommitDetails] -> [String] + new_errors (Left err) = errorMessage recipe_name err:errors_list + new_errors (Right _) = errors_list + + offset :: Int + offset = fromMaybe 0 moffset + + limit :: Int + limit = fromMaybe 20 mlimit + + catch_recipe_changes :: T.Text -> IO (Either String [CommitDetails]) + catch_recipe_changes recipe_name = + CES.catches (Right <$> listRecipeCommits (gitRepo cfgRepoLock) (defaultBranch mbranch) recipe_name) + [CES.Handler (\(e :: GitError) -> return $ Left (show e)), + CES.Handler (\(e :: GError) -> return $ Left (show e))] + + +-- | POST /api/v0/blueprints/new +-- Create or update a blueprint. +-- +-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object +-- [@mbranch@]: The branch name +-- [@recipe@]: The blueprint record +-- +-- The body of the post is a JSON or TOML representation of the blueprint. If Conten-Type is application/json +-- it uses the same format received from /api/v0/blueprints/info/\, and if it is text/x-toml it uses +-- the blueprint's TOML format for the body. +-- +-- The response for a successful POST is: +-- +-- > { +-- > "status": true, +-- > "errors": [] +-- > } +recipesNew :: ServerConfig -> Maybe String -> Recipe -> Handler APIResponse +recipesNew ServerConfig{..} mbranch recipe = do + result <- liftIO $ RWL.withWrite (gitRepoLock cfgRepoLock) catch_recipe_new + case result of + Left err -> throwError $ createAPIError err400 False [errorMessage ("Unknown:" :: String) err] + Right _ -> return $ APIResponse True [] + where + catch_recipe_new :: IO (Either String Git.OId) + catch_recipe_new = + CES.catches (Right <$> commitRecipe (gitRepo cfgRepoLock) (defaultBranch mbranch) recipe) + [CES.Handler (\(e :: GitError) -> return $ Left (show e)), + CES.Handler (\(e :: GError) -> return $ Left (show e))] + + +-- | DELETE /api/v0/blueprints/delete/\ +-- Delete the named blueprint from the repository branch +-- +-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object +-- [@mbranch@]: The branch name +-- [@recipe_name@]: The blueprint name +-- +-- The response for a successful DELETE is: +-- +-- > { +-- > "status": true, +-- > "errors": [] +-- > } +recipesDelete :: ServerConfig -> Maybe String -> String -> Handler APIResponse +recipesDelete ServerConfig{..} mbranch recipe_name = do + result <- liftIO $ RWL.withWrite (gitRepoLock cfgRepoLock) catch_recipe_delete + case result of + Left err -> throwError $ createAPIError err400 False [errorMessage recipe_name err] + Right _ -> return $ APIResponse True [] + where + catch_recipe_delete :: IO (Either String Git.OId) + catch_recipe_delete = + CES.catches (Right <$> deleteRecipe (gitRepo cfgRepoLock) (defaultBranch mbranch) (T.pack recipe_name)) + [CES.Handler (\(e :: GitError) -> return $ Left (show e)), + CES.Handler (\(e :: GError) -> return $ Left (show e))] + + +-- | POST /api/v0/blueprints/undo/\/\ +-- Revert a blueprint to a previous commit +-- +-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object +-- [@mbranch@]: The branch name +-- [@recipe_name@]: The blueprint name +-- [@commit@]: The commit to revert to +-- +-- The response for a successful POST is: +-- +-- > { +-- > "status": true, +-- > "errors": [] +-- > } +recipesUndo :: ServerConfig -> Maybe String -> String -> String -> Handler APIResponse +recipesUndo ServerConfig{..} mbranch recipe_name commit = do + result <- liftIO $ RWL.withWrite (gitRepoLock cfgRepoLock) catch_recipe_undo + case result of + Left err -> throwError $ createAPIError err400 False [errorMessage recipe_name err] + Right _ -> return $ APIResponse True [] + where + catch_recipe_undo :: IO (Either String Git.OId) + catch_recipe_undo = + CES.catches (Right <$> revertRecipe (gitRepo cfgRepoLock) (defaultBranch mbranch) (T.pack recipe_name) (T.pack commit)) + [CES.Handler (\(e :: GitError) -> return $ Left (show e)), + CES.Handler (\(e :: GError) -> return $ Left (show e))] + + +-- | POST /api/v0/blueprints/workspace +-- Update the temporary blueprint workspace +-- +-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object +-- [@mbranch@]: The branch name +-- [@recipe@]: The blueprint record +-- +-- The body of the post is the same as /blueprints/new/. For more details on the +-- workspace see "BDCS.API.Workspace" +-- +-- The response for a successful POST is: +-- +-- > { +-- > "status": true, +-- > "errors": [] +-- > } +recipesWorkspace :: ServerConfig -> Maybe String -> Recipe -> Handler APIResponse +recipesWorkspace ServerConfig{..} mbranch recipe = do + result <- liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) catch_recipe_ws + case result of + Left err -> throwError $ createAPIError err400 False [errorMessage ("Unknown: " :: String) err] + Right _ -> return $ APIResponse True [] + where + catch_recipe_ws :: IO (Either String ()) + catch_recipe_ws = + CES.catches (Right <$> workspaceWrite (gitRepo cfgRepoLock) (defaultBranch mbranch) recipe) + [CES.Handler (\(e :: GitError) -> return $ Left (show e)), + CES.Handler (\(e :: GError) -> return $ Left (show e))] + + +-- | DELETE /api/v0/blueprints/workspace/\ +-- Delete the named blueprint from the workspace +-- +-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object +-- [@mbranch@]: The branch name +-- [@recipe_name@]: The blueprint name +-- +-- The response for a successful DELETE is: +-- +-- > { +-- > "status": true, +-- > "errors": [] +-- > } +recipesWorkspaceDelete :: ServerConfig -> Maybe String -> String -> Handler APIResponse +recipesWorkspaceDelete ServerConfig{..} mbranch recipe_name = do + result <- liftIO $ RWL.withWrite (gitRepoLock cfgRepoLock) catch_recipe_delete + case result of + Left err -> throwError $ createAPIError err400 False [errorMessage recipe_name err] + Right _ -> return $ APIResponse True [] + where + catch_recipe_delete :: IO (Either String ()) + catch_recipe_delete = + CES.catches (Right <$> workspaceDelete (gitRepo cfgRepoLock) (defaultBranch mbranch) (T.pack recipe_name)) + [CES.Handler (\(e :: GitError) -> return $ Left (show e)), + CES.Handler (\(e :: GError) -> return $ Left (show e))] + + +-- | POST /api/v0/blueprints/tag/ +-- Tag the most recent blueprint commit as the next revision +-- +-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object +-- [@mbranch@]: The branch name +-- [@recipe_name@]: The blueprint name +-- +-- If the commit is already tagged it will return False. +-- +-- The response for a successful POST is: +-- +-- > { +-- > "status": true, +-- > "errors": [] +-- > } +recipesTag :: ServerConfig -> Maybe String -> String -> Handler APIResponse +recipesTag ServerConfig{..} mbranch recipe_name = do + result <- liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) catch_recipe_tag + case result of + Left err -> throwError $ createAPIError err400 False ["Unknown: " ++ cs err] + Right status -> return $ APIResponse status [] + where + catch_recipe_tag :: IO (Either String Bool) + catch_recipe_tag = + CES.catches (Right <$> tagRecipeCommit (gitRepo cfgRepoLock) (defaultBranch mbranch) (T.pack recipe_name)) + [CES.Handler (\(e :: GitError) -> return $ Left (show e)), + CES.Handler (\(e :: GError) -> return $ Left (show e))] + + +-- | JSON response for /blueprints/diff +data RecipesDiffResponse = RecipesDiffResponse { + rdrDiff :: [RecipeDiffEntry] +} deriving (Eq, Show) + +instance ToJSON RecipesDiffResponse where + toJSON RecipesDiffResponse{..} = object [ + "diff" .= rdrDiff ] + +instance FromJSON RecipesDiffResponse where + parseJSON = withObject "/blueprints/diff response" $ \o -> do + rdrDiff <- o .: "diff" + return RecipesDiffResponse{..} + +-- | /api/v0/blueprints/diff/// +-- Return the diff between the two blueprint commits. +-- +-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object +-- [@mbranch@]: The branch name +-- [@recipe_name@]: The blueprint name +-- [@from_commit@]: The older commit to caclulate the difference from, can also be NEWEST +-- [@to_commit@]: The newer commit to calculate the diff. to, can also be NEWEST or WORKSPACE +-- +-- If there is an error retrieving a commit (eg. it cannot find the hash), it will use HEAD +-- instead and log an error. +-- +-- +-- In addition to the commit hashes listed by a call to /blueprints/changes/\ you +-- can use NEWEST to compare the latest commit, and WORKSPACE to compare it with +-- the current temporary workspace version of the blueprint. eg. to see what the differences +-- are between the current workspace and most recent commit of http-server you would call: +-- +-- > /blueprints/diff/http-server/NEWEST/WORKSPACE +-- +-- Each entry in the response's diff object contains the old blueprint value and the new one. +-- If old is null and new is set, then it was added. +-- If new is null and old is set, then it was removed. +-- If both are set, then it was changed. +-- +-- The old/new entries will have the name of the blueprint field that was changed. This +-- can be one of: Name, Description, Version, Module, or Package. +-- The contents for these will be the old/new values for them. +-- +-- In the example below the description and version were changed. The php module's +-- version was changed, the rsync package was removed, and the vim-enhanced package +-- was added. +-- +-- # Examples +-- +-- > { +-- > "diff": [ +-- > { +-- > "old": { +-- > "Description": "An example http server with PHP and MySQL support." +-- > }, +-- > "new": { +-- > "Description": "Apache HTTP Server" +-- > } +-- > }, +-- > { +-- > "old": { +-- > "Version": "0.0.1" +-- > }, +-- > "new": { +-- > "Version": "0.1.1" +-- > } +-- > }, +-- > { +-- > "old": { +-- > "Module": { +-- > "name": "php", +-- > "version": "5.4.*" +-- > } +-- > }, +-- > "new": { +-- > "Module": { +-- > "name": "php", +-- > "version": "5.6.*" +-- > } +-- > } +-- > }, +-- > { +-- > "old": null, +-- > "new": { +-- > "Package": { +-- > "name": "vim-enhanced", +-- > "version": "8.0.*" +-- > } +-- > } +-- > }, +-- > { +-- > "old": { +-- > "Package": { +-- > "name": "rsync", +-- > "version": "3.0.*" +-- > } +-- > }, +-- > "new": null +-- > } +-- > ] +-- > } +recipesDiff :: ServerConfig -> Maybe String -> String -> String -> String -> Handler RecipesDiffResponse +recipesDiff ServerConfig{..} mbranch recipe_name from_commit to_commit = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do + -- Setup old_recipe + -- NEWEST == read the latest git commit for recipe_name + -- Otherwise try to read the passed-in commit hash string + old_recipe <- get_recipe from_commit + + -- Setup new_recipe + -- WORKSPACE == read the recipe's workspace + -- NEWEST == read the latest git commit for recipe_name + -- Otherwise try to read the passed-in commit hash string + new_recipe <- get_recipe to_commit + + case (old_recipe, new_recipe) of + (Left _, _) -> return $ RecipesDiffResponse [] + (_, Left _) -> return $ RecipesDiffResponse [] + (Right (_, o), Right (_, n)) -> do + let diff = recipeDiff o n + return $ RecipesDiffResponse diff + where + get_recipe :: String -> IO (Either String (T.Text, Recipe)) + get_recipe "NEWEST" = catch_git_recipe (T.pack recipe_name) Nothing + get_recipe "WORKSPACE" = do + ws_recipe <- catch_ws_recipe (T.pack recipe_name) + -- If there is no workspace recipe fall back to most recent commit + case ws_recipe of + Just recipe -> return $ Right ("WORKSPACE", recipe) + Nothing -> get_recipe "NEWEST" + get_recipe commit = catch_git_recipe (T.pack recipe_name) (Just $ T.pack commit) + + -- | Read the recipe from the workspace, and convert WorkspaceErrors into Nothing + catch_ws_recipe :: T.Text -> IO (Maybe Recipe) + catch_ws_recipe name = + CES.catch (workspaceRead (gitRepo cfgRepoLock) (defaultBranch mbranch) name) + (\(_ :: WorkspaceError) -> return Nothing) + + -- | Read the recipe from git, and convert errors into Left descriptions of what went wrong. + catch_git_recipe :: T.Text -> Maybe T.Text -> IO (Either String (T.Text, Recipe)) + catch_git_recipe name commit = + CES.catches (readRecipeCommit (gitRepo cfgRepoLock) (defaultBranch mbranch) name commit) + [CES.Handler (\(e :: GitError) -> return $ Left (show e)), + CES.Handler (\(e :: GError) -> return $ Left (show e))] + + +-- | The blueprint's dependency details +data RecipeDependencies = RecipeDependencies { + rdRecipe :: Recipe, + rdDependencies :: [PackageNEVRA], + rdModules :: [PackageNEVRA] +} deriving (Show, Eq) + +instance ToJSON RecipeDependencies where + toJSON RecipeDependencies{..} = object [ + "blueprint" .= rdRecipe + , "dependencies" .= rdDependencies + , "modules" .= rdModules ] + +instance FromJSON RecipeDependencies where + parseJSON = withObject "blueprint dependencies" $ \o -> do + rdRecipe <- o .: "blueprint" + rdDependencies <- o .: "dependencies" + rdModules <- o .: "modules" + return RecipeDependencies{..} + + +-- | The JSON response for /blueprints/depsolve/ +data RecipesDepsolveResponse = RecipesDepsolveResponse { + rdrRecipes :: [RecipeDependencies], -- ^ List of blueprints and their dependencies + rdrErrors :: [String] -- ^ Errors reading the blueprint +} deriving (Show, Eq) + +instance ToJSON RecipesDepsolveResponse where + toJSON RecipesDepsolveResponse{..} = object [ + "blueprints" .= rdrRecipes + , "errors" .= rdrErrors ] + +instance FromJSON RecipesDepsolveResponse where + parseJSON = withObject "/blueprints/depsolve response" $ \o -> do + rdrRecipes <- o .: "blueprints" + rdrErrors <- o .: "errors" + return RecipesDepsolveResponse{..} + +-- | /api/v0/blueprints/depsolve/ +-- Return the blueprint and summary information about all of its modules and packages. +-- +-- [@pool@]: The sqlite connection pool object +-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object +-- [@mbranch@]: The branch name +-- [@recipe_names@]: The blueprint names to depsolve, comma-separated if there is more than one +-- +-- If a workspace version of the blueprint is found it will be used for the depsolve. If there are +-- any errors reading the blueprint, or depsolving it, they will be returned in the 'errors' object. +-- +-- # Error example +-- +-- > { +-- > "errors": ["nfs-server.toml is not present on branch master"], +-- > "blueprints": [] +-- > } +-- +-- +-- A successful result will include 3 items. 'dependencies' will be the NEVRAs of all of the +-- projects needed to satisfy the blueprint's dependencies. 'modules' will be the project NEVRAs +-- for the modules and packages explicitly listed in the blueprint, and 'blueprint' will be a copy of +-- the blueprint that was depsolved. +-- +-- # Abbreviated successful example +-- +-- > { +-- > "errors": [], +-- > "blueprints": [ +-- > { +-- > "dependencies": [ +-- > { +-- > "arch": "x86_64", +-- > "epoch": 0, +-- > "name": "apr", +-- > "release": "3.el7", +-- > "version": "1.4.8" +-- > }, +-- > { +-- > "arch": "x86_64", +-- > "epoch": 0, +-- > "name": "apr-util", +-- > "release": "6.el7", +-- > "version": "1.5.2" +-- > }, +-- > ... +-- > ], +-- > "modules": [ +-- > { +-- > "arch": "x86_64", +-- > "epoch": 0, +-- > "name": "httpd", +-- > "release": "67.el7", +-- > "version": "2.4.6" +-- > }, +-- > { +-- > "arch": "x86_64", +-- > "epoch": 0, +-- > "name": "mod_auth_kerb", +-- > "release": "28.el7", +-- > "version": "5.4" +-- > }, +-- > ... +-- > ], +-- > "blueprint": { +-- > "description": "An example http server with PHP and MySQL support.", +-- > "modules": [ +-- > { +-- > "name": "httpd", +-- > "version": "2.4.*" +-- > }, +-- > { +-- > "name": "mod_auth_kerb", +-- > "version": "5.4" +-- > }, +-- > { +-- > "name": "mod_ssl", +-- > "version": "2.4.*" +-- > }, +-- > { +-- > "name": "php", +-- > "version": "5.4.*" +-- > }, +-- > { +-- > "name": "php-mysql", +-- > "version": "5.4.*" +-- > } +-- > ], +-- > "name": "http-server", +-- > "packages": [ +-- > { +-- > "name": "tmux", +-- > "version": "2.2" +-- > }, +-- > { +-- > "name": "openssh-server", +-- > "version": "6.6.*" +-- > }, +-- > { +-- > "name": "rsync", +-- > "version": "3.0.*" +-- > } +-- > ], +-- > "version": "0.2.0" +-- > } +-- > } +-- > ] +-- > } +recipesDepsolve :: ServerConfig -> Maybe String -> String -> Handler RecipesDepsolveResponse +recipesDepsolve ServerConfig{..} mbranch recipe_names = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do + let recipe_name_list = map T.pack (argify [recipe_names]) + (recipes, errors) <- liftIO $ allRecipeDeps recipe_name_list + return $ RecipesDepsolveResponse recipes errors + where + allRecipeDeps :: [T.Text] -> IO ([RecipeDependencies], [String]) + allRecipeDeps recipeNames = do + -- Convert the list of names into a list of Recipes. Also collect a list of errors + -- that occurred while doing the conversion. We don't simply stop on the first error. + results <- mapM (getOneRecipeInfo cfgRepoLock (defaultBranch mbranch)) recipeNames + let (errors, recipes) = partitionEithers results + + -- Depsolve each recipe, also gathering up any errors from this process as well. Because + -- depsolveRecipe lives elsewhere and therefore cannot return types defined in this file, + -- it returns more generic things lacking the recipe name. Thus, here we must convert + -- both possibilities of the return type. + results' <- mapM (\r -> bimap (toRecipesAPIError r) + (toRecipeDependencies r) + <$> depsolveRecipe cfgPool r) + recipes + let (depErrors, deps) = partitionEithers results' + return (deps, errors ++ depErrors) + + toRecipesAPIError :: Recipe -> T.Text -> String + toRecipesAPIError Recipe{..} msg = errorMessage rName msg + + toRecipeDependencies :: Recipe -> ([PackageNEVRA], [PackageNEVRA]) -> RecipeDependencies + toRecipeDependencies recipe (deps, mods) = + RecipeDependencies { rdRecipe=recipe, rdDependencies=deps, rdModules=mods } + + getOneRecipeInfo :: GitLock -> T.Text -> T.Text -> IO (Either String Recipe) + getOneRecipeInfo lock branch name = + getRecipeInfo lock branch name >>= \case + Left err -> return $ Left $ errorMessage name err + Right (_, r) -> return $ Right r + + +-- | The JSON response for /blueprints/freeze/ +data RecipesFreezeResponse = RecipesFreezeResponse { + rfrRecipes :: [Recipe], -- ^ Recipes with exact versions + rfrErrors :: [String] -- ^ Errors reading the blueprint +} deriving (Show, Eq) + +instance ToJSON RecipesFreezeResponse where + toJSON RecipesFreezeResponse{..} = object [ + "blueprints" .= rfrRecipes + , "errors" .= rfrErrors ] + +instance FromJSON RecipesFreezeResponse where + parseJSON = withObject "/blueprints/freeze response" $ \o -> do + rfrRecipes <- o .: "blueprints" + rfrErrors <- o .: "errors" + return RecipesFreezeResponse{..} + +-- | /api/v0/blueprints/freeze/ +-- Return the contents of the blueprint with frozen dependencies instead of expressions. +-- +-- This depsolves the blueprint, and then replaces the modules and packages versions with +-- the EVR found by the depsolve, returning a frozen blueprint. +-- +-- # Examples +-- +-- > { +-- > "errors": [], +-- > "blueprints": [ +-- > { +-- > "description": "An example http server with PHP and MySQL support.", +-- > "modules": [ +-- > { +-- > "name": "httpd", +-- > "version": "2.4.6-67.el7" +-- > }, +-- > { +-- > "name": "mod_auth_kerb", +-- > "version": "5.4-28.el7" +-- > }, +-- > { +-- > "name": "mod_ssl", +-- > "version": "1:2.4.6-67.el7" +-- > }, +-- > { +-- > "name": "php", +-- > "version": "5.4.16-42.el7" +-- > }, +-- > { +-- > "name": "php-mysql", +-- > "version": "5.4.16-42.el7" +-- > } +-- > ], +-- > "name": "http-server", +-- > "packages": [ +-- > { +-- > "name": "tmux", +-- > "version": "1.8-4.el7" +-- > }, +-- > { +-- > "name": "openssh-server", +-- > "version": "7.4p1-11.el7" +-- > }, +-- > { +-- > "name": "rsync", +-- > "version": "3.0.9-18.el7" +-- > } +-- > ], +-- > "version": "0.2.0" +-- > } +-- > ] +-- > } +recipesFreeze :: ServerConfig -> Maybe String -> String -> Handler RecipesFreezeResponse +recipesFreeze ServerConfig{..} mbranch recipe_names = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do + let recipe_name_list = map T.pack (argify [recipe_names]) + (recipes, errors) <- liftIO $ allRecipeDeps recipe_name_list + return $ RecipesFreezeResponse recipes errors + where + allRecipeDeps :: [T.Text] -> IO ([Recipe], [String]) + allRecipeDeps recipeNames = do + -- Convert the list of names into a list of Recipes. Also collect a list of errors + -- that occurred while doing the conversion. We don't simply stop on the first error. + results <- mapM (getOneRecipeInfo cfgRepoLock (defaultBranch mbranch)) recipeNames + let (errors, recipes) = partitionEithers results + + -- Depsolve each recipe, also gathering up any errors from this process as well. Because + -- depsolveRecipe lives elsewhere and therefore cannot return types defined in this file, + -- it returns more generic things lacking the recipe name. Thus, here we must convert + -- both possibilities of the return type. + -- + -- Additionally, here we must replace everything with the frozen version numbers. + results' <- mapM (\r -> bimap (toRecipesAPIError r) + (frozenRecipe r) + <$> depsolveRecipe cfgPool r) + recipes + let (depErrors, recipes') = partitionEithers results' + return (recipes', errors ++ depErrors) + + toRecipesAPIError :: Recipe -> T.Text -> String + toRecipesAPIError Recipe{..} msg = errorMessage rName msg + + getOneRecipeInfo :: GitLock -> T.Text -> T.Text -> IO (Either String Recipe) + getOneRecipeInfo lock branch name = + getRecipeInfo lock branch name >>= \case + Left err -> return $ Left $ errorMessage name err + Right (_, r) -> return $ Right r + + -- Replace the recipe's module and package versions with the EVR selected by depsolving + frozenRecipe :: Recipe -> ([PackageNEVRA], [PackageNEVRA]) -> Recipe + frozenRecipe recipe (dep_nevras, _) = do + let new_modules = getFrozenModules (rModules recipe) dep_nevras + let new_packages= getFrozenModules (rPackages recipe) dep_nevras + recipe { rModules = new_modules, rPackages = new_packages } + + -- Get a frozen list of projects using the depsolved NEVRAs + getFrozenModules :: [RecipeModule] -> [PackageNEVRA] -> [RecipeModule] + getFrozenModules recipe_modules all_nevras = mapMaybe (getFrozenRecipeModule all_nevras) recipe_modules + + getFrozenRecipeModule :: [PackageNEVRA] -> RecipeModule -> Maybe RecipeModule + getFrozenRecipeModule all_nevras recipe_module = + lookupRecipeModule recipe_module all_nevras >>= \module_nevra -> + Just (frozenRecipeModule recipe_module module_nevra) + + -- Lookup a RecipeModule in the list of depsolved packages + lookupRecipeModule :: RecipeModule -> [PackageNEVRA] -> Maybe PackageNEVRA + lookupRecipeModule recipe_module all_nevras = find (\e -> pnName e == T.pack (rmName recipe_module)) all_nevras + + -- Create a new RecipeModule with frozen version + frozenRecipeModule :: RecipeModule -> PackageNEVRA -> RecipeModule + frozenRecipeModule rm pn = rm { rmVersion = getVersionFromNEVRA pn } + + -- Convert a PackageNEVRA to a string for RecipeModule + -- eg. 2:3.1.4-22.fc27 + getVersionFromNEVRA :: PackageNEVRA -> String + getVersionFromNEVRA nevra = T.unpack $ T.concat [epoch $ pnEpoch nevra, pnVersion nevra, "-", pnRelease nevra] + where + epoch Nothing = "" + epoch (Just e) = T.pack (show e) `T.append` ":" + +-- | The JSON response for /projects/list +data ProjectsListResponse = ProjectsListResponse { + plpProjects :: [Projects], -- ^ List of project names + plpOffset :: Int, -- ^ Pagination offset into results + plpLimit :: Int, -- ^ Pagination limit of results + plpTotal :: Int -- ^ Total number of project names +} deriving (Show, Eq) + +instance ToJSON ProjectsListResponse where + toJSON ProjectsListResponse{..} = object [ + "projects" .= plpProjects + , "offset" .= plpOffset + , "limit" .= plpLimit + , "total" .= plpTotal ] + +instance FromJSON ProjectsListResponse where + parseJSON = withObject "/projects/list response" $ \o -> do + plpProjects <- o .: "projects" + plpOffset <- o .: "offset" + plpLimit <- o .: "limit" + plpTotal <- o .: "total" + return ProjectsListResponse{..} + +-- | /api/v0/projects/list +-- Return the list of available projects +-- +-- # Example +-- +-- > { +-- > "limit": 20, +-- > "offset": 0, +-- > "projects": [ +-- > { +-- > "description": "389 Directory Server is an LDAPv3 compliant server. ...", +-- > "homepage": "https://www.port389.org/", +-- > "name": "389-ds-base", +-- > "summary": "389 Directory Server (base)", +-- > "upstream_vcs": "UPSTREAM_VCS" +-- > }, +-- > } +-- > ], +-- > "total": 2117 +-- > } +projectsList :: ServerConfig -> Maybe Int -> Maybe Int -> Handler ProjectsListResponse +projectsList ServerConfig{..} moffset mlimit = do + result <- runExceptT $ runSqlPool (getProjectsLike offset64 limit64 "%") cfgPool + case result of + -- TODO Properly report errors with a different response + Left _ -> return $ ProjectsListResponse [] offset limit 0 + Right (project_info, total64) -> return $ ProjectsListResponse project_info offset limit (fromIntegral total64) + where + -- | Return the offset or the default + offset :: Int + offset = fromMaybe 0 moffset + + -- | Return the limit or the default + limit :: Int + limit = fromMaybe 20 mlimit + + -- | Return the offset or the default + offset64 :: Maybe Int64 + offset64 = Just $ fromIntegral $ fromMaybe 0 moffset + + -- | Return the limit or the default + limit64 :: Maybe Int64 + limit64 = Just $ fromIntegral $ fromMaybe 20 mlimit + + +-- | The JSON response for /projects/info +data Metadata = Metadata { + mdKey :: T.Text, + mdVal :: T.Text +} deriving (Show, Eq) + +instance ToJSON Metadata where + toJSON Metadata{..} = object [ + "key" .= mdKey, + "val" .= mdVal ] + +instance FromJSON Metadata where + parseJSON = withObject "/projects/info metadata" $ \o -> + Metadata <$> o .: "key" + <*> o .: "val" + +data SourceInfo = SourceInfo { + siLicense :: T.Text, + siMetadata :: [Metadata], + siSourceRef :: T.Text, + siVersion :: T.Text +} deriving (Show, Eq) + +instance ToJSON SourceInfo where + toJSON SourceInfo{..} = object [ + "license" .= siLicense, + "metadata" .= siMetadata, + "source_ref" .= siSourceRef, + "version" .= siVersion ] + +instance FromJSON SourceInfo where + parseJSON = withObject "/projects/info source info" $ \o -> + SourceInfo <$> o .: "license" + <*> o .: "metadata" + <*> o .: "source_ref" + <*> o .: "version" + +data BuildInfo = BuildInfo { + biArch :: T.Text, + biConfigRef :: T.Text, + biEnvRef :: T.Text, + biBuildTime :: UTCTime, + biChangelog :: T.Text, + biEpoch :: Maybe Int, + biMetadata :: [Metadata], + biRelease :: T.Text, + biSource :: SourceInfo +} deriving (Show, Eq) + +instance ToJSON BuildInfo where + toJSON BuildInfo{..} = object [ + "arch" .= biArch, + "build_config_ref" .= biConfigRef, + "build_env_ref" .= biEnvRef, + "build_time" .= biBuildTime, + "changelog" .= biChangelog, + "epoch" .= biEpoch, + "metadata" .= biMetadata, + "release" .= biRelease, + "source" .= biSource ] + +instance FromJSON BuildInfo where + parseJSON = withObject "/projects/info build info" $ \o -> + BuildInfo <$> o .: "arch" + <*> o .: "build_config_ref" + <*> o .: "build_env_ref" + <*> o .: "build_time" + <*> o .: "changelog" + <*> o .: "epoch" + <*> o .: "metadata" + <*> o .: "release" + <*> o .: "source" + +data ProjectInfo = ProjectInfo { + piBuilds :: [BuildInfo], + piDescription :: T.Text, + piHomepage :: Maybe T.Text, + piName :: T.Text, + piSummary :: T.Text, + piUpstream :: Maybe T.Text +} deriving (Show, Eq) + +instance ToJSON ProjectInfo where + toJSON ProjectInfo{..} = object [ + "builds" .= piBuilds, + "description" .= piDescription, + "homepage" .= piHomepage, + "name" .= piName, + "summary" .= piSummary, + "upstream_vcs" .= piUpstream ] + +instance FromJSON ProjectInfo where + parseJSON = withObject "/projects/info project info" $ \o -> + ProjectInfo <$> o .: "builds" + <*> o .: "description" + <*> o .: "homepage" + <*> o .: "name" + <*> o .: "summary" + <*> o .: "upstream_vcs" + +data ProjectsInfoResponse = ProjectsInfoResponse { + pipProjects :: [ProjectInfo] +} deriving (Show, Eq) + +instance ToJSON ProjectsInfoResponse where + toJSON ProjectsInfoResponse{..} = object [ + "projects" .= pipProjects ] + +instance FromJSON ProjectsInfoResponse where + parseJSON = withObject "/projects/info response" $ \o -> + ProjectsInfoResponse <$> o .: "projects" + +-- | /api/v0/projects/info/ +-- Return information about the comma-separated list of projects +-- +-- # Example +-- +-- > { +-- > "projects": [ +-- > { +-- > "builds": [ +-- > { +-- > "arch": "x86_64", +-- > "build_config_ref": "BUILD_CONFIG_REF", +-- > "build_env_ref": "BUILD_ENV_REF", +-- > "build_time": "2017-03-01T08:39:23", +-- > "changelog": "- restore incremental backups correctly, files ...", +-- > "epoch": "2", +-- > "metadata": {}, +-- > "release": "32.el7", +-- > "source": { +-- > "license": "GPLv3+", +-- > "metadata": {}, +-- > "source_ref": "SOURCE_REF", +-- > "version": "1.26" +-- > } +-- > } +-- > ], +-- > "description": "The GNU tar program saves many files ...", +-- > "homepage": "http://www.gnu.org/software/tar/", +-- > "name": "tar", +-- > "summary": "A GNU file archiving program", +-- > "upstream_vcs": "UPSTREAM_VCS" +-- > } +-- > ] +-- > } +-- > +projectsInfo :: ServerConfig -> String -> Handler ProjectsInfoResponse +projectsInfo ServerConfig{..} project_names = do + let project_name_list = map T.pack $ sortBy caseInsensitive $ argify [project_names] + results <- liftIO $ mapM (runExceptT . getProjectInfo) project_name_list + return $ ProjectsInfoResponse (rights results) + where + getProjectInfo :: T.Text -> ExceptT String IO ProjectInfo + getProjectInfo project_name = do + (projKey, proj) <- fetchProjects project_name + sources <- fetchSources projKey + tuples <- mapM combineSourceAndBuilds sources + + let nfos = concatMap (\(src, blds) -> map (mkBuildInfo src) blds) tuples + + return ProjectInfo { piBuilds=nfos, + piDescription=projectsDescription proj, + piHomepage=projectsHomepage proj, + piName=projectsName proj, + piSummary=projectsSummary proj, + piUpstream=projectsUpstream_vcs proj } + where + combineSourceAndBuilds :: (Key Sources, Sources) -> ExceptT e IO (Sources, [Builds]) + combineSourceAndBuilds (key, src) = do + builds <- fetchBuilds key + return (src, builds) + + mkBuildInfo :: Sources -> Builds -> BuildInfo + mkBuildInfo src Builds{..} = + BuildInfo { biArch=buildsArch, + biConfigRef=buildsBuild_config_ref, + biEnvRef=buildsBuild_env_ref, + biBuildTime=buildsBuild_time, + biChangelog=cs buildsChangelog, + biEpoch=if buildsEpoch == 0 then Nothing else Just buildsEpoch, + biMetadata=[], + biRelease=buildsRelease, + biSource=mkSourceInfo src } + + mkSourceInfo :: Sources -> SourceInfo + mkSourceInfo Sources{..} = + SourceInfo { siLicense=sourcesLicense, + siMetadata=[], + siSourceRef=sourcesSource_ref, + siVersion=sourcesVersion } + + fetchProjects :: IsString e => T.Text -> ExceptT e IO (Key Projects, Projects) + fetchProjects project_name = flip runSqlPool cfgPool $ do + key <- findProject project_name >>= maybeToEither "no project record with given name" + proj <- getProject key >>= maybeToEither "no project record with given name" + return (key, proj) + + fetchSources :: Key Projects -> ExceptT e IO [(Key Sources, Sources)] + fetchSources projectId = flip runSqlPool cfgPool $ do + keys <- findSources projectId + sources <- mapM getSource keys + return $ mapMaybe removeEmptySource (zip keys sources) + where + removeEmptySource :: (Key Sources, Maybe Sources) -> Maybe (Key Sources, Sources) + removeEmptySource (_, Nothing) = Nothing + removeEmptySource (key, Just src) = Just (key, src) + + fetchBuilds :: Key Sources -> ExceptT e IO [Builds] + fetchBuilds sourceId = flip runSqlPool cfgPool $ + findBuilds sourceId >>= mapMaybeM getBuild + +-- | The JSON response for /projects/depsolve/ +data ProjectsDepsolveResponse = ProjectsDepsolveResponse { + pdrProjects :: [PackageNEVRA] -- ^List of dependencies +} deriving (Show, Eq) + +instance ToJSON ProjectsDepsolveResponse where + toJSON ProjectsDepsolveResponse{..} = object [ + "projects" .= pdrProjects ] + +instance FromJSON ProjectsDepsolveResponse where + parseJSON = withObject "/projects/depsolve response" $ \o -> do + pdrProjects <- o .: "projects" + return ProjectsDepsolveResponse{..} + +-- | /api/v0/projects/depsolve/ +-- Return the dependencies of a comma separated list of projects +projectsDepsolve :: ServerConfig -> String -> Handler ProjectsDepsolveResponse +projectsDepsolve ServerConfig{..} project_names = do + let project_name_list = map T.pack (argify [project_names]) + liftIO $ depsolveProjects cfgPool project_name_list >>= \case + Left _ -> return $ ProjectsDepsolveResponse [] + Right project_deps -> return $ ProjectsDepsolveResponse project_deps + + +-- | Information about a module +data ModuleName = ModuleName { + mnName :: T.Text, -- ^ Module name + mnGroupType :: T.Text -- ^ Group type (always "rpm" for now) +} deriving (Show, Eq) + +instance ToJSON ModuleName where + toJSON ModuleName{..} = object [ + "name" .= mnName, + "group_type" .= mnGroupType ] + +instance FromJSON ModuleName where + parseJSON = withObject "module info" $ \o -> do + mnName <- o .: "name" + mnGroupType <- o .: "group_type" + return ModuleName{..} + +-- | Make a ModuleName from a string +mkModuleName :: T.Text -> ModuleName +mkModuleName name = ModuleName { mnName=name, mnGroupType="rpm" } + + +-- | The JSON response for /modules/list +data ModulesListResponse = ModulesListResponse { + mlrModules :: [ModuleName], -- ^ List of modules + mlrOffset :: Int, -- ^ Pagination offset into results + mlrLimit :: Int, -- ^ Pagination limit of results + mlrTotal :: Int -- ^ Total number of module names +} deriving (Show, Eq) + +instance ToJSON ModulesListResponse where + toJSON ModulesListResponse{..} = object [ + "modules" .= mlrModules + , "offset" .= mlrOffset + , "limit" .= mlrLimit + , "total" .= mlrTotal ] + +instance FromJSON ModulesListResponse where + parseJSON = withObject "/modules/list response" $ \o -> do + mlrModules <- o .: "modules" + mlrOffset <- o .: "offset" + mlrLimit <- o .: "limit" + mlrTotal <- o .: "total" + return ModulesListResponse{..} + +-- | /api/v0/modules/list +-- /api/v0/modules/list/ +-- Return a list of all of the available modules, filtering by module_names (a comma-separated +-- list). This includes the name and the group_type, which is currently always "rpm". +-- +-- > { +-- > "modules": [ +-- > { +-- > "group_type": "rpm", +-- > "name": "0ad" +-- > }, +-- > { +-- > "group_type": "rpm", +-- > "name": "0ad-data" +-- > }, +-- > .... +-- > ], +-- > "offset": 0, +-- > "limit": 20, +-- > "total": 6 +-- > } +modulesList :: ServerConfig -> Maybe Int -> Maybe Int -> String -> Handler ModulesListResponse + +-- | Special case for listing all the modules +-- Uses SQL offset, limit, and case-insensitive sorting +modulesList ServerConfig{..} moffset mlimit "*" = do + result <- runExceptT $ flip runSqlPool cfgPool $ getGroupsLike offset64 limit64 "%" + case result of + Left _ -> + return $ ModulesListResponse [] offset limit 0 + Right (tuples, total64) -> + let names = nubOrd $ map snd tuples + objs = map mkModuleName names + in return $ ModulesListResponse objs offset limit (fromIntegral total64) + where + -- | Return the offset or the default + offset :: Int + offset = fromMaybe 0 moffset + + -- | Return the limit or the default + limit :: Int + limit = fromMaybe 20 mlimit + + -- | Return the offset or the default + offset64 :: Maybe Int64 + offset64 = Just $ fromIntegral $ fromMaybe 0 moffset + + -- | Return the limit or the default + limit64 :: Maybe Int64 + limit64 = Just $ fromIntegral $ fromMaybe 20 mlimit + +modulesList ServerConfig{..} moffset mlimit module_names = do + -- Substitute % for * in the module_names + let module_names_list = map T.pack $ argify [map (\c -> if c == '*' then '%' else c) module_names] + result <- runExceptT $ flip runSqlPool cfgPool $ concatMapM (fmap fst . getGroupsLike Nothing Nothing) module_names_list + case result of + Left _ -> return $ ModulesListResponse [] offset limit 0 + Right tuples -> let names = nubOrd $ sortBy caseInsensitiveT $ map snd tuples + total = length names + objs = applyLimits limit offset $ map mkModuleName names + in return $ ModulesListResponse objs offset limit total + where + -- | Return the offset or the default + offset :: Int + offset = fromMaybe 0 moffset + + -- | Return the limit or the default + limit :: Int + limit = fromMaybe 20 mlimit + +data ComposeBody = ComposeBody { + cbName :: T.Text, -- ^ Recipe name (from /blueprints/list) + cbType :: T.Text, -- ^ Compose type (from /compose/types) + cbBranch :: Maybe T.Text -- ^ The git branch to use for this blueprint +} deriving (Show, Eq) + +instance ToJSON ComposeBody where + toJSON ComposeBody{..} = object [ + "blueprint_name" .= cbName + , "compose_type" .= cbType + , "branch" .= fromMaybe "master" cbBranch ] + +instance FromJSON ComposeBody where + parseJSON = withObject "compose" $ \o -> do + cbName <- o .: "blueprint_name" + cbType <- o .: "compose_type" + cbBranch <- o .:? "branch" + return ComposeBody{..} + +-- | JSON status response +data ComposeResponse = ComposeResponse { + crStatus :: Bool, -- ^ Success/Failure of the request + crBuildID :: T.Text -- ^ UUID of the in-progress build +} deriving (Show, Eq) + +instance ToJSON ComposeResponse where + toJSON ComposeResponse{..} = object [ + "status" .= crStatus + , "build_id" .= crBuildID ] + +instance FromJSON ComposeResponse where + parseJSON = withObject "/compose response" $ \o -> do + crStatus <- o .: "status" + crBuildID <- o .: "build_id" + return ComposeResponse{..} + +-- | POST /api/v0/compose +-- Start a compose. +-- TODO implement test support +compose :: ServerConfig -> ComposeBody -> Maybe Int -> Handler ComposeResponse +compose cfg@ServerConfig{..} ComposeBody{..} _test = case exportTypeFromText cbType of + Nothing -> throwError unsupportedOutput + Just ty -> withRecipe cfgRepoLock cbBranch cbName $ \commit_id recipe -> do + buildId <- liftIO nextRandom + let resultsDir = cfgResultsDir show buildId + liftIO $ do + createDirectoryIfMissing True resultsDir + TIO.writeFile (resultsDir "STATUS") (queueStatusText QWaiting) + -- Write out the original recipe. + TIO.writeFile (resultsDir "blueprint.toml") (recipeTOML recipe) + -- Write out the compose details + TIO.writeFile (resultsDir "compose.toml") (composeConfigTOML $ ComposeConfig commit_id ty) + + -- Freeze the recipe so we have precise versions of its components. This could potentially + -- return multiple frozen recipes, but I think only if we asked it to do multiple things. + -- We did not, so we can safely assume there's only one result. + withFrozenRecipe cbBranch cbName $ \frozen -> liftIO $ do + TIO.writeFile (resultsDir "frozen.toml") (recipeTOML frozen) + + customActions <- processCustomization $ rCustomization frozen + + let dest = resultsDir "compose." ++ T.unpack cbType + ci = ComposeInfo { ciDest=dest, + ciId=T.pack $ show buildId, + ciRecipe=recipe, + ciResultsDir=resultsDir, + ciCustom=customActions, + ciType=ty } + + liftIO $ atomically $ writeTChan cfgChan (AskCompose ci, Nothing) + return $ ComposeResponse True (T.pack $ show buildId) + where + -- | Construct an error message for unsupported output selected + unsupportedOutput = createAPIError err400 False [errorMessage ("compose" :: String) (unsupportedOutputMsg cbType)] + + withRecipe :: GitLock -> Maybe T.Text -> T.Text -> (T.Text -> Recipe -> Handler ComposeResponse) -> Handler ComposeResponse + withRecipe lock branch name fn = + liftIO (getRecipeAndCommit lock (defaultBranch $ fmap cs branch) name) >>= \case + Left err -> throwError $ createAPIError err400 False [err] + Right (_, (commit_id, recipe)) -> fn commit_id recipe + + withFrozenRecipe :: Maybe T.Text -> T.Text -> (Recipe -> Handler ComposeResponse) -> Handler ComposeResponse + withFrozenRecipe branch name fn = + recipesFreeze cfg (fmap cs branch) (cs name) >>= \case + RecipesFreezeResponse [] errs -> throwError $ createAPIError err400 False (map show errs) + RecipesFreezeResponse (frozen:_) _ -> fn frozen + +-- | The JSON response for /compose/types +data ComposeType = ComposeType { + ctEnabled :: Bool, -- ^ Is this output type enabled? + ctName :: T.Text -- ^ The name of the output type +} deriving (Show, Eq) + +instance ToJSON ComposeType where + toJSON ComposeType{..} = object [ + "enabled" .= ctEnabled + , "name" .= ctName ] + +instance FromJSON ComposeType where + parseJSON = withObject "compose type" $ \o -> do + ctEnabled <- o .: "enabled" + ctName <- o .: "name" + return ComposeType{..} + +data ComposeTypesResponse = ComposeTypesResponse { + ctrTypes :: [ComposeType] +} deriving (Show, Eq) + +instance ToJSON ComposeTypesResponse where + toJSON ComposeTypesResponse{..} = object [ + "types" .= ctrTypes ] + +instance FromJSON ComposeTypesResponse where + parseJSON = withObject "/compose/types response" $ \o -> do + ctrTypes <- o .: "types" + return ComposeTypesResponse{..} + + +-- | /api/v0/compose/types +-- +-- Returns the list of supported output types that are valid for use with 'POST /api/v0/compose' +-- +-- > { +-- > "types": [ +-- > { +-- > "enabled": true, +-- > "name": "tar" +-- > } +-- > ] +-- > } +composeTypes :: Handler ComposeTypesResponse +composeTypes = + return $ ComposeTypesResponse $ map (ComposeType True . exportTypeText) supportedExportTypes + + +data ComposeQueueResponse = ComposeQueueResponse { + cqrNew :: [ComposeStatus], + cqrRun :: [ComposeStatus] +} deriving (Show, Eq) + +instance ToJSON ComposeQueueResponse where + toJSON ComposeQueueResponse{..} = object [ + "new" .= cqrNew + , "run" .= cqrRun ] + +instance FromJSON ComposeQueueResponse where + parseJSON = withObject "/compose/queue response" $ \o -> + ComposeQueueResponse <$> o .: "new" + <*> o .: "run" + +-- | /api/v0/compose/queue +-- +-- Return the status of the build queue. It includes information about the builds waiting, +-- and the build that is running. +-- +-- > { +-- > "new": [ +-- > { +-- > "id": "45502a6d-06e8-48a5-a215-2b4174b3614b", +-- > "recipe": "glusterfs", +-- > "queue_status": "WAITING", +-- > "timestamp": 1517362647.4570868, +-- > "version": "0.0.6" +-- > }, +-- > { +-- > "id": "6d292bd0-bec7-4825-8d7d-41ef9c3e4b73", +-- > "recipe": "kubernetes", +-- > "queue_status": "WAITING", +-- > "timestamp": 1517362659.0034983, +-- > "version": "0.0.1" +-- > } +-- > ], +-- > "run": [ +-- > { +-- > "id": "745712b2-96db-44c0-8014-fe925c35e795", +-- > "recipe": "glusterfs", +-- > "queue_status": "RUNNING", +-- > "timestamp": 1517362633.7965999, +-- > "version": "0.0.6" +-- > } +-- > ] +-- > } +composeQueue :: ServerConfig -> Handler ComposeQueueResponse +composeQueue ServerConfig{..} = do + -- Construct a new message to ask what composes are currently waiting. + -- Each message includes an initially empty TMVar where the response + -- will be written. This prevents needing to write a communications + -- protocol. Making it initially empty is very important. + r <- liftIO $ atomically newEmptyTMVar + liftIO $ atomically $ writeTChan cfgChan (AskBuildsWaiting, Just r) + + -- Wait for the response to show up in the TMVar we created. This blocks, + -- but the server doesn't do much in its main thread so it shouldn't block + -- for long. + buildsWaiting <- liftIO (atomically $ readTMVar r) >>= \case + RespBuildsWaiting lst -> return lst + _ -> return [] + + -- And then we do the same thing for builds currently running. + r' <- liftIO $ atomically newEmptyTMVar + liftIO $ atomically $ writeTChan cfgChan (AskBuildsInProgress, Just r') + buildsRunning <- liftIO (atomically $ readTMVar r') >>= \case + RespBuildsInProgress lst -> return lst + _ -> return [] + + -- Finally we can create a response to send back to the client. + waitingCS <- filterMapComposeStatus cfgResultsDir buildsWaiting + runningCS <- filterMapComposeStatus cfgResultsDir buildsRunning + return $ ComposeQueueResponse waitingCS runningCS + + +data ComposeFinishedResponse = ComposeFinishedResponse { + cfrFinished :: [ComposeStatus] +} deriving (Show, Eq) + +instance ToJSON ComposeFinishedResponse where + toJSON ComposeFinishedResponse{..} = object [ + "finished" .= cfrFinished ] + +instance FromJSON ComposeFinishedResponse where + parseJSON = withObject "/compose/queue/finished response" $ \o -> + ComposeFinishedResponse <$> o .: "finished" + +-- | /api/v0/compose/finished +-- +-- Return the details on all of the finished composes on the system. +-- +-- > { +-- > "finished": [ +-- > { +-- > "id": "70b84195-9817-4b8a-af92-45e380f39894", +-- > "recipe": "glusterfs", +-- > "queue_status": "FINISHED", +-- > "timestamp": 1517351003.8210032, +-- > "version": "0.0.6" +-- > }, +-- > { +-- > "id": "e695affd-397f-4af9-9022-add2636e7459", +-- > "recipe": "glusterfs", +-- > "queue_status": "FINISHED", +-- > "timestamp": 1517362289.7193348, +-- > "version": "0.0.6" +-- > } +-- > ] +-- > } +composeQueueFinished :: ServerConfig -> Handler ComposeFinishedResponse +composeQueueFinished ServerConfig{..} = do + results <- liftIO $ getComposesWithStatus cfgResultsDir QFinished + return $ ComposeFinishedResponse results + + +data ComposeFailedResponse = ComposeFailedResponse { + cfrFailed :: [ComposeStatus] +} deriving (Show, Eq) + +instance ToJSON ComposeFailedResponse where + toJSON ComposeFailedResponse{..} = object [ + "failed" .= cfrFailed ] + +instance FromJSON ComposeFailedResponse where + parseJSON = withObject "/compose/queue/failed response" $ \o -> + ComposeFailedResponse <$> o .: "failed" + +-- | /api/v0/compose/failed +-- +-- Return the details on all of the failed composes on the system. +-- +-- > { +-- > "failed": [ +-- > { +-- > "id": "8c8435ef-d6bd-4c68-9bf1-a2ef832e6b1a", +-- > "recipe": "http-server", +-- > "queue_status": "FAILED", +-- > "timestamp": 1517523249.9301329, +-- > "version": "0.0.2" +-- > } +-- > ] +-- > } +composeQueueFailed :: ServerConfig -> Handler ComposeFailedResponse +composeQueueFailed ServerConfig{..} = do + results <- liftIO $ getComposesWithStatus cfgResultsDir QFailed + return $ ComposeFailedResponse results + + +data ComposeStatusResponse = ComposeStatusResponse { + csrUuids :: [ComposeStatus] +} deriving (Show, Eq) + +instance ToJSON ComposeStatusResponse where + toJSON ComposeStatusResponse{..} = object [ + "uuids" .= csrUuids ] + +instance FromJSON ComposeStatusResponse where + parseJSON = withObject "/compose/queue/status response" $ \o -> + ComposeStatusResponse <$> o .: "uuids" + +-- | /api/v0/compose/status/ +-- +-- Return the details for each of the comma-separated list of uuids. +-- +-- > { +-- > "uuids": [ +-- > { +-- > "id": "8c8435ef-d6bd-4c68-9bf1-a2ef832e6b1a", +-- > "recipe": "http-server", +-- > "queue_status": "FINISHED", +-- > "timestamp": 1517523644.2384307, +-- > "version": "0.0.2" +-- > }, +-- > { +-- > "id": "45502a6d-06e8-48a5-a215-2b4174b3614b", +-- > "recipe": "glusterfs", +-- > "queue_status": "FINISHED", +-- > "timestamp": 1517363442.188399, +-- > "version": "0.0.6" +-- > } +-- > ] +-- > } +composeStatus :: ServerConfig -> [T.Text] -> Handler ComposeStatusResponse +composeStatus ServerConfig{..} uuids = + ComposeStatusResponse <$> filterMapComposeStatus cfgResultsDir uuids + + +data ComposeInfoResponse = ComposeInfoResponse { + cirCommit :: T.Text, -- ^ Blueprint git commit hash + cirBlueprint :: Recipe, -- ^ Frozen Blueprint + cirType :: ExportType, -- ^ Export type (tar, etc.) + cirBuildId :: T.Text, -- ^ Build UUID + cirQueueStatus :: T.Text -- ^ Build queue status +} deriving (Show, Eq) + +instance ToJSON ComposeInfoResponse where + toJSON ComposeInfoResponse{..} = object + [ "commit" .= cirCommit + , "blueprint" .= cirBlueprint + , "compose_type" .= exportTypeText cirType + , "id" .= cirBuildId + , "queue_status" .= cirQueueStatus + ] + +instance FromJSON ComposeInfoResponse where + parseJSON = withObject "/compose/info response" $ \o -> do + cirCommit <- o .: "commit" + cirBlueprint <- o .: "blueprint" + cirType <- (o .: "compose_type") >>= \et -> return $ fromMaybe ExportTar $ exportTypeFromText et + cirBuildId <- o .: "id" + cirQueueStatus <- o .: "queue_status" + return ComposeInfoResponse{..} + +-- | /api/v0/compose/info/ +-- +-- Get detailed information about the compose. The returned JSON string will +-- contain the following information: +-- +-- * id - The uuid of the comoposition +-- * config - containing the configuration settings used to run Anaconda +-- * blueprint - The depsolved blueprint used to generate the kickstart +-- * commit - The (local) git commit hash for the blueprint used +-- * deps - The NEVRA of all of the dependencies used in the composition +-- * compose_type - The type of output generated (tar, iso, etc.) +-- * queue_status - The final status of the composition (FINISHED or FAILED) +-- +-- Example:: +-- +-- > { +-- > "commit": "7078e521a54b12eae31c3fd028680da7a0815a4d", +-- > "compose_type": "tar", +-- > "id": "c30b7d80-523b-4a23-ad52-61b799739ce8", +-- > "queue_status": "FINISHED", +-- > "blueprint": { +-- > "description": "An example kubernetes master", +-- > ... +-- > } +-- > } +-- +composeInfo :: ServerConfig -> String -> Handler ComposeInfoResponse +composeInfo ServerConfig{..} uuid = do + result <- liftIO $ runExceptT $ do + ComposeStatus{..} <- withExceptT (const invalid_uuid) + (mkComposeStatus cfgResultsDir (cs uuid)) + ComposeConfig{..} <- readComposeConfigFile results_dir + recipe <- readFrozenBlueprintFile results_dir + return $ ComposeInfoResponse ccCommit recipe ccExportType (cs uuid) (queueStatusText csQueueStatus) + + case result of + Left err -> throwError err + Right r -> return r + where + results_dir = cfgResultsDir cs uuid + invalid_uuid = createAPIError err400 False ["compose_info: " ++ cs uuid ++ " is not a valid build uuid"] + config_error = createAPIError err400 False ["compose_info: " ++ cs uuid ++ " had a problem reading the compose.toml file"] + frozen_error = createAPIError err400 False ["compose_info: " ++ cs uuid ++ " had a problem reading the frozen.toml file"] + + -- Read the compose.toml ComposeConfig data from the results directory + readComposeConfigFile :: FilePath -> ExceptT ServantErr IO ComposeConfig + readComposeConfigFile dir = withExceptT (const config_error) $ + tryIO (TIO.readFile (dir "compose.toml")) >>= ExceptT . return . parseComposeConfig + + -- Read the frozen.toml blueprint from the results directory + readFrozenBlueprintFile :: FilePath -> ExceptT ServantErr IO Recipe + readFrozenBlueprintFile dir = withExceptT (const frozen_error) $ + tryIO (TIO.readFile (dir "compose.toml")) >>= ExceptT . return . parseRecipe + +data ComposeDeleteResponse = ComposeDeleteResponse { + cdrErrors :: [String], + cdrUuids :: [UuidStatus] +} deriving (Show, Eq) + +instance ToJSON ComposeDeleteResponse where + toJSON ComposeDeleteResponse{..} = object [ + "errors" .= cdrErrors, + "uuids" .= cdrUuids ] + +instance FromJSON ComposeDeleteResponse where + parseJSON = withObject "/compose/delete response" $ \o -> + ComposeDeleteResponse <$> o .: "errors" + <*> o .: "uuids" + + +-- | DELETE /api/v0/compose/cancel/ +-- +-- Cancel the build, if it is not finished, and delete the results. It will return a +-- status of True if it is successful. +-- +-- The response for a successful DELETE is: +-- +-- > { +-- > "status": true, +-- > "errors": [] +-- > } +composeCancel :: ServerConfig -> String -> Handler APIResponse +composeCancel ServerConfig{..} uuid = do + result <- liftIO $ runExceptT $ mkComposeStatus cfgResultsDir (cs uuid) + case result of + Left _ -> throwError $ createAPIError err400 False ["compose_cancel: " ++ cs uuid ++ " is not a valid build uuid"] + Right ComposeStatus{..} -> case csQueueStatus of + QWaiting -> do r <- liftIO $ atomically newEmptyTMVar + liftIO $ atomically $ writeTChan cfgChan (AskDequeueBuild csBuildId, Just r) + liftIO (atomically $ readTMVar r) >>= \case + RespBuildDequeued True -> return $ APIResponse True [] + _ -> throwError $ createAPIError err400 False ["compose_cancel: " ++ cs uuid ++ " could not be canceled"] + + QRunning -> do r <- liftIO $ atomically newEmptyTMVar + liftIO $ atomically $ writeTChan cfgChan (AskCancelBuild csBuildId, Just r) + liftIO (atomically $ readTMVar r) >>= \case + RespBuildCancelled True -> return $ APIResponse True [] + _ -> throwError $ createAPIError err400 False ["compose_cancel: " ++ cs uuid ++ "could not be canceled"] + + _ -> throwError $ createAPIError err400 False ["compose_cancel: " ++ cs uuid ++ " is not in WAITING or RUNNING"] + +-- | DELETE /api/v0/compose/delete/ +-- +-- Delete the list of comma-separated uuids from the compose results. +-- +-- > { +-- > "errors": [], +-- > "uuids": [ +-- > { +-- > "status": true, +-- > "uuid": "ae1bf7e3-7f16-4c9f-b36e-3726a1093fd0" +-- > } +-- > ] +-- > } +composeDelete :: ServerConfig -> [T.Text] -> Handler ComposeDeleteResponse +composeDelete ServerConfig{..} uuids = do + results <- liftIO $ mapM (deleteCompose cfgResultsDir) uuids + let (errors, successes) = partitionEithers results + return ComposeDeleteResponse { cdrErrors=errors, cdrUuids=successes } + + +-- | /api/v0/compose/logs/ +-- +-- Returns a .tar of the compose logs. The tar is not compressed, but it is +-- not large. +-- +-- The mime type is set to 'application/x-tar' and the filename is set to +-- UUID-logs.tar +composeLogs :: KnownSymbol h => ServerConfig -> String -> Handler (Headers '[Header h String] LBS.ByteString) +composeLogs ServerConfig{..} uuid = do + result <- liftIO $ runExceptT $ mkComposeStatus cfgResultsDir (cs uuid) + case result of + Left _ -> throwError $ createAPIError err400 False ["compose_logs: " ++ cs uuid ++ " is not a valid build uuid"] + Right ComposeStatus{..} -> + if not (queueStatusEnded csQueueStatus) + then throwError $ createAPIError err400 False ["compose_logs: Build " ++ cs uuid ++ " not in FINISHED or FAILED state."] + else do + let composeResultsDir = cfgResultsDir cs uuid + logFiles = ["compose.log"] + + tar <- liftIO $ Tar.pack composeResultsDir logFiles + return $ addHeader ("attachment; filename=" ++ uuid ++ "-logs.tar;") (Tar.write tar) + + +-- | /api/v0/compose/image/ +-- +-- Returns the output image from the build. The filename is set to the filename +-- from the build with the UUID as a prefix. eg. UUID-root.tar.xz or UUID-boot.iso. +composeImage :: KnownSymbol h => ServerConfig -> T.Text -> Handler (Headers '[Header h String] LBS.ByteString) +composeImage ServerConfig{..} uuid = do + result <- liftIO $ runExceptT $ mkComposeStatus cfgResultsDir (cs uuid) + case result of + Left _ -> throwError $ createAPIError err400 False ["compose_image: " ++ cs uuid ++ " is not a valid build uuid"] + Right ComposeStatus{..} -> + if not (queueStatusEnded csQueueStatus) + then throwError $ createAPIError err400 False ["compose_logs: Build " ++ cs uuid ++ " not in FINISHED or FAILED state."] + else liftIO (readArtifactFile $ cfgResultsDir cs uuid) >>= \case + Nothing -> throwError $ createAPIError err400 False ["compose_image: Build " ++ cs uuid ++ " is missing image file."] + Just fn -> do f <- liftIO $ LBS.readFile (cfgResultsDir fn) + return $ addHeader ("attachment; filename=" ++ filename fn ++ ";") f + where + readArtifactFile :: FilePath -> IO (Maybe String) + readArtifactFile dir = + CES.catch (Just <$> readFile (dir "ARTIFACT")) + (\(_ :: CES.IOException) -> return Nothing) + filename fn = cs uuid ++ "-" ++ takeFileName fn diff --git a/src/BDCS/API/Version.hs b/src/BDCS/API/Version.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/Version.hs @@ -0,0 +1,32 @@ +-- Copyright (C) 2018 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE TemplateHaskell #-} + +module BDCS.API.Version(buildVersion) + where + +import Data.Version (showVersion) +import Development.GitRev +import Paths_bdcs_api(version) + +buildVersion :: String +buildVersion = do + let git_version = $(gitDescribe) + if git_version == "UNKNOWN" then + "v" ++ showVersion version + else + git_version diff --git a/src/BDCS/API/Workspace.hs b/src/BDCS/API/Workspace.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/API/Workspace.hs @@ -0,0 +1,111 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE OverloadedStrings #-} + +{-| Workspace functions - The workspace is a temporary storage location for Recipes. + + The workspace files are stored under the ./git/workspace/\ directory + using the recipe's toml filename as created by 'recipeTomlFilename'. + + Recipes written to the workspace are not committed to git, and are overwritten + on the next call to 'workspaceWrite' +-} +module BDCS.API.Workspace(workspaceRead, + workspaceWrite, + workspaceDelete, + workspaceDir, + WorkspaceError(..)) + where + +import BDCS.API.Recipe(Recipe(..), parseRecipe, recipeTOML, recipeTomlFilename) +import BDCS.API.Utils(maybeThrow) +import Control.Conditional(ifM, whenM) +import qualified Control.Exception.Safe as CES +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import GI.Gio(fileGetPath) +import qualified GI.Ggit as Git +import System.Directory(createDirectoryIfMissing, doesFileExist, removeFile) +import System.FilePath.Posix(()) + +-- | Workspace Errors +data WorkspaceError = + RepoLocationError -- ^ There was a problem getting the path to the repository + | ParseRecipeError String -- ^ There was an error parsing the recipe, details will be included + deriving (Eq, Show) + +instance CES.Exception WorkspaceError + +-- | Create the branch's workspace path +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +workspaceDir :: Git.Repository -> T.Text -> IO FilePath +workspaceDir repo branch = do + location <- Git.repositoryGetLocation repo >>= maybeThrow RepoLocationError + path <- fileGetPath location >>= maybeThrow RepoLocationError + return $ path "workspace" T.unpack branch + +-- | Read a 'Recipe' from the branch's workspace +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@recipe_name@]: The name, not the filename, of the recipe to read +-- +-- Can throw 'WorkspaceError' +workspaceRead :: Git.Repository -> T.Text -> T.Text -> IO (Maybe Recipe) +workspaceRead repo branch recipe_name = do + dir <- workspaceDir repo branch + createDirectoryIfMissing True dir + let filename = dir T.unpack (recipeTomlFilename $ T.unpack recipe_name) + ifM (doesFileExist filename) + (Just <$> readRecipe filename) + (return Nothing) + where + readRecipe :: FilePath -> IO Recipe + readRecipe filename = do + toml_in <- TIO.readFile filename + let erecipe = parseRecipe toml_in + case erecipe of + Left e -> CES.throwIO $ ParseRecipeError e + Right recipe -> return recipe + +-- | Write a 'Recipe' to the branch's workspace +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@recipe@]: The 'Recipe' to write to the workspace +workspaceWrite :: Git.Repository -> T.Text -> Recipe -> IO () +workspaceWrite repo branch recipe = do + dir <- workspaceDir repo branch + createDirectoryIfMissing True dir + let toml_out = T.unpack $ recipeTOML recipe + let filename = dir T.unpack (recipeTomlFilename (rName recipe)) + writeFile filename toml_out + +-- | Delete the recipe from the branch's workspace +-- +-- [@repo@]: Open git repository +-- [@branch@]: Branch name +-- [@recipe_name@]: The name, not the filename, of the recipe to read +-- +-- Can throw a WorkspaceError +workspaceDelete :: Git.Repository -> T.Text -> T.Text -> IO () +workspaceDelete repo branch recipe_name = do + dir <- workspaceDir repo branch + let filename = dir T.unpack (recipeTomlFilename $ T.unpack recipe_name) + whenM (doesFileExist filename) (removeFile filename) diff --git a/tests/RecipeSpec.hs b/tests/RecipeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/RecipeSpec.hs @@ -0,0 +1,155 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module RecipeSpec + where + +import BDCS.API.Customization +import BDCS.API.Recipe +import BDCS.API.TOMLMediaType +import Data.Aeson +import qualified Data.ByteString.Lazy as BSL +import Data.Maybe(fromJust) +import Data.String.Conversions(cs) +import Data.String.QQ +import qualified Data.Text as T +import Test.Hspec + +-- Test data +test1TOML :: T.Text +test1TOML = [s| +name = "test-server" +version = "0.1.2" +description = "Testing git commit of a Recipe record" + +[[modules]] +name = "httpd" +version = "2.4.*" + +[[modules]] +name = "mod_auth_kerb" +version = "5.4" + +[[modules]] +name = "mod_ssl" +version = "2.4.*" + +[[modules]] +name = "php" +version = "5.4.*" + +[[modules]] +name = "php-mysql" +version = "5.4.*" + +[[packages]] +name = "tmux" +version = "2.2" + +[[packages]] +name = "openssh-server" +version = "6.6.*" + +[[packages]] +name = "rsync" +version = "3.0.*" + +|] + +-- Recipe record of test1TOML +test1Recipe :: Recipe +test1Recipe = + Recipe {rName = "test-server", + rVersion = Just "0.1.2", + rDescription = "Testing git commit of a Recipe record", + rPackages = [RecipeModule {rmName = "tmux", rmVersion = "2.2"}, + RecipeModule {rmName = "openssh-server", rmVersion = "6.6.*"}, + RecipeModule {rmName = "rsync", rmVersion = "3.0.*"}], + rModules = [RecipeModule {rmName = "httpd", rmVersion = "2.4.*"}, + RecipeModule {rmName = "mod_auth_kerb", rmVersion = "5.4"}, + RecipeModule {rmName = "mod_ssl", rmVersion = "2.4.*"}, + RecipeModule {rmName = "php", rmVersion = "5.4.*"}, + RecipeModule {rmName = "php-mysql", rmVersion = "5.4.*"}], + rCustomization = emptyCustomization + } + +-- JSON version of test1Recipe +test1JSON :: BSL.ByteString +test1JSON = [s|{ +"name": "test-server", +"version": "0.1.2", +"description": "Testing git commit of a Recipe record", +"packages": [{"name": "tmux", "version": "2.2"}, + {"name": "openssh-server", "version": "6.6.*"}, + {"name": "rsync", "version": "3.0.*"}], +"modules": [{"name": "httpd", "version": "2.4.*"}, + {"name": "mod_auth_kerb", "version": "5.4"}, + {"name": "mod_ssl", "version": "2.4.*"}, + {"name": "php", "version": "5.4.*"}, + {"name": "php-mysql", "version": "5.4.*"}], +"customizations": {} +} +|] + +{-# ANN module ("HLint: ignore Redundant do Found" :: String) #-} +spec :: Spec +spec = + describe "Recipe Record" $ do + it "Parse a TOML string and return a Recipe Record" $ + parseRecipe test1TOML `shouldBe` Right test1Recipe + + it "Output the TOML string from a Recipe Record" $ + recipeTOML test1Recipe `shouldBe` test1TOML + + it "Recipe filename from the Recipe name" $ do + recipeTomlFilename "http server alpha" `shouldBe` "http-server-alpha.toml" + recipeTomlFilename "jenkins-server" `shouldBe` "jenkins-server.toml" + recipeTomlFilename "kubernetes" `shouldBe` "kubernetes.toml" + + it "Output the JSON string from a Recipe Record" $ + toJSON test1Recipe `shouldBe` fromJust (decode test1JSON) + + it "Parse a JSON string and return a Recipe Record" $ + fromJSON (fromJust $ decode test1JSON) `shouldBe` Success test1Recipe + + it "Output the TOML string from a Recipe Record" $ + toTOML test1Recipe `shouldBe` cs test1TOML + + it "Parse a TOML string and return a Recipe Record" $ + parseTOML (cs test1TOML) `shouldBe` Right test1Recipe + + it "Bump the version in various ways" $ do + bumpVersion Nothing Nothing `shouldBe` Right "0.0.1" + bumpVersion Nothing (Just "0.1.0") `shouldBe` Right "0.1.0" + bumpVersion (Just "0.0.2") Nothing `shouldBe` Right "0.0.3" + bumpVersion (Just "0.1.1") (Just "0.1.1") `shouldBe` Right "0.1.2" + bumpVersion (Just "0.0.2") (Just "0.2.1") `shouldBe` Right "0.2.1" + + it "Bump some invalid versions" $ do + bumpVersion Nothing (Just "AAA") `shouldBe` Left "Failed to parse version: AAA" + bumpVersion (Just "AAA") Nothing `shouldBe` Left "Failed to parse version: AAA" + bumpVersion (Just "BBB") (Just "BBB") `shouldBe` Left "Failed to parse version: BBB" + bumpVersion (Just "AAA") (Just "BBB") `shouldBe` Left "Failed to parse version: BBB" + + it "Bump the version of a Recipe and return a new Recipe" $ do + recipeBumpVersion test1Recipe Nothing `shouldBe` Right test1Recipe { rVersion = Just "0.1.2" } + recipeBumpVersion test1Recipe (Just "0.1.2") `shouldBe` Right test1Recipe { rVersion = Just "0.1.3" } + recipeBumpVersion test1Recipe (Just "0.2.1") `shouldBe` Right test1Recipe { rVersion = Just "0.1.2" } + let test2Recipe = test1Recipe {rVersion = Just "0.3.1"} + recipeBumpVersion test2Recipe (Just "0.1.2") `shouldBe` Right test2Recipe diff --git a/tests/RecipesSpec.hs b/tests/RecipesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/RecipesSpec.hs @@ -0,0 +1,93 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE OverloadedStrings #-} + +module RecipesSpec + where + +import BDCS.API.Customization(emptyCustomization) +import BDCS.API.Recipes(runGitRepoTests, runWorkspaceTests, recipeDiff, + RecipeDiffType(..), RecipeDiffEntry(..)) +import BDCS.API.Recipe(Recipe(..), RecipeModule(..)) +import Test.Hspec + + +-- | Recipe to be used for diff test +testOldRecipe :: Recipe +testOldRecipe = + Recipe {rName = "test-server", + rVersion = Just "0.1.2", + rDescription = "Testing diff of Recipe records", + rPackages = [RecipeModule {rmName = "tmux", rmVersion = "2.2"}, + RecipeModule {rmName = "openssh-server", rmVersion = "6.6.*"}, + RecipeModule {rmName = "rsync", rmVersion = "3.0.*"}], + rModules = [RecipeModule {rmName = "httpd", rmVersion = "2.4.*"}, + RecipeModule {rmName = "mod_auth_kerb", rmVersion = "5.4"}, + RecipeModule {rmName = "mod_ssl", rmVersion = "2.4.*"}, + RecipeModule {rmName = "php", rmVersion = "5.4.*"}, + RecipeModule {rmName = "php-mysql", rmVersion = "5.4.*"}], + rCustomization = emptyCustomization + } + +-- | Recipe to be used for diff test +testNewRecipe :: Recipe +testNewRecipe = + Recipe {rName = "test-server", + rVersion = Just "0.1.3", + rDescription = "Testing diff of Recipe records, new version", + rPackages = [RecipeModule {rmName = "tmux", rmVersion = "2.2"}, + RecipeModule {rmName = "openssh-server", rmVersion = "6.7.*"}, + RecipeModule {rmName = "vim-enhanced", rmVersion = "8.0.*"}], + rModules = [RecipeModule {rmName = "httpd", rmVersion = "2.4.*"}, + RecipeModule {rmName = "mod_auth_kerb", rmVersion = "5.5"}, + RecipeModule {rmName = "mod_ssl", rmVersion = "2.4.*"}, + RecipeModule {rmName = "php", rmVersion = "5.4.*"}, + RecipeModule {rmName = "perl", rmVersion = "6.0"}], + rCustomization = emptyCustomization + } + +testDiffResults :: [RecipeDiffEntry] +testDiffResults = [RecipeDiffEntry {rdeOld = Description {rdtDescription = "Testing diff of Recipe records"}, + rdeNew = Description {rdtDescription = "Testing diff of Recipe records, new version"}}, + RecipeDiffEntry {rdeOld = Version {rdtVersion = Just "0.1.2"}, + rdeNew = Version {rdtVersion = Just "0.1.3"}}, + RecipeDiffEntry {rdeOld = Module {rdtModule = RecipeModule {rmName = "php-mysql", rmVersion = "5.4.*"}}, + rdeNew = None}, + RecipeDiffEntry {rdeOld = None, + rdeNew = Module {rdtModule = RecipeModule {rmName = "perl", rmVersion = "6.0"}}}, + RecipeDiffEntry {rdeOld = Module {rdtModule = RecipeModule {rmName = "mod_auth_kerb", rmVersion = "5.4"}}, + rdeNew = Module {rdtModule = RecipeModule {rmName = "mod_auth_kerb", rmVersion = "5.5"}}}, + RecipeDiffEntry {rdeOld = Package {rdtPackage = RecipeModule {rmName = "rsync", rmVersion = "3.0.*"}}, + rdeNew = None}, + RecipeDiffEntry {rdeOld = None, + rdeNew = Package {rdtPackage = RecipeModule {rmName = "vim-enhanced", rmVersion = "8.0.*"}}}, + RecipeDiffEntry {rdeOld = Package {rdtPackage = RecipeModule {rmName = "openssh-server", rmVersion = "6.6.*"}}, + rdeNew = Package {rdtPackage = RecipeModule {rmName = "openssh-server", rmVersion = "6.7.*"}}}] + + +{-# ANN module ("HLint: ignore Redundant do Found" :: String) #-} +spec :: Spec +spec = + describe "Recipes" $ do + it "Ran a series of tests on storing Recipes in a Git repo" $ + runGitRepoTests `shouldReturn` True + + it "Ran a series of tests on storing Recipes in a Workspace" $ + runWorkspaceTests `shouldReturn` True + + it "Test Recipe Diff" $ + recipeDiff testOldRecipe testNewRecipe `shouldBe` testDiffResults diff --git a/tests/ServerSpec.hs b/tests/ServerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ServerSpec.hs @@ -0,0 +1,654 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module ServerSpec + where + +import BDCS.API.Customization(RecipeCustomization(..), RecipeSshKey(..), emptyCustomization) +import BDCS.API.Error(APIResponse(..)) +import BDCS.API.Recipe(Recipe(..), RecipeModule(..)) +import BDCS.API.Recipes(CommitDetails(..), RecipeDiffType(..), RecipeDiffEntry(..)) +import BDCS.API.Server +import BDCS.API.V0 +import BDCS.DB(Projects(..), schemaVersion) +import Control.Conditional(whenM) +import Control.Exception.Safe(throwIO) +import Control.Monad.Loops(allM) +import qualified Data.ByteString.Lazy as LBS +import Data.List(isSuffixOf) +import qualified Data.Text as T +import Data.Time.Clock(UTCTime) +import Network.HTTP.Client (Manager, newManager, defaultManagerSettings) +import Network.Wai (Application) +import Network.Wai.Handler.Warp +import Servant +import Servant.Client +import System.Directory(copyFileWithMetadata, createDirectoryIfMissing, doesPathExist, + listDirectory, removeDirectoryRecursive) +import System.FilePath.Posix(()) +import Text.Printf(printf) +import Test.Hspec + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{-# ANN module ("HLint: ignore Use null" :: String) #-} +{-# ANN module ("HLint: ignore Use head" :: String) #-} + +-- Client API +getStatus :: ClientM ServerStatus +getProjectsList :: Maybe Int -> Maybe Int -> ClientM ProjectsListResponse +getProjectsInfo :: String -> ClientM ProjectsInfoResponse +getProjectsDepsolve :: String -> ClientM ProjectsDepsolveResponse +getRecipes :: Maybe Int -> Maybe Int -> Maybe String -> ClientM RecipesListResponse +getRecipesInfo :: String -> Maybe String -> ClientM RecipesInfoResponse +getRecipesChanges :: String -> Maybe Int -> Maybe Int -> Maybe String -> ClientM RecipesChangesResponse +postRecipesNew :: Recipe -> Maybe String -> ClientM APIResponse +deleteRecipes :: String -> Maybe String -> ClientM APIResponse +postRecipesUndo :: String -> String -> Maybe String -> ClientM APIResponse +postRecipesWorkspace :: Recipe -> Maybe String -> ClientM APIResponse +deleteRecipesWorkspace :: String -> Maybe String -> ClientM APIResponse +postRecipesTag :: String -> Maybe String -> ClientM APIResponse +getRecipesDiff :: String -> String -> String -> Maybe String -> ClientM RecipesDiffResponse +getRecipesDepsolve :: String -> Maybe String -> ClientM RecipesDepsolveResponse +getRecipesFreeze :: String -> Maybe String -> ClientM RecipesFreezeResponse +getModulesList :: Maybe Int -> Maybe Int -> ClientM ModulesListResponse +getModulesList' :: String -> Maybe Int -> Maybe Int -> ClientM ModulesListResponse +getCompose :: ComposeBody -> Maybe Int -> ClientM ComposeResponse +getComposeTypes :: ClientM ComposeTypesResponse +getComposeQueue :: ClientM ComposeQueueResponse +getComposeQueueFinished :: ClientM ComposeFinishedResponse +getComposeQueueFailed :: ClientM ComposeFailedResponse +getComposeStatus :: String -> ClientM ComposeStatusResponse +getComposeInfo :: String -> ClientM ComposeInfoResponse +getComposeCancel :: String -> ClientM APIResponse +getComposeDelete :: String -> ClientM ComposeDeleteResponse +getComposeLogs :: String -> ClientM (Headers '[Header "Content-Disposition" String] LBS.ByteString) +getComposeImage :: String -> ClientM (Headers '[Header "Content-Disposition" String] LBS.ByteString) +getStatus :<|> getProjectsList :<|> getProjectsInfo :<|> getProjectsDepsolve + :<|> getRecipes :<|> getRecipesInfo :<|> getRecipesChanges + :<|> postRecipesNew :<|> deleteRecipes :<|> postRecipesUndo + :<|> postRecipesWorkspace :<|> deleteRecipesWorkspace :<|> postRecipesTag :<|> getRecipesDiff + :<|> getRecipesDepsolve :<|> getRecipesFreeze :<|> getModulesList + :<|> getModulesList' :<|> getCompose :<|> getComposeTypes :<|> getComposeQueue + :<|> getComposeQueueFinished :<|> getComposeQueueFailed :<|> getComposeStatus :<|> getComposeInfo + :<|> getComposeCancel :<|> getComposeDelete :<|> getComposeLogs :<|> getComposeImage = client proxyAPI + + +-- Test results, depends on the contents of the ./tests/recipes files. +recipesListResponse1 :: RecipesListResponse +recipesListResponse1 = RecipesListResponse ["glusterfs", "http-server", "kubernetes", "test-fake"] 0 20 4 + +recipesListResponse2 :: RecipesListResponse +recipesListResponse2 = RecipesListResponse ["http-server"] 1 1 4 + +missingRecipeResponse :: RecipesInfoResponse +missingRecipeResponse = RecipesInfoResponse [] [] ["missing-recipe: missing-recipe.toml is not present on branch master"] + +httpserverRecipeResponse :: RecipesInfoResponse +httpserverRecipeResponse = + RecipesInfoResponse [WorkspaceChanges "http-server" False] + [Recipe "http-server" (Just "0.2.0") "An example http server with PHP and MySQL support." + [RecipeModule "tmux" "2.2", + RecipeModule "openssh-server" "6.6.*", + RecipeModule "rsync" "3.0.*"] + [RecipeModule "httpd" "2.4.*", + RecipeModule "mod_auth_kerb" "5.4", + RecipeModule "mod_ssl" "2.4.*", + RecipeModule "php" "5.4.*", + RecipeModule "php-mysql" "5.4.*"] + emptyCustomization + ] + [] + +multipleRecipeResponse :: RecipesInfoResponse +multipleRecipeResponse = + RecipesInfoResponse [WorkspaceChanges "glusterfs" False, + WorkspaceChanges "http-server" False] + [Recipe "glusterfs" (Just "0.0.1") "An example GlusterFS server with samba" + [RecipeModule "samba" "4.2.*"] + [RecipeModule "glusterfs" "3.7.*", + RecipeModule "glusterfs-cli" "3.7.*"] + emptyCustomization, + Recipe "http-server" (Just "0.2.0") "An example http server with PHP and MySQL support." + [RecipeModule "tmux" "2.2", + RecipeModule "openssh-server" "6.6.*", + RecipeModule "rsync" "3.0.*"] + [RecipeModule "httpd" "2.4.*", + RecipeModule "mod_auth_kerb" "5.4", + RecipeModule "mod_ssl" "2.4.*", + RecipeModule "php" "5.4.*", + RecipeModule "php-mysql" "5.4.*"] + emptyCustomization + ] + [] + +errorRecipeResponse :: RecipesInfoResponse +errorRecipeResponse = + RecipesInfoResponse [WorkspaceChanges "glusterfs" False, + WorkspaceChanges "http-server" False] + [Recipe "glusterfs" (Just "0.0.1") "An example GlusterFS server with samba" + [RecipeModule "samba" "4.2.*"] + [RecipeModule "glusterfs" "3.7.*", + RecipeModule "glusterfs-cli" "3.7.*"] + emptyCustomization, + Recipe "http-server" (Just "0.2.0") "An example http server with PHP and MySQL support." + [RecipeModule "tmux" "2.2", + RecipeModule "openssh-server" "6.6.*", + RecipeModule "rsync" "3.0.*"] + [RecipeModule "httpd" "2.4.*", + RecipeModule "mod_auth_kerb" "5.4", + RecipeModule "mod_ssl" "2.4.*", + RecipeModule "php" "5.4.*", + RecipeModule "php-mysql" "5.4.*"] + emptyCustomization + ] + ["missing-recipe: missing-recipe.toml is not present on branch master"] + +recipesNewResponse :: APIResponse +recipesNewResponse = APIResponse True [] + +aTestRecipe :: Recipe +aTestRecipe = Recipe "A Test Recipe" (Just "0.0.1") "A simple recipe to use for testing" + [RecipeModule "rsync" "3.0.*"] + [RecipeModule "httpd" "2.4.*"] + emptyCustomization + +recipesCustomization1 :: RecipeCustomization +recipesCustomization1 = RecipeCustomization (Just "ralph") [RecipeSshKey "maggie" "KEYDATA"] + +recipesDepsolveResponse1 :: RecipesDepsolveResponse +recipesDepsolveResponse1 = + RecipesDepsolveResponse [RecipeDependencies (Recipe "test-fake" (Just "0.0.1") "A test recipe that uses the fake rpms" + [RecipeModule "bdcs-fake-lisa""1.0.*"] + [RecipeModule "bdcs-fake-bart" "1.3.*"] + recipesCustomization1) + [PackageNEVRA "bdcs-fake-bart" (Just 0) "1.3.1" "12" "x86_64", + PackageNEVRA "bdcs-fake-homer" (Just 0) "2.0.1" "4" "x86_64", + PackageNEVRA "bdcs-fake-lisa" (Just 3) "1.0.0" "1" "x86_64", + PackageNEVRA "bdcs-fake-sax" (Just 0) "3.8.1" "1" "x86_64"] + [PackageNEVRA "bdcs-fake-bart" (Just 0) "1.3.1" "12" "x86_64", + PackageNEVRA "bdcs-fake-lisa" (Just 3) "1.0.0" "1" "x86_64"]] + [] + +recipesDepsolveResponse2 :: RecipesDepsolveResponse +recipesDepsolveResponse2 = + RecipesDepsolveResponse [] ["unknown-recipe: unknown-recipe.toml is not present on branch master"] + +recipesFreezeResponse1 :: RecipesFreezeResponse +recipesFreezeResponse1 = + RecipesFreezeResponse [Recipe "test-fake" (Just "0.0.1") "A test recipe that uses the fake rpms" + [RecipeModule "bdcs-fake-lisa" "3:1.0.0-1"] + [RecipeModule "bdcs-fake-bart" "1.3.1-12"] + recipesCustomization1] + [] + +recipesFreezeResponse2 :: RecipesFreezeResponse +recipesFreezeResponse2 = + RecipesFreezeResponse [] ["unknown-recipe: unknown-recipe.toml is not present on branch master"] + +projectsDepsolveResponse1 :: ProjectsDepsolveResponse +projectsDepsolveResponse1 = + ProjectsDepsolveResponse [PackageNEVRA "bdcs-fake-lisa" (Just 3) "1.0.0" "1" "x86_64", + PackageNEVRA "bdcs-fake-sax" (Just 0) "3.8.1" "1" "x86_64"] + +projectsDepsolveResponse2 :: ProjectsDepsolveResponse +projectsDepsolveResponse2 = + ProjectsDepsolveResponse [] + +projectsListResponse1 :: ProjectsListResponse +projectsListResponse1 = ProjectsListResponse [Projects "bdcs-fake-bart" "Dummy summary" "This is a dummy description." Nothing Nothing, + Projects "bdcs-fake-homer" "Dummy summary" "This is a dummy description." Nothing Nothing, + Projects "bdcs-fake-lisa" "Dummy summary" "This is a dummy description." Nothing Nothing, + Projects "bdcs-fake-sax" "Dummy summary" "This is a dummy description." Nothing Nothing] + 0 20 4 + +projectsListResponse2 :: ProjectsListResponse +projectsListResponse2 = ProjectsListResponse [Projects "bdcs-fake-bart" "Dummy summary" "This is a dummy description." Nothing Nothing, + Projects "bdcs-fake-homer" "Dummy summary" "This is a dummy description." Nothing Nothing] + 0 2 4 + +projectsListResponse3 :: ProjectsListResponse +projectsListResponse3 = ProjectsListResponse [ Projects "bdcs-fake-lisa" "Dummy summary" "This is a dummy description." Nothing Nothing, + Projects "bdcs-fake-sax" "Dummy summary" "This is a dummy description." Nothing Nothing] + 2 20 4 + +projectsInfoResponse1 :: ProjectsInfoResponse +projectsInfoResponse1 = ProjectsInfoResponse [ + ProjectInfo { piBuilds = [BuildInfo { biArch = "x86_64", + biConfigRef = "BUILD_CONFIG_REF", + biEnvRef = "BUILD_ENV_REF", + biBuildTime = read "2018-01-10 18:29:25 UTC" :: UTCTime, + biChangelog = "- Initial version", + biEpoch = Nothing, + biMetadata = [], + biRelease = "12", + biSource = SourceInfo { siLicense = "GPL", + siMetadata = [], + siSourceRef = "SOURCE_REF", + siVersion = "1.3.1" } + }], + piDescription = "This is a dummy description.", + piHomepage = Nothing, + piName = "bdcs-fake-bart", + piSummary = "Dummy summary", + piUpstream = Nothing } ] + +projectsInfoResponse2 :: ProjectsInfoResponse +projectsInfoResponse2 = ProjectsInfoResponse [ + ProjectInfo { piBuilds = [BuildInfo { biArch = "x86_64", + biConfigRef = "BUILD_CONFIG_REF", + biEnvRef = "BUILD_ENV_REF", + biBuildTime = read "2018-01-10 18:29:25 UTC" :: UTCTime, + biChangelog = "- Initial version", + biEpoch = Nothing, + biMetadata = [], + biRelease = "12", + biSource = SourceInfo { siLicense = "GPL", + siMetadata = [], + siSourceRef = "SOURCE_REF", + siVersion = "1.3.1" } + }], + piDescription = "This is a dummy description.", + piHomepage = Nothing, + piName = "bdcs-fake-bart", + piSummary = "Dummy summary", + piUpstream = Nothing }, + ProjectInfo { piBuilds = [BuildInfo { biArch = "x86_64", + biConfigRef = "BUILD_CONFIG_REF", + biEnvRef = "BUILD_ENV_REF", + biBuildTime = read "2018-01-10 18:29:25 UTC" :: UTCTime, + biChangelog = "- Initial version", + biEpoch = Nothing, + biMetadata = [], + biRelease = "1", + biSource = SourceInfo { siLicense = "GPL", + siMetadata = [], + siSourceRef = "SOURCE_REF", + siVersion = "3.8.1" } + }], + piDescription = "This is a dummy description.", + piHomepage = Nothing, + piName = "bdcs-fake-sax", + piSummary = "Dummy summary", + piUpstream = Nothing } ] + +modulesListResponse1 :: ModulesListResponse +modulesListResponse1 = ModulesListResponse + [ ModuleName "bdcs-fake-bart" "rpm" + , ModuleName "bdcs-fake-homer" "rpm" + , ModuleName "bdcs-fake-lisa" "rpm" + , ModuleName "bdcs-fake-sax" "rpm"] + 0 20 4 + +modulesListResponse2 :: ModulesListResponse +modulesListResponse2 = ModulesListResponse + [ ModuleName "bdcs-fake-bart" "rpm" + , ModuleName "bdcs-fake-homer" "rpm"] + 0 2 4 + +modulesListResponse3 :: ModulesListResponse +modulesListResponse3 = ModulesListResponse + [ ModuleName "bdcs-fake-lisa" "rpm" + , ModuleName "bdcs-fake-sax" "rpm"] + 2 20 4 + +modulesListResponse4 :: ModulesListResponse +modulesListResponse4 = ModulesListResponse + [ ModuleName "bdcs-fake-bart" "rpm"] + 0 20 1 + +-- | Check the status response +-- Make sure it looks reasonable +checkStatusResponse :: ClientM Bool +checkStatusResponse = do + response <- getStatus + return $ weldrOK response && schemaOK response && dbOK response && srvDbSupported response + where + weldrOK :: ServerStatus -> Bool + weldrOK response = srvBackend response == "weldr" + + schemaOK :: ServerStatus -> Bool + schemaOK response = srvSchemaVersion response == show schemaVersion + + -- During testing the schema and the database should always be equal + dbOK :: ServerStatus -> Bool + dbOK response = srvDbVersion response == show schemaVersion + + + +-- Post 10 changes to the test recipe +postMultipleChanges :: ClientM Bool +postMultipleChanges = allM newVersion [0..10] + where + newVersion :: Integer -> ClientM Bool + newVersion patch = status_ok <$> postRecipesNew aTestRecipe {rVersion = Just $ patchedVersion patch} Nothing + + patchedVersion :: Integer -> String + patchedVersion = printf "0.1.%d" + + status_ok :: APIResponse -> Bool + status_ok = arjStatus + +-- If it has 0 errors, 1 change named http-server, 0 offset and a limit of 20 it passes +recipesChangesTest1 :: ClientM Bool +recipesChangesTest1 = do + response <- getRecipesChanges "http-server" Nothing Nothing Nothing + return $ length_ok response && name_ok response && error_ok response && limits_ok response + where + length_ok :: RecipesChangesResponse -> Bool + length_ok response = length (rcrRecipes response) == 1 + + name_ok :: RecipesChangesResponse -> Bool + name_ok response = rcName (rcrRecipes response !! 0) == "http-server" + + error_ok :: RecipesChangesResponse -> Bool + error_ok response = length (rcrErrors response) == 0 + + limits_ok :: RecipesChangesResponse -> Bool + limits_ok response = rcrOffset response == 0 && rcrLimit response == 20 + +-- If it has 0 errors, 1 change named http-server, 1 named glusterfs, 0 offset and a limit of 20 it passes +recipesChangesTest2 :: ClientM Bool +recipesChangesTest2 = do + response <- getRecipesChanges "http-server,glusterfs" Nothing Nothing Nothing + return $ length_ok response && name_ok response && error_ok response && limits_ok response + where + length_ok :: RecipesChangesResponse -> Bool + length_ok response = length (rcrRecipes response) == 2 + + name_ok :: RecipesChangesResponse -> Bool + name_ok response = rcName (rcrRecipes response !! 0) == "glusterfs" && + rcName (rcrRecipes response !! 1) == "http-server" + + error_ok :: RecipesChangesResponse -> Bool + error_ok response = length (rcrErrors response) == 0 + + limits_ok :: RecipesChangesResponse -> Bool + limits_ok response = rcrOffset response == 0 && rcrLimit response == 20 + +-- | Check that limit and offset are parsed correctly +-- +-- This must be called after posting > 10 changes to the recipe +recipesChangesTest3 :: ClientM Bool +recipesChangesTest3 = do + response <- getRecipesChanges "A Test Recipe" (Just 5) (Just 5) Nothing + return $ limits_ok response && length_ok response && name_ok response && total_ok response + where + limits_ok :: RecipesChangesResponse -> Bool + limits_ok response = rcrOffset response == 5 && rcrLimit response == 5 + + -- Should only be 1 recipe in the response + length_ok :: RecipesChangesResponse -> Bool + length_ok response = length (rcrRecipes response) == 1 + + name_ok :: RecipesChangesResponse -> Bool + name_ok response = rcName (rcrRecipes response !! 0) == "A Test Recipe" + + total_ok :: RecipesChangesResponse -> Bool + total_ok response = rcTotal (rcrRecipes response !! 0) == 5 + + +-- | Check that deleting a recipe removes it from the list +recipesDeleteTest :: ClientM Bool +recipesDeleteTest = do + result_1 <- recipe_in_list + result_2 <- delete_recipe + result_3 <- recipe_not_in_list + return $ result_1 && result_2 && result_3 + where + -- Is the recipe in the list? + recipe_in_list :: ClientM Bool + recipe_in_list = do + response <- getRecipes Nothing Nothing Nothing + return $ "A-Test-Recipe" `elem` rlrRecipes response + + -- Delete it from the list + delete_recipe :: ClientM Bool + delete_recipe = arjStatus <$> deleteRecipes "A Test Recipe" Nothing + + -- Is it NOT in the list? + recipe_not_in_list = do + response <- getRecipes Nothing Nothing Nothing + return $ "A-Test-Recipe" `notElem` rlrRecipes response + +-- | Check reverting a recipe to a previous commit +recipesUndoTest :: ClientM Bool +recipesUndoTest = do + -- Get a list of the commits + response_1 <- getRecipesChanges "A Test Recipe" Nothing Nothing Nothing + let commit = cdCommit (rcChange (rcrRecipes response_1 !! 0) !! 1) + + -- Revert to a previous commit + arjStatus <$> postRecipesUndo "A Test Recipe" (T.unpack commit) Nothing + +-- | Check that writing to the workspace storage works +recipesWorkspaceTest :: ClientM Bool +recipesWorkspaceTest = status_ok <$> postRecipesWorkspace aTestRecipe {rDescription = "A workspace only recipe"} Nothing + where + status_ok :: APIResponse -> Bool + status_ok = arjStatus + +-- | Test the various /recipes/diff/ methods +recipesDiffTest :: ClientM Bool +recipesDiffTest = do + result_1 <- oldest_diff + result_2 <- workspace_diff + result_3 <- commit_diff + return $ result_1 && result_2 && result_3 + where + oldest_diff = do + response <- getRecipesChanges "A Test Recipe" Nothing Nothing Nothing + let first_commit = cdCommit $ last $ rcChange (rcrRecipes response !! 0) + + response_1 <- getRecipesDiff "A Test Recipe" (T.unpack first_commit) "NEWEST" Nothing + let old_version = rdtVersion $ rdeOld (rdrDiff response_1 !! 0) + let new_version = rdtVersion $ rdeNew (rdrDiff response_1 !! 0) + return $ old_version /= new_version && new_version == Just "0.1.9" + + workspace_diff = do + response <- getRecipesChanges "A Test Recipe" Nothing Nothing Nothing + let first_commit = cdCommit $ last $ rcChange (rcrRecipes response !! 0) + + response_1 <- getRecipesDiff "A Test Recipe" (T.unpack first_commit) "WORKSPACE" Nothing + let old_desc = rdtDescription $ rdeOld (rdrDiff response_1 !! 0) + let new_desc = rdtDescription $ rdeNew (rdrDiff response_1 !! 0) + return $ old_desc /= new_desc && new_desc == "A workspace only recipe" + + commit_diff = do + response <- getRecipesChanges "A Test Recipe" Nothing Nothing Nothing + let first_commit = cdCommit $ last $ rcChange (rcrRecipes response !! 0) + let newer_commit = cdCommit (rcChange (rcrRecipes response !! 0) !! 3) + + response_1 <- getRecipesDiff "A Test Recipe" (T.unpack first_commit) (T.unpack newer_commit) Nothing + let old_version = rdtVersion $ rdeOld (rdrDiff response_1 !! 0) + let new_version = rdtVersion $ rdeNew (rdrDiff response_1 !! 0) + return $ old_version /= new_version && new_version == Just "0.1.8" + +composeTypesResponse :: ComposeTypesResponse +composeTypesResponse = ComposeTypesResponse [ ComposeType True "directory" + , ComposeType True "ostree" + , ComposeType True "qcow2" + , ComposeType True "tar"] + +composeEmptyQueueResponse :: ComposeQueueResponse +composeEmptyQueueResponse = ComposeQueueResponse [] [] + +composeEmptyFailedResponse :: ComposeFailedResponse +composeEmptyFailedResponse = ComposeFailedResponse [] + +composeEmptyFinishedResponse :: ComposeFinishedResponse +composeEmptyFinishedResponse = ComposeFinishedResponse [] + +-- | Setup the temporary repo directory with some example recipes +-- +-- If the directory exists it is first removed. +-- Then example recipes are copied into it +setupTempRepoDir :: FilePath -> FilePath -> IO () +setupTempRepoDir exampleRecipes gitRepoPath = do + whenM (doesPathExist gitRepoPath) (removeDirectoryRecursive gitRepoPath) + createDirectoryIfMissing True gitRepoPath + copyTOMLFiles exampleRecipes gitRepoPath + where + -- Copy files ending with .toml from one directory to another + copyTOMLFiles :: FilePath -> FilePath -> IO () + copyTOMLFiles fromDir toDir = do + files <- filter (".toml" `isSuffixOf`) <$> listDirectory fromDir + let fromFiles = map (fromDir ) files + let toFiles = map (toDir ) files + mapM_ (\(from, to) -> copyFileWithMetadata from to) $ zip fromFiles toFiles + + +spec :: Spec +spec = do + describe "Setup" $ do + it "Setup the temporary test directory" $ + setupTempRepoDir "./tests/recipes/" "/var/tmp/bdcs-tmp-recipes/" + + it "Copy the test database to /var/tmp/test-bdcs.db" $ + copyFileWithMetadata "./tests/mddb/metadata.db" "/var/tmp/test-bdcs.db" + + describe "/api" $ + -- NOTE that mkApp is executed for EACH of the 'it' sections + withClient (mkApp "/var/tmp/content-store" "/var/tmp/bdcs-tmp-recipes/" "/var/tmp/test-bdcs.db") $ do + it "API Status" $ \env -> + try env checkStatusResponse `shouldReturn` True + + it "list the available recipes" $ \env -> + try env (getRecipes Nothing Nothing Nothing) `shouldReturn` recipesListResponse1 + + it "list recipes with offset and limit" $ \env -> + try env (getRecipes (Just 1) (Just 1) Nothing) `shouldReturn` recipesListResponse2 + + it "Get a non-existant recipe's info" $ \env -> + try env (getRecipesInfo "missing-recipe" Nothing) `shouldReturn` missingRecipeResponse + + it "Get the http-server recipe's info" $ \env -> + try env (getRecipesInfo "http-server" Nothing) `shouldReturn` httpserverRecipeResponse + + it "Get multiple recipe's info" $ \env -> + try env (getRecipesInfo "http-server,glusterfs" Nothing) `shouldReturn` multipleRecipeResponse + + it "Get http-server recipe and missing-recipe info" $ \env -> + try env (getRecipesInfo "http-server,missing-recipe,glusterfs" Nothing) `shouldReturn` errorRecipeResponse + it "Post a test recipe" $ \env -> + try env (postRecipesNew aTestRecipe Nothing) `shouldReturn` recipesNewResponse + + it "Post several changes to test recipe" $ \env -> + try env postMultipleChanges `shouldReturn` True + + it "Get changes to http-server recipe" $ \env -> + try env recipesChangesTest1 `shouldReturn` True + + it "Get changes to http-server and glusterfs recipes" $ \env -> + try env recipesChangesTest2 `shouldReturn` True + + it "Check offset and limit usage" $ \env -> + try env recipesChangesTest3 `shouldReturn` True + + it "Check delete recipe" $ \env -> + try env recipesDeleteTest `shouldReturn` True + + it "Undo the recipe delete" $ \env -> + try env recipesUndoTest `shouldReturn` True + + it "Write a recipe to the workspace" $ \env -> + try env recipesWorkspaceTest `shouldReturn` True + + it "Tag the most recent commit of the recipe" $ \env -> + try env (postRecipesTag "A Test Recipe" Nothing) `shouldReturn` APIResponse True [] + + it "Get the recipe differences" $ \env -> + try env recipesDiffTest `shouldReturn` True + + it "Depsolve the test-fake recipe" $ \env -> + try env (getRecipesDepsolve "test-fake" Nothing) `shouldReturn` recipesDepsolveResponse1 + + it "Depsolve an unknown recipe" $ \env -> + try env (getRecipesDepsolve "unknown-recipe" Nothing) `shouldReturn` recipesDepsolveResponse2 + + it "Get a frozen test-fake recipe" $ \env -> + try env (getRecipesFreeze "test-fake" Nothing) `shouldReturn` recipesFreezeResponse1 + + it "Freeze an unknown recipe" $ \env -> + try env (getRecipesFreeze "unknown-recipe" Nothing) `shouldReturn` recipesFreezeResponse2 + + it "Depsolve a test package" $ \env -> + try env (getProjectsDepsolve "bdcs-fake-lisa") `shouldReturn` projectsDepsolveResponse1 + + it "Depsolve an unknown package" $ \env -> + try env (getProjectsDepsolve "unknown-recipe") `shouldReturn` projectsDepsolveResponse2 + + it "List the available projects" $ \env -> + try env (getProjectsList Nothing Nothing) `shouldReturn` projectsListResponse1 + + it "List the first 2 projects" $ \env -> + try env (getProjectsList Nothing (Just 2)) `shouldReturn` projectsListResponse2 + + it "List the last 2 projects" $ \env -> + try env (getProjectsList (Just 2) Nothing) `shouldReturn` projectsListResponse3 + + it "Get info on one project" $ \env -> + try env (getProjectsInfo "bdcs-fake-bart") `shouldReturn` projectsInfoResponse1 + + it "Get info on two projects" $ \env -> + try env (getProjectsInfo "bdcs-fake-bart,bdcs-fake-sax") `shouldReturn` projectsInfoResponse2 + + it "Get list of modules" $ \env -> + try env (getModulesList Nothing Nothing) `shouldReturn` modulesListResponse1 + + it "Get first 2 modules" $ \env -> + try env (getModulesList Nothing (Just 2)) `shouldReturn` modulesListResponse2 + + it "Get last 2 modules" $ \env -> + try env (getModulesList (Just 2) Nothing) `shouldReturn` modulesListResponse3 + + it "Get list of modules with 'bart' in them" $ \env -> + try env (getModulesList' "*bart*" Nothing Nothing) `shouldReturn` modulesListResponse4 + + it "Get list of modules starting with 'bdcs' in them" $ \env -> + try env (getModulesList' "bdcs*" Nothing Nothing) `shouldReturn` modulesListResponse1 + + it "Get a list of the available compose export types" $ \env -> + try env getComposeTypes `shouldReturn` composeTypesResponse + + it "Get the (empty) compose queue" $ \env -> + try env getComposeQueue `shouldReturn` composeEmptyQueueResponse + + it "Get the (empty) failed list of composes" $ \env -> + try env getComposeQueueFailed `shouldReturn` composeEmptyFailedResponse + + it "Get the (empty)finished list of composes" $ \env -> + try env getComposeQueueFinished `shouldReturn` composeEmptyFinishedResponse + + describe "cleanup" $ + it "Remove the temporary directory" $ + removeDirectoryRecursive "/var/tmp/bdcs-tmp-recipes/" + + +withClient :: IO Application -> SpecWith ClientEnv -> SpecWith () +withClient x innerSpec = + beforeAll (newManager defaultManagerSettings) $ + flip aroundWith innerSpec $ \action mgr -> + testWithApplication x $ \port -> do + let base = BaseUrl Http "localhost" port "" + action (ClientEnv mgr base) + +type Host = (Manager, BaseUrl) + +try :: ClientEnv -> ClientM a -> IO a +try clientEnv action = either throwIO return =<< runClientM action clientEnv diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/UtilsSpec.hs b/tests/UtilsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/UtilsSpec.hs @@ -0,0 +1,26 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . +module UtilsSpec + where + +import Test.Hspec +import BDCS.API.Utils + +spec :: Spec +spec = describe "Utility functions" $ + it "argify strings" $ + argify ["first,", "second", "third,fourth"] `shouldBe` ["first", "second", "third", "fourth"] diff --git a/tests/mddb/bdcs-fake-bart-1.3.1-12.x86_64.rpm b/tests/mddb/bdcs-fake-bart-1.3.1-12.x86_64.rpm new file mode 100644 Binary files /dev/null and b/tests/mddb/bdcs-fake-bart-1.3.1-12.x86_64.rpm differ diff --git a/tests/mddb/bdcs-fake-homer-2.0.1-4.x86_64.rpm b/tests/mddb/bdcs-fake-homer-2.0.1-4.x86_64.rpm new file mode 100644 Binary files /dev/null and b/tests/mddb/bdcs-fake-homer-2.0.1-4.x86_64.rpm differ diff --git a/tests/mddb/bdcs-fake-lisa-1.0.0-1.x86_64.rpm b/tests/mddb/bdcs-fake-lisa-1.0.0-1.x86_64.rpm new file mode 100644 Binary files /dev/null and b/tests/mddb/bdcs-fake-lisa-1.0.0-1.x86_64.rpm differ diff --git a/tests/mddb/bdcs-fake-sax-3.8.1-1.x86_64.rpm b/tests/mddb/bdcs-fake-sax-3.8.1-1.x86_64.rpm new file mode 100644 Binary files /dev/null and b/tests/mddb/bdcs-fake-sax-3.8.1-1.x86_64.rpm differ diff --git a/tests/mddb/metadata.db b/tests/mddb/metadata.db new file mode 100644 Binary files /dev/null and b/tests/mddb/metadata.db differ diff --git a/tests/mkTestRPMs.py b/tests/mkTestRPMs.py new file mode 100644 --- /dev/null +++ b/tests/mkTestRPMs.py @@ -0,0 +1,65 @@ +#!/usr/bin/python3 +# Copyright (C) 2017 Red Hat, Inc. +# +# This file is part of bdcs-api. +# +# bdcs-api 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. +# +# bdcs-api 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 bdcs-api. If not, see . + +# This utility is used to create the fake rpms used for ServerSpec.h API testing +# It depends on rpmfluff from https://pagure.io/rpmfluff + +from contextlib import contextmanager +import os +import shutil +import tempfile + +from rpmfluff import SimpleRpmBuild, expectedArch + +# helpers for creating RPMs to test with +@contextmanager +def in_tempdir(prefix='tmp'): + oldcwd = os.getcwd() + tmpdir = tempfile.mkdtemp(prefix=prefix) + os.chdir(tmpdir) + yield + os.chdir(oldcwd) + shutil.rmtree(tmpdir) + +def make_fake_rpm(outdir, name, epoch, version, release, requires=None, provides=None): + p = SimpleRpmBuild(name, version, release) + if epoch: + p.epoch = epoch + if requires: + p.add_requires(requires) + if provides: + p.add_provides(provides) + + with in_tempdir("bdcs-test-rpms."): + p.make() + rpmfile = p.get_built_rpm(expectedArch) + shutil.move(rpmfile, os.path.join(outdir, os.path.basename(rpmfile))) + + +def main(outdir): + # Build 4 test packages for use with the API ServerSpec.hs tests + pkgs = [["bdcs-fake-bart", 0, "1.3.1", "12", "bdcs-fake-homer", None], + ["bdcs-fake-lisa", 3, "1.0.0", "1", "music", None], + ["bdcs-fake-homer", 0, "2.0.1", "4", None, None], + ["bdcs-fake-sax", 0, "3.8.1", "1", None, "music"], + ] + for args in pkgs: + make_fake_rpm(outdir, *args) + +if __name__ == "__main__": + main(os.path.abspath("./tests/mddb/")) diff --git a/tests/recipes/glusterfs.toml b/tests/recipes/glusterfs.toml new file mode 100644 --- /dev/null +++ b/tests/recipes/glusterfs.toml @@ -0,0 +1,16 @@ +name = "glusterfs" +version = "0.0.1" +description = "An example GlusterFS server with samba" + +[[modules]] +name = "glusterfs" +version = "3.7.*" + +[[modules]] +name = "glusterfs-cli" +version = "3.7.*" + +[[packages]] +name = "samba" +version = "4.2.*" + diff --git a/tests/recipes/http-server.toml b/tests/recipes/http-server.toml new file mode 100644 --- /dev/null +++ b/tests/recipes/http-server.toml @@ -0,0 +1,36 @@ +name = "http-server" +version = "0.2.0" +description = "An example http server with PHP and MySQL support." + +[[modules]] +name = "httpd" +version = "2.4.*" + +[[modules]] +name = "mod_auth_kerb" +version = "5.4" + +[[modules]] +name = "mod_ssl" +version = "2.4.*" + +[[modules]] +name = "php" +version = "5.4.*" + +[[modules]] +name = "php-mysql" +version = "5.4.*" + +[[packages]] +name = "tmux" +version = "2.2" + +[[packages]] +name = "openssh-server" +version = "6.6.*" + +[[packages]] +name = "rsync" +version = "3.0.*" + diff --git a/tests/recipes/kubernetes.toml b/tests/recipes/kubernetes.toml new file mode 100644 --- /dev/null +++ b/tests/recipes/kubernetes.toml @@ -0,0 +1,28 @@ +name = "kubernetes" +version = "0.1.2" +description = "An example kubernetes master" + +[[modules]] +name = "kubernetes" +version = "1.2.*" + +[[modules]] +name = "docker" +version = "1.10.*" + +[[modules]] +name = "docker-lvm-plugin" +version = "1.10.*" + +[[modules]] +name = "etcd" +version = "2.3.*" + +[[modules]] +name = "flannel" +version = "0.5.*" + +[[packages]] +name = "oci-systemd-hook" +version = "0.1.*" + diff --git a/tests/recipes/test-fake.toml b/tests/recipes/test-fake.toml new file mode 100644 --- /dev/null +++ b/tests/recipes/test-fake.toml @@ -0,0 +1,18 @@ +name = "test-fake" +version = "0.0.1" +description = "A test recipe that uses the fake rpms" + +[[modules]] +name = "bdcs-fake-bart" +version = "1.3.*" + +[[packages]] +name = "bdcs-fake-lisa" +version = "1.0.*" + +[customizations] +hostname = "ralph" + +[[customizations.sshkey]] +user = "maggie" +key = "KEYDATA" diff --git a/tools/Cmdline.hs b/tools/Cmdline.hs new file mode 100644 --- /dev/null +++ b/tools/Cmdline.hs @@ -0,0 +1,104 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-cli. +-- +-- bdcs-cli 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. +-- +-- bdcs-cli 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 bdcs-cli. If not, see . +module Cmdline(CliOptions(..), + parseArgs, + usage) + where + +import System.Console.GetOpt +import System.Environment(getArgs) +import Text.Printf(printf) + +-- +-- Commandline parsing +-- + +data CliOptions = CliOptions + { optVerbose :: Bool + , optShowVersion :: Bool + , optLogfile :: FilePath + , optMockfiles :: FilePath + , optBDCS :: FilePath + , optMetadataDB :: FilePath + , optRecipeRepo :: FilePath + , optSocketPath :: FilePath + , optSocketGroup :: String + } deriving Show + +defaultOptions :: CliOptions +defaultOptions = CliOptions + { optVerbose = False + , optShowVersion = False + , optLogfile = "/var/log/bdcs-api.log" + , optMockfiles = "/var/tmp/bdcs-mockfiles" + , optBDCS = "/mddb/cs.repo/" + , optMetadataDB = "" + , optRecipeRepo = "" + , optSocketPath = "" + , optSocketGroup = "weldr" + } + +cliOptions :: [OptDescr (CliOptions -> CliOptions)] +cliOptions = + [ Option ['v'] ["verbose"] + (NoArg (\opts -> opts { optVerbose = True })) + "Verbose output" + , Option ['V','?'] ["version"] + (NoArg (\opts -> opts { optShowVersion = True })) + "show version number" + , Option ['l'] ["log"] + (ReqArg (\logfile opts -> opts { optLogfile = logfile }) "LOGFILE") + (printf "Path to JSON logfile (%s)" $ optLogfile defaultOptions) + , Option ['m'] ["mockfiles"] + (ReqArg (\mockfiles opts -> opts { optMockfiles = mockfiles }) "MOCKFILES") + (printf "Path to JSON files used for /api/mock/ paths (%s)" $ optMockfiles defaultOptions) + , Option ['b'] ["bdcs"] + (ReqArg (\bdcs opts -> opts { optBDCS = bdcs }) "BDCS") + (printf "Path to the content store directory (%s)" $ optBDCS defaultOptions) + , Option ['s'] ["socket"] + (ReqArg (\sock opts -> opts { optSocketPath = sock }) "SOCKET") + (printf "Path to a UNIX socket") + , Option ['g'] ["group"] + (ReqArg (\grp opts -> opts { optSocketGroup = grp }) "GROUP") + (printf "Group to set ownership of the socket to") + ] + +cliHeader :: String +cliHeader = "Usage: bdcs-api-server [OPTIONS...] " + +parseOpts :: [String] -> IO CliOptions +parseOpts argv = + case getOpt Permute cliOptions argv of + (o, [mddb, recipes], []) -> return $ resolveDefaults (o ++ [mddbOption mddb, recipesOption recipes]) + (_, _, []) -> ioError $ userError $ usageInfo cliHeader cliOptions + (_,_,errs) -> ioError $ userError $ concat errs ++ usageInfo cliHeader cliOptions + where + resolveDefaults o = foldl (flip id) defaultOptions o + mddbOption m opts = opts { optMetadataDB = m } + recipesOption r opts = opts { optRecipeRepo = r } + +helpText :: String +helpText = "\ +\\n" + +usage :: IO () +usage = do + putStrLn $ usageInfo cliHeader cliOptions + putStr helpText + +parseArgs :: IO CliOptions +parseArgs = getArgs >>= parseOpts diff --git a/tools/bdcs-api-server.hs b/tools/bdcs-api-server.hs new file mode 100644 --- /dev/null +++ b/tools/bdcs-api-server.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This file is part of bdcs-api. +-- +-- bdcs-api 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. +-- +-- bdcs-api 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 bdcs-api. If not, see . + +import BDCS.API.Server(SocketException(..), runServer) +import BDCS.API.Version(buildVersion) +import Cmdline(CliOptions(..), parseArgs) +import qualified Control.Exception.Safe as CES +import Control.Monad(when) + +main :: IO () +main = do + CliOptions{..} <- parseArgs + + when optShowVersion $ putStrLn ("bdcs-api " ++ buildVersion) + + CES.catch (runServer optSocketPath optSocketGroup optBDCS optRecipeRepo optMetadataDB) + (\case + BadFileDescriptor -> putStrLn "Bad value provided in $LISTEN_FDS" + BadGroup g -> putStrLn $ "Provided group does not exist: " ++ g + NoSocketError -> putStrLn "One of $LISTEN_FDS or -s must be provided")