bdcs-api (empty) → 0.1.0
raw patch · 41 files changed
+7038/−0 lines, 41 filesdep +aesondep +asyncdep +basesetup-changedbinary-added
Dependencies added: aeson, async, base, bdcs, bdcs-api, bifunctors, bytestring, concurrent-extra, cond, containers, directory, extra, filepath, gi-ggit, gi-gio, gi-glib, gitrev, haskell-gi-base, hspec, htoml, http-client, http-media, http-types, monad-logger, monad-loops, mtl, network, persistent, persistent-sqlite, resourcet, safe-exceptions, semver, servant-client, servant-options, servant-server, split, stm, string-conversions, string-qq, tar, temporary, text, time, transformers, unix, uuid, wai, wai-cors, warp
Files
- ChangeLog.md +3/−0
- Dockerfile +6/−0
- Dockerfile.build +13/−0
- LICENSE +674/−0
- Makefile +60/−0
- README.tests +23/−0
- Setup.hs +2/−0
- bdcs-api.cabal +142/−0
- entrypoint.sh +7/−0
- src/BDCS/API/Compose.hs +211/−0
- src/BDCS/API/ComposeConfig.hs +71/−0
- src/BDCS/API/Config.hs +41/−0
- src/BDCS/API/Customization.hs +120/−0
- src/BDCS/API/Depsolve.hs +109/−0
- src/BDCS/API/Error.hs +80/−0
- src/BDCS/API/QueueStatus.hs +71/−0
- src/BDCS/API/Recipe.hs +199/−0
- src/BDCS/API/Recipes.hs +1151/−0
- src/BDCS/API/Server.hs +329/−0
- src/BDCS/API/TOMLMediaType.hs +58/−0
- src/BDCS/API/Utils.hs +74/−0
- src/BDCS/API/V0.hs +2218/−0
- src/BDCS/API/Version.hs +32/−0
- src/BDCS/API/Workspace.hs +111/−0
- tests/RecipeSpec.hs +155/−0
- tests/RecipesSpec.hs +93/−0
- tests/ServerSpec.hs +654/−0
- tests/Spec.hs +1/−0
- tests/UtilsSpec.hs +26/−0
- tests/mddb/bdcs-fake-bart-1.3.1-12.x86_64.rpm binary
- tests/mddb/bdcs-fake-homer-2.0.1-4.x86_64.rpm binary
- tests/mddb/bdcs-fake-lisa-1.0.0-1.x86_64.rpm binary
- tests/mddb/bdcs-fake-sax-3.8.1-1.x86_64.rpm binary
- tests/mddb/metadata.db binary
- tests/mkTestRPMs.py +65/−0
- tests/recipes/glusterfs.toml +16/−0
- tests/recipes/http-server.toml +36/−0
- tests/recipes/kubernetes.toml +28/−0
- tests/recipes/test-fake.toml +18/−0
- tools/Cmdline.hs +104/−0
- tools/bdcs-api-server.hs +37/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+## 0.1.0++* Initial release.
+ Dockerfile view
@@ -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
+ Dockerfile.build view
@@ -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"]
+ LICENSE view
@@ -0,0 +1,674 @@+ GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU General Public License is a free, copyleft license for+software and other kinds of works.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users. We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors. You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights. Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received. You must make sure that they, too, receive+or can get the source code. And you must show them these terms so they+know their rights.++ Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++ For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software. For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++ Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so. This is fundamentally incompatible with the aim of+protecting users' freedom to change the software. The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable. Therefore, we+have designed this version of the GPL to prohibit the practice for those+products. If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++ Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary. To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Use with the GNU Affero General Public License.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++ <program> Copyright (C) <year> <name of author>+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++ The GNU General Public License does not permit incorporating your program+into proprietary programs. If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License. But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Makefile view
@@ -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
+ README.tests view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bdcs-api.cabal view
@@ -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
+ entrypoint.sh view
@@ -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"
+ src/BDCS/API/Compose.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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 }
+ src/BDCS/API/ComposeConfig.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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)
+ src/BDCS/API/Config.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-| 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+ }
+ src/BDCS/API/Customization.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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)]
+ src/BDCS/API/Depsolve.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/API/Error.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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))
+ src/BDCS/API/QueueStatus.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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"
+ src/BDCS/API/Recipe.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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)
+ src/BDCS/API/Recipes.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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. \<commit\>:\<filename\> or \<branch\>:\<filename\>+--+-- 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/\<branch\>/\<filename\>/r\<revision\>+-- 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/\<branch\>/\<filename\>/r\<revision\>+--+-- 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/\<branch\>/\<filename\>/r\<revision\>+-- 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
+ src/BDCS/API/Server.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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 ()
+ src/BDCS/API/TOMLMediaType.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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
+ src/BDCS/API/Utils.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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
+ src/BDCS/API/V0.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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/\<recipes\>+-- 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/\<recipes\>+-- 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/\<blueprints\>, 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/\<recipe\>+-- 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/\<recipe\>/\<commit\>+-- 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/\<recipe\>+-- 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/<blueprint>+-- 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/<blueprint>/<from_commit>/<to_commit>+-- 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/\<blueprint-name\> 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/<blueprints>+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/<blueprints>+-- 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/<blueprints>+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/<blueprints>+-- 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/<projects>+-- 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/<projects>+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/<projects>+-- 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/<module_names>+-- 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/<uuids>+--+-- 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/<uuid>+--+-- 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/<uuid>+--+-- 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/<uuids>+--+-- 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/<uuid>+--+-- 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/<uuid>+--+-- 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
+ src/BDCS/API/Version.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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
+ src/BDCS/API/Workspace.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# LANGUAGE OverloadedStrings #-}++{-| Workspace functions - The workspace is a temporary storage location for Recipes.++ The workspace files are stored under the ./git/workspace/\<branch\> 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)
+ tests/RecipeSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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
+ tests/RecipesSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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
+ tests/ServerSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/UtilsSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.+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"]
+ tests/mddb/bdcs-fake-bart-1.3.1-12.x86_64.rpm view
binary file changed (absent → 6092 bytes)
+ tests/mddb/bdcs-fake-homer-2.0.1-4.x86_64.rpm view
binary file changed (absent → 6068 bytes)
+ tests/mddb/bdcs-fake-lisa-1.0.0-1.x86_64.rpm view
binary file changed (absent → 6100 bytes)
+ tests/mddb/bdcs-fake-sax-3.8.1-1.x86_64.rpm view
binary file changed (absent → 6068 bytes)
+ tests/mddb/metadata.db view
binary file changed (absent → 200704 bytes)
+ tests/mkTestRPMs.py view
@@ -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 <http://www.gnu.org/licenses/>.++# 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/"))
+ tests/recipes/glusterfs.toml view
@@ -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.*"+
+ tests/recipes/http-server.toml view
@@ -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.*"+
+ tests/recipes/kubernetes.toml view
@@ -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.*"+
+ tests/recipes/test-fake.toml view
@@ -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"
+ tools/Cmdline.hs view
@@ -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 <http://www.gnu.org/licenses/>.+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...] <METADATA-DB> <BLUEPRINT-REPO>"++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
+ tools/bdcs-api-server.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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 <socket> must be provided")