diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## 0.1.0 + +* Initial release. diff --git a/Dockerfile b/Dockerfile new file mode 100644 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,9 @@ +FROM welder/fedora:latest + +COPY entrypoint.sh /usr/local/bin/entrypoint.sh +ENTRYPOINT ["/usr/local/bin/entrypoint.sh"] + +COPY bdcs /usr/local/bin +COPY bdcs-import /usr/local/libexec/weldr/ +COPY bdcs-export /usr/local/libexec/weldr/ +COPY schema.sql /root/schema.sql diff --git a/Dockerfile.build b/Dockerfile.build new file mode 100644 --- /dev/null +++ b/Dockerfile.build @@ -0,0 +1,32 @@ +FROM welder/fedora:latest + +# workaround for https://github.com/bos/math-functions/issues/52 +RUN dnf -y install cabal-install \ + https://kojipkgs.fedoraproject.org//packages/ghc-vector-th-unbox/0.2.1.6/1.fc26/x86_64/ghc-vector-th-unbox-0.2.1.6-1.fc26.x86_64.rpm \ + https://kojipkgs.fedoraproject.org//packages/ghc-vector-th-unbox/0.2.1.6/1.fc26/x86_64/ghc-vector-th-unbox-devel-0.2.1.6-1.fc26.x86_64.rpm && \ + dnf clean all + +ENV PATH /root/.cabal/bin:$PATH + +RUN cabal update +RUN cabal install happy +RUN cabal install hlint + +RUN mkdir /bdcs + +# install the build dependencies first so we can cache this layer +COPY bdcs.cabal /bdcs/ +RUN cd /bdcs/ && cabal update && cabal install --dependencies-only --enable-tests --force-reinstall + +# copy the rest of the code and build the application +COPY cabal.config LICENSE Setup.hs .hlint.yaml /bdcs/ +COPY data/ /bdcs/data/ +COPY src/ /bdcs/src/ +COPY tests/ /bdcs/tests/ + +WORKDIR /bdcs/ +RUN hlint . +RUN cabal configure --enable-tests --enable-coverage --prefix=/usr/local +RUN cabal build +RUN cabal test --show-details=always +RUN cabal install --prefix=/usr/local diff --git a/Dockerfile.integration-test b/Dockerfile.integration-test new file mode 100644 --- /dev/null +++ b/Dockerfile.integration-test @@ -0,0 +1,8 @@ +FROM welder/bdcs-build-img:latest +MAINTAINER Alexander Todorov + +RUN dnf -y install wget diffutils && dnf clean all + +COPY schema.sql / +COPY entrypoint-integration-test.sh /usr/local/bin/entrypoint-integration-test.sh +ENTRYPOINT ["/usr/local/bin/entrypoint-integration-test.sh"] diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,502 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +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 this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +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 +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser 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 Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "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 +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY 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 +LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,133 @@ +ifdef WORKSPACE +d = ${WORKSPACE} +else +d = ${CURDIR} +endif + +ORG_NAME=welder +STORE ?= cs.repo +MDDB ?= metadata.db + +weld-f25: + git clone https://github.com/weldr/welder-deployment + $(MAKE) -C welder-deployment weld-f25 + -rm -rf ./welder-deployment + +build: Dockerfile.build + if [ -n "$$TRAVIS" ]; then \ + sudo docker build -t $(ORG_NAME)/bdcs-build-img -f $< --cache-from $(ORG_NAME)/bdcs-build-img:latest .; \ + else \ + sudo docker build -t $(ORG_NAME)/bdcs-build-img -f $< .; \ + fi; + sudo docker create --name build-cont $(ORG_NAME)/bdcs-build-img /bin/bash + sudo docker cp build-cont:/usr/local/bin/bdcs ./bdcs + sudo docker cp build-cont:/usr/local/libexec/weldr/bdcs-import ./bdcs-import + sudo docker cp build-cont:/usr/local/libexec/weldr/bdcs-export ./bdcs-export + sudo docker rm build-cont + +importer: build + sudo docker build -t $(ORG_NAME)/bdcs-import-img . + +integration-test: build Dockerfile.integration-test + sudo docker build -t $(ORG_NAME)/bdcs-integration-test -f Dockerfile.integration-test . + sudo docker run --name tests $(ORG_NAME)/bdcs-integration-test + + +# NOTE: The mddb and content store under ./mddb/ will be removed +# Unless KEEP_STORE=1 and KEEP_MDDB=1 are set. +mddb: + @if [ ! -e ${d}/mddb ]; then \ + mkdir ${d}/mddb; \ + fi; + sudo docker rm -f mddb-container || true + sudo docker run -v ${d}/mddb/:/mddb/ -v ${d}/rpms:/rpms:ro --security-opt="label=disable" \ + --name mddb-container \ + -e "IMPORT_URL=$(IMPORT_URL)" \ + -e "KEEP_STORE=$(KEEP_STORE)" \ + -e "STORE=$(STORE)" \ + -e "KEEP_MDDB=$(KEEP_MDDB)" \ + -e "MDDB=$(MDDB)" \ + $(ORG_NAME)/bdcs-import-img + sudo docker rm mddb-container + +api-mddb: + @if [ ! -e ${d}/api-rpms ]; then \ + mkdir ${d}/api-rpms; \ + fi; \ + if [ ! -e ${d}/api-mddb ]; then \ + mkdir ${d}/api-mddb; \ + fi; \ + cd ${d}/api-rpms; \ + wget -c http://mirror.centos.org/centos/7/os/x86_64/Packages/basesystem-10.0-7.el7.centos.noarch.rpm \ + http://mirror.centos.org/centos/7/os/x86_64/Packages/filesystem-3.2-21.el7.x86_64.rpm \ + http://mirror.centos.org/centos/7/os/x86_64/Packages/httpd-2.4.6-67.el7.centos.x86_64.rpm \ + http://mirror.centos.org/centos/7/os/x86_64/Packages/bash-4.2.46-28.el7.x86_64.rpm \ + http://mirror.centos.org/centos/7/updates/x86_64/Packages/bash-4.2.46-29.el7_4.x86_64.rpm + sudo docker volume create -d local --name api-test-mddb-volume + sudo docker run -v ${d}/api-mddb:/mddb:z -v ${d}/api-rpms:/rpms:z,ro --security-opt="label:disable" $(ORG_NAME)/bdcs-import-img + + +.PHONY: importer mddb api-mddb ci + +import-centos7: + make weld-f25 + make importer + mkdir rpms/ + + if [ ! -e ${d}/mddb ]; then \ + mkdir ${d}/mddb; \ + fi; \ + + if [ -n "$$EXISTING_MDDB" ]; then \ + wget --progress=dot:giga "$$EXISTING_MDDB"; \ + gunzip -q `basename "$$EXISTING_MDDB"`; \ + UNZIPPED=`basename "$$EXISTING_MDDB" | sed 's/.gz//'`; \ + mv $$UNZIPPED ${d}/mddb/$(MDDB); \ + fi + + if [ -n "$$EXISTING_STORE" ]; then \ + STORE=`basename "$$EXISTING_STORE"`; \ + ostree --repo=${d}/mddb/$$STORE init --mode=archive; \ + ostree --repo=${d}/mddb/$$STORE remote add --no-gpg-verify existing "$$EXISTING_STORE"; \ + # note: pulls with --depth=0, only the last commit \ + ostree --repo=${d}/mddb/$$STORE pull --mirror existing; \ + fi \ + + set -e + for REPO in http://mirror.centos.org/centos/7/os/x86_64/ \ + http://mirror.centos.org/centos/7/extras/x86_64/; do \ + export IMPORT_URL="$$REPO"; \ + export KEEP_STORE=1; \ + export STORE="$$STORE"; \ + export KEEP_MDDB=1; \ + make mddb; \ + done + +ci: integration-test + +ci_after_success: + # copy coverage data & compiled binaries out of the container + sudo docker cp tests:/bdcs/dist ./bdcs/dist + sudo docker rm tests + + sudo chown travis:travis -R ./bdcs/dist + [ -x ~/.cabal/bin/hpc-coveralls ] || cabal update && cabal install hpc-coveralls + cd bdcs/ && ~/.cabal/bin/hpc-coveralls --display-report test-bdcs bdcs bdcs-import bdcs-inspect inspect-groups inspect-ls inspect-nevras bdcs-export bdcs-tmpfiles bdcs-depsolve && cd .. + + # upload artifacts on which other test activities depend + s3cmd sync -v -P ./bdcs/dist/build/bdcs-import/bdcs-import s3://weldr/bdcs-import + s3cmd sync -v -P ./bdcs/dist/build/bdcs-export/bdcs-export s3://weldr/bdcs-export + +sandbox: + [ -d .cabal-sandbox ] || cabal sandbox init + +hlint: sandbox + [ -x .cabal-sandbox/bin/happy ] || cabal install happy + [ -x .cabal-sandbox/bin/hlint ] || cabal install hlint + cabal exec hlint . + +tests: sandbox + cabal install --dependencies-only --enable-tests + cabal configure --enable-tests --enable-coverage + cabal build + cabal test diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,162 @@ +[![Build Status](https://travis-ci.org/weldr/bdcs.svg?branch=master)](https://travis-ci.org/weldr/bdcs) +[![Coverage Status](https://coveralls.io/repos/github/weldr/bdcs/badge.svg?branch=master)](https://coveralls.io/github/weldr/bdcs?branch=master) + +This code generates a metadata database (mddb) given an input directory of +RPMs. You can generate this either by running locally or running under docker. +It's really best if you have the RPMs stored locally, too, not under some NFS +mount or other network storage. That can slow things down quite a bit. + +Importing the same set of RPMs into the same database twice should result in no +changes. Importing additional RPMs into the same database should result in those +RPMs being added to the existing database. There is currently no provision for +removing an imported RPM. In this way, you could import a very large set of +packages piecemeal if needed. + + +Running locally +=============== + +You will first need a directory full of RPMs somewhere. Here, I assume that +is the $PWD/Packages directory. Then run: + +``` +$ cd src +$ cabal sandbox init +$ cabal install --dependencies-only --enable-tests +$ cabal build +$ sqlite3 metadata.db < ../schema.sql +$ for f in ${PWD}/Packages/*rpm; do dist/build/import/import metadata.db cs.repo file://${f}; done +``` + +Running with docker +=================== + +Running with docker is a two step process, as indicated by Dockerfile.build +and Dockerfile. Dockerfile.build is used to compile the program needed to +build an mddb and produces an image with that program. Dockerfile then runs +that image and produces the mddb. + +The Dockerfile depends on a base image, named weld/fedora:25, which needs have +been previously built. If it is not available it can be built from the +welder-deployment repository by running `make weld-f25`. + +The Makefile lays out the exact steps and can be used to simplify all this - +just run `make importer mddb`. If make is unavailable, just copy the steps +out of there and run them manually. + +You will first need a volume to store the mddb in and a volume containing all +the RPMs. The Makefile expects that the mddb will be put into $PWD/mddb, and +that the RPMs are in $PWD/rpms. + +After completion, the mddb will be in $PWD/mddb/metadata.db and the ostree +based content store will be in $PWD/mddb/cs.repo/ + +Preparing local development environment for Haskell +=================================================== + +For development we use the latest upstream versions: + +1) Remove the standard `haskell-platform` and `ghc-*` RPMs if you have them installed +2) Download version **8.0.2** of the generic Haskell Platform distribution from + https://www.haskell.org/platform/linux.html#linux-generic +3) +``` +$ tar -xzvf haskell-platform-8.0.2-unknown-posix--minimal-x86_64.tar.gz +$ sudo ./install-haskell-platform.sh +``` +4) Add `/usr/local/bin` to your PATH if not already there! +5) Install build dependencies: +``` +# dnf -y install xz-devel zlib-devel glib2-devel gobject-introspection-devel ostree-devel +``` + +**NOTE:** On RHEL 7 `ostree-devel` is part of the Atomic Host product! + + +Building the project locally +============================ + +`cabal` is used to install and manage Haskell dependencies from upstream. + +``` +$ cd src/ && cabal sandbox init && cabal install +``` + +Executing unit tests +==================== + + $ cd src/ + $ cabal sandbox init + $ cabal install --dependencies-only --enable-tests + $ cabal test + Running 1 test suites... + Test suite tests: RUNNING... + Test suite tests: PASS + Test suite logged to: dist/test/db-0.1.0.0-test-db.log + 1 of 1 test suites (1 of 1 test cases) passed. + +Produce code coverage report +============================ + + $ cd src/ + $ cabal sandbox init + $ cabal install --enable-tests --enable-coverage + $ cabal test + $ firefox ./dist/hpc/vanilla/tix/*/hpc_index.html + +OSTree cheat sheet +================== + +After importing RPMs (via the `import` executable) the results are a +`metadata.db` SQL database and a `cs.repo` directory containing an +OSTree repository. Here are a few quick examples how to work with `ostree`: + + +To see what references aka "branches" are in the repo: + + ostree --repo=cs.repo/ refs + master + + +To see the commit log (use `less` because ostree doesn't paginate like git): + + ostree --repo=cs.repo/ log master + commit 816b63ab93a7a866d598c552f212c3a407648096521fde74cc9aa317730da8b1 + Date: 2017-07-03 16:32:39 +0000 + + Import of zsh-html into the repo + + commit f3d66bf3b40e269eac7ed62b6d6f7afdeb5059b17e1b8737aec8b52a03ea82c6 + Date: 2017-07-03 16:32:38 +0000 + + Import of zsh into the repo + + commit e370924c48e5b759c05d61b1c4960d96366a91e46eb7449a47c5064986029e50 + Date: 2017-07-03 16:32:35 +0000 + + Import of yum-rhn-plugin into the repo + +To find out the latest commit at `master`: + + ostree --repo=cs.repo/ rev-parse master + 816b63ab93a7a866d598c552f212c3a407648096521fde74cc9aa317730da8b1 + +To see what files are inside a particular commit: + + ostree --repo=cs.repo/ ls -RC 816b63ab93a7a866d598c552f212c3a407648096521fde74cc9aa317730da8b1 + d00755 0 0 0 30bdab0c9a4156b26a923831f0e1c6ba6141c0a8e35c61f30e8febffe7f78de0 446a0ef11b7cc167f3b603e585c7eeeeb675faa412d5ec73f62988eb0b6c5488 / + d00755 0 0 0 eeae4a3c7450b786b3d9a6958ef2195c99c1867c2040d9153395e13f38b1ca7b 446a0ef11b7cc167f3b603e585c7eeeeb675faa412d5ec73f62988eb0b6c5488 /usr + d00755 0 0 0 0e1e668a21df0ef296e0a7287509b9bac8ae2a03bf6849954b3d0ef905b0cd9a 446a0ef11b7cc167f3b603e585c7eeeeb675faa412d5ec73f62988eb0b6c5488 /usr/share + d00755 0 0 0 d5c72afb0dc8197bba6249a8cdfcf155eed0e1d8bf3d3bd02a4e53f3d8c42b37 446a0ef11b7cc167f3b603e585c7eeeeb675faa412d5ec73f62988eb0b6c5488 /usr/share/doc + d00755 0 0 0 58efea079328274a2845195529729b190b31b06cc16b5f31c2dc1e2f88825563 446a0ef11b7cc167f3b603e585c7eeeeb675faa412d5ec73f62988eb0b6c5488 /usr/share/doc/zsh-html-5.0.2 + -00644 0 0 1724 6c691ad9ce0f053823e3fe34795d911170bac0f78f9231389c2e9e2e1271f73a /usr/share/doc/zsh-html-5.0.2/Aliasing.html + -00644 0 0 1892 835ffd08dba662f47c7eb3164ae76aa5903363c63d3d606268c0ba928b725e6e /usr/share/doc/zsh-html-5.0.2/Alternate-Forms-For-Complex-Commands.html + -00644 0 0 1830 59184f18d807a6b9fc963b709ef82dba4d00f536388935aa79b74160fe90cbfe /usr/share/doc/zsh-html-5.0.2/Alternative-Completion.html + -00644 0 0 1734 b1bd5813c780a0862843fd3f468021c9358f5852c8a2029cb6857fb64dd2aed1 /usr/share/doc/zsh-html-5.0.2/Arguments.html + -00644 0 0 17635 89309b924ef3874172c73bab3c45eab56da0b847d6328dc387e0e1c5b3dfa633 /usr/share/doc/zsh-html-5.0.2/Arithmetic-Evaluation.html + +**NOTE:** `-R` means recursive, `-C` displays file checksums + +To check out aka export a commit into a filesystem tree: + + sudo ostree --repo=cs.repo/ checkout 816b63ab93a7a866d598c552f212c3a407648096521fde74cc9aa317730da8b1 some.dir/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,76 @@ +-- Copyright (C) 2016-2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +module Main(main) + where + +import Data.List(isPrefixOf) +import Distribution.PackageDescription(Executable(..), GenericPackageDescription, HookedBuildInfo, PackageDescription(..)) +import Distribution.Simple(defaultMainWithHooks, simpleUserHooks) +import Distribution.Simple.Install(install) +import Distribution.Simple.InstallDirs(InstallDirs(..), fromPathTemplate, toPathTemplate) +import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..)) +import Distribution.Simple.UserHooks(UserHooks(..)) +import Distribution.Simple.Setup(ConfigFlags, CopyFlags) +import System.FilePath(()) + +main :: IO () +main = defaultMainWithHooks $ simpleUserHooks { confHook = bdcsConf, + copyHook = bdcsCopy } + +-- Make sure $libexecdir gets "weldr/" appended to it. This will affect both the installation location +-- for anything that should go into $libexecdir (like our subcommand programs) as well as the auto +-- generated Paths_bdcs.hs file. +-- +-- This also means if you pass --libexecdir= to "cabal configure" or any other program, you should not +-- add "weldr/" to it. Otherwise you'll get it in there twice. +bdcsConf :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo +bdcsConf (descr, hbi) flags = do + lbi <- confHook simpleUserHooks (descr, hbi) flags + let dest = mangle $ libexecdir $ installDirTemplates lbi + return $ lbi { installDirTemplates = (installDirTemplates lbi) { libexecdir = dest } } + where + mangle = toPathTemplate . ( "weldr") . fromPathTemplate + +bdcsCopy :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () +bdcsCopy pkg lbi _ flags = do + -- First, install everything that's not a subcommand. That is almost everything + -- listed in the cabal file. + let (mainPkg, mainLbi) = extractMainComponents pkg lbi + install mainPkg mainLbi flags + + -- Second, install only the subcommands into $prefix/libexec/weldr. + let (subPkg, subLbi) = extractSubComponents pkg lbi + install subPkg subLbi flags + +isSubcommand :: String -> Bool +isSubcommand s = "inspect-" `isPrefixOf` s || "bdcs-" `isPrefixOf` s + +extractMainComponents :: PackageDescription -> LocalBuildInfo -> (PackageDescription, LocalBuildInfo) +extractMainComponents pkg lbi = let + pkg' = pkg { executables = filter (not . isSubcommand . exeName) + (executables pkg) } + in + (pkg', lbi) + +extractSubComponents :: PackageDescription -> LocalBuildInfo -> (PackageDescription, LocalBuildInfo) +extractSubComponents pkg lbi = let + dest = libexecdir (installDirTemplates lbi) + + pkg' = pkg { executables = filter (isSubcommand . exeName) + (executables pkg) } + lbi' = lbi { installDirTemplates = (installDirTemplates lbi) { bindir = dest } } + in + (pkg', lbi') diff --git a/bdcs.cabal b/bdcs.cabal new file mode 100644 --- /dev/null +++ b/bdcs.cabal @@ -0,0 +1,391 @@ +name: bdcs +version: 0.1.0 +synopsis: Tools for managing a content store of software packages +description: This module provides a library and various tools for managing a content store and + metadata database. These store the contents of software packages that make up a + Linux distribution as well as a lot of metadata about those software packages. + Tools are inclued to construct those stores from pre-built software and to pull + files back out to turn into bootable images. +homepage: https://github.com/weldr/bdcs +category: Distribution +author: Chris Lumens +maintainer: clumens@redhat.com +license: LGPL +license-file: LICENSE +build-type: Custom +cabal-version: >= 1.10 + +data-dir: data +data-files: sysusers-default.conf, + tmpfiles-default.conf, + tmpfiles-ostree.conf, + nsswitch-altfiles.conf + +extra-source-files: ChangeLog.md, + Dockerfile, + Dockerfile.build, + Dockerfile.integration-test, + entrypoint-integration-test.sh, + entrypoint.sh, + cabal.config, + Makefile, + queries, + README.md + schema.sql, + src/tests/*.hs, + src/tests/BDCS/*.hs, + src/tests/BDCS/Export/*.hs, + src/tests/BDCS/RPM/*.hs, + tests/*.sh + +custom-setup + setup-depends: base, + Cabal, + filepath + +source-repository head + type: git + location: https://github.com/weldr/bdcs + +flag scripts + description: Enable importing package scripts to the database + default: False + +library + hs-source-dirs: src + + exposed-modules: BDCS.Build.NPM, + BDCS.Builds, + BDCS.CS, + BDCS.DB, + BDCS.Depclose, + BDCS.Depsolve, + BDCS.Exceptions, + BDCS.Export.Directory, + BDCS.Export.Qcow2, + BDCS.Export.Ostree, + BDCS.Export.Tar, + BDCS.Export.TmpFiles, + BDCS.Export.Utils, + BDCS.Files, + BDCS.GroupKeyValue, + BDCS.Groups, + BDCS.Import.Comps, + BDCS.Import.Conduit, + BDCS.Import.NPM, + BDCS.Import.RPM, + BDCS.Import.Repodata, + BDCS.Import.State, + BDCS.Import.URI, + BDCS.KeyType, + BDCS.KeyValue, + BDCS.Label.Docs, + BDCS.Label.Fonts, + BDCS.Label.FileLabels, + BDCS.Label.InfoPage, + BDCS.Label.Library, + BDCS.Label.License, + BDCS.Label.ManPage, + BDCS.Label.Service, + BDCS.Label.Translation, + BDCS.Label.Types, + BDCS.Label.Utils, + BDCS.NPM.SemVer, + BDCS.Packages, + BDCS.Projects, + BDCS.RPM.Builds, + BDCS.RPM.Files, + BDCS.RPM.Groups, + BDCS.RPM.Projects, + BDCS.RPM.Requirements, + BDCS.RPM.Scripts, + BDCS.RPM.Signatures, + BDCS.RPM.Sources, + BDCS.RPM.Utils, + BDCS.ReqType, + BDCS.Requirements, + BDCS.Scripts, + BDCS.Signatures, + BDCS.Sources, + BDCS.Utils.Conduit, + BDCS.Utils.Either, + BDCS.Utils.Error, + BDCS.Utils.Filesystem, + BDCS.Utils.Mode, + BDCS.Utils.Monad + BDCS.Version + + build-depends: aeson >= 1.0.0.0 && < 1.3.0.0, + base >= 4.9 && < 5.0, + bytestring >= 0.10 && < 0.11, + codec-rpm >= 0.2.0 && < 0.3, + cond >= 0.4.1.1 && < 0.5.0.0, + conduit >= 1.2.8 && < 1.3, + conduit-combinators >= 1.1.0 && < 1.2, + conduit-extra >= 1.1.0 && < 1.2, + containers >= 0.5.7.1 && < 0.6, + content-store >= 0.2.0 && < 0.3.0, + cpio-conduit >= 0.7.0 && < 0.8.0, + cryptonite >= 0.22 && < 0.30, + directory >= 1.3.0.0 && < 1.4.0.0, + esqueleto >= 2.5.3 && < 2.6.0, + exceptions >= 0.8.0 && < 0.9.0, + filepath >= 1.4.1.1 && < 1.5.0.0, + gi-gio >= 2.0.14 && < 2.1.0, + gi-glib >= 2.0.14 && < 2.1.0, + gi-ostree >= 1.0.3 && < 1.1.0, + gitrev >= 1.3.1 && < 1.4.0, + http-conduit >= 2.2.3 && < 2.3.0, + memory >= 0.14.3 && < 0.15.0, + monad-control >= 1.0.1.0 && < 1.1.0.0, + monad-logger >= 0.3.20.2 && < 0.4.0, + mtl >= 2.2.1 && < 2.3, + network-uri >= 2.6.0 && < 2.7.0, + parsec >= 3.1.10 && < 3.2.0, + parsec-numbers >= 0.1.0 && < 0.2.0, + persistent >= 2.7.0 && < 2.8.0, + persistent-sqlite >= 2.6.0 && < 2.7.0, + persistent-template >= 2.5.0 && < 2.6.0, + process >= 1.4.3.0 && < 2.0, + regex-pcre >= 0.94 && < 0.95, + resourcet >= 1.1.9 && < 1.2, + split >= 0.2.3 && < 0.3, + tar >= 0.5 && < 0.6, + tar-conduit >= 0.1.0 && < 0.2.0, + temporary >= 1.2.0.4 && < 1.3.0.0, + text >= 1.2.2.0 && < 1.3, + time >= 1.6.0.1 && < 2.0, + unix >= 2.7.2.1 && < 2.8.0.0, + unordered-containers >= 0.2.7.2 && < 0.2.9.0, + xml-conduit >= 1.4.0.4 && < 1.8.0 + + pkgconfig-depends: ostree-1 >= 2017.8 + + other-modules: Paths_bdcs + default-language: Haskell2010 + + if flag(scripts) + cpp-options: -DSCRIPTS + cc-options: "-DSCRIPTS" + ghc-options: -Wall + else + ghc-options: -Wall + +executable bdcs + main-is: bdcs.hs + hs-source-dirs: src/tools + + other-modules: Utils.GetOpt, + Utils.Subcommands + + build-depends: bdcs, + base >= 4.7 && < 5.0, + 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, + monad-loops >= 0.4.0 && < 0.5, + process >= 1.4.3.0 && < 2.0, + text >= 1.2.2.0 && < 1.3 + + default-language: Haskell2010 + + ghc-options: -Wall + +executable bdcs-import + main-is: import.hs + hs-source-dirs: src/tools + + other-modules: Utils.GetOpt + + build-depends: bdcs, + base >= 4.7 && < 5.0, + cond >= 0.4.1.1 && < 0.5.0.0, + content-store >= 0.2.0 && < 0.3.0, + directory >= 1.3.0.0 && < 1.4.0.0, + mtl >= 2.2.1, + network-uri, + text >= 1.2.2.0 && < 1.3 + + default-language: Haskell2010 + + ghc-options: -Wall + +executable bdcs-inspect + main-is: inspect.hs + hs-source-dirs: src/tools/inspect, + src/tools + + other-modules: Utils.GetOpt, + Utils.IO, + Utils.Subcommands + + build-depends: bdcs, + base >= 4.7 && < 5.0, + 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, + monad-loops >= 0.4.0 && < 0.5, + process >= 1.4.3.0 && < 2.0, + text >= 1.2.2.0 && < 1.3 + + default-language: Haskell2010 + + ghc-options: -Wall + +executable inspect-groups + main-is: groups.hs + hs-source-dirs: src/tools/inspect/subcommands, + src/tools/inspect, + src/tools + + other-modules: Utils.GetOpt, + Utils.IO, + Utils.KeyVal + + build-depends: aeson >= 1.0.0.0 && < 1.3.0.0, + aeson-pretty, + base >= 4.7 && < 5.0, + bdcs, + bytestring >= 0.10 && < 0.11, + cond >= 0.4.1.1 && < 0.5.0.0, + conduit >= 1.2.8 && < 1.3, + directory >= 1.3.0.0 && < 1.4.0.0, + mtl >= 2.2.1 && < 2.3, + persistent-sqlite >= 2.6.0 && < 2.7.0, + regex-pcre >= 0.94 && < 0.95, + text >= 1.2.2.0 && < 1.3 + + default-language: Haskell2010 + ghc-options: -Wall + +executable inspect-ls + main-is: ls.hs + hs-source-dirs: src/tools/inspect/subcommands, + src/tools/inspect, + src/tools + + other-modules: Utils.Exceptions, + Utils.GetOpt, + Utils.IO, + Utils.KeyVal + + build-depends: aeson >= 1.0.0.0 && < 1.3.0.0, + aeson-pretty, + base >= 4.7 && < 5.0, + bdcs, + bytestring >= 0.10 && < 0.11, + cond >= 0.4.1.1 && < 0.5.0.0, + conduit >= 1.2.8 && < 1.3, + directory >= 1.3.0.0 && < 1.4.0.0, + mtl >= 2.2.1 && < 2.3, + regex-pcre >= 0.94 && < 0.95, + text >= 1.2.2.0 && < 1.3, + time >= 1.6.0.1 && < 2.0 + + default-language: Haskell2010 + ghc-options: -Wall + +executable inspect-nevras + main-is: nevras.hs + hs-source-dirs: src/tools/inspect/subcommands, + src/tools/inspect, + src/tools + + other-modules: Utils.GetOpt, + Utils.IO + + build-depends: bdcs, + base >= 4.7 && < 5.0, + cond >= 0.4.1.1 && < 0.5.0.0, + conduit >= 1.2.8 && < 1.3, + directory >= 1.3.0.0 && < 1.4.0.0, + mtl >= 2.2.1 && < 2.3, + regex-pcre >= 0.94 && < 0.95, + text >= 1.2.2.0 && < 1.3 + + default-language: Haskell2010 + ghc-options: -Wall + +executable bdcs-export + main-is: export.hs + hs-source-dirs: src/tools + + other-modules: Utils.GetOpt + + build-depends: bdcs, + base >= 4.9 && < 5.0, + cond >= 0.4.1.1 && < 0.5.0.0, + conduit >= 1.2.8 && < 1.3, + content-store >= 0.2.0 && < 0.3.0, + directory >= 1.3.0.0 && < 1.4.0.0, + mtl >= 2.2.1 && < 2.3, + text >= 1.2.2.0 && < 1.3 + + default-language: Haskell2010 + + ghc-options: -Wall + +executable bdcs-tmpfiles + main-is: bdcs-tmpfiles.hs + hs-source-dirs: src/tools + + build-depends: bdcs, + base >= 4.9 && < 5.0, + directory >= 1.3.0.0 && < 1.4.0.0 + + default-language: Haskell2010 + + ghc-options: -Wall + +executable bdcs-depsolve + main-is: depsolve.hs + hs-source-dirs: src/tools + + other-modules: Utils.GetOpt + + build-depends: bdcs, + base >= 4.9 && < 5.0, + mtl >= 2.2.1 && < 2.3, + text >= 1.2.2.0 && < 1.3 + + default-language: Haskell2010 + + ghc-options: -Wall + +Test-Suite test-bdcs + type: exitcode-stdio-1.0 + hs-source-dirs: src, + src/tests + main-is: Spec.hs + + build-depends: hspec == 2.*, + HUnit >= 1.5.0.0 && < 1.7.0.0, + aeson >= 1.0.0.0 && < 1.3.0.0, + base >= 4.8 && < 5.0, + bytestring >= 0.10 && < 0.11, + codec-rpm >= 0.2.0 && < 0.3, + cond >= 0.4.1.1 && < 0.5.0.0, + conduit >= 1.2.8 && < 1.3, + conduit-combinators >= 1.1.0 && < 1.2, + containers >= 0.5.7.1 && < 0.6, + directory >= 1.3.0.0 && < 1.4.0.0, + esqueleto >= 2.5.3 && < 2.6.0, + filepath >= 1.4.1.1 && < 1.5.0.0, + gi-gio >= 2.0.14 && < 2.1.0, + gi-glib >= 2.0.14 && < 2.1.0, + monad-logger >= 0.3.20.2 && < 0.4.0, + mtl >= 2.2.1 && < 2.3, + parsec >= 3.1.10 && < 3.2.0, + parsec-numbers >= 0.1.0 && < 0.2.0, + persistent >= 2.7.0 && < 2.8.0, + persistent-sqlite >= 2.6.0 && < 2.7.0, + persistent-template >= 2.5.0 && < 2.6.0, + resourcet >= 1.1.9 && < 1.2, + text >= 1.2.2.0 && < 1.3, + time >= 1.6.0.1 && < 2.0, + unix >= 2.7.2.1 && < 2.8.0.0 + + ghc-options: -Wall + cpp-options: -DTEST + + default-language: Haskell2010 diff --git a/cabal.config b/cabal.config new file mode 100644 --- /dev/null +++ b/cabal.config @@ -0,0 +1,1 @@ +constraints: persistent-sqlite +systemlib diff --git a/data/nsswitch-altfiles.conf b/data/nsswitch-altfiles.conf new file mode 100644 --- /dev/null +++ b/data/nsswitch-altfiles.conf @@ -0,0 +1,63 @@ +# +# /etc/nsswitch.conf +# +# An example Name Service Switch config file. This file should be +# sorted with the most-used services at the beginning. +# +# The entry '[NOTFOUND=return]' means that the search for an +# entry should stop if the search in the previous entry turned +# up nothing. Note that if the search failed due to some other reason +# (like no NIS server responding) then the search continues with the +# next entry. +# +# Valid entries include: +# +# nisplus Use NIS+ (NIS version 3) +# nis Use NIS (NIS version 2), also called YP +# dns Use DNS (Domain Name Service) +# files Use the local files +# db Use the local database (.db) files +# compat Use NIS on compat mode +# hesiod Use Hesiod for user lookups +# [NOTFOUND=return] Stop searching if not found so far +# + +# To use db, put the "db" in front of "files" for entries you want to be +# looked up first in the databases +# +# Example: +#passwd: db files nisplus nis +#shadow: db files nisplus nis +#group: db files nisplus nis + +passwd: files altfiles sss +shadow: files sss +group: files altfiles sss +initgroups: files + +#hosts: db files nisplus nis dns +hosts: files dns myhostname + +# Example - obey only what nisplus tells us... +#services: nisplus [NOTFOUND=return] files +#networks: nisplus [NOTFOUND=return] files +#protocols: nisplus [NOTFOUND=return] files +#rpc: nisplus [NOTFOUND=return] files +#ethers: nisplus [NOTFOUND=return] files +#netmasks: nisplus [NOTFOUND=return] files + +bootparams: nisplus [NOTFOUND=return] files + +ethers: files +netmasks: files +networks: files +protocols: files +rpc: files +services: files sss + +netgroup: nisplus sss + +publickey: nisplus + +automount: files nisplus +aliases: files nisplus diff --git a/data/sysusers-default.conf b/data/sysusers-default.conf new file mode 100644 --- /dev/null +++ b/data/sysusers-default.conf @@ -0,0 +1,112 @@ +u stap-server 155 "Systemtap Compile Server" /var/lib/stap-server +u rpc 32 "Rpcbind Daemon" /var/lib/rpcbind +u arpwatch 77 - /var/lib/arpwatch +u colord - "User for colord" /var/lib/colord +g sfcb - +u postgres 26 "PostgreSQL Server" /var/lib/pgsql +g slocate 21 +u tcpdump 72 +g kvm 36 +u qemu 107 "qemu user" +m qemu kvm +g dip 40 +u sssd - "User for sssd" +g screen 84 +u ldap 55 "OpenLDAP server" /var/lib/ldap +u gdm 42 - /var/lib/gdm +g stapdev 158 +g stapusr 156 +g stapsys 157 +g dirsrv $dirsrv_gid +u dirsrv $dirsrv_uid "389-ds-base" /usr/share/dirsrv +g systemd-journal 190 +g floppy 19 +g utmp 22 +g tape 33 +g dialout 18 +g cdrom 11 +g input - +u systemd-bus-proxy - "systemd Bus Proxy" +u systemd-network 192 "systemd Network Management" +u abrt 173 - /etc/abrt +u mailman 41 "GNU Mailing List Manager" /usr/lib/mailman +g pegasus 65 +u pegasus 66 "tog-pegasus OpenPegasus WBEM/CIM services" /var/lib/Pegasus +g utmp 22 +u ntp 38 - /etc/ntp +u pcp - "Performance Co-Pilot" /var/lib/pcp +g libvirt - +g pkcs11 - +u smmsp 51 - /var/spool/mqueue +u mailnull 47 - /var/spool/mqueue +u bacula 133 "Bacula Backup System" /var/spool/bacula +g cgred - +u tss 59 "Account used by the trousers package to sandbox the tcsd daemon" /dev/null +u dovecot 97 "Dovecot IMAP server" /usr/libexec/dovecot +u dovenull - "Dovecot's unauthorized user" /usr/libexec/dovecot +u sssd - "User for sssd" +u memcached - "Memcached daemon" /run/memcached +u libstoragemgmt - "daemon account for libstoragemgmt" /var/run/lsm +u radvd 75 "radvd user" +u ident 98 +g kvm 36 +u qemu 107 "qemu user" +m qemu kvm +u uuidd - "UUID generator helper daemon" /var/lib/libuuid +g wbpriv 88 +u squid 23 - /var/spool/squid +g cgred - +u setroubleshoot - - /var/lib/setroubleshoot +u apache 48 "Apache" /usr/share/httpd +u sshd 74 "Privilege-separated SSH" /var/empty/sshd +u usbmuxd 113 "usbmuxd user" +g ldap 55 +u nslcd 65 "LDAP Client User" +g saslauth 76 +u saslauth - "Saslauthd user" /run/saslauthd +u ipsilon - "Ipsilon Server" /var/lib/ipsilon +g quaggavt 85 +u quagga 92 "Quagga routing suite" /var/run/quagga +u oprofile 16 "Special user account to be used by OProfile" /var/lib/oprofile +u nfsnobody 65534 "Anonymous NFS User" /var/lib/nfs +u rpcuser 29 "RPC Service User" /var/lib/nfs +g wbpriv 88 +u gnome-initial-setup - - /run/gnome-initial-setup/ +g utmp 22 +g utempter 35 +u dhcpd 177 "DHCP server" +g saslauth 76 +u cyrus 76 "Cyrus IMAP Server" /var/lib/imap +m cyrus saslauth +u rtkit 172 "RealtimeKit" /proc +u avahi 70 "Avahi mDNS/DNS-SD Stack" /var/run/avahi-daemon +u haproxy 188 "haproxy" /var/lib/haproxy +u ods - "opendnssec daemon account" /etc/opendnssec +u tomcat 91 "Apache Tomcat" /usr/share/tomcat +u mysql 27 "MariaDB Server" /var/lib/mysql +u polkitd - "User for polkitd" +g mail 12 +g postdrop 90 +u postfix 89 - /var/spool/postfix +m postfix mail +u named 25 "Named" /var/named +u dbus 81 "System message bus" +g ssh_keys - +g pulse-rt - +g pulse-access - +u pulse 171 "PulseAudio System Daemon" /var/run/pulse +g uucp 14 +u uucp 10 "Uucp user" /var/spool/uucp +u chrony - - /var/lib/chrony +u ods - "softhsm private keys owner" /var/lib/softhsm +u hsqldb 96 - /var/lib/hsqldb +g lock 54 +u pkiuser 17 "Certificate System" /usr/share/pki +u avahi-autoipd 170 "Avahi IPv4LL Stack" /var/lib/avahi-autoipd +u nscd 28 "NSCD Daemon" +u unbound - "Unbound DNS resolver" /etc/unbound +u geoclue - "User for geoclue" /var/lib/geoclue +g wireshark - +u amandabackup 33 "Amanda user" /var/lib/amanda +u sssd - "User for sssd" +u radiusd 95 "radiusd user" /var/lib/radiusd diff --git a/data/tmpfiles-default.conf b/data/tmpfiles-default.conf new file mode 100644 --- /dev/null +++ b/data/tmpfiles-default.conf @@ -0,0 +1,36 @@ +d /etc - - - - +d /etc/sysconfig - - - - +d /run - - - - +d /selinux - - - - +d /usr - - - - +d /usr/bin - - - - +d /usr/lib - - - - +d /usr/lib64 - - - - +d /usr/lib/debug - - - - +d /usr/lib/debug/usr - - - - +d /usr/lib/debug/usr/bin - - - - +d /usr/lib/debug/usr/lib - - - - +d /usr/lib/debug/usr/lib64 - - - - +d /usr/lib/debug/usr/sbin - - - - +d /usr/sbin - - - - +d /var/cache/fontconfig - - - - +d /var/lib/logrotate - - - - +d /var/lib/pear - - - - +d /var/lib/rpm-state/mailman/ - - - - +d /var/log/ - - - - +L+ /bin - - - - usr/bin +L+ /etc/mtab - - - - /proc/mounts +L+ /etc/sysconfig/selinux - - - - ../selinux/config +L+ /lib64 - - - - usr/lib64 +L+ /lib - - - - usr/lib +L+ /sbin - - - - usr/sbin +L+ /usr/lib/debug/bin - - - - usr/bin +L+ /usr/lib/debug/lib64 - - - - usr/lib64 +L+ /usr/lib/debug/lib - - - - usr/lib +L+ /usr/lib/debug/sbin - - - - usr/sbin +L+ /usr/lib/debug/usr/.dwz - - - - ../.dwz +L+ /var/lock - - - - ../run/lock +L+ /var/run - - - - ../run +f /var/log/btmp 0600 root utmp - +f /var/log/lastlog 0644 root root - +f /var/log/wtmp 0664 root utmp - diff --git a/data/tmpfiles-ostree.conf b/data/tmpfiles-ostree.conf new file mode 100644 --- /dev/null +++ b/data/tmpfiles-ostree.conf @@ -0,0 +1,18 @@ +d /var/home 0755 root root - +d /var/opt 0755 root root - +d /var/srv 0755 root root - +d /var/roothome 0700 root root - +d /var/usrlocal 0755 root root - +d /var/usrlocal/bin 0755 root root - +d /var/usrlocal/etc 0755 root root - +d /var/usrlocal/games 0755 root root - +d /var/usrlocal/include 0755 root root - +d /var/usrlocal/lib 0755 root root - +d /var/usrlocal/man 0755 root root - +d /var/usrlocal/sbin 0755 root root - +d /var/usrlocal/share 0755 root root - +d /var/usrlocal/src 0755 root root - +d /var/mnt 0755 root root - +d /run/media 0755 root root - +d /var/lib 0755 root root - +L /var/lib/rpm - - - - ../../usr/share/rpm diff --git a/entrypoint-integration-test.sh b/entrypoint-integration-test.sh new file mode 100644 --- /dev/null +++ b/entrypoint-integration-test.sh @@ -0,0 +1,20 @@ +#!/bin/bash + +set -ex + +cd /bdcs/ + +./tests/test_tmpfiles.sh +./tests/test_import.sh +./tests/test_export.sh +./tests/test_depsolve.sh + +# collect coverage data from unit tests and binaries +mkdir ./dist/hpc/vanilla/tix/bdcs-tmpfiles/ +mkdir ./dist/hpc/vanilla/tix/bdcs-import/ +mkdir ./dist/hpc/vanilla/tix/bdcs-export/ +mkdir ./dist/hpc/vanilla/tix/bdcs-depsolve/ +mv bdcs-tmpfiles.tix ./dist/hpc/vanilla/tix/bdcs-tmpfiles/ +mv bdcs-import.tix ./dist/hpc/vanilla/tix/bdcs-import/ +mv bdcs-export.tix ./dist/hpc/vanilla/tix/bdcs-export/ +mv bdcs-depsolve.tix ./dist/hpc/vanilla/tix/bdcs-depsolve/ diff --git a/entrypoint.sh b/entrypoint.sh new file mode 100644 --- /dev/null +++ b/entrypoint.sh @@ -0,0 +1,25 @@ +#!/bin/bash + +STORE=$(realpath /mddb/${STORE:-cs.repo}) +MDDB="/mddb/${MDDB:-metadata.db}" + +if [[ -e "$STORE" && -z "$KEEP_STORE" && "$STORE" =~ ^/mddb/ ]]; then + rm -rf "$STORE" +fi + +if [[ -e "$MDDB" && -z "$KEEP_MDDB" ]]; then + rm "$MDDB" +fi + +if [ ! -f "$MDDB" ]; then + sqlite3 "$MDDB" < /root/schema.sql +fi + +for f in /rpms/*rpm; do + /usr/local/bin/bdcs import "$MDDB" "$STORE" file://${f} +done + +# if URL was passed try to import from there +if [ -n "$IMPORT_URL" ]; then + /usr/local/bin/bdcs import "$MDDB" "$STORE" $IMPORT_URL +fi diff --git a/queries b/queries new file mode 100644 --- /dev/null +++ b/queries @@ -0,0 +1,76 @@ +* List contents of a package given by name. + + select files.path + from files, key_val, file_key_values + on key_val.id == file_key_values.key_val_id and + file_key_values.file_id == files.id + where key_val.key_value == "packageName" and + key_val.val_value == "python3-kickstart" + ^ YOUR RPM PACKAGE NAME HERE + +* List contents of a package given by NEVRA. + + select files.path + from projects, sources, builds, files, build_files, key_val, file_key_values + on key_val.id == file_key_values.key_val_id and + file_key_values.file_id == files.id and + sources.project_id == projects.id and + builds.source_id == sources.id and + build_files.build_id == builds.id and + build_files.file_id == files.id + where key_val.key_value == "packageName" and + key_val.val_value == "pykickstart" and + sources.version == "1.99.66.6" and + builds.epoch == 0 and + builds.release == "1.el7" and + builds.arch == "noarch"; + +* List contents of a build. + + select files.path + from files, build_files, builds + on files.id == build_files.file_id and + builds.id == build_files.build_id + where builds.id == 1; + ^ YOUR BUILD ID HERE. + +* Find the source package name for a given subpackage. + + select projects.name + from projects, sources, builds, build_key_values, key_val + on projects.id == sources.project_id and + sources.id == builds.source_id and + builds.id == build_key_values.build_id and + key_val.id == build_key_values.key_val_id + where key_val.key_value == "packageName" and + key_val.val_value == "anaconda-tui"; + ^ YOUR SUBPACKAGE NAME HERE + +* Find all packages that contain a given filename. + + select projects.name + from builds, files, build_files, sources, projects + on builds.id == build_files.build_id and + files.id == build_files.file_id and + builds.source_id == sources.id and + sources.project_id == projects.id + where files.path == "/usr/bin/ls"; + ^ YOUR FILENAME HERE + +* Find all builds that contain a given filename. + + select builds.* + from builds, files, build_files + on build_files.build_id == builds.id and + build_files.file_id == files.id + where files.path == "/usr/bin/ksvalidator"; + ^ YOUR FILENAME HERE + +* Find all builds that match a given package name. + + select builds.* + from builds, sources, projects + on builds.source_id == sources.id and + sources.project_id == projects.id + where projects.name == "coreutils-8.22-15.el7.src.rpm"; + ^ YOUR PACKAGE NAME HERE diff --git a/schema.sql b/schema.sql new file mode 100644 --- /dev/null +++ b/schema.sql @@ -0,0 +1,329 @@ +-- Increment this number any time the schema is changed, and update schemaVersion +-- in BDCS/DB.hs +PRAGMA user_version = 4; + +-- This describes the schema used by the metadata database (mddb). We +-- considered several options for how to implement the mddb, finally deciding +-- upon sqlite (though, other relational databases would also be fine). We +-- would like the mddb to eventually hold the data for multiple builds of each +-- package from many releases. This could mean hundreds of millions of rows +-- needed to store the files. Thus, the ability to work with a fairly large +-- database is important. +-- +-- We evaluated document-based databases like mongodb but found it too slow and +-- a little unwieldy to use for our purposes. We also evaluated key/value +-- systems like redis but found that accessing data was slow unless you add +-- your own index algorithm. And if you're going to do that, you might as well +-- use something that already provides indexing. Add sqlite's ubiquity and +-- the ability to move to another relational database if needed, and the +-- decision was made. +-- +-- In general, the design of this database does not worry too much about +-- normal forms. However, we do use a lot of intermediate tables to represent +-- one-to-many relationships as well as ensure that a piece of data only exists +-- in one place in the database. Examples of these intermediate tables are +-- the various *_files tables and the *_key_values tables. +-- +-- At the same time, we have sought to not overload the database with tons of +-- unnecessary tables. That is why there is the key_val table and all the +-- associated *_key_values tables. There are lots of pieces of data at all +-- levels (builds, files, etc.) that only exist for a handful of items. +-- Alternately, there are pieces of data that exist with a wide range of +-- possible values. The generic key_val table allows storing this kind of +-- data without making too much of a mess. + +-- A project is the database's representation of some upstream that produces +-- a piece of software. This could be as simple as a tarball that gets built +-- into a single RPM, or as complicated as a live OS image, or anything in +-- between. We don't impose any restrictions here on what kind of thing a +-- project can be. +-- +-- Starting with this table, we split NEVRA-style information up between here, +-- sources, and builds because it makes sense to do so. At each level, we only +-- store information that does not change between instances of that level. For +-- instance, this table stores the name. All sources released from a given +-- project will have the same name, as will all builds created from those +-- sources. +-- +-- At any one time, there will only be one row in this table for a single +-- project. It does not make sense to have several instances. +create table projects ( + id integer primary key, + name text not null unique, + summary text not null, + description text not null, + homepage text, + upstream_vcs text not null +); + +-- A source represents a release of a single upstream project (hence the +-- project_id reference). This table continues the theme of spreading NEVRA +-- style information out to several tables. In this table we store the version +-- since that piece is specific to a source. +-- +-- Over time, there will be several entries in this table with the same +-- project_id, as an upstream makes several releases and we import them. +-- +-- FIXME: Explain source_ref. We're not populating that right now anyway. +create table sources ( + id integer primary key, + project_id integer references projects(id) not null, + license text not null, + version text not null, + source_ref text not null +); +create index sources_project_id_idx on sources(project_id); + +-- A build represents a single successful compilation of a single source (hence +-- the source_id reference). It continues the theme of spreading NEVRA-style +-- information out to several tables. In this table we store the epoch, +-- release, and architecture since those pieces are specific to a build. +-- +-- Over time, there could potentially be many entries in the table with the +-- same source_id, depending on how often upstream does releases and how +-- frequently a single release is rebuilt. +-- +-- A build also has only a single changelog entry, the entry corresponding to +-- this latest build. Constructing the entire chain of changes for a given +-- project would require grabbing all rows out of this table whose associated +-- source has an associated project with the name you're looking for. It's a +-- little complicated, but it's expected that this sort of operation will not +-- be required often. +-- +-- FIXME: Explain build_config_ref and build_env_ref. We're not populating +-- those right now anyway. +create table builds ( + id integer primary key, + source_id integer references sources(id) not null, + epoch integer default 0, + release text not null, + arch text not null, + build_time text not null, + changelog blob not null, + build_config_ref text not null, + build_env_ref text not null +); +create index builds_source_id_idx on builds(source_id); + +-- Associate various types of build signatures with a single build. A build +-- signature could take the form of the RSA or SHA1 header out of a built RPM, or +-- a variety of other formats. Here we store both the type of the signature and +-- the signature itself, so it can be verified by other tools. A single build +-- can have several signatures at the same time. +create table build_signatures ( + id integer primary key, + build_id integer references builds(id) not null, + signature_type text not null, + signature_data blob not null +); +create index build_signatures_build_id_idx on build_signatures(build_id); + +-- This is one of the largest tables in the metadata database - the one that +-- stores a row for every file that has been imported. This table stores +-- everything required for recreating a file on disk with the right path and +-- permissions, except for the contents of the file. This is the metadata +-- database. The contents live in the content store. +-- +-- It is possible that a single file exists in multiple compilation units +-- (packages, for instance). Thus, the relationship between a file and what +-- contains it must be in some other table. See build_files for more +-- information. +-- +-- It is also possible (and in fact, likely) that a single file will exist in +-- multiple builds. Consider two builds of the same source - it is likely that +-- many of the files will be identical, and that only some will change in any +-- meaningful way. It would be nice if we could reduce duplication and only +-- store a new row for a single file when it had real changes. Alas, a file +-- that is identical across two builds will still have a different mtime. +-- +-- Thus (for now), each new build imported will result in rows for all its file +-- being created again. +-- +-- The content store contains some metadata about the file (size, mode) that is +-- not duplicated here. This table does include mtime, since that is not tracked +-- by the content store (and would cause problems with identitcal files across +-- multiple builds if it did), and user/group, since those are stored here as +-- names instead of UID/GID. +create table files ( + id integer primary key, + path text not null, + file_user text not null, + file_group text not null, + mtime integer not null, + cs_object blob, + mode integer not null, + size integer not null, + target text +); +create index files_path_idx on files(path); + +-- This table associates a single file with a single source. It allows for a +-- file to be part of several sources at the same time, and for a single source +-- to contain several files. +create table source_files ( + id integer primary key, + source_id integer references sources(id) not null, + file_id integer references files(id) not null +); +create index source_files_source_id_idx on source_files(source_id); +create index source_files_file_id_idx on source_files(file_id); + +-- This table associates a single file with a single build. It allows for a +-- file to be a part of several builds at the same time, and for a single build +-- to contain several files. +create table build_files ( + id integer primary key, + build_id integer references builds(id) not null, + file_id integer references files(id) not null +); +create index build_files_build_id_idx on build_files(build_id); +create index build_files_file_id_idx on build_files(file_id); + +-- This table is a free form key/value association. It allows storing data that +-- doesn't make sense anywhere else, or is more free form in nature, or just +-- doesn't fit with a traditional SQL-based database layout. This style of data +-- can exist at many levels - projects have it, as do sources, builds, and files. +-- The key/value pairs are stored in this table, and then the association with +-- some project or source is created in a specific table. This allows sharing +-- the key/value pair among several builds, or several files, or some combination. +-- +-- Primary examples of key/value data are: +-- +-- * Associating produced RPMs with a single build. Packages are a concept that +-- exist with RPM and potentially other sources of input, but not all. Thus +-- we do not go out of our way to model them in the database. Using a key/val +-- allows keeping track of what group of RPMs came from a given build without +-- needing extra tables that only make sense sometimes. +-- * Associating files with an RPM. For similar reasons, we use the key/value +-- pairing to keep track of which files make up which RPM. +-- * Keeping track of rpm-provide data. +create table key_val ( + id integer primary key, + key_value text not null, + val_value text, + ext_value text +); + +-- for key/val, it's not likely that we'll have a query that is looking up +-- a key name based on the value name. Queries will either be looking for +-- values given a key, or looking for ids based on a key/value pair. +-- So instead of an index on val_value, make the second index on both key +-- and value. +create index key_val_key_value_idx on key_val(key_value); +create index key_val_val_value_idx on key_val(key_value, val_value); + +-- Associate key/value data with an individual project. It is possible for a +-- single project to have many different key/value data pieces, or none. +create table project_values ( + id integer primary key, + project_id integer references projects(id) not null, + key_val_id integer references key_val(id) not null +); +create index project_values_project_id_idx on project_values(project_id); +create index project_values_key_val_id_idx on project_values(key_val_id); + +-- Associate key/value data with an individual source. It is possible for a +-- single source to have many different key/value data pieces, or none. +create table source_key_values ( + id integer primary key, + source_id integer references sources(id) not null, + key_val_id integer references key_val(id) not null +); +create index source_key_values_source_id_idx on source_key_values(source_id); +create index source_key_values_key_val_id_idx on source_key_values(key_val_id); + +-- Associate key/value data with an individual build. It is possible for a +-- single build to have many different key/value data pieces, or none. +create table build_key_values ( + id integer primary key, + build_id integer references builds(id) not null, + key_val_id integer references key_val(id) not null +); +create index build_key_values_build_id_idx on build_key_values(build_id); +create index build_key_values_key_val_id_idx on build_key_values(key_val_id); + +-- Associate key/value data with an individual file. It is possible for a +-- single file to have many different key/value data pieces, or none. +create table file_key_values ( + id integer primary key, + file_id integer references files(id) not null, + key_val_id integer references key_val(id) not null +); +create index file_key_values_file_id_idx on file_key_values(file_id); +create index file_key_values_key_val_id_idx on file_key_values(key_val_id); + +-- Groups of things. e.g., a rpm subpackage, a comps group, a module +-- This differs from file tags in that a group can contain other groups in +-- addition to individual files, and a group can be empty. +create table groups ( + id integer primary key, + name text not null, + group_type text not null, + build_id integer references builds(id) null +); +create index groups_name_idx on groups(name); + +create table group_files ( + id integer primary key, + group_id integer references groups(id) not null, + file_id integer references files(id) not null +); +create index group_files_group_id_idx on group_files(group_id); +create index group_files_file_id_idx on group_files(file_id); + +-- FIXME how do you prevent cycles in this thing? +create table group_groups ( + id integer primary key, + parent_group_id references groups(id) not null, + child_group_id references groups(id) not null +); +create index group_groups_parent_group_id_idx on group_groups(parent_group_id); +create index group_groups_child_group_id_idx on group_groups(child_group_id); + +create table group_key_values ( + id integer primary key, + group_id integer references groups(id) not null, + key_val_id integer references key_val(id) not null +); +create index group_key_values_group_id_idx on group_key_values(group_id); +create index group_key_values_key_val_id_idx on group_key_values(key_val_id); + +create table requirements ( + id integer primary key, + req_language text not null, + req_context text not null, + req_strength text not null, + req_expr text not null +); + +create table group_requirements ( + id integer primary key, + group_id integer references groups(id) not null, + req_id integer references requirements(id) not null +); +create index group_requirements_group_id_idx on group_requirements(group_id); +create index group_requirements_req_id_idx on group_requirements(req_id); + +-- These things are temporary and should not be relied upon. We will be getting +-- rid of them once we have an idea how common scriptlets are. + +create table scripts ( + id integer primary key, + ty text not null, + body text not null, + trigger_prog text, + trigger_index integer, + trigger_name text, + trigger_version text, + trigger_flags integer +); + +create table group_scripts ( + id integer primary key, + group_id integer references groups(id) not null, + script_id integer references scripts(id) not null +); +create index group_scripts_group_id_idx on group_scripts(group_id); +create index group_scripts_script_id_idx on group_scripts(script_id); + +.quit diff --git a/src/BDCS/Build/NPM.hs b/src/BDCS/Build/NPM.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Build/NPM.hs @@ -0,0 +1,193 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module BDCS.Build.NPM(rebuildNPM) + where + +import Control.Monad(forM_, void, when) +import Control.Monad.Except(MonadError, throwError) +import Control.Monad.IO.Class(MonadIO, liftIO) +import Control.Monad.Trans.Resource(MonadBaseControl, MonadResource) +import Data.Bifunctor(bimap) +import Data.Bits((.|.)) +import Data.Conduit(sourceToList) +import qualified Data.Text as T +import Data.Time.Clock(UTCTime, getCurrentTime) +import Data.Time.Clock.POSIX(utcTimeToPOSIXSeconds) +import Database.Esqueleto +import System.FilePath((), joinPath, makeRelative, splitDirectories) +import System.Posix.Files(directoryMode, symbolicLinkMode) + +import BDCS.Builds(insertBuild, insertBuildKeyValue) +import BDCS.DB +import BDCS.Files(associateFilesWithBuild, sourceIdToFiles) +import BDCS.KeyType +import BDCS.Label.FileLabels(apply) +import BDCS.NPM.SemVer(SemVer, SemVerRangeSet, parseSemVer, parseSemVerRangeSet, satisfies, toText) + +rebuildNPM :: (MonadBaseControl IO m, MonadIO m, MonadError String m, MonadResource m) => Key Sources -> SqlPersistT m [Key Builds] +rebuildNPM sourceId = do + -- get the name and version for this source + (name, version) <- getNameVer + + -- figure out what sources satisfy the dependencies for this package + -- Each list element represents one of the dependencies, within those each + -- element is a source ID that satisfies the dependencies. sequence the whole thing + -- to get all of the possible combinations that satisfy all dependencies. + dependencies <- sequence <$> getDeps + + -- get the list of files for this source + sourceFiles <- sourceToList $ sourceIdToFiles sourceId + + -- For each dependency list, create a new build + mapM (relink sourceFiles (name, version)) dependencies + where + copyFile :: Files -> FilePath -> Files + copyFile f@Files{..} newPath = let + basePath = makeRelative "/package" $ T.unpack filesPath + in + f {filesPath = T.pack $ newPath basePath} + + getDeps :: (MonadIO m, MonadError String m) => SqlPersistT m [[(T.Text, SemVer)]] + getDeps = do + -- fetch the list of dependencies + -- the dependencies for a given source are stored as key/vals, k="dependency", v=package name, e=version expression + kvs <- select $ from $ \(kv `InnerJoin` skv) -> do + on $ kv ^. KeyValId ==. skv ^. SourceKeyValuesKey_val_id + where_ $ skv ^. SourceKeyValuesSource_id ==. val sourceId &&. + kv ^. KeyValKey_value ==. val (TextKey "dependency") + return (kv ^. KeyValVal_value, kv ^. KeyValExt_value) + depnames <- mapM (unpackName . fst) kvs + depvers <- mapM (unpackVersion . snd) kvs + + mapM getOneDep $ zip depnames depvers + where + unpackName name = maybe (throwError "Invalid dependency name") return $ unValue name + + unpackVersion ver = do + unmaybe <- maybe (throwError "Invalid dependency version") return $ unValue ver + either (throwError . show) return $ parseSemVerRangeSet unmaybe + + getOneDep :: (MonadIO m, MonadError String m) => (T.Text, SemVerRangeSet) -> SqlPersistT m [(T.Text, SemVer)] + getOneDep (name, range) = do + -- Get all npm Sources records that match the name + sources <- select $ from $ \(p `InnerJoin` s `InnerJoin` skv `InnerJoin` kv) -> do + on $ kv ^. KeyValId ==. skv ^. SourceKeyValuesKey_val_id + on $ s ^. SourcesId ==. skv ^. SourceKeyValuesSource_id + on $ p ^. ProjectsId ==. s ^. SourcesProject_id + where_ $ kv ^. KeyValKey_value ==. val (TextKey "npm") &&. + p ^. ProjectsName ==. val name + return $ s ^. SourcesVersion + + -- if nothing is found, that's an error + when (null sources) $ throwError $ "Unable to satisfy dependency for " ++ show name ++ " " ++ show range + + -- Parse the versions into SemVers + versions <- mapM unpackVersion sources + + let filteredVersions = filter (`satisfies` range) versions + return $ zip (repeat name) filteredVersions + + where + unpackVersion ver = either (throwError . show) return $ parseSemVer $ unValue ver + + getNameVer :: (MonadIO m, MonadError String m) => SqlPersistT m (T.Text, T.Text) + getNameVer = do + nv <- select $ from $ \(sources `InnerJoin` projects) -> do + on $ sources ^. SourcesProject_id ==. projects ^. ProjectsId + where_ $ sources ^. SourcesId ==. val sourceId + limit 1 + return (projects ^. ProjectsName, sources ^. SourcesVersion) + + when (null nv) $ throwError $ "No such source id " ++ show sourceId + + return $ bimap unValue unValue $ head nv + + relink :: (MonadBaseControl IO m, MonadIO m) => [Files] -> (T.Text, T.Text) -> [(T.Text, SemVer)] -> SqlPersistT m (Key Builds) + relink sourceFiles (name, ver) depList = do + buildTime <- liftIO getCurrentTime + + -- Create a directory for this module in /usr/lib/node_modules + -- NB: In order to allow multiple versions of an npm module to be included in the same export, + -- the /usr/lib/node_modules name is @ instead of just , + -- and none of the bin or man symlinks are installed to /usr/bin and /usr/share/man. It's up to the + -- export to determine which modules need to be accessible system-wide and to create the bin and man + -- symlinks and the /usr/lib/node_modules/ directory. + let module_dir = "/" "usr" "lib" "node_modules" T.unpack (T.concat [name, "@", ver]) + + -- Create the /usr/lib/node_modules/ directory, and a node_modules directory under that + moduleDirsIds <- mkdirs buildTime $ module_dir "node_modules" + + -- Copy everything from the Source into the module directory + let packageFiles = map (`copyFile` module_dir) sourceFiles + packageFilesIds <- mapM (\file -> (file,) <$> insert file) packageFiles + + -- For each of the dependencies, create a symlink from the /usr/lib/node_modules/@ directory + -- to this module's node_modules directory. + deplinkFilesIds <- mapM (createDepLink module_dir buildTime) depList + + + -- Apply the file-based labels + let buildFilesIds = moduleDirsIds ++ packageFilesIds ++ deplinkFilesIds + void $ apply buildFilesIds + + -- Create a build and add the files to it + createBuild $ map snd buildFilesIds + where + createDepLink :: MonadIO m => FilePath -> UTCTime -> (T.Text, SemVer) -> SqlPersistT m (Files, Key Files) + createDepLink module_dir buildTime (depname, depver) = let + verstr = toText depver + source = T.pack $ joinPath ["/", "usr", "lib", "node_modules", T.unpack (T.concat [depname, "@", verstr])] + dest = T.pack $ joinPath [module_dir, "node_modules", T.unpack depname] + link = Files dest "root" "root" (floor $ utcTimeToPOSIXSeconds buildTime) Nothing (fromIntegral $ symbolicLinkMode .|. 0o0644) 0 (Just source) + in + (link,) <$> insert link + + mkdirs :: MonadIO m => UTCTime -> FilePath -> SqlPersistT m [(Files, Key Files)] + mkdirs buildTime path = mapM mkdir $ scanl1 () $ splitDirectories path + where + mkdir :: MonadIO m => FilePath -> SqlPersistT m (Files, Key Files) + mkdir subPath = let + newdir = Files (T.pack subPath) "root" "root" (floor $ utcTimeToPOSIXSeconds buildTime) Nothing (fromIntegral $ directoryMode .|. 0o0755) 0 Nothing + in + (newdir,) <$> insert newdir + + createBuild :: MonadIO m => [Key Files] -> SqlPersistT m (Key Builds) + createBuild fids = do + buildTime <- liftIO getCurrentTime + + -- There is no equivalent to epoch or release in npm, so use 0 and "" + let epoch = 0 + let release = "" + -- FIXME there are some npm packages that are arch-specific but for now ignore those + let arch = "noarch" + -- FIXME changelog? + let changelog = "" + -- FIXME ?? + let build_config_ref = "BUILD_CONFIG_REF" + let build_env_ref = "BUILD_ENV_REF" + + buildId <- insertBuild $ Builds sourceId epoch release arch buildTime changelog build_config_ref build_env_ref + void $ associateFilesWithBuild fids buildId + + -- Record the exact-version dependencies used for this build + forM_ depList $ \(n, v) -> insertBuildKeyValue (TextKey "dependency") n (Just $ toText v) buildId + + return buildId diff --git a/src/BDCS/Builds.hs b/src/BDCS/Builds.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Builds.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: BDCS.Builds +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Manage 'Builds' records in the database. This record keeps track of a single +-- build of a single software source (tarball, etc.). A single source can be +-- built multiple times, each of which will require a separate 'Builds' record. + +module BDCS.Builds(associateBuildWithPackage, + findBuild, + getBuild, + insertBuild, + insertBuildKeyValue) + where + +import Control.Monad.IO.Class(MonadIO) +import qualified Data.Text as T +import Database.Esqueleto + +import BDCS.DB +import BDCS.KeyType +import BDCS.KeyValue(findKeyValue, insertKeyValue) + +-- | Find a single build of a software package in the database, returning the database key +-- for that build if it exists. All arguments are required and must be matched for this +-- function to return anything. Note that conceptually, a build is of some software source +-- which is why a key to a 'Sources' record is required. +findBuild :: MonadIO m => + Int -- ^ Epoch (usually, 0) + -> T.Text -- ^ Release + -> T.Text -- ^ Hardware architecture + -> Key Sources -- ^ Reference to a 'Sources' record + -> SqlPersistT m (Maybe (Key Builds)) +findBuild epoch release arch sourceId = firstKeyResult $ + -- FIXME: Is (source_id, epoch, release, arch) unique in Builds? + select $ from $ \build -> do + where_ $ build ^. BuildsSource_id ==. val sourceId &&. + build ^. BuildsEpoch ==. val epoch &&. + build ^. BuildsRelease ==. val release &&. + build ^. BuildsArch ==. val arch + limit 1 + return $ build ^. BuildsId + +-- | Given a key to a 'Builds' record in the database, return that record. This function is +-- suitable for using on the result of 'findBuild'. +getBuild :: MonadIO m => Key Builds -> SqlPersistT m (Maybe Builds) +getBuild key = firstEntityResult $ + select $ from $ \build -> do + where_ $ build ^. BuildsId ==. val key + limit 1 + return build + +-- | Conditionally add a new 'Builds' record to the database. If the record already exists, +-- return its key. Otherwise, insert the record and return the new key. +insertBuild :: MonadIO m => Builds -> SqlPersistT m (Key Builds) +insertBuild build@Builds{..} = + findBuild buildsEpoch buildsRelease buildsArch buildsSource_id `orInsert` build + +-- | Conditionally add a new 'KeyVal' record to the database and associate a 'Builds' record +-- with it. If the 'KeyVal' record already exists, it is reused in creating the association. +-- The database key of the association is returned. +insertBuildKeyValue :: MonadIO m => + KeyType -- ^ Type of the 'KeyVal' + -> T.Text -- ^ Value of the 'KeyVal' + -> Maybe T.Text -- ^ Extended value of the 'KeyVal' + -> Key Builds -- ^ Build to be associated with the 'KeyVal' + -> SqlPersistT m (Key BuildKeyValues) +insertBuildKeyValue k v e buildId = + maybeKey (insertKeyValue k (Just v) e >>= associateBuildWithPackage buildId) + (associateBuildWithPackage buildId) + (findKeyValue k (Just v) e) + +-- | Create a link in the database between an existing 'Builds' record and an existing 'KeyVal' +-- record. This is different from 'insertBuildKeyValue', which also creates the 'KeyVal' record. +-- A single build can potentially have zero or many 'KeyVal' pairs associated with it. On the +-- other hand, a single 'KeyVal' pair can apply to many builds. +-- +-- The database key of the new link is returned. +associateBuildWithPackage :: MonadIO m => Key Builds -> Key KeyVal -> SqlPersistT m (Key BuildKeyValues) +associateBuildWithPackage buildId kvId = + insert $ BuildKeyValues buildId kvId diff --git a/src/BDCS/CS.hs b/src/BDCS/CS.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/CS.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module: BDCS.CS +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Conduit-based interface between BDCS and its underlying content store. + +module BDCS.CS(Object(..), + filesToObjectsC, + objectToTarEntry) + where + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import Control.Monad.Except(ExceptT(..), MonadError, runExceptT, throwError) +import Control.Monad.IO.Class(MonadIO, liftIO) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy(fromStrict) +import Data.Conduit(Conduit, awaitForever, yield) +import Data.ContentStore(ContentStore, contentStoreDigest, fetchByteString, runCsMonad) +import Data.ContentStore.Digest(fromByteString) +import qualified Data.Text as T +import System.Posix.Files(blockSpecialMode, characterSpecialMode, directoryMode, fileTypeModes, intersectFileModes, namedPipeMode, regularFileMode, symbolicLinkMode) +import System.Posix.Types(CMode(..), FileMode) + +import BDCS.DB +import BDCS.Utils.Either(maybeToEither) + +-- | An object in the content store is either a regular file or something else +-- (directory, symlink, etc.) described by the 'Files' metadata. +data Object = SpecialObject -- ^ Some non-file object that should be accompanied + -- by a 'Files' record so its metadata can be tracked + | FileObject BS.ByteString -- ^ A file object with its contents + +-- | Read 'Files' records from a 'Conduit', find the object in the content store, and return the +-- matching 'Object' if found. An error is thrown if the object does not exist, or if there is +-- any other error interacting with the content store. In addition, the 'Files' object is also +-- returned as part of the result tuple so its metadata can be used by downstream consumers. +filesToObjectsC :: (MonadError String m, MonadIO m) => ContentStore -> Conduit Files m (Files, Object) +filesToObjectsC repo = awaitForever $ \f@Files{..} -> + let isRegular = fromIntegral filesMode `intersectFileModes` fileTypeModes == regularFileMode + in case (isRegular, filesCs_object) of + -- Not a regular file + (False, _) -> yield (f, SpecialObject) + -- Regular file but no content, probably a %ghost. Just skip it. + (True, Nothing) -> return () + (True, Just cksum) -> do + digest <- maybe (throwError "Invalid cs_object") return $ fromByteString (contentStoreDigest repo) cksum + liftIO (runCsMonad $ fetchByteString repo digest) >>= \case + Left e -> throwError (show e) + Right obj -> yield (f, FileObject obj) + +-- | Read tuples from a 'Conduit' and convert each into a 'Codec.Archive.Tar.Entry' suitable for +-- streaming into an archive. Metadata such as permissions and ownerships will be set correctly. +-- Symlinks and other special non-file things will be handled correctly. This function is suitable +-- as a downstream consumer of 'filesToObjectsC'. +objectToTarEntry :: (MonadError String m, MonadIO m) => Conduit (Files, Object) m Tar.Entry +objectToTarEntry = awaitForever $ \(f@Files{..}, obj) -> do + result <- case obj of + SpecialObject -> return $ checkoutSpecial f + FileObject contents -> liftIO . runExceptT $ checkoutFile f contents + + either (\e -> throwError $ "Could not checkout out object " ++ T.unpack filesPath ++ ": " ++ e) + yield + result + + objectToTarEntry + where + modeToContent :: FileMode -> Either String Tar.EntryContent + modeToContent mode = + if | mode == directoryMode -> Right Tar.Directory + | mode == namedPipeMode -> Right Tar.NamedPipe + -- TODO major/minor + | mode == characterSpecialMode -> Right $ Tar.CharacterDevice 0 0 + | mode == blockSpecialMode -> Right $ Tar.BlockDevice 0 0 + | otherwise -> Left "Invalid file mode" + + checkoutSpecial :: Files -> Either String Tar.Entry + checkoutSpecial f@Files{..} = let mode = fromIntegral filesMode `intersectFileModes` fileTypeModes + in if mode == symbolicLinkMode then + maybe (Left "Missing symlink target") (checkoutSymlink f) filesTarget + else do + path <- Tar.toTarPath True (T.unpack filesPath) + content <- modeToContent mode + return $ setMetadata f (Tar.simpleEntry path content) + + checkoutSymlink :: Files -> T.Text -> Either String Tar.Entry + checkoutSymlink f@Files{..} target = do + path' <- Tar.toTarPath False (T.unpack filesPath) + target' <- maybeToEither ("Path is too long or contains invalid characters: " ++ T.unpack target) + (Tar.toLinkTarget (T.unpack target)) + return $ setMetadata f (Tar.simpleEntry path' (Tar.SymbolicLink target')) + + checkoutFile :: Files -> BS.ByteString -> ExceptT String IO Tar.Entry + checkoutFile f@Files{filesTarget=Just target, ..} _ = + ExceptT $ return $ checkoutSymlink f target + checkoutFile f@Files{..} contents = do + path <- ExceptT $ return $ Tar.toTarPath False (T.unpack filesPath) + return $ setMetadata f (Tar.fileEntry path (fromStrict contents)) + -- TODO? + + setMetadata :: Files -> Tar.Entry -> Tar.Entry + setMetadata Files{..} entry = + entry { Tar.entryPermissions = CMode (fromIntegral filesMode), + Tar.entryOwnership = Tar.Ownership { Tar.ownerId = 0, + Tar.groupId = 0, + Tar.ownerName = T.unpack filesFile_user, + Tar.groupName = T.unpack filesFile_group }, + Tar.entryTime = fromIntegral filesMtime } diff --git a/src/BDCS/DB.hs b/src/BDCS/DB.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/DB.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module: BDCS.DB +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- The metadata database schema and miscellaneous database helper functions + +module BDCS.DB where + +import Control.Monad(unless) +import Control.Monad.Except(MonadError, throwError) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Logger(NoLoggingT) +import Control.Monad.Trans.Resource(MonadBaseControl, ResourceT) +import qualified Data.Aeson as Aeson +import Data.ByteString(ByteString) +import Data.Int(Int64) +import Data.Maybe(fromJust, listToMaybe) +import qualified Data.Text as T +import Data.Time(UTCTime) +import Database.Esqueleto(Esqueleto, Entity, Key, PersistEntity, PersistField, SqlBackend, SqlPersistT, ToBackendKey, Value, + (==.), entityVal, insert, isNothing, val, unValue) +import Database.Persist.Sql(rawSql, unSingle) +import Database.Persist.Sqlite(runSqlite) +import Database.Persist.TH + +import BDCS.KeyType +import BDCS.ReqType + +{-# ANN module ("HLint: ignore Use module export list" :: String) #-} +-- Both esqueleto and maybe export isNothing. I don't want to have to use a qualified import, so +-- we'll just compare things directly to Nothing. +{-# ANN module ("HLint: ignore Use isNothing" :: String) #-} + +-- | The database schema version as implemented by this module. This must match the +-- PRAGMA user_version value in schema.sql, shipped elsewhere in the source. +schemaVersion :: Int64 +schemaVersion = 4 + +-- | Return the version number stored in the database. +getDbVersion :: MonadIO m => SqlPersistT m Int64 +getDbVersion = unSingle <$> head <$> rawSql "pragma user_version" [] + +-- | Verify that the version number stored in the database matches the schema version number +-- implemented by this module. If there is a version mismatch, throw an error. +checkDbVersion :: (MonadError String m, MonadIO m) => SqlPersistT m () +checkDbVersion = do + -- The change from version 3 to version 4 involves changing the content store, so there + -- is no automatic upgrade path. + userVersion <- getDbVersion + unless (userVersion == schemaVersion) $ throwError $ + "Database version " ++ show userVersion ++ " does not match expected version " ++ show schemaVersion ++ + ", please re-import your data" + +-- | Like 'Database.Persist.Sqlite.runSqlite', but first checks that the database's schema version +-- matches what is expected. This prevents running against incompatible database versions. +checkAndRunSqlite :: (MonadError String m, MonadBaseControl IO m, MonadIO m) => + T.Text -> SqlPersistT (NoLoggingT (ResourceT m)) a -> m a +checkAndRunSqlite db action = runSqlite db (checkDbVersion >> action) + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| + Projects + name T.Text + summary T.Text + description T.Text + homepage T.Text Maybe + upstream_vcs T.Text + NameKey name + deriving Eq Show + Sources + project_id ProjectsId + license T.Text + version T.Text + source_ref T.Text + deriving Eq Show + Builds + source_id SourcesId + epoch Int default=0 + release T.Text + arch T.Text + build_time UTCTime + changelog ByteString + build_config_ref T.Text + build_env_ref T.Text + deriving Eq Show + BuildSignatures + build_id BuildsId + signature_type T.Text + signature_data ByteString + deriving Eq Show + Files + path T.Text + file_user T.Text + file_group T.Text + mtime Int + cs_object ByteString Maybe + mode Int + size Int + target T.Text Maybe + deriving Eq Show + SourceFiles + source_id SourcesId + file_id FilesId + deriving Eq Show + BuildFiles + build_id BuildsId + file_id FilesId + deriving Eq Show + KeyVal + key_value KeyType + val_value T.Text Maybe + ext_value T.Text Maybe + deriving Eq Show + ProjectKeyValues + package_id ProjectsId + key_val_id KeyValId + deriving Eq Show + SourceKeyValues + source_id SourcesId + key_val_id KeyValId + deriving Eq Show + BuildKeyValues + build_id BuildsId + key_val_id KeyValId + deriving Eq Show + FileKeyValues + file_id FilesId + key_val_id KeyValId + deriving Eq Show + Groups + name T.Text + group_type T.Text + build_id BuildsId Maybe + deriving Eq Show + GroupFiles + group_id GroupsId + file_id FilesId + deriving Eq Show + GroupGroups + parent_group_id GroupsId + child_group_id GroupsId + deriving Eq Show + GroupKeyValues + group_id GroupsId + key_val_id KeyValId + deriving Eq Show + Requirements + req_language ReqLanguage + req_context ReqContext + req_strength ReqStrength + req_expr T.Text + deriving Eq Show + GroupRequirements + group_id GroupsId + req_id RequirementsId + deriving Eq Show + Scripts + ty T.Text + body T.Text + trigger_prog T.Text Maybe + trigger_index Int Maybe + trigger_name T.Text Maybe + trigger_version T.Text Maybe + trigger_flags Int Maybe + deriving Eq Show + GroupScripts + group_id GroupsId + script_id ScriptsId + deriving Eq Show + |] + +instance Aeson.ToJSON KeyVal where + toJSON kv = let + v = fmap Aeson.toJSON (keyValVal_value kv) + e = fmap Aeson.toJSON (keyValExt_value kv) + in + if | v == Nothing -> Aeson.Bool True + | v == e || e == Nothing -> fromJust v + | otherwise -> fromJust e + +-- | Run an SQL query, returning the first 'Entity' as a Maybe. Use this when you +-- want a single row out of the database. +firstEntityResult :: Monad m => m [Entity a] -> m (Maybe a) +firstEntityResult query = + listToMaybe . map entityVal <$> query + +-- | Run an SQL query, returning the first key as a Maybe. Use this when you want +-- a single index out of the database. +firstKeyResult :: Monad m => m [Value a] -> m (Maybe a) +firstKeyResult query = + listToMaybe . map unValue <$> query + +-- | Like 'maybe', but for keys. If the key is nothing, return the default value. Otherwise, +-- run the function on the key and return that value. +maybeKey :: MonadIO m => + m b -- ^ Default value + -> (t -> m b) -- ^ A function to run on the key + -> m (Maybe t) -- ^ A 'Maybe' key + -> m b +maybeKey def fn value = value >>= \case + Nothing -> def + Just v -> fn v + +-- | Return a query fragment to match a Maybe value. +-- If the value is Nothing, this is equivalent to (column is NULL) +-- If the value is Just x, this is (value == column) +-- Unlike the other Esqueleto operators, the right-hand value is not boxed in a Value, +-- since we need to examine it in order to generate the correct SQL. +-- +-- e.g., with a table like: +-- > create table example ( +-- > id integer primary key, +-- > value text ); +-- you could use an esqueleto query like: +-- > select $ from $ \example -> do +-- > where_ $ maybeVal ==? (example ?. ExampleValue) +infix 4 ==? +(==?) :: (PersistField typ, Esqueleto query expr backend) => expr (Value (Maybe typ)) -> Maybe typ -> expr (Value Bool) +(==?) column Nothing = isNothing column +(==?) column value@(Just _) = column ==. val value + +-- | Attempt to find a record in some table of the database. If it exists, return its key. +-- If it doesn't exist, perform some other action and return the key given by that action. +orDo :: MonadIO m => m (Maybe b) -> m b -> m b +orDo findFn doFn = + findFn >>= maybe doFn return + +-- | Attempt to find a record in some table of the database. If it exists, return its key. +-- If it doesn't exist, insert the given object and return its key. +orInsert :: (MonadIO m, PersistEntity a, ToBackendKey SqlBackend a) => SqlPersistT m (Maybe (Key a)) -> a -> SqlPersistT m (Key a) +orInsert findFn obj = + findFn >>= maybe (insert obj) return diff --git a/src/BDCS/Depclose.hs b/src/BDCS/Depclose.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Depclose.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: BDCS.Depclose +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Collect all the dependencies for a package, but do not solve them. + +module BDCS.Depclose(DepFormula, + depclose) + where + +import Codec.RPM.Version(DepRequirement(..), EVR(..), parseDepRequirement, satisfies) +import qualified Codec.RPM.Version as RPM(DepOrdering(EQ)) +import Control.Monad(filterM, foldM, when) +import Control.Monad.Except(MonadError, throwError) +import Control.Monad.IO.Class(MonadIO) +import Data.Bifunctor(first) +import Data.List(intersect) +import Data.Maybe(fromMaybe, mapMaybe) +import qualified Data.Set as Set +import qualified Data.Text as T +import Database.Persist.Sql(SqlPersistT) + +import BDCS.Depsolve(Formula(..)) +import BDCS.DB +import BDCS.Files(pathToGroupId) +import BDCS.Groups(getGroupId, getRequirementsForGroup) +import BDCS.GroupKeyValue(getGroupsByKeyVal, getKeyValuesForGroup, getValueForGroup) +import BDCS.KeyType +import qualified BDCS.ReqType as RT +import BDCS.Utils.Error(errorToMaybe) +import BDCS.Utils.Monad(concatMapM, foldMaybeM, mapMaybeM) + +data ParentItem = GroupId (Key Groups) + | Provides DepRequirement + deriving (Eq, Ord) + +-- The Set is used to store the groups that are parents of the current subexpression, +-- used to detect dependency loops and stop recursion. For instance: +-- +-- A Requires B +-- B Requires C +-- C Requires A +-- +-- When depclose gets to C Requires A it can stop, since that has already been resolved. +type DepParents = Set.Set ParentItem + +-- | Type of the depclose results - see 'BDCS.Depsolve.Formula' +type DepFormula = Formula (Key Groups) + +-- | Given a path to a mddb, a list of architectures, and a list of RPMS, return a formula describing the dependencies +-- The general idea is, given a list of packages to depclose, convert each to a group id, and for each id: +-- - gather the conflict and obsolete information, find matching group ids, express as Not conflict/obsolete-id +-- - gather the requirement expressions, for each: +-- * find a list of matching group ids +-- * if empty, the dependency is not satisfiable +-- * recurse on each group id to gather the requirements of the requirement +-- * return the expression as an Or of the matching group ids +-- - return the whole thing as an And [self, conflict/obsolete information, requirement information] +-- +-- Everything is run in a state with two components: a Map from groupid to expression to act as a cache, +-- and a Set containing the group ids that are part of the current branch of the dependency tree in order +-- to detect and ignore loops. +depclose :: (MonadError String m, MonadIO m) => [T.Text] -> [T.Text] -> SqlPersistT m DepFormula +depclose arches nevras = do + -- Convert each NEVRA into a group ID. + groupIds <- mapM getGroupId nevras + + -- resolve each group id into a DepFormula + -- Use foldM to pass the parents set from resolving one group into the next group, so we + -- don't depclose things already depclosed from a previous group ID. + (formulas, _) <- foldM foldIdToFormula ([], Set.empty) groupIds + + -- Every requirement in the list is required, so the final result is an And of the individual results. + return $ And formulas + where + -- turn groupIdToFormula into something we can use with fold + foldIdToFormula :: (MonadError String m, MonadIO m) => ([DepFormula], DepParents) -> Key Groups -> SqlPersistT m ([DepFormula], DepParents) + foldIdToFormula (formulaAcc, parents) groupId = first (:formulaAcc) <$> groupIdToFormula parents groupId + + -- convert a group id to a dependency formula. First, check the cache to see if we've already gathered this group id + groupIdToFormula :: (MonadError String m, MonadIO m) => DepParents -> Key Groups -> SqlPersistT m (DepFormula, DepParents) + groupIdToFormula parents groupId = do + -- add this group id to the parents set + let parents' = Set.insert (GroupId groupId) parents + + -- grab the key/value based data + conflicts <- getKeyValuesForGroup groupId (Just $ TextKey "rpm-conflict") >>= mapM kvToDep + obsoletes <- getKeyValuesForGroup groupId (Just $ TextKey "rpm-obsolete") >>= mapM kvToDep + + -- map the strings to group ids. Obsolete and Conflict both express a potential group id + -- that should NOT be included in the final, depsolved result, so express that information here + -- as Not + -- + -- In RPM headers: the expressions in Conflicts headers match corresponding names in the Provides + -- headers. Obsoletes, however, matches package names. + conflictIds <- concatMapM providerIds conflicts + obsoleteIds <- concatMapM nameReqIds obsoletes + let obsConflictFormulas = map Not (conflictIds ++ obsoleteIds) + + -- grab all of the providers strings and add them to the parents set + -- Saving this data allows us to avoid repeatedly depclosing over a requirement provided + -- by more than one group. For instance, if there's more than one version of glibc available + -- in the mddb, a requirement for "libc.so.6" might resolve to Or [glibc-1, glibc-2]. Since + -- there are two choices, we can't say that either group id is definitely part of the expression, + -- but "libc.so.6" is definitely solved as part of the expression and does not need to be repeated. + providesSet <- Set.union parents' + <$> Set.fromList + <$> map Provides + <$> (getKeyValuesForGroup groupId (Just $ TextKey "rpm-provide") >>= mapM kvToDep) + + -- Now the recursive part. First, grab everything from the requirements table for this group: + -- TODO maybe do something with strength, context, etc. + + requirements <- getRequirementsForGroup groupId RT.Runtime >>= mapM reqToDep + + -- Resolve each requirement to a list of group ids. Each group id is a possibility for satisfying + -- the requirement. An empty list means the requirement cannot be satisfied. + -- Zip the list of ids with the original requirement for error reporting. + requirementIds <- zip requirements <$> mapM providerIds requirements + + -- Resolve each list of group ids to a formula + -- Fold the parents set returned by each requirement into the next requirement, so we don't repeat + -- ourselves too much. + (requirementFormulas, requirementParents) <- foldMaybeM resolveOneReq ([], providesSet) requirementIds + + -- add an atom for the groupId itself, And it all together + return (And (Atom groupId : obsConflictFormulas ++ requirementFormulas), requirementParents) + where + resolveOneReq :: (MonadError String m, MonadIO m) => ([DepFormula], DepParents) -> (DepRequirement, [Key Groups]) -> SqlPersistT m (Maybe ([DepFormula], DepParents)) + resolveOneReq (formulaAcc, parentAcc) (req, idlist) = + -- If any of the possible ids are in the parents set, the requirement is already satisfied in the parents + if | any (`Set.member` parentAcc) (map GroupId idlist) -> return Nothing + -- If this exact requirement is already in the parents set, the requirement is already solved, so skip this group + | Set.member (Provides req) parentAcc -> return Nothing + | otherwise -> do + -- map each possible ID to a forumula, discarding the ones that cannot be satisfied + (formulaList, parentList) <- unzip <$> mapMaybeM (errorToMaybe . groupIdToFormula parentAcc) idlist + + -- If nothing worked, that's an error + when (null formulaList) $ throwError $ "Unable to resolve requirement: " ++ show req + + -- The solution to this requirement is an Or of all the possibilities + -- The group ids that are definitely required by this formulas is the intersection of all of the individual sets + let reqFormula = Or formulaList + let reqParents = foldl1 Set.intersection parentList + + -- Add the results to the accumulators + return $ Just (reqFormula : formulaAcc, Set.union parentAcc reqParents) + + -- convert requirements to group IDs + + -- Given a DepRequirement, return the group ids with a matching rpm-provide key/val + providerIds :: (MonadError String m, MonadIO m) => DepRequirement -> SqlPersistT m [Key Groups] + providerIds req = do + -- Pull the name out of the requirement + let DepRequirement reqname _ = req + + -- Find all groups with a matching rpm-provide + vals <- getGroupsByKeyVal "rpm" (TextKey "rpm-provide") (Just reqname) + + -- Filter out any that don't have a matching version + -- convert the second part of the tuple (the KeyVal) to a Dep and check it against the input req + valsVersion <- filterM (fmap (`satisfies` req) . kvToDep . snd) vals + + -- we're done with the actual expression now, just need the group ids + let valsVersionIds = map fst valsVersion + + -- Filter out the ones with the wrong arch + providerVals <- filterM matchesArch valsVersionIds + + -- If the requirement looks like a filename, check for groups providing the file *in addition to* rpm-provide + fileVals <- if "/" `T.isPrefixOf` reqname then pathToGroupId reqname >>= filterM matchesArch + else return [] + + return $ providerVals ++ fileVals + + -- Given a DepRequirement, return the group ids that match by name. + -- This is used to satisfy Obsoletes + nameReqIds :: MonadIO m => DepRequirement -> SqlPersistT m [Key Groups] + nameReqIds req = do + -- Pull the name out of the requirement + let DepRequirement reqname _ = req + + vals <- map fst <$> getGroupsByKeyVal "rpm" (TextKey "name") (Just reqname) + + -- filter out the values that don't match by arch + valsArch <- filterM matchesArch vals + + -- If there is no version in the DepRequirement we're trying to satisfy, we're done. + -- otherwise, grab more info from the mddb to turn each group id into a name = EVR DepRequirement, + -- and filter out the ones that do not satisfy the version. + case req of + DepRequirement _ Nothing -> return valsArch + DepRequirement _ (Just _) -> filterM (\gid -> do + providerReq <- groupIdToDep reqname gid + return $ req `satisfies` providerReq) + valsArch + where + -- Return a versioned DepRequirement expression for this group id + groupIdToDep :: MonadIO m => T.Text -> Key Groups -> SqlPersistT m DepRequirement + groupIdToDep name groupId = do + epochStr <- getValueForGroup groupId (TextKey "epoch") + version <- fromMaybe "" <$> getValueForGroup groupId (TextKey "version") + release <- fromMaybe "" <$> getValueForGroup groupId (TextKey "release") + + let epochInt = read <$> T.unpack <$> epochStr + + return $ DepRequirement name $ Just (RPM.EQ, EVR {epoch=epochInt, version, release}) + + -- Check if the given group matches either the target arch or noarch + matchesArch :: MonadIO m => Key Groups -> SqlPersistT m Bool + matchesArch groupId = do + kvArches <- mapMaybe keyValVal_value <$> getKeyValuesForGroup groupId (Just $ TextKey "arch") + return $ (not . null) (("noarch":arches) `intersect` kvArches) + + -- various ways of converting things to DepRequirement + + -- convert the Either ParseError result from parseDepRequirement to a MonadError String + parseDepRequirementError :: MonadError String m => T.Text -> m DepRequirement + parseDepRequirementError req = either (throwError . show) return $ parseDepRequirement req + + -- key/val to DepRequirement, for rpm-provide/rpm-confict/rpm-obsolete values + kvToDep :: MonadError String m => KeyVal -> m DepRequirement + kvToDep KeyVal {keyValExt_value=Nothing} = throwError "Invalid key/val data" + kvToDep KeyVal {keyValExt_value=Just ext} = parseDepRequirementError ext + + -- Requirement to DepRequirement + reqToDep :: MonadError String m => Requirements -> m DepRequirement + reqToDep Requirements{..} = parseDepRequirementError requirementsReq_expr diff --git a/src/BDCS/Depsolve.hs b/src/BDCS/Depsolve.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Depsolve.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} + +-- | +-- Module: BDCS.Depsolve +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Manage 'Builds' records in the database. + +module BDCS.Depsolve(Formula(..), + CNFLiteral(..), + CNFAtom(..), + CNFFormula, + DepAssignment, + formulaToCNF, + solveCNF +-- export private symbols for testing +#ifdef TEST + , pureLiteralEliminate + , unitPropagate +#endif + ) + where + +import Control.Monad.Except(MonadError, catchError, throwError) +import Control.Monad.State(State, evalState, state) +import Data.Map.Strict(Map) +import qualified Data.Map.Strict as Map +import Data.Maybe(isNothing, mapMaybe) +import Data.Set(Set) +import qualified Data.Set as Set + +import BDCS.Utils.Monad(concatMapM) + +-- A logical proposition in negation normal form +-- (i.e., NOT is applied only to atoms, not sub-formulas) +data Formula a = Atom a + | Not a + | Or [Formula a] + | And [Formula a] + + deriving(Eq, Show) + +-- Conjunctive Normal Form (CNF) is, essentially, and AND of ORs. The formula is of the form +-- (a1 OR a2 ...) AND (b1 OR b2 OR ...) AND ... +-- where each a1, b2, etc is an atom or a not-atom. +-- To keep the size of converted formulas under control, some extra variables are added to represent +-- sub-formulas from the original expression. +data CNFLiteral a = CNFOriginal a + | CNFSubstitute Int + deriving(Eq, Ord, Show) + +data CNFAtom a = CNFAtom (CNFLiteral a) + | CNFNot (CNFLiteral a) + deriving(Eq, Ord, Show) + +type CNFFormula a = [[CNFAtom a]] + +formulaToCNF :: Formula a -> CNFFormula a +formulaToCNF f = + -- wrap the call in a State Int starting at 0 to create a counter for substitution variables + evalState (formulaToCNF' f) 0 + where + formulaToCNF' :: Formula a -> State Int (CNFFormula a) + + -- easy ones: a becomes AND(OR(a)), NOT(a) becomes AND(OR(NOT(a))) + formulaToCNF' (Atom x) = return [[CNFAtom (CNFOriginal x)]] + formulaToCNF' (Not x) = return [[CNFNot (CNFOriginal x)]] + + -- -- for an expression of the form And [a1, a2, a3, ...], we need to convert + -- each a1, a2, ... to CNF and concatenate the results. + -- + -- In other words, for And [a1, a2], map the list to something like + -- + -- [And[Or[a1_or1_1, a1_or1_2], + -- Or[a1_or2_1, a1_or2_2]], + -- And[Or[a2_or1, a2_or1_2], + -- Or[a2_or2_1, a2_or2_2]]] + -- + -- which is equivalent to + -- + -- And[Or[a1_or1_1, a1_or1_2], + -- Or[a1_or2_1, a1_or2_2], + -- Or[a2_or1_1, a2_or1_2], + -- Or[a2_or2_1, a2_or2_2]] + formulaToCNF' (And andFormulas) = concatMapM formulaToCNF' andFormulas + + -- For Or, the equivalent formula is exponentially larger than the original, so instead + -- create an equisatisfiable formula using new substitution variables, via Tseytin transformations. + -- + -- For a given expression: + -- + -- a1 OR a2 OR a3 ... + -- + -- we start out by creating an equisatisfiable expression with new variables: + -- + -- (Z1 -> a1) AND (NOT(Z1) -> (a2 OR a3 ...)) + -- + -- starting with the left side of the AND, the expression is equivalent to + -- + -- (NOT(Z1) OR a1) + -- + -- and if we can convert a1 into CNF, we get an expression of the form + -- + -- NOT(Z1) OR (a1_1 AND a1_2 AND ...) + -- + -- where each a1_1, a1_2 etc is an OR. We can then use the distributive property to create + -- + -- (NOT(Z1) OR a1_1) AND (NOT(Z1) OR a1_2) AND ... + -- + -- which is CNF. Then, for the right hand side of that original AND pair up there, we're + -- left with: + -- + -- Z1 OR (a2 OR a3 OR ...) + -- + -- so to recurse, we convert (a2 OR a3 OR ...) to CNF, and then convert (Z1 OR (CNF)) + -- to CNF via distribution as above. We then have AND , which is CNF. + + -- end of recursion: OR of nothing is nothing, OR of 1 thing is just that thing + formulaToCNF' (Or []) = return [[]] + formulaToCNF' (Or [x]) = formulaToCNF' x + + formulaToCNF' (Or (x:xs)) = do + -- Get and increment the counter + subVar <- state $ \i -> (CNFSubstitute i, i+1) + + -- recurse on the left hand expression + lhCNF <- formulaToCNF' x + + -- distribute NOT(subVar) AND lhCNF by adding NOT(subVar) into each of the OR lists + let lhSubCNF = map (CNFNot subVar:) lhCNF + + -- recurse on the right hand side + rhCNF <- formulaToCNF' (Or xs) + + -- distribute subVar across the right hand expression + let rhSubCNF = map (CNFAtom subVar:) rhCNF + + -- combine the results + return (lhSubCNF ++ rhSubCNF) + +-- assignments to literals that will satisfy a formula +type DepAssignment a = (a, Bool) + +-- internal types for the variable=bool assignments +type AssignmentMap a = Map (CNFLiteral a) Bool + +-- if the formula is unsolvable, returns Nothing, other Just the list of assignments +-- This function uses the Davis-Putnam-Logemann-Loveman procedure for satisfying the formula, which is as follows: +-- Repeatedly simplify the formula using unit propagation and pure literal elimination: +-- unit propagation looks for a clause that contains only one literal, assigns it, and then removes clauses satisfied by the assignment +-- for example, in +-- (a OR b OR c) AND (a) AND (b OR ~c) +-- +-- (a) appears alone, so it must be true. We can then remove both (a) and (a OR b OR c), as these clauses are now satisfied +-- by a=True. +-- +-- pure literal elimation looks for literals that only appear as true or false. In the above example, b is only present +-- in the formula as True (there is no ~b in the formula), so we can assign b=True and then remove all clauses containing b. +-- +-- once simplified, pick a literal and assign it to True and try to satisfy the formula. If that doesn't work, assign to to False. +-- +-- Repeat until solved. +solveCNF :: (MonadError String m, Ord a) => CNFFormula a -> m [DepAssignment a] +solveCNF formula = solveCNF' Map.empty formula + where + -- helper function that takes an assignment map and a formula + solveCNF' :: (MonadError String m, Ord a) => AssignmentMap a -> CNFFormula a -> m [DepAssignment a] + solveCNF' assignments f = + -- simplify the formula. simplify will recurse as necessary + simplify assignments f >>= \case + -- All clauses have been satisfied, we're done. Return the assignments + (assignments', []) -> return $ assignmentsToList assignments' + -- otherwise, try an assignment, or if that fails try the opposite assignment + (assignments', formula') -> guessAndCheck assignments' formula' + + guessAndCheck :: (MonadError String m, Ord a) => AssignmentMap a -> CNFFormula a -> m [DepAssignment a] + guessAndCheck assignments f@((firstLiteral:_):_) = + try True `catchError` const (try False) + where + try val = do + let tryAssignments = Map.insert (atomToLiteral firstLiteral) val assignments + solveCNF' tryAssignments f + + -- probably shouldn't happen + guessAndCheck assignments ([]:ys) = guessAndCheck assignments ys + + -- No variables left, so we're done + guessAndCheck _ [] = return [] + + simplify :: (MonadError String m, Ord a) => AssignmentMap a -> CNFFormula a -> m (AssignmentMap a, CNFFormula a) + simplify assignments f = do + -- pureLiteralEliminate only updates the assignments, the assigned literals are actually + -- removed by unitPropagate. + let pleAssignments = pureLiteralEliminate Set.empty assignments f + + (upAssignments, upFormula) <- unitPropagate pleAssignments f + + -- repeat until the formula doesn't change + if f == upFormula then + return (upAssignments, upFormula) + else + simplify upAssignments upFormula + + assignmentsToList :: Ord a => AssignmentMap a -> [DepAssignment a] + assignmentsToList assignments = let + -- start by getting everything out of the map as a list of (CNFLiteral, Bool) + literalList = Map.assocs assignments + in + -- map each (literal, bool) to Maybe (orig, bool), mapMaybe will filter out the Nothings + mapMaybe literalToOriginal literalList + where + -- unwrap original values, discard substitutes + literalToOriginal :: (CNFLiteral a, Bool) -> Maybe (a, Bool) + literalToOriginal (CNFOriginal x, b) = Just (x, b) + literalToOriginal _ = Nothing + +-- find pure literals and add them to the assignment map. This just updates assignments and does not make a decision as +-- to satisfiability. It works by assuming every new literal it finds is pure and then correcting as needed. The Set +-- argument is the literals that have been found to be unpure (i.e, they appear as both A and ~A) +pureLiteralEliminate :: Ord a => Set (CNFLiteral a) -> AssignmentMap a -> CNFFormula a -> AssignmentMap a + +-- end of recursion +pureLiteralEliminate _ assignments [] = assignments +-- end of a clause, move on to the next one +pureLiteralEliminate unpure assignments ([]:ys) = pureLiteralEliminate unpure assignments ys + +-- update unpure and assignments based on the first element and continue +pureLiteralEliminate unpure assignments ((x:xs):ys) = let + (unpure', assignments') = updateAssignments + in + pureLiteralEliminate unpure' assignments' (xs:ys) + where + updateAssignments = let + literalX = atomToLiteral x + in + case (x, Map.lookup literalX assignments, Set.member literalX unpure) of + -- something we've already marked as unpure, skip it + (_, _, True) -> (unpure, assignments) + + -- Not in the map, add it + (CNFAtom a, Nothing, _) -> (unpure, Map.insert a True assignments) + (CNFNot a, Nothing, _) -> (unpure, Map.insert a False assignments) + + -- In the map and matches our guess, keep it + (CNFAtom _, Just True, _) -> (unpure, assignments) + (CNFNot _, Just False, _) -> (unpure, assignments) + + -- otherwise we guessed wrong. Remove from the map and add to unpure + _ -> (Set.insert literalX unpure, Map.delete literalX assignments) + +unitPropagate :: (MonadError String m, Ord a) => AssignmentMap a -> CNFFormula a -> m (AssignmentMap a, CNFFormula a) + +-- We have a unit! If it's new, add it to assignments and eliminate the unit +-- If it's something in assignments, check that it matches +unitPropagate assignments ([x]:ys) = do + let literalX = atomToLiteral x + let boolX = atomToBool x + let literalLookup = Map.lookup literalX assignments + + -- if literalLookup is Nothing, this is a new literal. add it to the assignments. + assignments' <- if | isNothing literalLookup -> return $ Map.insert literalX boolX assignments + -- old literal, matches + | Just boolX == literalLookup -> return assignments + -- old literal, does not match + | otherwise -> throwError "Unable to solve expression" + + unitPropagate assignments' ys + +-- for clauses with more than one thing: +-- if the clause contains any literal that matches the map, the whole clause is true and we can remove it +-- otherwise, remove any literals that do not match the map, as they cannot be true. If, after removing +-- untrue literals, the clause is empty, the expression is unsolvable. +unitPropagate assignments (clause:ys) = do + let clauseTrue = any (\atom -> Just (atomToBool atom) == Map.lookup (atomToLiteral atom) assignments) clause + let clauseFiltered = filter (\atom -> case Map.lookup (atomToLiteral atom) assignments of + Nothing -> True + Just x -> x == atomToBool atom) clause + + if | clauseTrue -> unitPropagate assignments ys + | null clauseFiltered -> throwError "Unable to solve expression" + | otherwise -> do + (assignments', formula') <- unitPropagate assignments ys + return (assignments', clauseFiltered:formula') + +unitPropagate assignments [] = return (assignments, []) + +-- unwrap an atom +atomToLiteral :: CNFAtom a -> CNFLiteral a +atomToLiteral (CNFAtom x) = x +atomToLiteral (CNFNot x) = x + +atomToBool :: CNFAtom a -> Bool +atomToBool (CNFAtom _) = True +atomToBool (CNFNot _) = False diff --git a/src/BDCS/Exceptions.hs b/src/BDCS/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Exceptions.hs @@ -0,0 +1,59 @@ +-- | +-- Module: BDCS.Builds +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Utilities for working with database-related exceptions. + +module BDCS.Exceptions(DBException(..), + isDBExceptionException, + isMissingRPMTagException, + throwIfNothing, + throwIfNothingOtherwise) + where + +import Control.Exception(Exception, throw) +import Data.Data(Typeable) + +-- | A general purpose exception type for dealing with things that go wrong when working +-- with the database. This type could grow into a more complex system in the future, if +-- needed. This type is most helpful because runSqlite will roll back the entire +-- transaction if an exception is raised. +data DBException = DBException String -- ^ A general purpose exception type, + -- including an error message. + | MissingRPMTag String -- ^ A required tag was missing from the + -- RPM being processed. The argument should + -- be the name of the missing tag. + deriving(Eq, Typeable) + +instance Exception DBException + +instance Show DBException where + show (DBException s) = show s + show (MissingRPMTag s) = "Missing required tag in RPM: " ++ s + +-- | If a 'Maybe' value is Nothing, throw the given exception. Otherwise, return the +-- value inside. +throwIfNothing :: Exception e => Maybe a -> e -> a +throwIfNothing (Just v) _ = v +throwIfNothing _ exn = throw exn + +-- | If a 'Maybe' value is Nothing, throw the given exception. Otherwise, run the +-- provided function on the value inside and return the result. +throwIfNothingOtherwise :: Exception e => Maybe a -> e -> (a -> b) -> b +throwIfNothingOtherwise (Just v) _ fn = fn v +throwIfNothingOtherwise _ exn _ = throw exn + +-- | Is a given 'DBException' type the general 'DBException'? +isDBExceptionException :: DBException -> Bool +isDBExceptionException (DBException _) = True +isDBExceptionException _ = False + +-- | Is a given 'DBException' type a 'MissingRPMTag'? +isMissingRPMTagException :: DBException -> Bool +isMissingRPMTagException (MissingRPMTag _) = True +isMissingRPMTagException _ = False diff --git a/src/BDCS/Export/Directory.hs b/src/BDCS/Export/Directory.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Export/Directory.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: BDCS.Export.Directory +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Functions for exporting objects from the BDCS into a directory. + +module BDCS.Export.Directory(directorySink) + where + +import Control.Conditional(unlessM) +import Control.Monad.Except(MonadError, throwError) +import Control.Monad.IO.Class(MonadIO, liftIO) +import qualified Data.ByteString as BS +import Data.Conduit(Consumer, awaitForever) +import qualified Data.Text as T +import Data.Time.Clock.POSIX(posixSecondsToUTCTime) +import System.Directory(createDirectoryIfMissing, setModificationTime) +import System.FilePath((), dropDrive, takeDirectory) +import System.Posix.Files(createNamedPipe, createSymbolicLink, directoryMode, fileTypeModes, intersectFileModes, namedPipeMode, setFileMode, symbolicLinkMode) +import System.Posix.Types(CMode(..)) + +import qualified BDCS.CS as CS +import BDCS.DB +import BDCS.Utils.Filesystem(doesPathExist) + +-- | A 'Consumer' that writes objects into a provided directory. Symlinks and other file-like +-- objects will be handled properly. Only some metadata is currently handled. Various errors +-- can be thrown depending on problems encountered when interacting with the filesystem. +-- +-- It is expected that the caller will decide whether the destination directory should be empty +-- or not. This function does nothing to enforce that. +directorySink :: (MonadError String m, MonadIO m) => FilePath -> Consumer (Files, CS.Object) m () +directorySink outPath = awaitForever $ \case + (f, CS.SpecialObject) -> checkoutSpecial f + (f, CS.FileObject bs) -> checkoutFile f bs + where + checkoutSpecial :: (MonadError String m, MonadIO m) => Files -> m () + checkoutSpecial f@Files{..} = + let fullPath = outPath dropDrive (T.unpack filesPath) + fileType = fromIntegral filesMode `intersectFileModes` fileTypeModes + in + if | fileType == symbolicLinkMode -> checkoutSymlink fullPath f + | fileType == directoryMode -> liftIO $ createDirectoryIfMissing True fullPath >> setMetadata f fullPath + | fileType == namedPipeMode -> liftIO $ createNamedPipe fullPath $ fromIntegral filesMode + -- TODO, not storing major/minor for char/block special + | otherwise -> throwError "Invalid file type" + + checkoutSymlink :: (MonadError String m, MonadIO m) => FilePath -> Files -> m () + checkoutSymlink _ Files{filesTarget=Nothing, ..} = throwError "Missing symlink target" + checkoutSymlink fullPath Files{filesTarget=Just target, ..} = + -- Skip creating the symbolic link if the target already exists + liftIO $ unlessM (doesPathExist fullPath) (createSymbolicLink (T.unpack target) fullPath) + + checkoutFile :: MonadIO m => Files -> BS.ByteString -> m () + checkoutFile f@Files{..} contents = liftIO $ do + let fullPath = outPath dropDrive (T.unpack filesPath) + + createDirectoryIfMissing True $ takeDirectory fullPath + + BS.writeFile fullPath contents + setMetadata f fullPath + + setMetadata :: Files -> FilePath -> IO () + setMetadata Files{..} fullPath = do + -- set the mode + setFileMode fullPath (CMode $ fromIntegral filesMode) + + -- set the mtime + setModificationTime fullPath (posixSecondsToUTCTime $ realToFrac filesMtime) + + -- TODO user, group, xattrs diff --git a/src/BDCS/Export/Ostree.hs b/src/BDCS/Export/Ostree.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Export/Ostree.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module: BDCS.Export.Ostree +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Functions for exporting objects from the BDCS into an ostree repo. + +module BDCS.Export.Ostree(ostreeSink) + where + +import Conduit(Conduit, Consumer, Producer, (.|), bracketP, runConduit, sourceDirectory, yield) +import Control.Conditional(condM, otherwiseM, whenM) +import Control.Exception(SomeException, bracket_, catch) +import Control.Monad(void, when) +import Control.Monad.Except(MonadError) +import Control.Monad.IO.Class(MonadIO, liftIO) +import Control.Monad.Trans.Resource(MonadResource, runResourceT) +import Crypto.Hash(SHA256(..), hashInitWith, hashFinalize, hashUpdate) +import qualified Data.ByteString as BS (readFile) +import qualified Data.Conduit.List as CL +import Data.List(isPrefixOf) +import qualified Data.Text as T +import System.Directory +import System.FilePath((), takeDirectory, takeFileName) +import System.IO.Temp(createTempDirectory, withTempDirectory) +import System.Posix.Files(createSymbolicLink, fileGroup, fileMode, fileOwner, getFileStatus, readSymbolicLink) +import System.Process(callProcess) +import Text.Printf(printf) + +import GI.Gio(File, fileNewForPath, noCancellable) +import GI.OSTree + +import qualified BDCS.CS as CS +import BDCS.DB(Files) +import BDCS.Export.Directory(directorySink) +import BDCS.Export.Utils(runHacks) +import BDCS.Utils.Conduit(awaitWith) + +import Paths_bdcs(getDataFileName) + +-- Disable a hint in replaceDirs that just makes thing look confusing +{-# ANN ostreeSink ("HLint: ignore Use ." :: String) #-} + +-- | A 'Consumer' that writes objects into a provided ostree repo. A very large amount of work +-- required to make the destination a valid ostree repo is also done by this function - setting up +-- symlinks and directories, pruning unneeded directories, installing an initrd, building an +-- RPM database, and so forth. +ostreeSink :: (MonadError String m, MonadIO m, MonadResource m) => FilePath -> Consumer (Files, CS.Object) m () +ostreeSink outPath = do + -- While it's possible to copy objects from one OstreeRepo to another, we can't create our own objects, meaning + -- we can't add the dirtree objects we would need to tie all of the files together. So to export to a new + -- ostree repo, first export to a directory, then import that file to a new repo. + -- + -- Note that writing and importing a tar file does not work, because ostree chokes on paths with symlinks + -- (e.g., /lib64/libaudit.so.1) + dst_repo <- liftIO $ open outPath + + bracketP (createTempDirectory (takeDirectory outPath) "export") + removePathForcibly + (\tmpDir -> do + -- Run the sink to export to a directory + directorySink tmpDir + + liftIO $ do + -- Add the standard hacks + runHacks tmpDir + + -- Compile the locale-archive file + let localeDir = tmpDir "usr" "lib" "locale" + whenM (doesFileExist $ localeDir "locale-archive.tmpl") + (callProcess "chroot" [tmpDir, "/usr/sbin/build-locale-archive"]) + + -- Add the kernel and initramfs + installKernelInitrd tmpDir + + -- Replace /etc/nsswitch.conf with the altfiles version + getDataFileName "nsswitch-altfiles.conf" >>= readFile >>= writeFile (tmpDir "etc" "nsswitch.conf") + + -- Remove the fstab stub + removeFile $ tmpDir "etc" "fstab" + + -- Move things around how rpm-ostree wants them + renameDirs tmpDir + + -- Enable some systemd service + doSystemd tmpDir + + -- Convert /var to a tmpfiles entry + convertVar tmpDir + + -- Add more tmpfiles entries + let tmpfilesDir = tmpDir "usr" "lib" "tmpfiles.d" + getDataFileName "tmpfiles-ostree.conf" >>= readFile >>= writeFile (tmpfilesDir "weldr-ostree.conf") + + -- Replace a bunch of top-level directories with symlinks + replaceDirs tmpDir + + -- Create a /sysroot directory + createDirectory (tmpDir "sysroot") + + -- Replace /usr/local with a symlink for some reason + removePathForcibly $ tmpDir "usr" "local" + createSymbolicLink "../var/usrlocal" $ tmpDir "usr" "local" + + -- rpm-ostree moves /var/lib/rpm to /usr/share/rpm. We don't have a rpmdb to begin + -- with, so create an empty one at /usr/share/rpm. + -- rpmdb treats every path as absolute + rpmdbDir <- makeAbsolute $ tmpDir "usr" "share" "rpm" + createDirectoryIfMissing True rpmdbDir + callProcess "rpmdb" ["--initdb", "--dbpath=" ++ rpmdbDir] + + -- import the directory as a new commit + void $ withTransaction dst_repo $ \r -> do + f <- storeDirectory r tmpDir + commit r f "Export commit" Nothing) + + -- Regenerate the summary, necessary for mirroring + repoRegenerateSummary dst_repo Nothing noCancellable + + where + convertVar :: FilePath -> IO () + convertVar exportDir = do + -- /var needs to be empty except for a couple of symlinks we add at the end + -- Convert every directory and symlink we find to a tmpfiles entry. For everything + -- else, warn and remove. + let tmpfilesDir = exportDir "usr" "lib" "tmpfiles.d" + createDirectoryIfMissing True tmpfilesDir + + let varDir = exportDir "var" + writeFile (tmpfilesDir "weldr-var.conf") =<< + unlines <$> + runResourceT (runConduit $ convertToTmp "/var" varDir .| CL.consume) + + -- basePath is the directory we use for the paths in the tmpfiles lines (e.g., /var/lib) + -- realPath is the actual path we are traversing (e.g., /tmp/export.XXXX/var/lib) + convertToTmp :: MonadResource m => FilePath -> FilePath -> Producer m String + convertToTmp basePath realPath = + sourceDirectory realPath .| recurseAndEmit + where + recurseAndEmit :: MonadResource m => Conduit FilePath m String + recurseAndEmit = awaitWith $ \path -> do + let baseFilePath = basePath takeFileName path + + -- if it's a directory, recurse into it first + whenM (liftIO $ doesDirectoryExist path) (convertToTmp baseFilePath path) + + -- Emit a tmpfiles line + condM [(liftIO $ pathIsSymbolicLink path, yieldLink baseFilePath path), + (liftIO $ doesDirectoryExist path, yieldDir baseFilePath path), + -- If not something we can represent as a tmpfile, warn and continue + (otherwiseM, liftIO $ putStrLn $ "Warning: Unable to convert " ++ baseFilePath ++ " to a tmpfile")] + + -- Remove it + liftIO $ removePathForcibly path + + -- Repeat + recurseAndEmit + + yieldLink :: MonadIO m => FilePath -> FilePath -> Producer m String + yieldLink baseFilePath realFilePath = do + target <- liftIO $ readSymbolicLink realFilePath + yield $ printf "L %s - - - - %s" baseFilePath target + + yieldDir :: MonadIO m => FilePath -> FilePath -> Producer m String + yieldDir baseDirPath realDirPath = do + stat <- liftIO $ getFileStatus realDirPath + + -- coerce the stat fields into a type that implements PrintfArg + let mode = fromIntegral $ fileMode stat :: Integer + let userId = fromIntegral $ fileOwner stat :: Integer + let groupId = fromIntegral $ fileGroup stat :: Integer + + yield $ printf "d %s %#o %d %d - -" baseDirPath mode userId groupId + + installKernelInitrd :: FilePath -> IO () + installKernelInitrd exportDir = do + -- The kernel and initramfs need to be named /boot/vmlinuz- + -- and /boot/initramfs-, where CHECKSUM is the sha256 + -- of the kernel+initramfs. + + let bootDir = exportDir "boot" + + -- Find a vmlinuz- file. + kernelList <- filter ("vmlinuz-" `isPrefixOf`) <$> listDirectory bootDir + when (null kernelList) (error "No kernel found") + let kernel = bootDir head kernelList + let kver = drop (length ("vmlinuz-" :: String)) (head kernelList) + + -- Create the initramfs + let initramfs = bootDir "initramfs-" ++ kver + withTempDirectory exportDir "dracut" + (\tmpDir -> callProcess "chroot" + [exportDir, + "dracut", + "--add", "ostree", + "--no-hostonly", + "--tmpdir=/" ++ takeFileName tmpDir, + "-f", "/boot/" ++ takeFileName initramfs, + kver]) + + -- Append the checksum to the filenames + kernelData <- BS.readFile kernel + initramfsData <- BS.readFile initramfs + + let ctx = hashInitWith SHA256 + let update1 = hashUpdate ctx kernelData + let update2 = hashUpdate update1 initramfsData + let digest = show $ hashFinalize update2 + + renameFile kernel (kernel ++ "-" ++ digest) + renameFile initramfs (initramfs ++ "-" ++ digest) + + renameDirs :: FilePath -> IO () + renameDirs exportDir = do + -- ostree mandates /usr/etc, and fails if /etc also exists. + -- There is an empty /usr/etc owned by filesystem, so get rid of that and move /etc to /usr/etc + let etcPath = exportDir "etc" + let usrEtcPath = exportDir "usr" "etc" + + removePathForcibly usrEtcPath + renameDirectory etcPath usrEtcPath + + -- usr/etc/passwd and usr/etc/group are supposed to be empty (except root and wheel) + -- the real ones go in /usr/lib/{passwd,group} + let usrLibPath = exportDir "usr" "lib" + renameFile (usrEtcPath "passwd") (usrLibPath "passwd") + renameFile (usrEtcPath "group") (usrLibPath "group") + writeFile (usrEtcPath "passwd") "root:x:0:0:root:/root:/bin/bash\n" + writeFile (usrEtcPath "group") "root:x:0:\nwheel:x:10:\n" + + -- NB: rpm-ostree also requires that /var/lib/rpm be moved to /usr/share/rpm, but we don't have any + -- real RPM data to move. + + replaceDirs :: FilePath -> IO () + replaceDirs exportDir = do + -- Clear out anything that's already there. + -- removeDirectory will fail if not directory exists but is not empty + mapM_ (\dir -> whenM (doesPathExist dir) (removeDirectory dir)) + (map (exportDir ) ["home", "media", "mnt", "opt", "root", "srv", "tmp"]) + + -- And replace (plus one new one, /ostree) + createSymbolicLink "var/home" (exportDir "home") + createSymbolicLink "run/media" (exportDir "media") + createSymbolicLink "var/mnt" (exportDir "mnt") + createSymbolicLink "var/opt" (exportDir "opt") + createSymbolicLink "sysroot/ostree" (exportDir "ostree") + createSymbolicLink "var/roothome" (exportDir "root") + createSymbolicLink "var/srv" (exportDir "srv") + createSymbolicLink "sysroot/tmp" (exportDir "tmp") + + doSystemd :: FilePath -> IO () + doSystemd exportDir = do + let systemdDir = exportDir "usr" "etc" "systemd" "system" + createDirectoryIfMissing True systemdDir + + -- Set the default target to multi-user + createSymbolicLink "/usr/lib/systemd/system/multi-user.target" $ systemdDir "default.target" + + -- Add some services that look important + createDirectoryIfMissing True $ systemdDir "getty.target.wants" + createDirectoryIfMissing True $ systemdDir "local-fs.target.wants" + + createSymbolicLink "/usr/lib/systemd/system/getty@.service" $ systemdDir "getty.target.wants" "getty@tty1.service" + createSymbolicLink "/usr/lib/systemd/system/ostree-remount.service" $ systemdDir "local-fs.target.wants" "ostree-remount.service" + +-- Write the commit metadata object to an opened ostree repo, given the results of calling store. This +-- function also requires a commit subject and optionally a commit body. The subject and body are +-- visible if you use "ostree log master". Returns the checksum of the commit. +commit :: IsRepo a => a -> File -> T.Text -> Maybe T.Text -> IO T.Text +commit repo repoFile subject body = + unsafeCastTo RepoFile repoFile >>= \root -> do + -- Get the parent, which should always be whatever "master" points to. If there is no parent + -- (likely because nothing has been imported into this repo before), just return Nothing. + -- ostree will know what to do. + parent <- parentCommit repo "master" + checksum <- repoWriteCommit repo parent (Just subject) body Nothing root noCancellable + repoTransactionSetRef repo Nothing "master" (Just checksum) + return checksum + +-- Open the named ostree repo. If the repo does not already exist, it will first be created. +-- It is created in Z2 mode because that can be modified without being root. +open :: FilePath -> IO Repo +open fp = do + path <- fileNewForPath fp + repo <- repoNew path + + doesDirectoryExist fp >>= \case + True -> repoOpen repo noCancellable >> return repo + False -> repoCreate repo RepoModeArchiveZ2 noCancellable >> return repo + +-- Given a commit, return the parent of it or Nothing if no parent exists. +parentCommit :: IsRepo a => a -> T.Text -> IO (Maybe T.Text) +parentCommit repo commitSum = + catch (Just <$> repoResolveRev repo commitSum False) + (\(_ :: SomeException) -> return Nothing) + +-- Same as store, but takes a path to a directory to import +storeDirectory :: IsRepo a => a -> FilePath -> IO File +storeDirectory repo path = do + importFile <- fileNewForPath path + mtree <- mutableTreeNew + + repoWriteDirectoryToMtree repo importFile mtree Nothing noCancellable + repoWriteMtree repo mtree noCancellable + +-- Wrap some repo-manipulating function in a transaction, committing it if the function succeeds. +-- Returns the checksum of the commit. +withTransaction :: IsRepo a => a -> (a -> IO b) -> IO b +withTransaction repo fn = + bracket_ (repoPrepareTransaction repo noCancellable) + (repoCommitTransaction repo noCancellable) + (fn repo) diff --git a/src/BDCS/Export/Qcow2.hs b/src/BDCS/Export/Qcow2.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Export/Qcow2.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module: BDCS.Export.Qcow2 +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Functions for exporting objects from the BDCS into a qcow2 image. + +module BDCS.Export.Qcow2(qcow2Sink) + where + +import Control.Monad.Except(MonadError) +import Control.Monad.IO.Class(MonadIO, liftIO) +import Control.Monad.Trans.Resource(MonadResource) +import Data.Conduit(Consumer, bracketP) +import System.Directory(removePathForcibly) +import System.FilePath(takeDirectory) +import System.IO.Temp(createTempDirectory) +import System.Process(callProcess) + +import qualified BDCS.CS as CS +import BDCS.DB(Files) +import BDCS.Export.Directory(directorySink) +import BDCS.Export.Utils(runHacks, runTmpfiles) + +-- | A 'Consumer' that writes objects into a temporary directory, and then converts that directory into +-- a qcow2 image with virt-make-fs. +qcow2Sink :: (MonadResource m, MonadIO m, MonadError String m) => FilePath -> Consumer (Files, CS.Object) m () +qcow2Sink outPath = + -- Writing and importing a tar file probably will not work, because some rpms contain paths + -- with symlinks (e.g., /lib64/libaudit.so.1 is expected to be written to /usr/lib64). + -- Instead, export to a temp directory and convert that to qcow + + bracketP (createTempDirectory (takeDirectory outPath) "export") + removePathForcibly + (\tmpDir -> do + -- Apply tmpfiles.d to the directory first + liftIO $ runTmpfiles tmpDir + + -- Run the sink to create a directory export + directorySink tmpDir + + -- Make the direcotry export something usable, hopefully + liftIO $ runHacks tmpDir + + -- Run virt-make-fs to generate the qcow2 + liftIO $ callProcess "virt-make-fs" [tmpDir, outPath, "--format=qcow2", "--label=composer"] + ) diff --git a/src/BDCS/Export/Tar.hs b/src/BDCS/Export/Tar.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Export/Tar.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module: BDCS.Export.Tar +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Functions for exporting objects from the BDCS into a tar file. + +module BDCS.Export.Tar(tarSink) + where + +import qualified Codec.Archive.Tar as Tar +import Control.Monad.IO.Class(MonadIO, liftIO) +import Data.ByteString.Lazy(writeFile) +import Data.Conduit(Consumer) +import qualified Data.Conduit.List as CL +import Prelude hiding(writeFile) + +-- | A 'Consumer' that writes objects (in the form of 'Tar.Entry' records) into a tar archive +-- with the provided name. To convert objects into an Entry, see 'BDCS.CS.objectToTarEntry'. +tarSink :: MonadIO m => FilePath -> Consumer Tar.Entry m () +tarSink out_path = do + entries <- CL.consume + liftIO $ writeFile out_path (Tar.write entries) diff --git a/src/BDCS/Export/TmpFiles.hs b/src/BDCS/Export/TmpFiles.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Export/TmpFiles.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: BDCS.Export.TmpFiles +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Parse a tmpfiles.d config file into TmpFileEntry records. +-- +-- This parser is limited, it only supports types that are needed +-- by the bdcs export tool (eg. creating files and directories) +-- +-- Currently supported types are: +-- +-- f Create a new file and optionally write the arg to it. Will not overwrite. +-- F Remove existing file and make a new one, optionally writing arg to it. +-- d Create a new directory, only if it doesn't exist. +-- e Modify an existing directory's ownership and permissions +-- L Create a new symlink. Do nothing if it already exists. +-- L+ Remove file, directory tree, or symlink before creating it. WARNING this will remove a whole directory tree. +-- +module BDCS.Export.TmpFiles( + TmpFileEntry(..), + TmpFileType(..), + parseConfString, + setupFilesystem) + where + +import Control.Conditional(ifM) +import Data.List(sort) +import qualified Data.Text as T +import System.Directory(createDirectoryIfMissing, doesPathExist, removePathForcibly) +import System.FilePath((), dropDrive, takeFileName) +import System.Posix.Files(createSymbolicLink, setFileMode, setOwnerAndGroup) +import System.Posix.Types(CMode(..), CUid(..), CGid(..)) +import Text.Parsec +import Text.ParserCombinators.Parsec.Char(CharParser) +import Text.ParserCombinators.Parsec.Number(number) +import Text.Printf(printf) + +-- | Types for the tmpfiles.d config file. +-- This is not a complete list, some don't make sense for an empty filesystem and are unimplemented +-- NOTE Order is important, it needs to maintain at least: Directory, Symlink, File, etc. For more +-- detailed information on these types, see "man 5 tmpfiles.d". +data TmpFileType = NewDirectory + | NewSymlink + | ReplaceSymlink + | NewFile + | TruncateFile + | ModifyDirectory + | Unsupported -- Catchall for unsupported types + deriving(Ord, Eq, Show) + +-- Translate the type characters into the actual types +getTmpFileType :: String -> TmpFileType +getTmpFileType "f" = NewFile +getTmpFileType "F" = TruncateFile +getTmpFileType "d" = NewDirectory +getTmpFileType "e" = ModifyDirectory +getTmpFileType "L" = NewSymlink +getTmpFileType "L+"= ReplaceSymlink +getTmpFileType _ = Unsupported + +allowedTypes :: String +allowedTypes = "fFwdDevqQpLcbCxXrRzZtThHaA+!" + +-- | Record for the tmpfiles.d config file entries. For more detailed information on these +-- values, see "man 5 tmpfiles.d". +data TmpFileEntry = TmpFileEntry { + tfeType :: TmpFileType, -- ^ The type of file to create + tfePath :: FilePath, -- ^ File path + tfeMode :: Maybe Integer, -- ^ File access mode, or a default + tfeUid :: Maybe T.Text, -- ^ File's owner + tfeGid :: Maybe T.Text, -- ^ File's group + tfeAge :: Maybe T.Text, -- ^ How long to keep the file before deleting + tfeArg :: Maybe T.Text -- ^ Depends on the type of file + } deriving(Eq, Show) + +-- Order the records by: Directory, Symlink, File, etc. and when equal, sort by the path. +instance Ord TmpFileEntry where + a `compare` b = let cmp = tfeType a `compare` tfeType b + in if cmp == EQ then tfePath a `compare` tfePath b else cmp + +eol :: Parsec String () Char +eol = char '\n' + +-- Parse an Octal string with leading 0, o, O, or a +-- combination thereof. +octal :: Integral i => CharParser st i +octal = many1 (oneOf "Oo0") >> number 8 octDigit + +-- Skip spaces. NOT \n or \r. Also skip \t because they are ugly +skipSpaces :: Parsec String () () +skipSpaces = skipMany (oneOf " \t") + +-- Get a String field and convert it to T.Text +getTextField :: Parsec String () T.Text +getTextField = T.pack <$> many (noneOf " ") + +-- Parse a field that might have a '-' into a Maybe, using the supplied function to parse the value +parseMaybeDash :: Stream s m Char => ParsecT s u m a -> ParsecT s u m (Maybe a) +parseMaybeDash f = (Nothing <$ char '-') <|> (return <$> f) + +-- Convert the field into a tmpfiles.d entry type +parseType :: Parsec String () TmpFileType +parseType = getTmpFileType <$> many1 (oneOf allowedTypes) + +-- Parse a file path +parsePath :: Parsec String () FilePath +parsePath = many1 (noneOf " ") + +-- Parse an Octal file mode +-- Which can also be set to '-' to mean the default for the type +parseMode :: Parsec String () (Maybe Integer) +parseMode = parseMaybeDash octal + +-- Parse a uid/gid (only supports strings) +-- Which can also be set to '-' to mean the default for the type +parseId :: Parsec String () (Maybe T.Text) +parseId = parseMaybeDash getTextField + +-- Age may be the last entry, or it may not. +-- It can also be set to '-' to mean the default for the type +parseAge :: Parsec String () (Maybe T.Text) +parseAge = parseMaybeDash getAgeField + where + getAgeField = T.pack <$> many1 (oneOf "0123456789sminhdwu-") + +-- If Arg is present, it is the last, and may contain spaces +parseArg :: Parsec String () T.Text +parseArg = T.pack <$> many1 (noneOf "\n") + +parseConfLine :: Parsec String () TmpFileEntry +parseConfLine = do + t <- parseType + skipSpaces + p <- parsePath + skipSpaces + m <- parseMode + skipSpaces + uid <- parseId + skipSpaces + gid <- parseId + skipSpaces + age <- parseAge + skipSpaces + arg <- optionMaybe $ try parseArg + _ <- eol + + return TmpFileEntry{tfeType=t, tfePath=p, tfeMode=m, tfeUid=uid, tfeGid=gid, tfeAge=age, tfeArg=arg} + +-- | Given a string, convert it into a list of 'TmpFileEntry' records or a 'ParseError'. +parseConfString :: String -> Either ParseError [TmpFileEntry] +parseConfString = parse (many1 parseConfLine) "(tmpFiles.d)" + +-- TODO This is going to need a map from strings to ids +-- Use root for now +-- Convert an owner name (eg. root) to a CUid value +owner :: Maybe T.Text -> CUid +owner uid = case uid of + Nothing -> CUid 0 + Just _ -> CUid 0 + +-- TODO This is going to need a map from strings to ids +-- Use root for now +-- Convert a group name (eg. root) to a CUid value +group :: Maybe T.Text -> CGid +group gid = case gid of + Nothing -> CGid 0 + Just _ -> CGid 0 + + +-- Write a new file and set its ownership and permissions +writeNewFile :: FilePath -> TmpFileEntry -> IO () +writeNewFile outPath TmpFileEntry{..} = do + writeFile file content + setFileMode file mode + setOwnerAndGroup file (owner tfeUid) (group tfeGid) + where + file = outPath dropDrive tfePath + content = case tfeArg of + Nothing -> "" + Just c -> T.unpack c + mode = case tfeMode of + Nothing -> CMode 0o644 + Just m -> CMode $ fromIntegral m + +-- Create a new directory if there isn't already one present. +-- Also sets the ownership and permissions +applyEntry :: FilePath -> TmpFileEntry -> IO () +applyEntry outPath TmpFileEntry{tfeType=NewDirectory, ..} = do + createDirectoryIfMissing True dir + setFileMode dir mode + setOwnerAndGroup dir (owner tfeUid) (group tfeGid) + where + dir = outPath dropDrive tfePath + mode = case tfeMode of + Nothing -> CMode 0o755 + Just m -> CMode $ fromIntegral m + +-- Create a new file with optional contents. +-- Also sets the ownership and permissions +applyEntry outPath entry@TmpFileEntry{tfeType=NewFile, ..} = + ifM (doesPathExist file) + (printf "NewFile: %s already exists, skipping it." file) + (writeNewFile outPath entry) + where + file = outPath dropDrive tfePath + +-- Create or Truncate a file with optional contents. +-- Also sets the ownership and permissions +applyEntry outPath entry@TmpFileEntry{tfeType=TruncateFile, ..} = writeNewFile outPath entry + +-- Modify an existing directory's ownership and permissions> +applyEntry outPath TmpFileEntry{tfeType=ModifyDirectory, ..} = + ifM (doesPathExist dir) + modify + (printf "ModifyDirectory: %s doesn't exist, skipping it." dir) + where + dir = outPath dropDrive tfePath + mode = case tfeMode of + Nothing -> CMode 0o755 + Just m -> CMode $ fromIntegral m + modify = do + setFileMode dir mode + setOwnerAndGroup dir (owner tfeUid) (group tfeGid) + + +-- Create a new symlink. +-- Does NOT create parents of the source file, they must already exist +-- If no target arg is present it will link to the source filename under /usr/share/factory/ +applyEntry outPath TmpFileEntry{tfeType=NewSymlink, ..} = + ifM (doesPathExist source) + (printf "NewSymlink: %s exists, skipping." source) + (createSymbolicLink target source) + where + source = outPath dropDrive tfePath + target = case tfeArg of + Nothing -> "/usr/share/factory" takeFileName tfePath + Just arg -> T.unpack arg + +-- Replace a symlink, if it exists or create a new one. +-- If no target arg is present it will link to the source filename under /usr/share/factory/ +applyEntry outPath TmpFileEntry{tfeType=ReplaceSymlink, ..} = do + removePathForcibly source + createSymbolicLink target source + where + source = outPath dropDrive tfePath + target = case tfeArg of + Nothing -> "/usr/share/factory" takeFileName tfePath + Just arg -> T.unpack arg + +applyEntry _ TmpFileEntry{tfeType=Unsupported, ..} = undefined + + +-- | Read the tmpfiles.d snippet and apply it to the output directory +setupFilesystem :: FilePath -> FilePath -> IO () +setupFilesystem outPath tmpFileConf = do + createDirectoryIfMissing True outPath + tmpfiles <- parseConfString <$> readFile tmpFileConf + case tmpfiles of + Right entries -> mapM_ (applyEntry outPath) $ sort entries + Left err -> print err diff --git a/src/BDCS/Export/Utils.hs b/src/BDCS/Export/Utils.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Export/Utils.hs @@ -0,0 +1,76 @@ +-- | +-- Module: BDCS.Export.Utils +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Miscellaneous utilities useful in exporting objects. + +module BDCS.Export.Utils(runHacks, + runTmpfiles) + where + +import Control.Conditional(whenM) +import Control.Exception(tryJust) +import Control.Monad(guard) +import Data.List(intercalate) +import Data.List.Split(splitOn) +import System.Directory(createDirectoryIfMissing, doesFileExist, listDirectory, removePathForcibly, renameFile) +import System.FilePath(()) +import System.IO.Error(isDoesNotExistError) +import System.Process(callProcess) + +import BDCS.Export.TmpFiles(setupFilesystem) + +import Paths_bdcs(getDataFileName) + +-- | Run filesystem hacks needed to make a directory tree bootable. Any exporter that produces a +-- finished image should call this function. Otherwise, it is not generally useful and should be +-- avoided. The exact hacks required is likely to change over time. +runHacks :: FilePath -> IO () +runHacks exportPath = do + -- set a root password + -- pre-crypted from "redhat" + shadowRecs <- map (splitOn ":") <$> lines <$> readFile (exportPath "etc" "shadow") + let newRecs = map (\rec -> if head rec == "root" then + ["root", "$6$3VLMX3dyCGRa.JX3$RpveyimtrKjqcbZNTanUkjauuTRwqAVzRK8GZFkEinbjzklo7Yj9Z6FqXNlyajpgCdsLf4FEQQKH6tTza35xs/"] ++ drop 2 rec + else + rec) shadowRecs + writeFile (exportPath "etc" "shadow.new") (unlines $ map (intercalate ":") newRecs) + renameFile (exportPath "etc" "shadow.new") (exportPath "etc" "shadow") + + -- create an empty machine-id + writeFile (exportPath "etc" "machine-id") "" + + -- Install a sysusers.d config file, and run systemd-sysusers to implement it + let sysusersDir = exportPath "usr" "lib" "sysusers.d" + createDirectoryIfMissing True sysusersDir + getDataFileName "sysusers-default.conf" >>= readFile >>= writeFile (sysusersDir "weldr.conf") + callProcess "systemd-sysusers" ["--root", exportPath] + + -- Run depmod on any kernel modules that might be present + let modDir = exportPath "usr" "lib" "modules" + modVers <- tryJust (guard . isDoesNotExistError) (listDirectory modDir) + mapM_ (\ver -> callProcess "depmod" ["-b", exportPath, "-a", ver]) $ either (const []) id modVers + + -- Create a fstab stub + writeFile (exportPath "etc" "fstab") "LABEL=composer / ext2 defaults 0 0" + + -- Clean up /run + -- Some packages create directories in /var/run, which a symlink to /run, which is a tmpfs. + (map ((exportPath "run") ) <$> listDirectory (exportPath "run")) >>= mapM_ removePathForcibly + + -- EXTRA HACKY: turn off mod_ssl + let sslConf = exportPath "etc" "httpd" "conf.d" "ssl.conf" + whenM (doesFileExist sslConf) + (renameFile sslConf (sslConf ++ ".off")) + +-- | Run tmpfiles.d snippet on the new directory. Most exporters should call this function. Otherwise, +-- it is not generally useful and should be avoided. +runTmpfiles :: FilePath -> IO () +runTmpfiles exportPath = do + configPath <- getDataFileName "tmpfiles-default.conf" + setupFilesystem exportPath configPath diff --git a/src/BDCS/Files.hs b/src/BDCS/Files.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Files.hs @@ -0,0 +1,117 @@ +-- Copyright (C) 2016-2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +module BDCS.Files(insertFiles, + associateFilesWithBuild, + associateFilesWithSource, + associateFilesWithPackage, + files, + filesC, + getFile, + getKeyValuesForFile, + groupIdToFiles, + groupIdToFilesC, + pathToGroupId, + sourceIdToFiles, + sourceIdToFilesC) + where + +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Trans.Resource(MonadResource) +import Data.Conduit((.|), Conduit, Source, toProducer) +import qualified Data.Conduit.List as CL +import qualified Data.Text as T +import Database.Esqueleto + +import BDCS.DB +import BDCS.Utils.Conduit(awaitWith) + +insertFiles :: MonadIO m => [Files] -> SqlPersistT m [Key Files] +insertFiles = mapM insert + +associateFilesWithBuild :: MonadIO m => [Key Files] -> Key Builds -> SqlPersistT m [Key BuildFiles] +associateFilesWithBuild fs build = + mapM (\(fID, bID) -> insert $ BuildFiles bID fID) + (zip fs $ repeat build) + +associateFilesWithSource :: MonadIO m => [Key Files] -> Key Sources -> SqlPersistT m [Key SourceFiles] +associateFilesWithSource fs source = + mapM (\(fID, sID) -> insert $ SourceFiles sID fID) + (zip fs $ repeat source) + +associateFilesWithPackage :: MonadIO m => [Key Files] -> Key KeyVal -> SqlPersistT m [Key FileKeyValues] +associateFilesWithPackage fs package = + mapM (\(fID, pID) -> insert $ FileKeyValues fID pID) + (zip fs $ repeat package) + +files :: MonadIO m => SqlPersistT m [Files] +files = do + results <- select $ from $ \file -> do + orderBy [asc (file ^. FilesPath)] + return file + return $ map entityVal results + +filesC :: (MonadResource m, MonadIO m) => Source (SqlPersistT m) Files +filesC = do + let source = selectSource $ from $ \file -> do + orderBy [asc (file ^. FilesPath)] + return file + source .| CL.map entityVal + +getFile :: MonadIO m => Key Files -> SqlPersistT m (Maybe Files) +getFile key = firstEntityResult $ + select $ from $ \file -> do + where_ $ file ^. FilesId ==. val key + limit 1 + return file + +getKeyValuesForFile :: MonadIO m => T.Text -> SqlPersistT m [KeyVal] +getKeyValuesForFile path = do + results <- select $ from $ \(file `InnerJoin` file_key_val `InnerJoin` key_val) -> do + on $ file ^. FilesId ==. file_key_val ^. FileKeyValuesFile_id &&. + key_val ^. KeyValId ==. file_key_val ^. FileKeyValuesKey_val_id + where_ $ file ^. FilesPath ==. val path + return key_val + return $ map entityVal results + +groupIdToFiles :: MonadResource m => Key Groups -> Source (SqlPersistT m) Files +groupIdToFiles groupid = do + let source = selectSource $ from $ \(fs `InnerJoin` group_files) -> do + on $ fs ^. FilesId ==. group_files ^. GroupFilesFile_id + where_ $ group_files ^. GroupFilesGroup_id ==. val groupid + return fs + source .| CL.map entityVal + +groupIdToFilesC :: MonadResource m => Conduit (Key Groups) (SqlPersistT m) Files +groupIdToFilesC = awaitWith $ \groupid -> toProducer (groupIdToFiles groupid) >> groupIdToFilesC + +sourceIdToFiles :: MonadResource m => Key Sources -> Source (SqlPersistT m) Files +sourceIdToFiles sourceid = do + let source = selectSource $ from $ \(fs `InnerJoin` source_files) -> do + on $ fs ^. FilesId ==. source_files ^. SourceFilesFile_id + where_ $ source_files ^. SourceFilesSource_id ==. val sourceid + return fs + source .| CL.map entityVal + +sourceIdToFilesC :: MonadResource m => Conduit (Key Sources) (SqlPersistT m) Files +sourceIdToFilesC = awaitWith $ \sourceid -> toProducer (sourceIdToFiles sourceid) >> sourceIdToFilesC + +pathToGroupId :: MonadIO m => T.Text -> SqlPersistT m [Key Groups] +pathToGroupId path = do + vals <- select $ distinct $ from $ \(group_files `InnerJoin` fs) -> do + on $ group_files ^. GroupFilesFile_id ==. fs ^. FilesId + where_ $ fs ^. FilesPath ==. val path + return $ group_files ^. GroupFilesGroup_id + return $ map unValue vals diff --git a/src/BDCS/GroupKeyValue.hs b/src/BDCS/GroupKeyValue.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/GroupKeyValue.hs @@ -0,0 +1,62 @@ +-- Copyright (C) 2016-2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +module BDCS.GroupKeyValue(getGroupsByKeyVal, + getKeyValuesForGroup, + getValueForGroup, + insertGroupKeyValue) + where + +import Control.Monad.IO.Class(MonadIO) +import Data.Maybe(listToMaybe, mapMaybe) +import Data.Bifunctor(bimap) +import qualified Data.Text as T +import Database.Esqueleto + +import BDCS.DB +import BDCS.KeyType +import BDCS.KeyValue(findKeyValue, insertKeyValue) + +insertGroupKeyValue :: MonadIO m => KeyType -> T.Text -> Maybe T.Text -> Key Groups -> SqlPersistT m (Key GroupKeyValues) +insertGroupKeyValue k v e groupId = + maybeKey (insertKeyValue k (Just v) e >>= \kvId -> insert $ GroupKeyValues groupId kvId) + (insert . GroupKeyValues groupId) + (findKeyValue k (Just v) e) + +-- Given a group id and a key, return a list of the matching values +getKeyValuesForGroup :: MonadIO m => Key Groups -> Maybe KeyType -> SqlPersistT m [KeyVal] +getKeyValuesForGroup groupId key = do + vals <- select $ from $ \(keyval `InnerJoin` group_keyval) -> do + on $ keyval ^. KeyValId ==. group_keyval ^. GroupKeyValuesKey_val_id + where_ $ group_keyval ^. GroupKeyValuesGroup_id ==. val groupId &&. + (isNothing (val key) ||. just (keyval ^. KeyValKey_value) ==. val key) + return keyval + return $ map entityVal vals + +-- Fetch the value for a key/val pair that is expected to occur only once +getValueForGroup :: MonadIO m => Key Groups -> KeyType -> SqlPersistT m (Maybe T.Text) +getValueForGroup groupId key = listToMaybe <$> mapMaybe keyValVal_value <$> getKeyValuesForGroup groupId (Just key) + +-- Return groups matching a given key/val +getGroupsByKeyVal :: MonadIO m => T.Text -> KeyType -> Maybe T.Text -> SqlPersistT m [(Key Groups, KeyVal)] +getGroupsByKeyVal groupType key value = do + vals <- select $ distinct $ from $ \(keyval `InnerJoin` group_keyval `InnerJoin` groups) -> do + on $ groups ^. GroupsId ==. group_keyval ^. GroupKeyValuesGroup_id + on $ keyval ^. KeyValId ==. group_keyval ^. GroupKeyValuesKey_val_id + where_ $ keyval ^. KeyValKey_value ==. val key &&. + keyval ^. KeyValVal_value ==? value &&. + groups ^. GroupsGroup_type ==. val groupType + return (group_keyval ^. GroupKeyValuesGroup_id, keyval) + return $ map (bimap unValue entityVal) vals diff --git a/src/BDCS/Groups.hs b/src/BDCS/Groups.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Groups.hs @@ -0,0 +1,180 @@ +-- Copyright (C) 2016-2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module BDCS.Groups(findGroupRequirements, + findRequires, + getRequires, + getGroupId, + getGroupIdC, + getGroup, + getGroupRequirements, + getRequirementsForGroup, + groups, + groupsC, + groupIdToNevra, + nameToGroupIds, + nevraToGroupId) + where + +import Control.Monad.Except(MonadError, throwError) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Trans.Resource(MonadResource) +import Data.Bifunctor(bimap) +import Data.Conduit((.|), Conduit, Source) +import qualified Data.Conduit.List as CL +import Data.Maybe(isNothing, fromJust, fromMaybe) +import qualified Data.Text as T +import Database.Esqueleto hiding (isNothing) + +import BDCS.DB +import BDCS.GroupKeyValue(getValueForGroup) +import BDCS.KeyType +import qualified BDCS.ReqType as RT +import BDCS.RPM.Utils(splitFilename) + +findGroupRequirements :: MonadIO m => Key Groups -> Key Requirements -> SqlPersistT m (Maybe (Key GroupRequirements)) +findGroupRequirements groupId reqId = firstKeyResult $ + select $ from $ \r -> do + where_ $ r ^. GroupRequirementsGroup_id ==. val groupId &&. + r ^. GroupRequirementsReq_id ==. val reqId + limit 1 + return $ r ^. GroupRequirementsId + +getGroupRequirements :: MonadIO m => Key GroupRequirements -> SqlPersistT m (Maybe GroupRequirements) +getGroupRequirements key = firstEntityResult $ + select $ from $ \r -> do + where_ $ r ^. GroupRequirementsId ==. val key + limit 1 + return r + +findRequires :: MonadIO m => RT.ReqLanguage -> RT.ReqContext -> RT.ReqStrength -> T.Text -> SqlPersistT m (Maybe (Key Requirements)) +findRequires reqLang reqCtx reqStrength reqExpr = firstKeyResult $ + select $ from $ \r -> do + where_ $ r ^. RequirementsReq_language ==. val reqLang &&. + r ^. RequirementsReq_context ==. val reqCtx &&. + r ^. RequirementsReq_strength ==. val reqStrength &&. + r ^. RequirementsReq_expr ==. val reqExpr + limit 1 + return $ r ^. RequirementsId + +getRequires :: MonadIO m => Key Requirements -> SqlPersistT m (Maybe Requirements) +getRequires key = firstEntityResult $ + select $ from $ \r -> do + where_ $ r ^. RequirementsId ==. val key + limit 1 + return r + +getGroupId :: (MonadError String m, MonadIO m) => T.Text -> SqlPersistT m (Key Groups) +getGroupId thing = + nevraToGroupId (splitFilename thing) >>= \case + Just gid -> return gid + Nothing -> throwError $ "No such group " ++ T.unpack thing + +getGroupIdC :: (MonadError String m, MonadIO m) => Conduit T.Text (SqlPersistT m) (Key Groups) +getGroupIdC = CL.mapM getGroupId + +getGroup :: MonadIO m => Key Groups -> SqlPersistT m (Maybe Groups) +getGroup key = firstEntityResult $ + select $ from $ \group -> do + where_ $ group ^. GroupsId ==. val key + limit 1 + return group + +groups :: MonadIO m => SqlPersistT m [(Key Groups, T.Text)] +groups = do + results <- select $ from $ \group -> do + orderBy [asc (group ^. GroupsName)] + return (group ^. GroupsId, group ^. GroupsName) + return $ map (bimap unValue unValue) results + +groupsC :: (MonadResource m, MonadIO m) => Source (SqlPersistT m) (Key Groups, T.Text) +groupsC = do + let source = selectSource $ from $ \group -> do + orderBy [asc (group ^. GroupsName)] + return (group ^. GroupsId, group ^. GroupsName) + source .| CL.map (bimap unValue unValue) + +groupIdToNevra :: MonadIO m => Key Groups -> SqlPersistT m (Maybe T.Text) +groupIdToNevra groupId = do + n <- getValueForGroup groupId (TextKey "name") + e <- getValueForGroup groupId (TextKey "epoch") + v <- getValueForGroup groupId (TextKey "version") + r <- getValueForGroup groupId (TextKey "release") + a <- getValueForGroup groupId (TextKey "arch") + + if isNothing n || isNothing v || isNothing r || isNothing a + then return Nothing + else return $ Just $ T.concat [fromMaybe "" e, fromJust n, "-", fromJust v, "-", fromJust r, ".", fromJust a] + +getRequirementsForGroup :: MonadIO m => Key Groups -> RT.ReqContext -> SqlPersistT m [Requirements] +getRequirementsForGroup groupId context = do + vals <- select $ from $ \(reqs `InnerJoin` groupreqs) -> do + on $ reqs ^. RequirementsId ==. groupreqs ^. GroupRequirementsReq_id + where_ $ groupreqs ^. GroupRequirementsGroup_id ==. val groupId &&. + reqs ^. RequirementsReq_context ==. val context + return reqs + return $ map entityVal vals + +-- Given a group name, return a list of matching group ids +nameToGroupIds :: MonadIO m => T.Text -> SqlPersistT m [Key Groups] +nameToGroupIds name = do + result <- select $ distinct $ from $ \(keyval `InnerJoin` group_keyval `InnerJoin` group) -> do + on $ keyval ^. KeyValId ==. group_keyval ^. GroupKeyValuesKey_val_id &&. + group_keyval ^. GroupKeyValuesGroup_id ==. group ^. GroupsId + where_ $ keyval ^. KeyValKey_value ==. val (TextKey "name") &&. + keyval ^. KeyValVal_value ==. just (val name) &&. + group ^. GroupsGroup_type ==. val "rpm" + return $ group ^. GroupsId + return $ map unValue result + +nevraToGroupId :: MonadIO m => (T.Text, Maybe T.Text, T.Text, T.Text, T.Text) -> SqlPersistT m (Maybe (Key Groups)) +nevraToGroupId (n, e, v, r, a) = firstKeyResult $ + -- Each key/val pair to match against is a separate row in key_val, so each one needs to be joined into the + -- query as if it were a separate table. + -- The idea here is to create a key_val/group_key_values join for each key_val.key_value we're looking up, and + -- then join that to the previous key_val/group_key_values in the chain. The one for epoch is an outer join since + -- epoch is optional. + -- As far as esqueleto quirks: "on" is applied in reverse order, so the first "on" attaches to the last join, then + -- the next to the one before that, and so on. + select $ distinct $ from $ \((gkv_name `InnerJoin` kv_name) `InnerJoin` + (gkv_ver `InnerJoin` kv_ver) `InnerJoin` + (gkv_rel `InnerJoin` kv_rel) `InnerJoin` + (gkv_arch `InnerJoin` kv_arch) `LeftOuterJoin` + (gkv_epoch `InnerJoin` kv_epoch)) -> do + on $ kv_epoch ^. KeyValId ==. gkv_epoch ^. GroupKeyValuesKey_val_id &&. + kv_epoch ^. KeyValKey_value ==. val (TextKey "epoch") + on $ gkv_epoch ^. GroupKeyValuesGroup_id ==. gkv_arch ^. GroupKeyValuesGroup_id + on $ kv_arch ^. KeyValId ==. gkv_arch ^. GroupKeyValuesKey_val_id &&. + kv_arch ^. KeyValKey_value ==. val (TextKey "arch") + on $ gkv_arch ^. GroupKeyValuesGroup_id ==. gkv_rel ^. GroupKeyValuesGroup_id + on $ kv_rel ^. KeyValId ==. gkv_rel ^. GroupKeyValuesKey_val_id &&. + kv_rel ^. KeyValKey_value ==. val (TextKey "release") + on $ gkv_rel ^. GroupKeyValuesGroup_id ==. gkv_ver ^. GroupKeyValuesGroup_id + on $ kv_ver ^. KeyValId ==. gkv_ver ^. GroupKeyValuesKey_val_id &&. + kv_ver ^. KeyValKey_value ==. val (TextKey "version") + on $ gkv_ver ^. GroupKeyValuesGroup_id ==. gkv_name ^. GroupKeyValuesGroup_id + on $ kv_name ^. KeyValId ==. gkv_name ^. GroupKeyValuesKey_val_id &&. + kv_name ^. KeyValKey_value ==. val (TextKey "name") + where_ $ kv_name ^. KeyValVal_value ==. just (val n) &&. + kv_ver ^. KeyValVal_value ==. just (val v) &&. + kv_rel ^. KeyValVal_value ==. just (val r) &&. + kv_arch ^. KeyValVal_value ==. just (val a) &&. + kv_epoch ^. KeyValVal_value ==? e + limit 1 + return $ gkv_name ^. GroupKeyValuesGroup_id diff --git a/src/BDCS/Import/Comps.hs b/src/BDCS/Import/Comps.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Import/Comps.hs @@ -0,0 +1,91 @@ +-- Copyright (C) 2016-2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module BDCS.Import.Comps(CompsPkg(..), + CompsGroup(..), + loadFromURI) + where + +import Control.Monad.Reader(ReaderT) +import Data.Conduit((.|), runConduitRes) +import qualified Data.Text as T +import Network.URI(URI(..)) +import Text.XML(Document, sinkDoc) +import Text.XML.Cursor +import Text.XML.Stream.Parse(def) + +import BDCS.Import.Conduit(getFromURI, ungzipIfCompressed) +import BDCS.Import.State(ImportState) + +data CompsPkg = CPMandatory T.Text + | CPDefault T.Text + | CPOptional T.Text + | CPUnknown T.Text + | T.Text `CPRequires` T.Text + deriving(Show) + +data CompsGroup = CompsGroup T.Text T.Text [CompsPkg] + deriving(Show) + +parseCompsPkg :: Cursor -> [CompsPkg] +parseCompsPkg cursor = do + let tys = cursor $| attribute "type" + let names = cursor $/ content + let reqs = cursor $| attribute' "requires" + + map toCompsPkg (zip3 tys names reqs) + where + -- Like attribute, but returns an empty string instead of an empty list. This is so tys, + -- names, and reqs above are all the same length and the tuples line up. + attribute' n c = case attribute n c of + [] -> [""] + x -> x + + toCompsPkg ("mandatory", n, _) = CPMandatory n + toCompsPkg ("default", n, _) = CPDefault n + toCompsPkg ("optional", n, _) = CPOptional n + toCompsPkg ("conditional", n, "") = CPUnknown n + toCompsPkg ("conditional", n, r) = n `CPRequires` r + -- Shouldn't happen, but this marks them so we'll know there's something to look into. + toCompsPkg (_, n, _) = CPUnknown n + +parseCompsGroup :: Cursor -> CompsGroup +parseCompsGroup cursor = do + let groupIds = cursor $/ laxElement "id" &/ content + let groupNames = cursor $/ laxElement "name" &/ content + let packages = cursor $// laxElement "packagereq" >=> parseCompsPkg + CompsGroup (head groupIds) (head groupNames) packages + +extractGroups :: Document -> [CompsGroup] +extractGroups doc = let + cursor = fromDocument doc + groupCursors = cursor $// laxElement "group" + in + map parseCompsGroup groupCursors + +loadFromURI :: URI -> ReaderT ImportState IO () +loadFromURI uri = do + _groups <- extractGroups <$> runConduitRes (readMetadataPipeline uri) + -- FIXME: For now we don't actually do any loading. There's a lot of questions + -- about how this is going to fit into the database, but I want to make sure this + -- code doesn't get lost. + return () + where + readMetadataPipeline p = getFromURI p .| ungzipIfCompressed .| sinkDoc def diff --git a/src/BDCS/Import/Conduit.hs b/src/BDCS/Import/Conduit.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Import/Conduit.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: BDCS.Import.Conduit +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Utilities for working with 'Conduit's when importing. + +module BDCS.Import.Conduit(getFromURI, + ungzipIfCompressed) + where + +import Conduit(Conduit, Producer, (.|), leftover, sourceFile) +import Control.Monad.Trans.Resource(MonadResource) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Conduit.Binary as CB(take) +import Data.Conduit.Zlib(ungzip) +import Data.Word(Word8) +import Network.HTTP.Simple(getResponseBody, httpSource, parseRequest) +import Network.URI(URI(..)) + +import BDCS.Import.URI(showURI, uriToPath) +import BDCS.Utils.Conduit(identityC) + +-- | Load data from a given file: or http: 'URI' into a 'BS.ByteString'. +getFromURI :: MonadResource m => URI -> Producer m BS.ByteString +getFromURI uri@URI{..} | uriScheme == "file:" = sourceFile $ uriToPath uri + | otherwise = do request <- parseRequest $ showURI uri + httpSource request getResponseBody + +-- | If the 'BS.ByteString' in a 'Conduit' is compressed, pass it through ungzip to +-- uncompress it. Otherwise, pass it through without doing anything. We determine +-- whether a stream is compressed by looking for the gzip magic bytes at the start +-- of the stream. +ungzipIfCompressed :: MonadResource m => Conduit BS.ByteString m BS.ByteString +ungzipIfCompressed = do + magic <- CB.take 2 + let nextPipe = if BSL.unpack magic == gzipMagic then ungzip else identityC + + -- send the two bytes we consumed as a leftover, then continue the conduit + leftover (BSL.toStrict magic) .| nextPipe + nextPipe + where + gzipMagic :: [Word8] + gzipMagic = [0x1f, 0x8b] diff --git a/src/BDCS/Import/NPM.hs b/src/BDCS/Import/NPM.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Import/NPM.hs @@ -0,0 +1,381 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module: BDCS.Import.NPM +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Functions for importing NPM packages into the database + +module BDCS.Import.NPM(loadFromURI) + where + +import Control.Monad(void) +import Control.Monad.Catch(MonadThrow) +import Control.Monad.Except(MonadError, runExceptT, throwError) +import Control.Monad.IO.Class(MonadIO, liftIO) +import Control.Monad.Reader(ReaderT, ask) +import Control.Monad.State(MonadState, get, modify) +import Control.Monad.Trans.Resource(MonadBaseControl, MonadResource) +import Data.Aeson(FromJSON(..), Object, Value(..), (.:), (.:?), (.!=), eitherDecode, withObject, withText) +import Data.Aeson.Types(Parser, typeMismatch) +import Data.Bits((.|.)) +import Data.ByteArray(convert) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as BSL +import Data.Conduit(Conduit, Consumer, ZipConduit(..), (.|), getZipConduit, runConduitRes, toConsumer, yield) +import Data.Conduit.Binary(sinkLbs) +import qualified Data.Conduit.Combinators as CC +import qualified Data.Conduit.List as CL +import Data.Conduit.Lift(evalStateLC) +import qualified Data.Conduit.Tar as CT +import Data.ContentStore(ContentStore, storeByteStringSink) +import Data.ContentStore.Digest(ObjectDigest) +import qualified Data.HashMap.Lazy as HM +import Data.List(isPrefixOf) +import Data.Maybe(fromMaybe) +import qualified Data.Text as T +import Data.Text.Encoding(decodeUtf8) +import Database.Persist.Sql(SqlPersistT) +import Network.URI(URI(..), URIAuth(..), nullURI, parseURI, relativeTo) +import System.FilePath((), makeRelative, normalise, takeDirectory, takeFileName) +import System.Posix.Files(blockSpecialMode, characterSpecialMode, directoryMode, namedPipeMode, regularFileMode, symbolicLinkMode) +import Text.Regex.PCRE((=~)) + +import BDCS.Build.NPM(rebuildNPM) +import BDCS.DB +import BDCS.Files(associateFilesWithSource, insertFiles) +import BDCS.Import.Conduit(getFromURI, ungzipIfCompressed) +import BDCS.Import.State(ImportState(..)) +import BDCS.KeyType +import BDCS.Projects(insertProject) +import BDCS.Sources(insertSource, insertSourceKeyValue) +import BDCS.Utils.Either(whenLeft) +import BDCS.Utils.Monad((>>?)) + +-- base URI for the package.json information +npmRegistry :: URI +npmRegistry = URI {uriScheme = "https:", + uriAuthority = Just URIAuth{uriUserInfo = "", uriRegName = "registry.npmjs.org", uriPort = ""}, + uriPath = "/", + uriQuery = "", + uriFragment = "" } + +-- The data returned by the registry contains a lot of the same things as package.json, +-- but it may not actually match the real data in package.json. The only part we can +-- use is information in the "dist" object. +data PackageDist = PackageDist { + _integrity :: Maybe T.Text, + _shasum :: Maybe T.Text, + tarball :: T.Text } + deriving(Show) + +instance FromJSON PackageDist where + parseJSON = withObject "registry JSON" $ \v -> + case HM.lookup "dist" v of + Nothing -> fail "Missing dist object" + Just (Object d) -> PackageDist <$> d .:? "integrity" + <*> d .:? "shasum" + <*> d .: "tarball" + Just _ -> fail "Dist not an object" + +-- the parts of package.json we care about +data PackageJSON = PackageJSON { + packageName :: T.Text, + packageVersion :: T.Text, + description :: T.Text, + homepage :: Maybe T.Text, + license :: T.Text, + + -- This can show up in package.json in two ways: either as the map of executable + -- names to js paths ("bin" : { "exec1": "./script1.js", "exec2": "./script2.js" }), + -- or as a single string ("bin": "./script1.js"). The single string case should be + -- interpreted as the path to an executable that should be named the same as the name + -- of the package. + bin :: Maybe [(T.Text, T.Text)], + + -- This can appear as either a list of strings or a single string + man :: Maybe [T.Text], + + -- The package.json documentation implies that it is an error to have both bin and + -- directories.bin in package.json. And then npm itself does exactly that. So, what + -- this actually means: + -- + -- * If bin is present, in any form (even if it is empty), it takes + -- precedence and directories.bin is ignored for our purposes + -- * If bin is not present and directories.bin is present, every path in this directory + -- gets symlinked to /usr/bin. Subdirectories gets symlinked too and are not traversed, + -- so if you have /subdir, that gets symlinked as /usr/bin/subdir. + binDirectory :: Maybe T.Text, + + -- Similar to bin, if man is present (even as an empty list), then this is ignored. + -- Subdirectories are traversed. + manDirectory :: Maybe T.Text, + + -- list of packagename, semver pairs + dependencies :: Maybe [(T.Text, T.Text)] } + deriving(Show) + +instance FromJSON PackageJSON where + parseJSON = withObject "package.json" $ \v -> PackageJSON + <$> v .: "name" + <*> v .: "version" + <*> v .:? "description" .!= "" + <*> v .:? "homepage" + <*> v .:? "license" .!= "" + <*> parseBin v + <*> v .:? "man" + <*> parseDirectories v "bin" + <*> parseDirectories v "man" + <*> ((v .:? "dependencies") >>? parseTextObject) + where + -- custom handler for directories.bin and directories.man, to get rid of the intermediate object, + -- and to skip if it's overriden by bin or man. + parseDirectories :: Object -> T.Text -> Parser (Maybe T.Text) + parseDirectories obj key = + if HM.member key obj then return Nothing + else case HM.lookup "directories" obj of + Nothing -> return Nothing + Just (Object v) -> v .:? key + Just err -> typeMismatch "Object" err + + -- parse "bin", which has a mixed type + parseBin :: Object -> Parser (Maybe [(T.Text, T.Text)]) + parseBin obj = do + -- retrieve the name for the String case + name <- (obj .: "name") >>= withText "String" return + + case HM.lookup "bin" obj of + Nothing -> return Nothing + -- list of strings, return as a list of pairs + Just v@(Object _) -> Just <$> parseTextObject v + -- just a String, pair with the package name + Just (String s) -> return $ Just [(name, s)] + Just err -> typeMismatch "Object or String" err + + -- Convert an object that's all "key":"value" pairs to a list of (Text, Text) + parseTextObject :: Value -> Parser [(T.Text, T.Text)] + parseTextObject = withObject "Object" $ HM.foldrWithKey f (return []) + where + f :: T.Text -> Value -> Parser [(T.Text, T.Text)] -> Parser [(T.Text, T.Text)] + f key val acc = withText "String" (\s -> ((key, s):) <$> acc) val + +readRegistryJSON :: (MonadError String m, MonadBaseControl IO m, MonadThrow m, MonadIO m) => String -> m PackageDist +readRegistryJSON pkgname = do + let uri = relativeTo (nullURI {uriPath = pkgname ++ "/latest"}) npmRegistry + jsonData <- runConduitRes $ getFromURI uri .| sinkLbs + either throwError return $ eitherDecode jsonData + +loadIntoMDDB :: MonadIO m => PackageJSON -> [Files] -> SqlPersistT m (Key Sources) +loadIntoMDDB PackageJSON{..} files = do + -- Create the project/source/build entries from the package.json data + -- npm doesn't provide separate descriptions and summaries, so just leave projects.description blank + -- upstream_vcs is usually the same as homepage, but we can't tell automatically so leave that blank too + projectId <- insertProject $ Projects packageName description "" homepage "" + sourceId <- insertSource $ Sources projectId license packageVersion "" + + fileIds <- insertFiles files + void $ associateFilesWithSource fileIds sourceId + + -- load the bin information into the mddb as key/val pairs. /usr/bin symlinks will not be created + -- until export, since there could be multiple versions of a package installed as dependencies and + -- we only want the bin symlinks for the top-level ones. + -- If there is an explicit bin list, that takes precendence, otherwise use directories.bin. + case (bin, binDirectory) of + (Just binlist, _) -> mapM_ (addBin sourceId) binlist + (Nothing, Just binDir) -> addBinDir sourceId binDir + _ -> return () + + -- similar thing for man pages + case (man, manDirectory) of + (Just manList, _) -> mapM_ (addMan sourceId) manList + (Nothing, Just manDir) -> addManDir sourceId manDir + _ -> return () + + -- save the requirements as build key/vals. These are the semver requirement ranges. + -- When the source is "linked" into a build, and from to an exportable group, the semvers + -- will be translated to exact-version requirements and stored in the requirements table. + mapM_ (\(reqname, reqver) -> insertSourceKeyValue (TextKey "dependency") reqname (Just reqver) sourceId) $ + fromMaybe [] dependencies + + -- mark the source as coming from npm + -- TODO figure out a better way to express this kind of thing + void $ insertSourceKeyValue (TextKey "npm") "" Nothing sourceId + + return sourceId + where + normaliseText :: T.Text -> T.Text + normaliseText path = T.pack $ normalise $ T.unpack path + + -- package.json contains "bin", which is a list of (, ) pairs + -- Insert as k=bin, v=, e= + addBin :: MonadIO m => Key Sources -> (T.Text, T.Text) -> SqlPersistT m () + addBin sourceId (binName, path) = void $ insertSourceKeyValue (TextKey "bin") binName (Just (normaliseText path)) sourceId + + -- package.json contains "directories.bin", which means everything in that directory + -- should become a /usr/bin symlink, using the name of the file as the name of the symlink. + -- No recursion, so if there's something like /subdir/subpath, subdir gets a symlink + -- and subpath is otherwise ignored. + -- Create KeyVal values like in addBin, using the filename for v. + addBinDir :: MonadIO m => Key Sources -> T.Text -> SqlPersistT m () + addBinDir sourceId binDir = let + -- normalize out the leading "./" and any other funkiness + binPrefix = normalise (T.unpack binDir) + + -- find paths where the directory component is the same as the prefix + binFiles = filter (\p -> takeDirectory p == binPrefix) $ map (makeRelative "/" . T.unpack . filesPath) files + in + mapM_ (\p -> insertSourceKeyValue (TextKey "bin") (T.pack $ takeFileName p) (Just (T.pack p)) sourceId) binFiles + + addMan :: MonadIO m => Key Sources -> T.Text -> SqlPersistT m () + addMan sourceId manName = void $ insertSourceKeyValue (TextKey "man") (normaliseText manName) Nothing sourceId + + -- Unlike directories.bin, we do need to recurse into this directory + addManDir :: MonadIO m => Key Sources -> T.Text -> SqlPersistT m () + addManDir sourceId manDir = let + manPrefix = normalise (T.unpack manDir) + paths = map (makeRelative "/" . T.unpack . filesPath) files + manFiles = filter (\p -> (manPrefix `isPrefixOf` p) && (p =~ ("\\.[0-9]$" :: String))) paths + in + mapM_ (\p -> insertSourceKeyValue (TextKey "man") (T.pack p) Nothing sourceId) manFiles + +-- | Fetch an NPM from a given 'URI' and load it into the MDDB. This function must be +-- run within the 'ReaderT' monad, which should be given an 'ImportState' record. This +-- is how importing knows where to store the results. Errors will be printed to the +-- screen. +loadFromURI :: URI -> ReaderT ImportState IO () +loadFromURI uri@URI{..} = do + db <- stDB <$> ask + repo <- stRepo <$> ask + + result <- runExceptT $ do + -- Fetch the JSON describing the package + distJson <- readRegistryJSON uriPath + + -- Get the URI to the tarball out of the JSON + let distTarball = T.unpack $ tarball distJson + distURI <- maybe (throwError $ "Error parsing dist URI: " ++ distTarball) return $ parseURI distTarball + + -- conduits for consuming the tar entries: + -- this one loads the content into the content store and returns a list of (uninserted) Files records + let pathPipe = tarEntryToFile repo .| CL.consume + -- this one returns the parsed package.json + let jsonPipe = parsePackageJson + + -- Zip them together into a sink returning a tuple + let tarSink = getZipConduit ((,) <$> ZipConduit pathPipe + <*> ZipConduit jsonPipe) + + -- Import the tarball to the content store + (files, packageJson) <- runConduitRes $ + getFromURI distURI + .| ungzipIfCompressed + .| CT.untar + .| tarSink + + -- Insert the metadata + checkAndRunSqlite (T.pack db) $ do + source <- loadIntoMDDB packageJson files + + -- Link the dependencies for the source + rebuildNPM source + + whenLeft result (\e -> liftIO $ print $ "Error importing " ++ show uri ++ ": " ++ show e) + + where + -- TODO handle TarExceptions + tarEntryToFile :: (MonadError String m, MonadThrow m, MonadResource m) => ContentStore -> Conduit CT.TarChunk m Files + tarEntryToFile cs = + -- Run the tar processing in a state with a map from FilePath to (ObjectDigest, CT.Size), + -- so hardlinks can get the data they need from earlier entries. + evalStateLC HM.empty $ CT.withEntries handleEntry + where + handleEntry :: (MonadState (HM.HashMap FilePath (ObjectDigest, CT.Size)) m, MonadError String m, MonadResource m) => CT.Header -> Conduit BS.ByteString m Files + handleEntry header@CT.Header{..} = do + let entryPath = CT.headerFilePath header + + -- Ignore the mode from tar. Set everything to 0644 if it's a file, 0755 if it's a directory + let modeBits = if CT.headerFileType header == CT.FTDirectory then 0o0755 else 0o0644 + + -- Add the file type bits to the mode based on the tar header type + let typeBits = case CT.headerFileType header of + CT.FTNormal -> regularFileMode + CT.FTHardLink -> regularFileMode + CT.FTSymbolicLink -> symbolicLinkMode + CT.FTCharacterSpecial -> characterSpecialMode + CT.FTBlockSpecial -> blockSpecialMode + CT.FTDirectory -> directoryMode + CT.FTFifo -> namedPipeMode + -- TODO? + CT.FTOther _ -> 0 + + -- Make the start of a Files record. Ignore the user/group/mode from tar + let baseFile = Files{filesPath = T.pack ("/" normalise entryPath), + filesFile_user = "root", + filesFile_group = "root", + filesMtime = fromIntegral headerTime, + filesMode = modeBits .|. fromIntegral typeBits, + filesTarget = Nothing, + filesCs_object = Nothing, + filesSize = 0} + + file <- case CT.headerFileType header of + -- for NormalFile, add the object to the content store, add the digest and size to the state, and add the digest in the record + CT.FTNormal -> handleRegularFile baseFile entryPath headerPayloadSize + -- For hard links, the content is the link target: look it up in the state and fill in the digest and size + CT.FTHardLink -> handleHardLink baseFile + + -- for symlinks, set the target + CT.FTSymbolicLink -> handleSymlink baseFile + + -- TODO? + CT.FTOther code -> throwError $ "Unknown tar entry type " ++ show code + + -- TODO: need somewhere for block/char special major and minor + -- otherwise nothing else has anything special + _ -> return baseFile + + yield file + + handleRegularFile :: (MonadState (HM.HashMap FilePath (ObjectDigest, CT.Size)) m, MonadError String m, MonadResource m) => Files -> FilePath -> CT.Size -> Consumer BS.ByteString m Files + handleRegularFile baseFile entryPath size = do + digest <- toConsumer $ storeByteStringSink cs + modify (HM.insert entryPath (digest, size)) + return $ baseFile {filesSize = fromIntegral size, + filesCs_object = Just $ convert digest} + + handleHardLink :: (MonadState (HM.HashMap FilePath (ObjectDigest, CT.Size)) m, MonadError String m) => Files -> Consumer BS.ByteString m Files + handleHardLink baseFile = do + -- Use the same ByteString -> FilePath unpacking that headerFilePath uses + target <- S8.unpack <$> CC.fold + (HM.lookup target <$> get) >>= + maybe (throwError $ "Broken hard link to " ++ target) + (\(digest, size) -> return $ baseFile {filesSize = fromIntegral size, + filesCs_object = Just $ convert digest}) + + handleSymlink :: Monad m => Files -> Consumer BS.ByteString m Files + handleSymlink baseFile = do + target <- decodeUtf8 <$> CC.fold + return $ baseFile {filesTarget = Just target} + + -- TODO handle TarExceptions + parsePackageJson :: (MonadError String m, MonadThrow m) => Consumer CT.TarChunk m PackageJSON + parsePackageJson = CT.withEntry handler >>= maybe parsePackageJson return + where + handler :: MonadError String m => CT.Header -> Consumer BS.ByteString m (Maybe PackageJSON) + handler header = let + path = makeRelative "/" $ normalise $ CT.headerFilePath header + in + -- Everything in an npm tarball is under "package/" + if path == ("package" "package.json") then + (eitherDecode <$> BSL.fromStrict <$> CC.fold) >>= either throwError (return . Just) + else + return Nothing diff --git a/src/BDCS/Import/RPM.hs b/src/BDCS/Import/RPM.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Import/RPM.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: BDCS.Import.RPM +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Functions for importing individual RPM packages into the database + +module BDCS.Import.RPM(consume, + loadIntoMDDB, + loadFromURI, + rpmExistsInMDDB) + where + +import Codec.RPM.Conduit(parseRPMC, payloadContentsC) +import Codec.RPM.Tags +import Codec.RPM.Types +import Control.Conditional(ifM) +import Control.Exception(evaluate, tryJust) +import Control.Monad(guard, void) +import Control.Monad.Except +import Control.Monad.IO.Class(liftIO) +import Control.Monad.Reader(ReaderT, ask) +import Control.Monad.Trans(lift) +import Control.Monad.Trans.Control(MonadBaseControl) +import Control.Monad.Trans.Resource(MonadResource, MonadThrow) +import qualified Data.ByteString.Char8 as C8 +import Data.CPIO(Entry(..)) +import Data.Conduit((.|), Conduit, Consumer, ZipConduit(..), await, awaitForever, mapOutput, runConduit, runConduitRes, transPipe, yield) +import Data.Conduit.Combinators(sinkList) +import qualified Data.Conduit.List as CL +import Data.ContentStore(ContentStore, CsError(..), runCsMonad, storeLazyByteStringC) +import Data.ContentStore.Digest(ObjectDigest) +import Database.Esqueleto +import Data.Foldable(toList) +import qualified Data.Text as T +import Data.Text.Encoding(decodeUtf8) +import Network.URI(URI(..)) +import System.Posix.Files(fileTypeModes, intersectFileModes, regularFileMode) + +import BDCS.Builds(associateBuildWithPackage, insertBuild) +import BDCS.DB +import BDCS.Exceptions(DBException(..), isMissingRPMTagException, throwIfNothing) +import BDCS.Files(associateFilesWithBuild, associateFilesWithPackage, insertFiles) +import BDCS.Import.Conduit(getFromURI) +import BDCS.Import.State(ImportState(..)) +import BDCS.Label.FileLabels(apply) +import BDCS.Packages(insertPackageName) +import BDCS.Projects(insertProject) +import BDCS.RPM.Builds(mkBuild) +import BDCS.RPM.Files(mkFiles) +import BDCS.RPM.Groups(createGroup) +import BDCS.RPM.Projects(mkProject) +import BDCS.RPM.Signatures(mkRSASignature, mkSHASignature) +import BDCS.RPM.Sources(mkSource) +import BDCS.Signatures(insertBuildSignatures) +import BDCS.Sources(insertSource) +import BDCS.Utils.Error(mapError) + +#ifdef SCRIPTS +import BDCS.RPM.Scripts(mkScripts, mkTriggerScripts) +import BDCS.Scripts(insertScript) +#endif + +buildImported :: MonadResource m => [Tag] -> SqlPersistT m Bool +buildImported sigs = + case findStringTag "SHA1Header" sigs of + Just sha -> do ndx <- select $ from $ \signatures -> do + where_ $ signatures ^. BuildSignaturesSignature_type ==. val "SHA1" &&. + signatures ^. BuildSignaturesSignature_data ==. val (C8.pack sha) + return $ signatures ^. BuildSignaturesId + return $ not $ null ndx + Nothing -> return False + +-- | A conduit consumer that takes in RPM data and stores its payload into the content store and its header +-- information into the mddb. The return value is whether or not an import occurred. This is not the +-- same as success vs. failure. On failures, a 'CsError' will be thrown. If the package already exists +-- in the database, this function will return False. +consume :: (MonadBaseControl IO m, MonadIO m, MonadThrow m, MonadError CsError m) => ContentStore -> FilePath -> Consumer RPM m Bool +consume repo db = await >>= \case + Just rpm -> + lift (runExceptT $ checkAndRunSqlite (T.pack db) (rpmExistsInMDDB rpm)) >>= \case + Left e -> throwError (CsError $ show e) + Right True -> return False + Right False -> unsafeConsume repo db rpm + Nothing -> return False + +-- Like consume, but does not first check to see if the RPM has previously been imported. Running +-- this could result in a very confused, incorrect mddb. It is currently for internal use only, +-- but that might change in the future. If so, its type should also change to be a Consumer. +unsafeConsume :: (MonadIO m, MonadBaseControl IO m, MonadThrow m, MonadError CsError m) => ContentStore -> FilePath -> RPM -> Consumer RPM m Bool +unsafeConsume repo db rpm = do + -- One source that takes an RPM, extracts its payload, and decompresses it. + let src = yield rpm .| payloadContentsC + -- The first conduit just extracts filenames out of each cpio entry. cpio puts a leading . on + -- each filename, but the RPM headers do not have that. Thus, we trim it out so the paths look + -- the same. + filenames = CL.map (T.dropWhile (== '.') . decodeUtf8 . cpioFileName) .| sinkList + -- The second conduit extracts each file from a cpio entry, stores it in the content store, + -- and returns its digest. + digests = maybeStore .| sinkList + + -- And then those two conduits run in parallel and the results are packaged up together so + -- we have filenames and their digests matched up. + result <- liftIO $ runCsMonad $ runConduit $ src + .| getZipConduit ((,) <$> ZipConduit filenames + <*> ZipConduit digests) + + -- checksums comes back as a ([filename], [digest]). We need to turn that around + -- to be [(filename, digest]). + checksums <- either throwError (return . uncurry zip) result + + lift (runExceptT $ checkAndRunSqlite (T.pack db) (loadIntoMDDB rpm checksums)) >>= \case + Left e -> throwError (CsError $ show e) + Right v -> return v + where + maybeStore :: (MonadResource m, MonadError CsError m) => Conduit Entry m (Maybe ObjectDigest) + maybeStore = awaitForever $ \Entry{..} -> + -- Only store regular files in the content store + -- Checking the type is more complicated then you'd think it should be, because + -- the type mode is more than just one bit. e.g., regular == 100000, symlink == 120000 + if fromIntegral cpioMode `intersectFileModes` fileTypeModes == regularFileMode then + mapOutput Just $ yield cpioFileData .| storeLazyByteStringC repo + else + yield Nothing + +-- | Load the headers from a parsed RPM into the MDDB. The return value is whether or not an import +-- occurred. This is not the same as success vs. failure. If the package already exists in the +-- database, this function will return False. +loadIntoMDDB :: (MonadBaseControl IO m, MonadResource m) => RPM -> [(T.Text, Maybe ObjectDigest)] -> SqlPersistT m Bool +loadIntoMDDB rpm checksums = + ifM (rpmExistsInMDDB rpm) + (return False) + (unsafeLoadIntoMDDB rpm checksums) + +-- Like loadIntoMDDB, but does not first check to see if the RPM has previously been imported. Running +-- this could result in a very confused, incorrect mddb. It is currently for internal use only, but +-- that might change in the future. +unsafeLoadIntoMDDB :: (MonadBaseControl IO m, MonadResource m) => RPM -> [(T.Text, Maybe ObjectDigest)] -> SqlPersistT m Bool +unsafeLoadIntoMDDB RPM{..} checksums = do + let sigHeaders = headerTags $ head rpmSignatures + let tagHeaders = headerTags $ head rpmHeaders + + projectId <- insertProject $ mkProject tagHeaders + sourceId <- insertSource $ mkSource tagHeaders projectId + buildId <- insertBuild $ mkBuild tagHeaders sourceId + + -- Ignore missing tag errors from mkRSASignature, it just means the RPM is unsigned + -- toList <$> tryJust will convert the result to [BuildSignatures], either containing one record on + -- success or an empty list on error. + rsaSignature <- liftIO $ toList <$> tryJust (guard . isMissingRPMTagException) (evaluate $ mkRSASignature sigHeaders buildId) + void $ insertBuildSignatures (mkSHASignature sigHeaders buildId:rsaSignature) + + pkgNameId <- insertPackageName $ T.pack $ findStringTag "Name" tagHeaders `throwIfNothing` MissingRPMTag "Name" + + files <- mkFiles tagHeaders checksums + filesIds <- insertFiles files + + -- Pair up files with their IDs in the Files table. Then use this mapping to add all the + -- various file-based labels to the KeyVal table. + void $ apply (zip files filesIds) + + void $ associateFilesWithBuild filesIds buildId + void $ associateFilesWithPackage filesIds pkgNameId + void $ associateBuildWithPackage buildId pkgNameId + +#ifdef SCRIPTS + -- groups and reqs + groupId <- createGroup filesIds tagHeaders + + -- scripts - These are here temporarily, just so we can figure out how widely they are + -- used. Once we are done, they are going away. + mapM_ (insertScript groupId) (mkScripts tagHeaders ++ mkTriggerScripts tagHeaders) +#else + void $ createGroup filesIds tagHeaders +#endif + + return True + +-- | Fetch an RPM from a given 'URI' and load it into the MDDB. This function must be +-- run within the 'ReaderT' monad, which should be given an 'ImportState' record. This +-- is how importing knows where to store the results. Errors will be printed to the +-- screen. +loadFromURI :: URI -> ReaderT ImportState IO () +loadFromURI uri = do + db <- stDB <$> ask + repo <- stRepo <$> ask + + result <- runExceptT $ runConduitRes $ + getFromURI uri + .| transPipe (mapError showParseError) parseRPMC + .| transPipe (mapError showCsError) (consume repo db) + + case result of + Left e -> liftIO $ putStrLn e + Right True -> liftIO $ putStrLn $ "Imported " ++ uriPath uri + _ -> return () + + where + showParseError e = "Error fetching " ++ uriPath uri ++ ": " ++ show e + showCsError e = "Error importing " ++ uriPath uri ++ ": " ++ show e + +-- | Query the MDDB to see if the package has already been imported. If so, quit now to prevent it +-- from being added to the content store a second time. Note that 'loadIntoMDDB' also performs this +-- check, but both of these functions are public and therefore both need to prevent duplicate imports. +rpmExistsInMDDB :: MonadResource m => RPM -> SqlPersistT m Bool +rpmExistsInMDDB RPM{..} = do + let sigHeaders = headerTags $ head rpmSignatures + buildImported sigHeaders diff --git a/src/BDCS/Import/Repodata.hs b/src/BDCS/Import/Repodata.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Import/Repodata.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module: BDCS.Import.Repodata +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Functions for importing RPM packages from a repo into the database + +module BDCS.Import.Repodata(RepoException, + loadFromURI, + loadRepoFromURI) + where + +import Control.Applicative((<|>)) +import Control.Exception(Exception) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader(ReaderT) +import Control.Monad.Trans.Resource(MonadBaseControl, MonadThrow) +import Data.Conduit((.|), runConduitRes) +import Data.Data(Typeable) +import Data.Maybe(listToMaybe) +import qualified Data.Text as T +import Network.URI(URI(..)) +import Text.XML(Document, sinkDoc) +import Text.XML.Cursor +import Text.XML.Stream.Parse(def) + +import BDCS.Exceptions(throwIfNothing) +import qualified BDCS.Import.Comps as Comps +import BDCS.Import.Conduit(getFromURI, ungzipIfCompressed) +import qualified BDCS.Import.RPM as RPM +import BDCS.Import.State(ImportState(..)) +import BDCS.Import.URI(appendURI, baseURI) + +-- | An exception type that is thrown when there is a problem accessing a package +-- repository or processing its metadata. +data RepoException = RepoException + deriving(Show, Typeable) + +instance Exception RepoException + +extractLocations :: Document -> [T.Text] +extractLocations doc = let + cursor = fromDocument doc + in + -- Find all elements and return the href's value. laxElement + -- means we ignore case and ignore namespacing. Otherwise we need to take into + -- account the namespace given in the primary.xml. + cursor $// laxElement "location" + >=> hasAttribute "href" + >=> attribute "href" + +-- For a given datatype name, return the first //data[@type=]/@href +extractType :: Document -> T.Text -> Maybe T.Text +extractType doc dataType = let + cursor = fromDocument doc + in + listToMaybe $ cursor $/ laxElement "data" >=> + attributeIs "type" dataType &/ + laxElement "location" >=> + attribute "href" + +-- fetch and parse an XML document +fetchAndParse :: (MonadThrow m, MonadIO m, MonadBaseControl IO m) => URI -> m Document +fetchAndParse uri = runConduitRes $ getFromURI uri .| ungzipIfCompressed .| sinkDoc def + +addSlash :: URI -> URI +addSlash u = let + path = uriPath u + in + if last path /= '/' then + u { uriPath = path ++ "/" } + else + u + +-- | Given the 'URI' to the base of some package repository, fetch its repo metadata and load +-- all its RPMs into the MDDB. This function must be run within the 'ReaderT' monad, which +-- should be given an 'ImportState' record. This is how importing knows where to store the +-- results. If the repo metadata data is invalid, a 'RepoException' will be thrown. Other +-- errors will be printed to the screen. +loadRepoFromURI :: URI -> ReaderT ImportState IO () +loadRepoFromURI uri = do + -- Fetch and parse repomd.xml + repomd <- fetchAndParse (appendOrThrow "repodata/repomd.xml") + + -- Import primary.xml + let primary = extractType repomd "primary" `throwIfNothing` RepoException + loadFromURI $ appendOrThrow primary + + -- Import comps if it exists + -- Try group_gz, then group. If neither exists group will be Nothing, which is fine, just skip it + let group = extractType repomd "group_gz" <|> extractType repomd "group" + let groupURI = fmap appendOrThrow group + case groupURI of + Just u -> Comps.loadFromURI u + Nothing -> return () + + where + appendOrThrow :: T.Text -> URI + appendOrThrow path = appendURI (addSlash uri) (T.unpack path) `throwIfNothing` RepoException + +-- | Given the 'URI' to a primary.xml file in some package repository, load all its RPMs +-- into the MDDB. This function must be run within the 'ReaderT' monad, which should be +-- given an 'ImportState' record. This is how importing knows where to store the results. +-- If the repo metadata data is invalid, a 'RepoException' will be thrown. Other errors +-- will be printed to the screen. +loadFromURI :: URI -> ReaderT ImportState IO () +loadFromURI metadataURI = do + document <- fetchAndParse metadataURI + let locations = map appendOrThrow $ extractLocations document + mapM_ RPM.loadFromURI locations + where + appendOrThrow :: T.Text -> URI + appendOrThrow path = appendURI (baseURI metadataURI) (T.unpack path) `throwIfNothing` RepoException diff --git a/src/BDCS/Import/State.hs b/src/BDCS/Import/State.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Import/State.hs @@ -0,0 +1,21 @@ +-- | +-- Module: BDCS.Import.State +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Types needed to maintain state when importing objects. + +module BDCS.Import.State(ImportState(..)) + where + +import Data.ContentStore(ContentStore) + +-- | The state record. This is helpful for keeping track of various pieces of +-- global data when importing objects. +data ImportState = ImportState { stDB :: FilePath, -- ^ The metadata database + stRepo :: ContentStore -- ^ The opened, initialized content store + } diff --git a/src/BDCS/Import/URI.hs b/src/BDCS/Import/URI.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Import/URI.hs @@ -0,0 +1,60 @@ +-- | +-- Module: BDCS.Import.URI +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Utilities for manipulating 'URI's during import. + +module BDCS.Import.URI(appendURI, + baseURI, + isCompsFile, + isPrimaryXMLFile, + showURI, + uriToPath) + where + +import Data.List(isInfixOf, isSuffixOf) +import Data.Maybe(fromJust) +import Network.URI(URI(..), escapeURIString, isUnescapedInURI, + parseURIReference, pathSegments, relativeTo, unEscapeString, uriToString) + +-- | Convert a file:// 'URI' to a 'FilePath'. +-- This does not check that the URI is a file:// URI, assumes posix-style paths +uriToPath :: URI -> FilePath +uriToPath uri = unEscapeString $ uriPath uri + +-- | Go up one directory in the 'URI'. For instance: +-- > ghci> let uri = parseURI "file:///path/to/repo/repodata/primary.xml" +-- > ghci> baseURI (fromJust uri) +-- > file:///path/to/repo/ +baseURI :: URI -> URI +baseURI uri = let upOne = fromJust $ parseURIReference ".." in + relativeTo upOne uri + +-- | Append a path to a 'URI'. +appendURI :: URI -> String -> Maybe URI +appendURI base path = let + -- Escape the path characters and create a URI reference + relativeURI = parseURIReference $ escapeURIString isUnescapedInURI path + appendToBase = (`relativeTo` base) + in + fmap appendToBase relativeURI + +-- | Convert a URI to string with no obfuscation +showURI :: URI -> String +showURI uri = uriToString id uri "" + +-- | Does a 'URI' point to a comps.xml file? This is only really useful when importing RPMs from +-- a comps file, as shipped by RPM-based distributions. +isCompsFile :: URI -> Bool +isCompsFile uri = let path = last (pathSegments uri) in + "-comps" `isInfixOf` path && (".xml" `isSuffixOf` path || ".xml.gz" `isSuffixOf` path) + +-- | Does a 'URI' point to a primary.xml file? This is only really useful when importing RPMs from +-- a repo in an RPM-based distribution. +isPrimaryXMLFile :: URI -> Bool +isPrimaryXMLFile uri = "primary.xml" `isInfixOf` last (pathSegments uri) diff --git a/src/BDCS/KeyType.hs b/src/BDCS/KeyType.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/KeyType.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module: BDCS.ReqType +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Data types for working with the key in a 'BDCS.DB.KeyVal'. + +module BDCS.KeyType(KeyType(..), + asText) + where + +import Database.Persist.TH +import Data.Aeson(ToJSON, toJSON) +import qualified Data.Text as T + +import qualified BDCS.Label.Types as Label + +-- | The 'BDCS.DB.KeyVal' record features a namespaced key, allowing multiple types of keys +-- to exist and be managed in the same database. This type allows differentiation of the +-- multiple kinds of keys. +data KeyType = LabelKey Label.Label -- ^ A key allowing only pre-defined labels to be appplied. + | TextKey T.Text -- ^ Ordinary text key + deriving(Eq, Read, Show) + +derivePersistField "KeyType" + +instance ToJSON KeyType where + toJSON (TextKey t) = toJSON t + toJSON (LabelKey l) = toJSON l + +-- | Convert a 'KeyType' into 'Data.Text.Text' +asText :: KeyType -> T.Text +asText (LabelKey l) = T.pack $ show l +asText (TextKey t) = t diff --git a/src/BDCS/KeyValue.hs b/src/BDCS/KeyValue.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/KeyValue.hs @@ -0,0 +1,96 @@ +-- Copyright (C) 2016 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module BDCS.KeyValue(findKeyValue, + formatKeyValue, + getKeyValue, + insertKeyValue, + keyValueListToJSON) + where + +import Control.Monad.IO.Class(MonadIO) +import Data.Aeson((.=), object, toJSON) +import Data.Aeson.Types(KeyValue) +import Data.List(partition) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Database.Esqueleto + +import BDCS.DB +import BDCS.KeyType + +findKeyValue :: MonadIO m => KeyType -> Maybe T.Text -> Maybe T.Text -> SqlPersistT m (Maybe (Key KeyVal)) +findKeyValue k v e = firstKeyResult $ + select $ from $ \kv -> do + where_ $ kv ^. KeyValKey_value ==. val k &&. + kv ^. KeyValVal_value ==? v &&. + kv ^. KeyValExt_value ==? e + limit 1 + return $ kv ^. KeyValId + +formatKeyValue :: KeyVal -> T.Text +formatKeyValue KeyVal{..} = let + rhs = case (keyValVal_value, keyValExt_value) of + (Just v, Nothing) -> T.concat [ " = ", v ] + (Just v, Just e) -> T.concat [ " = (", v, ", ", e, ")" ] + _ -> "" + in + T.concat [ T.pack $ show keyValKey_value, rhs ] + +getKeyValue :: MonadIO m => Key KeyVal -> SqlPersistT m (Maybe KeyVal) +getKeyValue key = firstEntityResult $ + select $ from $ \kv -> do + where_ $ kv ^. KeyValId ==. val key + limit 1 + return kv + +insertKeyValue :: MonadIO m => KeyType -> Maybe T.Text -> Maybe T.Text -> SqlPersistT m (Key KeyVal) +insertKeyValue k v e = + insert (KeyVal k v e) + +keyValueListToJSON :: KeyValue t => [KeyVal] -> [t] +keyValueListToJSON lst = let + isLabelKey (LabelKey _) = True + isLabelKey _ = False + + -- We want to handle LabelKeys differently from all other KeyTypes, so first let's sort them out. + (labelKvs, otherKvs) = partition (isLabelKey . keyValKey_value) lst + + -- Convert LabelKeys into tuples of ("labels", json). All LabelKeys will have the same first value + -- in their tuple - the string "labels". This assumes that LabelKeys do not store values or extended + -- values. If they start doing that, this will have to change. + labelVals = map (\kv -> (T.pack "labels", [toJSON $ keyValKey_value kv])) labelKvs + + -- Convert all other KeyTypes into tuples of (key, json). + otherVals = map (\kv -> (asText $ keyValKey_value kv, [toJSON kv])) otherKvs + + -- A single list can have many KeyVals with the same key (think about rpm-provides and requires + -- especially). We use an intermediate map to turn it into a list of (key, [json1, json2, ...]) tuples. + -- Both types get handled the same way here. + labelMap = Map.fromListWith (++) labelVals + otherMap = Map.fromListWith (++) otherVals + + -- If there's only one KeyVal for a given key, strip the list out before converting it to a + -- json list object. Otherwise, everything will end up in a list. + -- + -- On the other hand, we don't do anything to LabelKeys. This means labels will always end up + -- in a list named "labels". + pairs = map (\(k, v) -> if length v == 1 then k .= head v else k .= v) (Map.toList otherMap) ++ + map (uncurry (.=)) (Map.toList labelMap) + in + [T.pack "keyvals" .= object pairs] diff --git a/src/BDCS/Label/Docs.hs b/src/BDCS/Label/Docs.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Label/Docs.hs @@ -0,0 +1,34 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module BDCS.Label.Docs(matches, + mkLabel) + where + +import qualified Data.Text as T + +import BDCS.DB(Files(..)) +import BDCS.Label.Types(Label(..)) + +matches :: Files -> Bool +matches Files{..} = + -- FIXME: Are man pages and info pages also documentation? They certainly could be. + "/usr/share/doc/" `T.isPrefixOf` filesPath + +mkLabel :: Files -> Maybe Label +mkLabel _ = Just DocsLabel diff --git a/src/BDCS/Label/FileLabels.hs b/src/BDCS/Label/FileLabels.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Label/FileLabels.hs @@ -0,0 +1,63 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +module BDCS.Label.FileLabels(apply) + where + +import Control.Monad.IO.Class(MonadIO) +import Database.Esqueleto(Key, SqlPersistT) +import Data.Maybe(mapMaybe) + +import BDCS.DB(Files(..), FileKeyValues(..)) +import qualified BDCS.Label.Docs as Docs +import qualified BDCS.Label.Fonts as Fonts +import qualified BDCS.Label.InfoPage as Info +import qualified BDCS.Label.Library as Library +import qualified BDCS.Label.License as License +import qualified BDCS.Label.ManPage as Man +import qualified BDCS.Label.Service as Service +import qualified BDCS.Label.Translation as Xlat +import BDCS.Label.Types(Label(..)) +import BDCS.Label.Utils(addLabelKey) +import BDCS.Utils.Monad(concatForM) + +checks :: [(Files -> Bool, Files -> Maybe Label)] +checks = [(Docs.matches, Docs.mkLabel), + (Fonts.matches, Fonts.mkLabel), + (Info.matches, Info.mkLabel), + (License.matches, License.mkLabel), + (Library.matches, Library.mkLabel), + (Man.matches, Man.mkLabel), + (Service.matches, Service.mkLabel), + (Xlat.matches, Xlat.mkLabel)] + +apply :: MonadIO m => [(Files, Key Files)] -> SqlPersistT m [Key FileKeyValues] +apply lst = + -- Iterate over all the given files. + concatForM lst $ \(f, ndx) -> do + -- Gather up all the tuples from the checks list where the + -- file met the matching criteria. + let successfulChecks = filter (\(matches, _) -> matches f) checks + + -- Try to run the maker function from each of those tuples. + -- It's possible for the maker function to return Nothing + -- (though I don't know how that could happen right now), + -- so we need to filter those out. + let labels = mapMaybe (\(_, maker) -> maker f) successfulChecks + + -- Now add each of those labels to the database, collecting + -- the resulting IDs. + mapM (\lbl -> addLabelKey ndx lbl Nothing Nothing) + labels diff --git a/src/BDCS/Label/Fonts.hs b/src/BDCS/Label/Fonts.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Label/Fonts.hs @@ -0,0 +1,39 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module BDCS.Label.Fonts(matches, + mkLabel) + where + +import Data.List(isPrefixOf, isSuffixOf) +import qualified Data.Text as T +import System.FilePath.Posix(takeFileName) + +import BDCS.DB(Files(..)) +import BDCS.Label.Types(Label(..)) + +matches :: Files -> Bool +matches Files{..} = let + filesPath' = T.unpack filesPath + fn = takeFileName filesPath' + in + ("/usr/share/fonts/" `isPrefixOf` filesPath' && fn `notElem` ["encodings.dir", "donts.dir", "fonts.scale"] && not ("fonts.cache" `isPrefixOf` fn)) || + ("/usr/share/X11/fonts/" `isPrefixOf` filesPath' && ".gz" `isSuffixOf` fn) + +mkLabel :: Files -> Maybe Label +mkLabel _ = Just FontsLabel diff --git a/src/BDCS/Label/InfoPage.hs b/src/BDCS/Label/InfoPage.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Label/InfoPage.hs @@ -0,0 +1,37 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE RecordWildCards #-} + +module BDCS.Label.InfoPage(matches, + mkLabel) + where + +import Data.List(isPrefixOf, isSuffixOf) +import qualified Data.Text as T +import Text.Regex.PCRE((=~)) + +import BDCS.DB(Files(..)) +import BDCS.Label.Types(Label(..)) + +matches :: Files -> Bool +matches Files{..} = let + filesPath' = T.unpack filesPath + in + "/usr/share/info/" `isPrefixOf` filesPath' && + (".info.gz" `isSuffixOf` filesPath' || filesPath' =~ "\\.info-[0-9]+\\.gz") + +mkLabel :: Files -> Maybe Label +mkLabel _ = Just InfoPageLabel diff --git a/src/BDCS/Label/Library.hs b/src/BDCS/Label/Library.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Label/Library.hs @@ -0,0 +1,34 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module BDCS.Label.Library(matches, + mkLabel) + where + +import qualified Data.Text as T + +import BDCS.DB(Files(..)) +import BDCS.Label.Types(Label(..)) + +matches :: Files -> Bool +matches Files{..} = + ("/lib/" `T.isInfixOf` filesPath || "/lib64/" `T.isInfixOf` filesPath) && + (".so" `T.isSuffixOf` filesPath || ".so." `T.isInfixOf` filesPath || ".a" `T.isSuffixOf` filesPath) + +mkLabel :: Files -> Maybe Label +mkLabel _ = Just LibraryLabel diff --git a/src/BDCS/Label/License.hs b/src/BDCS/Label/License.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Label/License.hs @@ -0,0 +1,49 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE RecordWildCards #-} + +module BDCS.Label.License(matches, + mkLabel) + where + +import Data.Char(toUpper) +import Data.List(isPrefixOf) +import qualified Data.Text as T +import System.FilePath.Posix(takeFileName) + +import BDCS.DB(Files(..)) +import BDCS.Label.Types(Label(..)) + +feq :: FilePath -> String -> Bool +feq path s = let + path' = map toUpper path + sDot = s ++ "." + sDash = s ++ "-" + in + path' == s || + sDot `isPrefixOf` path || + sDash `isPrefixOf` path + +matches :: Files -> Bool +matches Files{..} = let + filesPath' = T.unpack filesPath + fn = takeFileName filesPath' + in + "/usr/share/licenses/" `isPrefixOf` filesPath' || + feq fn "COPYING" || feq fn "COPYRIGHT" || feq fn "LICENSE" + +mkLabel :: Files -> Maybe Label +mkLabel _ = Just LicenseLabel diff --git a/src/BDCS/Label/ManPage.hs b/src/BDCS/Label/ManPage.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Label/ManPage.hs @@ -0,0 +1,37 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE RecordWildCards #-} + +module BDCS.Label.ManPage(matches, + mkLabel) + where + +import Data.List(isPrefixOf) +import qualified Data.Text as T +import Text.Regex.PCRE((=~)) + +import BDCS.DB(Files(..)) +import BDCS.Label.Types(Label(..)) + +matches :: Files -> Bool +matches Files{..} = let + filesPath' = T.unpack filesPath + in + "/usr/share/man/" `isPrefixOf` filesPath' && + (filesPath' =~ "\\.[0-9]$" || filesPath' =~ "\\.[0-9]\\.gz$") + +mkLabel :: Files -> Maybe Label +mkLabel _ = Just ManPageLabel diff --git a/src/BDCS/Label/Service.hs b/src/BDCS/Label/Service.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Label/Service.hs @@ -0,0 +1,34 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module BDCS.Label.Service(matches, + mkLabel) + where + +import qualified Data.Text as T +import System.FilePath.Posix(takeExtension) + +import BDCS.DB(Files(..)) +import BDCS.Label.Types(Label(..)) + +matches :: Files -> Bool +matches Files{..} = + takeExtension (T.unpack filesPath) == ".service" + +mkLabel :: Files -> Maybe Label +mkLabel _ = Just ServiceLabel diff --git a/src/BDCS/Label/Translation.hs b/src/BDCS/Label/Translation.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Label/Translation.hs @@ -0,0 +1,36 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module BDCS.Label.Translation(matches, + mkLabel) + where + +import qualified Data.Text as T + +import BDCS.DB(Files(..)) +import BDCS.Label.Types(Label(..)) + +matches :: Files -> Bool +matches Files{..} = + "/usr/share/locale/" `T.isPrefixOf` filesPath && + ".mo" `T.isSuffixOf` filesPath + +mkLabel :: Files -> Maybe Label +mkLabel Files{..} = + T.stripPrefix "/usr/share/locale/" filesPath >>= \rest -> + Just $ TranslationLabel $ T.takeWhile (/= '/') rest diff --git a/src/BDCS/Label/Types.hs b/src/BDCS/Label/Types.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Label/Types.hs @@ -0,0 +1,53 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module BDCS.Label.Types(Label(..), + labelDescriptions) + where + +import Data.Aeson((.=), ToJSON, object, toJSON) +import qualified Data.Text as T +import Database.Persist.TH + +data Label = DocsLabel + | FontsLabel + | InfoPageLabel + | LibraryLabel + | LicenseLabel + | ManPageLabel + | ServiceLabel + | TranslationLabel T.Text + deriving(Eq, Read, Show) + +instance ToJSON Label where + toJSON (TranslationLabel lang) = object ["TranslationLabel" .= toJSON lang] + toJSON lbl = toJSON $ T.pack $ show lbl + +derivePersistField "Label" + +labelDescriptions :: [(String, String)] +labelDescriptions = [ + ("DocsLabel", "Documentation - mostly things in /usr/share/doc"), + ("FontsLabel", "Fonts"), + ("InfoPageLabel", "GNU info pages"), + ("LibraryLabel", "Static and shared libraries"), + ("LicenseLabel", "Files containing a software license"), + ("ManPageLabel", "man pages"), + ("ServiceLabel", "systemd .service files"), + ("TranslationLabel", "Translations - takes a language code as argument") + ] diff --git a/src/BDCS/Label/Utils.hs b/src/BDCS/Label/Utils.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Label/Utils.hs @@ -0,0 +1,32 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +module BDCS.Label.Utils(addLabelKey) + where + +import Control.Monad.IO.Class(MonadIO) +import qualified Data.Text as T +import Database.Esqueleto(Key, SqlPersistT, insert) + +import BDCS.DB(Files, FileKeyValues(..), maybeKey) +import BDCS.KeyValue(findKeyValue, insertKeyValue) +import BDCS.KeyType(KeyType(..)) +import BDCS.Label.Types(Label) + +addLabelKey :: MonadIO m => Key Files -> Label -> Maybe T.Text -> Maybe T.Text -> SqlPersistT m (Key FileKeyValues) +addLabelKey fileId k v e = + maybeKey (insertKeyValue (LabelKey k) v e >>= \kvId -> insert $ FileKeyValues fileId kvId) + (insert . FileKeyValues fileId) + (findKeyValue (LabelKey k) v e) diff --git a/src/BDCS/NPM/SemVer.hs b/src/BDCS/NPM/SemVer.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/NPM/SemVer.hs @@ -0,0 +1,470 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module BDCS.NPM.SemVer(SemVer(..), + SemVerIdentifier(..), + SemVerRangePart, + SemVerRange, + SemVerRangeSet, + parseSemVer, + parseSemVerRangeSet, + satisfies, + toText) + where + +import Control.Monad(void) +import Data.Char(isAsciiLower, isAsciiUpper, isDigit) +import Data.List(intersperse) +import Data.Monoid((<>)) +import qualified Data.Text as T +import Text.Parsec +import Text.Parsec.Error(Message(..), newErrorMessage) +import Text.Parsec.Pos(initialPos) +import Text.Parsec.Text(Parser) + +-- why not use the semver package? +-- As of semver-0.3.3.1, the following problem exists: +-- let v = version 1 2 3 [] [] +-- in compare v v == GT +-- +-- once that gets fixed, we can maybe use it. +-- Another potential issue is that the integer type used for major/minor/patch (Int) +-- is more restricted than what javascript's semver allows + +-- | A Semantic version, as defined by http://semver.org/ +data SemVer = SemVer { major :: Integer, + minor :: Integer, + patch :: Integer, + preRelease :: [SemVerIdentifier], + buildMeta :: [SemVerIdentifier] + } deriving (Eq, Show) + +instance Ord SemVer where + compare v1 v2 = major v1 `compare` major v2 <> + minor v1 `compare` minor v2 <> + patch v1 `compare` patch v2 <> + comparePreRelease (preRelease v1) (preRelease v2) + where + -- An empty pre-release is greater than a non-empty pre-releases. + -- If both versions have a pre-release, the comparison is the same as for 'List': + -- compare each element, the first one with a greater element wins, otherwise longer list is greater + comparePreRelease :: [SemVerIdentifier] -> [SemVerIdentifier] -> Ordering + comparePreRelease [] (_:_) = GT + comparePreRelease (_:_) [] = LT + comparePreRelease l1 l2 = l1 `compare` l2 + +-- | a component of a pre-release or buildmeta identifier list +data SemVerIdentifier = NumericIdentifier Integer + | TextIdentifier T.Text + deriving(Eq, Show) + +instance Ord SemVerIdentifier where + -- numeric identifiers are less than text identifiers + compare (NumericIdentifier _) (TextIdentifier _) = LT + compare (TextIdentifier _) (NumericIdentifier _) = GT + compare (NumericIdentifier n1) (NumericIdentifier n2) = n1 `compare` n2 + compare (TextIdentifier t1) (TextIdentifier t2) = t1 `compare` t2 + +-- | Parse a semantic version +parseSemVer :: T.Text -> Either ParseError SemVer +-- reuse the PartialSemVer parser and reject wildcards +parseSemVer input = case parse justPartialParsec "" input of + Left e -> Left e + Right PartialSemVer{partialMajor=Just major, + partialMinor=Just minor, + partialPatch=Just patch, + ..} -> Right $ SemVer major minor patch partialPreReleaseTags partialBuildMeta + Right _ -> Left $ newErrorMessage (Message "Wildcards not permitted in SemVer") (initialPos "") + where + justPartialParsec :: Parser PartialSemVer + justPartialParsec = do + p <- partialParsec + eof + return p + +initialVer :: SemVer +initialVer = SemVer 0 0 0 [] [] + +-- | A single version condition, e.g. >= 1.0.0. +-- To satisfy the condition, a 'SemVer' must match at least one of +-- the 'Ordering's. +type SemVerRangePart = [(Ordering, SemVer)] + +-- | A range of semantic versions. To satisfy the range, a 'SemVer' must +-- satisfy every element of the list. +type SemVerRange = [SemVerRangePart] + +-- | A set of semantic version ranges. To satisfy the set, a 'SemVer' must +-- satisfy at least one of the ranges in the list. +type SemVerRangeSet = [SemVerRange] + +-- | Parse a SemVer range set according to the npm syntax. +parseSemVerRangeSet :: T.Text -> Either ParseError SemVerRangeSet +parseSemVerRangeSet input = parse rangeSet "" input + where + -- lexical elements + logicalOr :: Parser () + logicalOr = void $ string "||" + + hyphen :: Parser () + hyphen = void $ char '-' + + gt :: Parser () + gt = void $ char '>' + + gte :: Parser () + gte = void $ string ">=" + + eq :: Parser () + eq = void $ char '=' + + lte :: Parser () + lte = void $ string "<=" + + lt :: Parser () + lt = void $ char '<' + + tilde :: Parser () + tilde = void $ char '~' + + caret :: Parser () + caret = void $ char '^' + + operator :: Parser SemVerOrdering + operator = + (try gte >> return GreaterThanEqual) <|> + (gt >> return GreaterThan) <|> + (eq >> return EqualTo) <|> + (try lte >> return LessThanEqual) <|> + (lt >> return LessThan) + + operatorToOrdering :: SemVerOrdering -> [Ordering] + operatorToOrdering GreaterThanEqual = [GT, EQ] + operatorToOrdering GreaterThan = [GT] + operatorToOrdering EqualTo = [EQ] + operatorToOrdering LessThanEqual = [LT, EQ] + operatorToOrdering LessThan = [LT] + + -- range set: range (|| range)* + rangeSet :: Parser SemVerRangeSet + rangeSet = do + set <- range `sepBy1` try (spaces >> logicalOr >> spaces) + eof + + return set + + -- range: lower-upper, or list of versions separated by spaces, or an empty string + range :: Parser SemVerRange + range = + try hyphenRange <|> + try simpleList <|> + return [[(EQ, initialVer), (GT, initialVer)]] + + -- lower-upper + hyphenRange :: Parser SemVerRange + hyphenRange = do + lowerVersion <- partialParsec + spaces + hyphen + spaces + upperVersion <- partialParsec + + return [partialToLowerRange lowerVersion, partialToUpperRange upperVersion] + + -- a list of individual versions + simpleList :: Parser SemVerRange + simpleList = do + s <- simpleParsec + l <- option [] $ try (spaces >> simpleList) + return (s ++ l) + + simpleParsec :: Parser SemVerRange + simpleParsec = + primitive <|> + tildeVersion <|> + caretVersion <|> + standaloneVersion + + -- This is a standalone operator + version, e.g., ">= 1.0" + -- For exact versions, it's just (operator) (version) + -- For wildcard versions: + -- - = p is the same as a standalone version, i.e. p - p + -- - > p is >= (partialToUpper p) + -- - < p is < (partialToLower p) + -- - <= p is < (partialToUpper p) + -- - >= p is >= (partialToLower p) + -- Any missing parts of the PartialSemVer are replaced with 0. + primitive :: Parser SemVerRange + primitive = do + ordering <- operator + spaces + p <- partialParsec + + return $ if isExact p then + [map (\o -> (o, partialToLower p)) (operatorToOrdering ordering)] + else + case ordering of + EqualTo -> [partialToLowerRange p, partialToUpperRange p] + GreaterThan -> [[(GT, partialToUpper p), (EQ, partialToUpper p)]] + LessThan -> [[(LT, partialToLower p)]] + LessThanEqual -> [[(LT, partialToUpper p)]] + GreaterThanEqual -> [[(GT, partialToLower p), (EQ, partialToLower p)]] + + -- patch-level changes if a minor is specified, minor-level changes if not + -- I don't know why, but npm allows '~ > ver', which is the same as '~ ver' + tildeVersion :: Parser SemVerRange + tildeVersion = do + tilde + spaces + optional gt + spaces + version <- partialParsec + + return [partialToLowerRange version, partialToTilde version] + + -- Allow changes that do not modify the left-most non-zero digit of the version + caretVersion :: Parser SemVerRange + caretVersion = do + caret + spaces + version <- partialParsec + + return [partialToLowerRange version, partialToCaret version] + + -- Just a version: this is equivalent to the range - + standaloneVersion :: Parser SemVerRange + standaloneVersion = do + version <- partialParsec + return [partialToLowerRange version, partialToUpperRange version] + +-- | Whether a given version satisfies a given range. +-- +-- When the version contains pre-release tags, it only satisifes a SemVerRange +-- if at least one version in the range has a matching major.minor.patch version +-- number and also contains pre-release tags. +satisfies :: SemVer -> SemVerRangeSet -> Bool +satisfies v1 set = any satisfiesRange set + where + satisfiesRange :: SemVerRange -> Bool + -- if v1 has no pre-release tags, we can just compare versions the normal way. + -- otherwise, the version only satisfies the range if there is match maj.min.patch with a pre-release + satisfiesRange range = let + normalCase = all satisfiesPart range + preReleaseCase = any matchesPart range + isPreRelease = (not . null) (preRelease v1) + in + if isPreRelease then + normalCase && preReleaseCase + else + normalCase + + satisfiesPart :: SemVerRangePart -> Bool + satisfiesPart = any satisfiesExpr + + satisfiesExpr :: (Ordering, SemVer) -> Bool + satisfiesExpr (o, v2) = compare v1 v2 == o + + matchesPart :: SemVerRangePart -> Bool + matchesPart = any matchesExpr + + matchesExpr :: (Ordering, SemVer) -> Bool + matchesExpr (_, v2) = (not . null) (preRelease v2) && + (major v1 == major v2) && + (minor v1 == minor v2) && + (patch v1 == patch v2) + +toText :: SemVer -> T.Text +toText SemVer{..} = let + mainver = [T.pack $ show major, ".", + T.pack $ show minor, ".", + T.pack $ show patch] + prever = if null preRelease then [] else "-":idsToText preRelease + buildver = if null buildMeta then [] else "+":idsToText buildMeta + in + T.concat $ mainver ++ prever ++ buildver + where + idsToText ids = intersperse "." $ map idToText ids + + idToText (NumericIdentifier i) = T.pack $ show i + idToText (TextIdentifier t) = t + +-- Internal type for parsing partial versions +data PartialSemVer = PartialSemVer { + partialMajor :: Maybe Integer, + partialMinor :: Maybe Integer, + partialPatch :: Maybe Integer, + partialPreReleaseTags :: [SemVerIdentifier], + partialBuildMeta :: [SemVerIdentifier] + } deriving (Show) + +-- Token type for Ordering, plus >= and <= +data SemVerOrdering = LessThan + | EqualTo + | GreaterThan + | LessThanEqual + | GreaterThanEqual + +partialParsec :: Parser PartialSemVer +partialParsec = do + let integer = Just <$> read <$> many1 digit + let parseWildCard = try integer <|> + (oneOf "xX*" >> return Nothing) + + -- allow the version to start with any combination of 'v', '=' or space characters + skipMany $ oneOf "v=" <|> space + + -- major is required, everything else is optional + major <- parseWildCard + minor <- option Nothing (char '.' >> parseWildCard) + + -- prerelease/buildmeta are also optional, but can only occur if patch is present + (patch, preRelease, buildMeta) <- + option (Nothing, [], []) $ do + patch <- char '.' >> parseWildCard + + -- pre-release is supposed to be preceded by a hyphen (1.2.3-pre), but + -- npm's "loose" mode allows the hyphen to be skipped (1.2.3pre) + + preRelease <- option [] (optional (char '-') >> parseExtra) + buildMeta <- option [] (char '+' >> parseExtra) + return (patch, preRelease, buildMeta) + + spaces + + return $ PartialSemVer major minor patch preRelease buildMeta + where + -- parse a pre-release or buildmeta item list + parseExtra :: Parser [SemVerIdentifier] + parseExtra = parseExtraItem `sepBy1` char '.' + + parseExtraItem :: Parser SemVerIdentifier + parseExtraItem = do + str <- many1 (satisfy isAsciiLower <|> + satisfy isAsciiUpper <|> + satisfy isDigit <|> + char '-') + + return $ if all isDigit str then + NumericIdentifier (read str) + else + TextIdentifier (T.pack str) + +isExact :: PartialSemVer -> Bool +isExact PartialSemVer{partialMajor=(Just _), + partialMinor=(Just _), + partialPatch=(Just _), + ..} = True +isExact _ = False + +-- Convert a wildcard semver to the lowest possible matching version. i.e., repalce wildcards with 0. +-- Anything after a missing piece is ignored, so something like 1.*.7 becomes 1.0.0 +partialToLower :: PartialSemVer -> SemVer +partialToLower PartialSemVer{..} = let + (major, minor, patch, prerelease) = case (partialMajor, partialMinor, partialPatch) of + (Nothing, _, _) -> (0, 0, 0, []) + (Just partMajor, Nothing, _) -> (partMajor, 0, 0, []) + (Just partMajor, Just partMinor, Nothing) -> (partMajor, partMinor, 0, []) + (Just partMajor, Just partMinor, Just partPatch) -> (partMajor, partMinor, partPatch, partialPreReleaseTags) + in + SemVer major minor patch prerelease [] + +-- Convert a wildcard semver to the lowest version that is greater than the wildcard. +-- Increment the last known component and replace the remaining components with 0. +-- This should not be used with exact versions. +partialToUpper :: PartialSemVer -> SemVer +partialToUpper PartialSemVer{partialMajor=Nothing} = initialVer +partialToUpper PartialSemVer{partialMajor=(Just major), + partialMinor=Nothing, + ..} = SemVer (major+1) 0 0 [] [] +partialToUpper PartialSemVer{partialMajor=(Just major), + partialMinor=(Just minor), + partialPatch=Nothing, + ..} = SemVer major (minor+1) 0 [] [] +partialToUpper PartialSemVer{partialMajor=(Just major), + partialMinor=(Just minor), + partialPatch=(Just patch), + ..} = SemVer major minor (patch+1) [] [] + +-- use a partial semver as the lower end of a range, >= p +partialToLowerRange :: PartialSemVer -> SemVerRangePart +partialToLowerRange p = let + semver = partialToLower p + in + [(EQ, semver), (GT, semver)] + +-- use a partial semver as the upper end of a range +-- For exact versions, this is <= p +-- For partial versions, this is < (partialToUpper) p +partialToUpperRange :: PartialSemVer -> SemVerRangePart + +-- all wildcard, return >= 0.0.0 as an always-true condition +partialToUpperRange PartialSemVer{partialMajor=Nothing, ..} = [(GT, initialVer), (EQ, initialVer)] + +-- No wildcard parts +partialToUpperRange PartialSemVer{partialMajor=(Just major), + partialMinor=(Just minor), + partialPatch=(Just patch), + ..} = + let s = SemVer major minor patch partialPreReleaseTags [] + in [(EQ, s), (LT, s)] + +-- some wildcard parts +partialToUpperRange p = [(LT, partialToUpper p)] + +-- For tilde ranges: allow patch-level changes if a minor version is specified, +-- minor-level changes if not +-- ~x.y.z => x.y.z - x.y.* +-- ~x.y.* => x.y.* +-- ~x.*.* => x.* +-- ~* => * +-- +-- This function returns the upper expression of the range +partialToTilde :: PartialSemVer -> SemVerRangePart +partialToTilde PartialSemVer{partialPatch=(Just _), ..} = partialToUpperRange $ PartialSemVer partialMajor partialMinor Nothing [] [] +partialToTilde p = partialToUpperRange p + +-- For caret ranges, allow changes that do not modify the left-most non-zero digit of the version +-- ^1.2.3 => 1.2.3 - 1.* +-- ^0.2.3 => 0.2.3 - 0.2.* +-- ^0.0.3 => >=0.0.3 && <0.0.4 (i.e., = 0.0.3) +-- +-- In the case of partial versions, the patch version is always allowed to +-- change even if major and minor are zero. +-- +-- ^1.2.* => ^1.2.0 => 1.2.0 - 1.* +-- ^0.2.* => ^0.2.0 => 0.2.0 - 0.2.* +-- ^0.0.* => 0.0.0 - 0.0.* => 0.0.* +-- +-- This function returns the upper expression of the range +partialToCaret :: PartialSemVer -> SemVerRangePart + +-- the special case, 0.0.: if patch is a wildcard, leave it as a wildcard so patch level can change +-- if patch is a version, leave the restriction in place +partialToCaret PartialSemVer{partialMajor=(Just 0), partialMinor=(Just 0), ..} = partialToUpperRange $ PartialSemVer (Just 0) (Just 0) partialPatch [] [] + +-- 0 major, wildcard or non-zero minor: +-- if minor is non-zero, leave it and allow patch to change +-- if minor is a wildcard, allow minor to change by leaving it a wildcard +partialToCaret PartialSemVer{partialMajor=(Just 0), ..} = partialToUpperRange $ PartialSemVer (Just 0) partialMinor Nothing [] [] + +-- non-zero or wildcard major: +-- if non-zero, leave major and allow minor and patch to change +-- if wildcard, leave it as a wildcard +partialToCaret PartialSemVer{..} = partialToUpperRange $ PartialSemVer partialMajor Nothing Nothing [] [] diff --git a/src/BDCS/Packages.hs b/src/BDCS/Packages.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Packages.hs @@ -0,0 +1,51 @@ +-- Copyright (C) 2016-2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE OverloadedStrings #-} + +module BDCS.Packages(filesInPackage, + findPackage, + insertPackageName) + where + +import Control.Monad.IO.Class(MonadIO) +import qualified Data.Text as T +import Database.Esqueleto + +import BDCS.DB +import BDCS.KeyValue(insertKeyValue) +import BDCS.KeyType + +filesInPackage :: MonadIO m => T.Text -> SqlPersistT m [T.Text] +filesInPackage name = do + results <- select $ from $ \(files `InnerJoin` key_val `InnerJoin` file_key_values) -> do + on $ key_val ^. KeyValId ==. file_key_values ^. FileKeyValuesKey_val_id &&. + file_key_values ^. FileKeyValuesFile_id ==. files ^. FilesId + where_ $ key_val ^. KeyValKey_value ==. val (TextKey "packageName") &&. + key_val ^. KeyValVal_value ==. just (val name) + return $ files ^. FilesPath + return $ map unValue results + +insertPackageName :: MonadIO m => T.Text -> SqlPersistT m (Key KeyVal) +insertPackageName packageName = + findPackage packageName `orDo` insertKeyValue (TextKey "packageName") (Just packageName) Nothing + +findPackage :: MonadIO m => T.Text -> SqlPersistT m (Maybe (Key KeyVal)) +findPackage name = firstKeyResult $ + select $ from $ \pkg -> do + where_ $ pkg ^. KeyValKey_value ==. val (TextKey "packageName") &&. + pkg ^. KeyValVal_value ==. just (val name) + limit 1 + return $ pkg ^. KeyValId diff --git a/src/BDCS/Projects.hs b/src/BDCS/Projects.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Projects.hs @@ -0,0 +1,45 @@ +-- Copyright (C) 2016 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE RecordWildCards #-} + +module BDCS.Projects(findProject, + getProject, + insertProject) + where + +import Control.Monad.IO.Class(MonadIO) +import qualified Data.Text as T +import Database.Esqueleto + +import BDCS.DB + +findProject :: MonadIO m => T.Text -> SqlPersistT m (Maybe (Key Projects)) +findProject name = firstKeyResult $ + select $ from $ \proj -> do + where_ $ proj ^. ProjectsName ==. val name + limit 1 + return $ proj ^. ProjectsId + +getProject :: MonadIO m => Key Projects -> SqlPersistT m (Maybe Projects) +getProject key = firstEntityResult $ + select $ from $ \proj -> do + where_ $ proj ^. ProjectsId ==. val key + limit 1 + return proj + +insertProject :: MonadIO m => Projects -> SqlPersistT m (Key Projects) +insertProject project@Projects{..} = + findProject projectsName `orInsert` project diff --git a/src/BDCS/RPM/Builds.hs b/src/BDCS/RPM/Builds.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/RPM/Builds.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: BDCS.RPM.Builds +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- 'Builds' record support for RPM packages. + +module BDCS.RPM.Builds(mkBuild) + where + +import Codec.RPM.Tags(Tag, findStringTag, findStringListTag, findTag, tagValue) +import Data.ByteString.Char8(pack) +import qualified Data.Text as T +import Data.Time.Clock.POSIX(posixSecondsToUTCTime) +import Data.Word(Word32) +import Database.Esqueleto(Key) + +import BDCS.DB(Builds(..), Sources) +import BDCS.Exceptions(DBException(..), throwIfNothing) + +-- | Return a 'Builds' record for the RPM package. +-- +-- Can throw MissingRPMTag +mkBuild :: [Tag] -> Key Sources -> Builds +mkBuild tags sourceId = let + epoch = maybe 0 fromIntegral (findTag "Epoch" tags >>= \t -> tagValue t :: Maybe Word32) + release = T.pack $ findStringTag "Release" tags `throwIfNothing` MissingRPMTag "Release" + arch = T.pack $ findStringTag "Arch" tags `throwIfNothing` MissingRPMTag "Arch" + + build_time = getBuildTime `throwIfNothing` MissingRPMTag "BuildTime" + -- FIXME: RPM splits the changelog up into three tag types. I'm just grabbing the text here for now. + changelog = getChangelog `throwIfNothing` MissingRPMTag "ChangeLogText" + + -- FIXME: Where to get these from? + build_config_ref = "BUILD_CONFIG_REF" + build_env_ref = "BUILD_ENV_REF" + in + Builds sourceId epoch release arch build_time changelog build_config_ref build_env_ref + where + getBuildTime = findTag "BuildTime" tags >>= \t -> (tagValue t :: Maybe Word32) >>= Just . posixSecondsToUTCTime . realToFrac + + getChangelog = case findStringListTag "ChangeLogText" tags of + [] -> Nothing + lst -> Just $ pack $ head lst diff --git a/src/BDCS/RPM/Files.hs b/src/BDCS/RPM/Files.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/RPM/Files.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: BDCS.RPM.Files +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- 'Files' record support for RPM packages. + +module BDCS.RPM.Files(mkFiles) + where + +import Codec.RPM.Tags(Tag, findWord16ListTag, findWord32ListTag, findStringListTag, findTag, tagValue) +import Control.Monad(join) +import Control.Monad.IO.Class(MonadIO) +import Data.ByteArray(convert) +import Data.ContentStore.Digest(ObjectDigest) +import Data.List(zip7) +import Data.Maybe(fromMaybe) +import qualified Data.Text as T +import Data.Word(Word32) +import Database.Esqueleto +import System.FilePath.Posix(()) + +import BDCS.DB + +type FileTuple = (T.Text, T.Text, T.Text, Int, Int, Int, Maybe T.Text) + +-- | Return a 'Files' record for the RPM package. +mkFiles :: MonadIO m => [Tag] -> [(T.Text, Maybe ObjectDigest)] -> SqlPersistT m [Files] +mkFiles rpm checksums = + mapM mkOneFile (zipFiles rpm) + where + mkOneFile :: MonadIO m => FileTuple -> SqlPersistT m Files + mkOneFile (path, user, group, mtime, mode, size, target) = do + let cksum = fmap convert (join $ lookup path checksums) + return $ Files path user group mtime cksum mode size target + + filePaths :: [Tag] -> [FilePath] + filePaths tags = let + indexes = fromMaybe [] $ findTag "DirIndexes" tags >>= \t -> tagValue t :: Maybe [Word32] + dirnames = findStringListTag "DirNames" tags + basenames = findStringListTag "BaseNames" tags + in + zipWith () (map (\i -> dirnames !! fromIntegral i) indexes) basenames + + zipFiles :: [Tag] -> [FileTuple] + zipFiles tags = let + paths = map T.pack $ filePaths tags + users = map T.pack $ findStringListTag "FileUserName" tags + groups = map T.pack $ findStringListTag "FileGroupName" tags + mtimes = fromMaybe [] $ findTag "FileMTimes" tags >>= \t -> (tagValue t :: Maybe [Word32]) >>= Just . map fromIntegral + modes = map fromIntegral $ findWord16ListTag "FileModes" tags + sizes = map fromIntegral $ findWord32ListTag "FileSizes" tags + targets = map (\t -> if t == "" then Nothing else Just $ T.pack t) + (findStringListTag "FileLinkTos" tags) + in + zip7 paths users groups mtimes modes sizes targets diff --git a/src/BDCS/RPM/Groups.hs b/src/BDCS/RPM/Groups.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/RPM/Groups.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: BDCS.RPM.Groups +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- 'Groups' record support for RPM packages. + +module BDCS.RPM.Groups(createGroup) + where + +import Codec.RPM.Tags(Tag, findStringTag, findStringListTag, findTag, findWord32ListTag, tagValue) +import Control.Conditional((<&&>), whenM) +import Control.Monad(forM_, void, when) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.State(State, execState, get, modify) +import Data.Bits(testBit) +import Data.Maybe(fromJust, isJust) +import qualified Data.Text as T +import Data.Word(Word32) +import Database.Persist.Sql(SqlPersistT, insert) + +import BDCS.DB +import BDCS.GroupKeyValue(insertGroupKeyValue) +import BDCS.KeyType +import BDCS.Requirements(insertGroupRequirement, insertRequirement) +import qualified BDCS.ReqType as RT +import BDCS.RPM.Requirements(mkGroupRequirement, mkRequirement) + +addPRCO :: MonadIO m => [Tag] -> Key Groups -> T.Text -> T.Text -> SqlPersistT m () +addPRCO tags groupId tagBase keyName = + withPRCO tagBase tags $ \(_, expr) -> let + -- split out the name part of "name >= version" + exprBase = T.takeWhile (/= ' ') expr + in + insertGroupKeyValue (TextKey keyName) exprBase (Just expr) groupId + +prcoExpressions :: T.Text -> [Tag] -> [(Word32, T.Text)] +prcoExpressions ty tags = let + ty' = T.toTitle ty + + names = map T.pack $ findStringListTag (T.unpack ty' ++ "Name") tags + flags = findWord32ListTag (T.unpack ty' ++ "Flags") tags + vers = map T.pack $ findStringListTag (T.unpack ty' ++ "Version") tags + in + zip flags $ map (\(n, f, v) -> T.stripEnd $ T.concat [n, " ", rpmFlagsToOperator f, " ", v]) + (zip3 names flags vers) + +-- Convert the RPM flags value to a comparison operator Text string +rpmFlagsToOperator :: Word32 -> T.Text +rpmFlagsToOperator f = + if | f `testBit` 1 && f `testBit` 3 -> "<=" + | f `testBit` 1 -> "<" + | f `testBit` 2 && f `testBit` 3 -> ">=" + | f `testBit` 2 -> ">" + | f `testBit` 3 -> "=" + | otherwise -> "" + +-- Return the list of contexts to which this requirement applies. +-- RPM interprets a combination of RPMSENSE_SCRIPT_* flags as meaning that the requirement is needed for +-- each of those script types. If the requirement is *also* needed for Runtime, it will appear +-- again in the requirements without any SCRIPT_* flags. +-- +-- RPMSENSE_INTERP is annoying: it doesn't add any information (INTERP | SCRIPT_PRE is just another %pre requirement) +-- *unless* it appears on its own, which instead means that it applies to all script types present. +-- +-- Ignoring RPMSENSE_CONFIG, since config(whatever) requirements have matching config(whatever) provides without +-- bringing flags into it. +-- +-- Also ignoring RPMSENSE_TRIGGER*, since they don't appear to ever be used +rpmFlagsToContexts :: [Tag] -> Word32 -> [RT.ReqContext] +rpmFlagsToContexts tags flags = + execState rpmFlagsToContextsState [] + where + rpmFlagsToContextsState :: State [RT.ReqContext] () + rpmFlagsToContextsState = do + when (flags `testBit` 9) (modify (RT.ScriptPre:)) + when (flags `testBit` 10) (modify (RT.ScriptPost:)) + when (flags `testBit` 11) (modify (RT.ScriptPreUn:)) + when (flags `testBit` 12) (modify (RT.ScriptPostUn:)) + when (flags `testBit` 7) (modify (RT.ScriptPreTrans:)) + when (flags `testBit` 5) (modify (RT.ScriptPostTrans:)) + when (flags `testBit` 13) (modify (RT.ScriptVerify:)) + + -- Check for a bare RPMSENSE_INTERP + whenM ((null <$> get) <&&> return (flags `testBit` 8)) $ do + when ((isJust . findTag "PreIn") tags) (modify (RT.ScriptPre:)) + when ((isJust . findTag "PostIn") tags) (modify (RT.ScriptPost:)) + when ((isJust . findTag "PreUn") tags) (modify (RT.ScriptPreUn:)) + when ((isJust . findTag "PostUn") tags) (modify (RT.ScriptPost:)) + when ((isJust . findTag "PreTrans") tags) (modify (RT.ScriptPreTrans:)) + when ((isJust . findTag "PostTrans") tags) (modify (RT.ScriptPostTrans:)) + when ((isJust . findTag "VerifyScript") tags) (modify (RT.ScriptVerify:)) + + when (flags `testBit` 24) (modify (RT.Feature:)) + + -- If nothing else set, return Runtime + whenM (null <$> get) (modify (RT.Runtime:)) + +withPRCO :: Monad m => T.Text -> [Tag] -> ((Word32, T.Text) -> m a) -> m () +withPRCO ty tags fn = + mapM_ fn (prcoExpressions ty tags) + +-- Ignore the suggestion to not use lambda for creating GroupFiles rows, since +-- the lambda makes it more clear what's actually happening +{-# ANN createGroup ("HLint: ignore Avoid lambda" :: String) #-} +-- | Given a list of 'Files' and an RPM package, create a new 'Groups' record and add +-- it to the database. Note the difference between this function and all the others +-- that operate on RPMs - those return a record, while this one creates a record, inserts +-- it, and returns its key. Groups are more complicated. +createGroup :: MonadIO m => [Key Files] -> [Tag] -> SqlPersistT m (Key Groups) +createGroup fileIds rpm = do + -- Get the NEVRA so it can be saved as attributes + let epoch = findTag "Epoch" rpm >>= \t -> (tagValue t :: Maybe Word32) >>= Just . T.pack . show + let name = maybe "" T.pack (findStringTag "Name" rpm) + let version = maybe "" T.pack (findStringTag "Version" rpm) + let release = maybe "" T.pack (findStringTag "Release" rpm) + let arch = maybe "" T.pack (findStringTag "Arch" rpm) + + -- Create the groups row + groupId <- insert $ Groups name "rpm" Nothing + + -- Create the group_files rows + mapM_ (\fId -> insert $ GroupFiles groupId fId) fileIds + + -- Create the (E)NVRA attributes + -- FIXME could at least deduplicate name and arch real easy + forM_ [(TextKey "name", name), (TextKey "version", version), (TextKey "release", release), (TextKey "arch", arch)] $ \tup -> + uncurry insertGroupKeyValue tup Nothing groupId + + -- Add the epoch attribute, when it exists. + when (isJust epoch) $ void $ + insertGroupKeyValue (TextKey "epoch") (fromJust epoch) Nothing groupId + + forM_ [("Provide", "rpm-provide"), ("Conflict", "rpm-conflict"), ("Obsolete", "rpm-obsolete"), ("Order", "rpm-install-after")] $ \tup -> + uncurry (addPRCO rpm groupId) tup + + -- Create the Requires attributes + forM_ [("Require", RT.Must), ("Recommend", RT.Should), ("Suggest", RT.May), + ("Supplement", RT.ShouldIfInstalled), ("Enhance", RT.MayIfInstalled)] $ \tup -> + withPRCO (fst tup) rpm $ \(flags, expr) -> + forM_ (rpmFlagsToContexts rpm flags) $ \context -> do + reqId <- insertRequirement $ mkRequirement context (snd tup) expr + + -- Don't insert a requirement for a group more than once. RPMs can have the same + -- requirement listed multiple times, for whatever reason, but we want to reduce + -- duplication. + insertGroupRequirement $ mkGroupRequirement groupId reqId + + return groupId diff --git a/src/BDCS/RPM/Projects.hs b/src/BDCS/RPM/Projects.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/RPM/Projects.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: BDCS.RPM.Projects +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- 'Projects' record support for RPM packages. + +module BDCS.RPM.Projects(mkProject) + where + +import Codec.RPM.Tags(Tag, findByteStringTag, findStringTag) +import Data.List(elemIndices) +import qualified Data.Text as T +import Data.Text.Encoding(decodeUtf8) + +import BDCS.DB(Projects(..)) +import BDCS.Exceptions(DBException(..), throwIfNothingOtherwise) + +-- | Return a 'Projects' record for the RPM package. +mkProject :: [Tag] -> Projects +mkProject tags = let + projectName = throwIfNothingOtherwise (findStringTag "SourceRPM" tags) + (MissingRPMTag "SourceRPM") + (T.pack . srpmToName) + summary = throwIfNothingOtherwise (findByteStringTag "Summary" tags) + (MissingRPMTag "Summary") + decodeUtf8 + description = throwIfNothingOtherwise (findByteStringTag "Description" tags) + (MissingRPMTag "Description") + decodeUtf8 + homepage = fmap T.pack (findStringTag "URL" tags) + + -- FIXME: Where to get this from? + upstream_vcs = "UPSTREAM_VCS" + in + Projects projectName summary description homepage upstream_vcs + where + -- the closest to a project name we have is the srpm name, e.g., pykickstart-2.32-1.fc26.src.rpm + -- This is essentially N-V-R.A.rpm. rpm does not allow hyphens in version of release, and epoch is + -- not included in the SRPM name, so we can just take everything before the second-to-last hyphen + -- as the name. + srpmToName :: String -> String + srpmToName s = + -- Find all the hyphens and take the second to last result + let nameHyphenIndex = head $ tail $ reverse $ elemIndices '-' s + in fst $ splitAt nameHyphenIndex s diff --git a/src/BDCS/RPM/Requirements.hs b/src/BDCS/RPM/Requirements.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/RPM/Requirements.hs @@ -0,0 +1,32 @@ +-- | +-- Module: BDCS.RPM.Requirements +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- 'Requirements' record support for RPM packages. + +module BDCS.RPM.Requirements(mkGroupRequirement, + mkRequirement) + where + +import Database.Esqueleto(Key) +import qualified Data.Text as T + +import BDCS.DB(GroupRequirements(..), Groups(..), Requirements(..)) +import qualified BDCS.ReqType as RT + +{-# ANN module "HLint: ignore Eta reduce" #-} + +-- | Return a 'GroupRequirements' record for the RPM package. +mkGroupRequirement :: Key Groups -> Key Requirements -> GroupRequirements +mkGroupRequirement groupId reqId = + GroupRequirements groupId reqId + +-- | Return a 'Requirements' record for the RPM package. +mkRequirement :: RT.ReqContext -> RT.ReqStrength -> T.Text -> Requirements +mkRequirement context strength expr = + Requirements RT.RPM context strength expr diff --git a/src/BDCS/RPM/Scripts.hs b/src/BDCS/RPM/Scripts.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/RPM/Scripts.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: BDCS.RPM.Scripts +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- 'Scripts' record support for RPM packages. + +module BDCS.RPM.Scripts(mkScripts, + mkTriggerScripts) + where + +import Codec.RPM.Tags(Tag, findStringListTag, findTag, findWord32ListTag, tagValue) +import Data.List(zip6) +import Data.Maybe(catMaybes) +import Data.Text(pack) + +import BDCS.DB(Scripts(..)) + +-- | Return a list of 'Scripts' records +mkScripts :: [Tag] -> [Scripts] +mkScripts tags = catMaybes [ + findTag "PreIn" tags >>= \t -> (tagValue t :: Maybe String) >>= \body -> Just $ Scripts "PreIn" (pack body) Nothing Nothing Nothing Nothing Nothing, + findTag "PostIn" tags >>= \t -> (tagValue t :: Maybe String) >>= \body -> Just $ Scripts "PostIn" (pack body) Nothing Nothing Nothing Nothing Nothing, + findTag "PreUn" tags >>= \t -> (tagValue t :: Maybe String) >>= \body -> Just $ Scripts "PreUn" (pack body) Nothing Nothing Nothing Nothing Nothing, + findTag "PostUn" tags >>= \t -> (tagValue t :: Maybe String) >>= \body -> Just $ Scripts "PostUn" (pack body) Nothing Nothing Nothing Nothing Nothing, + + findTag "PreTrans" tags >>= \t -> (tagValue t :: Maybe String) >>= \body -> Just $ Scripts "PreTrans" (pack body) Nothing Nothing Nothing Nothing Nothing, + findTag "PostTrans" tags >>= \t -> (tagValue t :: Maybe String) >>= \body -> Just $ Scripts "PostTrans" (pack body) Nothing Nothing Nothing Nothing Nothing + ] + +-- | Return a list of trigger scripts +mkTriggerScripts :: [Tag] -> [Scripts] +mkTriggerScripts tags = let + bodies = map pack $ findStringListTag "TriggerScripts" tags + names = map pack $ findStringListTag "TriggerName" tags + vers = map pack $ findStringListTag "TriggerVersion" tags + flags = map fromIntegral $ findWord32ListTag "TriggerFlags" tags + ndxs = map fromIntegral $ findWord32ListTag "TriggerIndex" tags + progs = map pack $ findStringListTag "TriggerScriptProg" tags + in + map (\(b, n, v, f, x, p) -> Scripts "Trigger" b (Just p) (Just x) (Just n) (Just v) (Just f)) + (zip6 bodies names vers flags ndxs progs) diff --git a/src/BDCS/RPM/Signatures.hs b/src/BDCS/RPM/Signatures.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/RPM/Signatures.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: BDCS.RPM.Signatures +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- 'BuildSignatures' record support for RPM packages. + +module BDCS.RPM.Signatures(mkRSASignature, + mkSHASignature) + where + +import Codec.RPM.Tags(Tag, findTag, tagValue) +import qualified Data.ByteString as BS +import Data.ByteString.Char8(pack) +import Database.Esqueleto + +import BDCS.DB(Builds, BuildSignatures(..)) +import BDCS.Exceptions(DBException(..), throwIfNothing) + +-- | Return a RSA 'BuildSignature' +-- +-- Can throw 'MissingRPMTag' +mkRSASignature :: [Tag] -> Key Builds -> BuildSignatures +mkRSASignature tags buildId = let + rsaSig = getRSASig `throwIfNothing` MissingRPMTag "RSAHeader" + in + BuildSignatures buildId "RSA" rsaSig + where + getRSASig = findTag "RSAHeader" tags >>= \t -> tagValue t :: Maybe BS.ByteString + +-- | Return a SHA1 'BuildSignature' +-- +-- Can throw 'MissingRPMTag' +mkSHASignature :: [Tag] -> Key Builds -> BuildSignatures +mkSHASignature tags buildId = let + shaSig = getSHASig `throwIfNothing` MissingRPMTag "SHA1Header" + in + BuildSignatures buildId "SHA1" shaSig + where + getSHASig = findTag "SHA1Header" tags >>= \t -> (tagValue t :: Maybe String) >>= Just . pack diff --git a/src/BDCS/RPM/Sources.hs b/src/BDCS/RPM/Sources.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/RPM/Sources.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: BDCS.RPM.Sources +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- 'Sources' record support for RPM packages. + +module BDCS.RPM.Sources(mkSource) + where + +import Codec.RPM.Tags(Tag, findStringTag) +import Database.Esqueleto(Key) +import qualified Data.Text as T + +import BDCS.DB(Projects, Sources(..)) +import BDCS.Exceptions(DBException(..), throwIfNothing) + +-- | Return a 'Sources' record. +-- +-- Can throw 'MissingRPMTag' +mkSource :: [Tag] -> Key Projects -> Sources +mkSource tags projectId = let + license = T.pack $ findStringTag "License" tags `throwIfNothing` MissingRPMTag "License" + version = T.pack $ findStringTag "Version" tags `throwIfNothing` MissingRPMTag "Version" + + -- FIXME: Where to get this from? + source_ref = "SOURCE_REF" + in + Sources projectId license version source_ref diff --git a/src/BDCS/RPM/Utils.hs b/src/BDCS/RPM/Utils.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/RPM/Utils.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: BDCS.RPM.Utils +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Utility functions for "BDCS.RPM" + +module BDCS.RPM.Utils(splitFilename) + where + +import Data.Bifunctor(first) +import qualified Data.Text as T + +-- | Turn an RPM filename in form of "NAME-[EPOCH:]VERSION-RELEASE.ARCH[.rpm] +-- into a tuple of (name, epoch, version, release, and arch). +splitFilename :: T.Text -> (T.Text, Maybe T.Text, T.Text, T.Text, T.Text) +splitFilename rpm_ = let + rpm = if ".rpm" `T.isSuffixOf` rpm_ then T.dropEnd 4 rpm_ else rpm_ + + (front, a) = T.breakOnEnd "." rpm + (front2, r) = T.breakOnEnd "-" $ T.dropWhileEnd (== '.') front + (n, ve) = first (T.dropWhileEnd (== '-')) $ T.breakOnEnd "-" $ T.dropWhileEnd (== '-') front2 + (e, v) = first (T.dropWhileEnd (== ':')) $ T.breakOnEnd ":" ve + in + (n, if e == "" then Nothing else Just $ T.dropWhile (== ':') e, v, r, a) diff --git a/src/BDCS/ReqType.hs b/src/BDCS/ReqType.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/ReqType.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module: BDCS.ReqType +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Data types for working with 'Requirements'. + +module BDCS.ReqType(ReqContext(..), + ReqLanguage(..), + ReqStrength(..)) + where + +import Database.Persist.TH + +{-# ANN module "HLint: ignore Use module export list" #-} + +-- | The type of a requirements language - this basically maps to a packaging +-- system. For now, only RPM is supported. +data ReqLanguage = RPM + deriving(Eq, Read, Show) + +-- | The type for specifying when a requirement should be enforced. +data ReqContext = Build -- ^ Applies when building + | Runtime -- ^ Applies when the package is on the system + | Test -- ^ Applies to running tests + | ScriptPre -- ^ Before a package install + | ScriptPost -- ^ After a package install + | ScriptPreUn -- ^ Before a package uninstall + | ScriptPostUn -- ^ After a package uninstall + | ScriptPreTrans -- ^ Before a package transaction + | ScriptPostTrans -- ^ After a package transaction + | ScriptVerify -- ^ Package verification script + | Feature -- ^ Feature requirement, e.g. rpmlib features + deriving(Eq, Read, Show) + +-- | The type for specifying how strictly a requirement should be enforced. +data ReqStrength = Must -- ^ A requirement must be satisfied + | Should -- ^ A requirement should be satisfied, but it is + -- not an error if it cannot be. + | May -- ^ A requirement should only be satisfied at the + -- user's option. Typically, automated processes + -- will ignore this. + | ShouldIfInstalled -- ^ Like 'Should', but looks at packages that are + -- already installed. + | MayIfInstalled -- ^ Like 'May', but looks at packages that are + -- already installed. + deriving(Eq, Read, Show) + +derivePersistField "ReqLanguage" +derivePersistField "ReqContext" +derivePersistField "ReqStrength" diff --git a/src/BDCS/Requirements.hs b/src/BDCS/Requirements.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Requirements.hs @@ -0,0 +1,34 @@ +-- Copyright (C) 2016-2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE RecordWildCards #-} + +module BDCS.Requirements(insertRequirement, + insertGroupRequirement) + where + +import Control.Monad.IO.Class(MonadIO) +import Database.Esqueleto + +import BDCS.DB(GroupRequirements(..), Requirements(..), orInsert) +import BDCS.Groups(findRequires, findGroupRequirements) + +insertGroupRequirement :: MonadIO m => GroupRequirements -> SqlPersistT m (Key GroupRequirements) +insertGroupRequirement gr@GroupRequirements{..} = + findGroupRequirements groupRequirementsGroup_id groupRequirementsReq_id `orInsert` gr + +insertRequirement :: MonadIO m => Requirements -> SqlPersistT m (Key Requirements) +insertRequirement req@Requirements{..} = + findRequires requirementsReq_language requirementsReq_context requirementsReq_strength requirementsReq_expr `orInsert` req diff --git a/src/BDCS/Scripts.hs b/src/BDCS/Scripts.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Scripts.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: BDCS.Scripts +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Manage 'Scripts' records in the database. This record keeps track of a single +-- script that is associated with a 'Groups' record. A script is some arbitrary +-- program that can be run at various points when installing, upgrading, or removing +-- a piece of software. Not all packaging systems support this concept, and the +-- BDCS only somewhat supports them at the moment. + +module BDCS.Scripts(findScript, + getScript, + insertScript) + where + +import Control.Monad.IO.Class(MonadIO) +import qualified Data.Text as T +import Database.Esqueleto + +import BDCS.DB + +-- | Find a single script in the database, returning the key for that script if it +-- exists. It is possible for multiple very similar scripts to exist in the same +-- database (or even, scripts with identical bodies but that differ in other ways) +-- so additional information must be provided. +findScript :: MonadIO m => + T.Text -- ^ The script type (generally, when it runs). + -- This value is highly packaging system dependent. + -> T.Text -- ^ The script body + -> Maybe T.Text -- ^ The name of any trigger required to fire + -- off this script. Most scripts do not use this, + -- and many packaging systems do not support it. + -> Maybe T.Text -- ^ The script version, currently unused + -> Maybe Int -- ^ The script index, currently unused + -> Maybe Int -- ^ The script flags, currently unused + -> SqlPersistT m (Maybe (Key Scripts)) +findScript ty body name _ver _ndx _flags = firstKeyResult $ + select $ from $ \script -> do + where_ $ script ^. ScriptsTy ==. val ty &&. + script ^. ScriptsBody ==. val body &&. + script ^. ScriptsTrigger_name ==? name + limit 1 + return $ script ^. ScriptsId + +-- | Given a key to a 'Scripts' record in the database, return that record. This function is +-- suitable for using on the result of 'findScript'. +getScript :: MonadIO m => Key Scripts -> SqlPersistT m (Maybe Scripts) +getScript key = firstEntityResult $ + select $ from $ \script -> do + where_ $ script ^. ScriptsId ==. val key + limit 1 + return script + +-- | Conditionally add a new 'Scripts' record to the database and associate a 'Groups' record +-- with it. If the association already exists, it is reused in creating the association. +-- The database key of the association is returned. A single group can potentially have zero +-- or many 'Scripts' associated with it. +insertScript :: MonadIO m => Key Groups -> Scripts -> SqlPersistT m (Key GroupScripts) +insertScript groupId script@Scripts{..} = + maybeKey (insert script >>= insert . GroupScripts groupId) + (insert . GroupScripts groupId) + (findScript scriptsTy scriptsBody scriptsTrigger_name scriptsTrigger_version scriptsTrigger_index scriptsTrigger_flags) diff --git a/src/BDCS/Signatures.hs b/src/BDCS/Signatures.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Signatures.hs @@ -0,0 +1,25 @@ +-- | +-- Module: BDCS.Signatures +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Manage 'BuildSignatures' records in the database. These are used for keeping track +-- of the signatures given to a build at build time. Multiple signatures can be associated +-- with a single 'Builds' record. + +module BDCS.Signatures(insertBuildSignatures) + where + +import Control.Monad.IO.Class(MonadIO) +import Database.Esqueleto + +import BDCS.DB + +-- | Loop over a list of provided 'BuildSignatures' and add them to the database, returning +-- their keys in the same order as the original list. +insertBuildSignatures :: MonadIO m => [BuildSignatures] -> SqlPersistT m [Key BuildSignatures] +insertBuildSignatures = mapM insert diff --git a/src/BDCS/Sources.hs b/src/BDCS/Sources.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Sources.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: BDCS.Sources +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Manage 'Sources' records in the database. This record keeps track of a single +-- software release of a single project. A single project can make many releases, +-- each of which will require a separate 'Sources' record. + +module BDCS.Sources(findSource, + getSource, + insertSource, + insertSourceKeyValue) + where + +import Control.Monad.IO.Class(MonadIO) +import qualified Data.Text as T +import Database.Esqueleto + +import BDCS.DB +import BDCS.KeyType +import BDCS.KeyValue(findKeyValue) + +-- | Given a version number and a key to a 'Projects' record, find a matching software +-- source in the database. If it exists, the database key is returned. +findSource :: MonadIO m => T.Text -> Key Projects -> SqlPersistT m (Maybe (Key Sources)) +findSource version projectId = firstKeyResult $ + -- FIXME: Is (project_id, version) unique in Sources? + select $ from $ \src -> do + where_ $ src ^. SourcesProject_id ==. val projectId &&. + src ^. SourcesVersion ==. val version + limit 1 + return $ src ^. SourcesId + +-- | Given a key to a 'Sources' record in the database, return that record. This function +-- is suitable for using on the result of 'findSource'. +getSource :: MonadIO m => Key Sources -> SqlPersistT m (Maybe Sources) +getSource key = firstEntityResult $ + select $ from $ \source -> do + where_ $ source ^. SourcesId ==. val key + limit 1 + return source + +-- | Conditionally add a new 'Sources' record to the database. If the record already exists, +-- return its key. Otherwise, insert the record and return the new key. +insertSource :: MonadIO m => Sources -> SqlPersistT m (Key Sources) +insertSource source@Sources{..} = + findSource sourcesVersion sourcesProject_id `orInsert` source + +-- | Conditionally add a new 'KeyVal' record to the database and associate a 'Sources' +-- record with it. If the 'KeyVal' record already exists, it is reused in creating the +-- association. They database key of the association is returned. +-- +-- A single source can potentially have zero or more 'KeyVal' paris associated with it. +-- On the other hand, a single 'KeyVal' pair can apply to many sources. +insertSourceKeyValue :: MonadIO m => + KeyType -- ^ Type of the 'KeyVal' + -> T.Text -- ^ Value of the 'KeyVal' + -> Maybe T.Text -- ^ Extended value of the 'KeyVal' + -> Key Sources -- ^ Source to be associated with the 'KeyVal' + -> SqlPersistT m (Key SourceKeyValues) +insertSourceKeyValue k v e sourceId = do + kvId <- findKeyValue k (Just v) e `orInsert` KeyVal k (Just v) e + insert $ SourceKeyValues sourceId kvId diff --git a/src/BDCS/Utils/Conduit.hs b/src/BDCS/Utils/Conduit.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Utils/Conduit.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module: BDCS.Utils.Conduit +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Conduit related utility functions + +module BDCS.Utils.Conduit(awaitWith, + identityC, + sourceInputStream) + where + +import Conduit(mapC) +import Control.Monad(unless) +import Control.Monad.IO.Class(liftIO) +import Control.Monad.Trans.Resource(MonadResource) +import Data.ByteString(ByteString) +import Data.Conduit(Conduit, Producer, await, yield) +import Data.Maybe(fromMaybe) +import GI.Gio(IsInputStream, inputStreamReadBytes, noCancellable) +import GI.GLib(bytesGetData, bytesGetSize) + +-- | Wait for a single value and then call fn on it. +awaitWith :: Monad m => (i -> Conduit i m o) -> Conduit i m o +awaitWith fn = await >>= \case + Nothing -> return () + Just v -> fn v + +-- | A conduit that takes its input and returns that as its output. +identityC :: Monad m => Conduit a m a +identityC = mapC id + +-- | Convert a 'GI.Gio.IsInputStream' to a conduit source +sourceInputStream :: (MonadResource m, IsInputStream i) => i -> Producer m ByteString +sourceInputStream input = do + let buf_size = 8096 + bytes <- liftIO $ inputStreamReadBytes input buf_size noCancellable + bytesSize <- liftIO $ bytesGetSize bytes + unless (bytesSize == 0) $ do + bytesData <- liftIO $ bytesGetData bytes + yield $ fromMaybe "" bytesData + sourceInputStream input diff --git a/src/BDCS/Utils/Either.hs b/src/BDCS/Utils/Either.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Utils/Either.hs @@ -0,0 +1,32 @@ +-- | +-- Module: BDCS.Utils.Either +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Utility functions to help with Either values + +module BDCS.Utils.Either(maybeToEither, + whenLeft, + whenRight) + where + +import Control.Monad.Except(MonadError, throwError) + +-- | Throw the passed err if the value is Nothing, otherwise return the value. +maybeToEither :: MonadError e m => e -> Maybe a -> m a +maybeToEither err Nothing = throwError err +maybeToEither _ (Just v) = return v + +-- | Run a function on the Left error, otherwise do nothing +whenLeft :: Monad m => Either e a -> (e -> m ()) -> m () +whenLeft (Left a) fn = fn a +whenLeft _ _ = return () + +-- | Run a function on the Right value, otherwise do nothing +whenRight :: Monad m => Either e a -> (a -> m ()) -> m () +whenRight (Right a) fn = fn a +whenRight _ _ = return () diff --git a/src/BDCS/Utils/Error.hs b/src/BDCS/Utils/Error.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Utils/Error.hs @@ -0,0 +1,33 @@ +-- | +-- Module: BDCS.Utils.Error +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Functions to help with errors + +module BDCS.Utils.Error(errorToEither, + errorToMaybe, + mapError) + + where + +import Control.Monad.Except(ExceptT(..), MonadError, catchError, runExceptT, throwError) + +-- | Convert an error action into an Either +-- This is essentially 'runExceptT' generalized to 'MonadError' +errorToEither :: MonadError e m => m a -> m (Either e a) +errorToEither action = (Right <$> action) `catchError` (return . Left) + +-- | Convert an error into into nothing +errorToMaybe :: MonadError e m => m a -> m (Maybe a) +errorToMaybe action = (Just <$> action) `catchError` (const . return) Nothing + +-- | Run an 'ExceptT' action. On error, run a supplied function to convert the error into +-- some type that can be thrown with 'throwError' in 'MonadError'. On success, simply +-- return the value of the action. +mapError :: MonadError e' m => (e -> e') -> ExceptT e m a -> m a +mapError f action = runExceptT action >>= either (throwError . f) return diff --git a/src/BDCS/Utils/Filesystem.hs b/src/BDCS/Utils/Filesystem.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Utils/Filesystem.hs @@ -0,0 +1,28 @@ +-- | +-- Module: BDCS.Utils.Filesystem +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Filesystem related utility functions + +module BDCS.Utils.Filesystem(doesPathExist) + where + +import Control.Exception(catchJust) +import Control.Monad(guard) +import System.IO.Error(doesNotExistErrorType, ioeGetErrorType) +import System.Posix.Files(getSymbolicLinkStatus) + +-- | A version of doesPathExist that also returns True if the path exists +-- and is a broken symlink. +doesPathExist :: FilePath -> IO Bool +doesPathExist path = catchJust isENOENT getStatus (const $ return False) + where + getStatus = getSymbolicLinkStatus path >> return True + + isENOENT :: IOError -> Maybe () + isENOENT e = guard $ ioeGetErrorType e == doesNotExistErrorType diff --git a/src/BDCS/Utils/Mode.hs b/src/BDCS/Utils/Mode.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Utils/Mode.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MultiWayIf #-} + +-- | +-- Module: BDCS.Utils.Mode +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Utility functions for Unix filesystem modes + +module BDCS.Utils.Mode(modeAsText) + where + +import Data.Bits(testBit) +import qualified Data.Text as T +import Data.Word(Word32) + +-- | Convert a mode value into a Text file mode string +-- +-- > modeAsText 0o755 +-- > "rwxr-xr-x" +modeAsText :: Word32 -> T.Text +modeAsText x = T.pack [ + if x `testBit` 8 then 'r' else '-', + if x `testBit` 7 then 'w' else '-', + if | x `testBit` 12 && x `testBit` 6 -> 's' + | x `testBit` 12 -> 'S' + | x `testBit` 6 -> 'x' + | otherwise -> '-', + if x `testBit` 5 then 'r' else '-', + if x `testBit` 4 then 'w' else '-', + if | x `testBit` 11 && x `testBit` 3 -> 's' + | x `testBit` 11 -> 'S' + | x `testBit` 3 -> 'x' + | otherwise -> '-', + if x `testBit` 2 then 'r' else '-', + if x `testBit` 1 then 'w' else '-', + if | x `testBit` 10 && x `testBit` 0 -> 't' + | x `testBit` 10 -> 'T' + | x `testBit` 0 -> 'x' + | otherwise -> '-' + ] diff --git a/src/BDCS/Utils/Monad.hs b/src/BDCS/Utils/Monad.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Utils/Monad.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE LambdaCase #-} + +-- | +-- Module: BDCS.Utils.Monad +-- Copyright: (c) 2016-2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Monad related utility functions + +module BDCS.Utils.Monad(concatForM, + concatMapM, + foldMaybeM, + mapMaybeM, + (>>?)) + where + +import Data.Maybe(catMaybes) + +-- | Like 'Data.List.concatMap', but with its arguments reversed (the list comes +-- first and the function comes second) and operates in a monad. +concatForM :: (Monad m, Traversable t) => t a -> (a -> m [b]) -> m [b] +concatForM lst fn = fmap concat (mapM fn lst) + +-- | Like 'Data.List.concatMap' but operates in a monad. +concatMapM :: (Monad m, Traversable t) => (a -> m [b]) -> t a -> m [b] +concatMapM fn lst = fmap concat (mapM fn lst) + +-- | Like 'Data.Maybe.mapMaybe' but operates in a monad. +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM fn = fmap catMaybes . mapM fn + +-- Like 'Control.Monad.foldM', but skip Nothing results. +foldMaybeM :: Monad m => (b -> a -> m (Maybe b)) -> b -> [a] -> m b +foldMaybeM _ acc [] = return acc +foldMaybeM action acc (x:xs) = do + result <- action acc x + case result of + -- skip this element, continue with the original accumulator + Nothing -> foldMaybeM action acc xs + -- Keep this one + Just r -> foldMaybeM action r xs + +-- | Apply a function to a monadic action. If the action is 'm Nothing', do nothing. Otherwise, apply the +-- function and return the result as 'm (Just a)'. +infixl 1 >>? +(>>?) :: Monad m => m (Maybe a) -> (a -> m b) -> m (Maybe b) +(>>?) input action = input >>= \case + Nothing -> return Nothing + Just x -> Just <$> action x diff --git a/src/BDCS/Version.hs b/src/BDCS/Version.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Version.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module: BDCS.Version +-- Copyright: (c) 2017 Red Hat, Inc. +-- License: LGPL +-- +-- Maintainer: https://github.com/weldr +-- Stability: alpha +-- Portability: portable +-- +-- Extract the version number of bdcs tools. + +module BDCS.Version(printVersion) + where + +import Data.Version (showVersion) +import Development.GitRev +import Text.Printf(printf) + +import Paths_bdcs (version) + +-- | Given the name of a bdcs tool, print its version number. +printVersion :: String -> IO () +printVersion toolName = do + let git_version = $(gitDescribe) + if git_version == "UNKNOWN" then + printf "%s v%s\n" toolName $ showVersion version + else + printf "%s %s\n" toolName git_version diff --git a/src/tests/BDCS/DepcloseSpec.hs b/src/tests/BDCS/DepcloseSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/BDCS/DepcloseSpec.hs @@ -0,0 +1,841 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module BDCS.DepcloseSpec(spec) + where + +import Control.Monad(void, when) +import Control.Monad.Except(ExceptT, runExceptT) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Logger(NoLoggingT) +import Control.Monad.Trans.Resource(MonadBaseControl, ResourceT) +import Data.Monoid((<>)) +import qualified Data.Text as T +import Database.Persist(insert) +import Database.Persist.Sql(Key, SqlPersistT, insertKey, toSqlKey) +import Test.Hspec + +import BDCS.DB(Files(..), GroupFiles(..), Groups(..)) +import BDCS.Depclose(depclose) +import BDCS.Depsolve(Formula(..)) +import BDCS.GroupKeyValue(insertGroupKeyValue) +import BDCS.KeyType(KeyType(..)) +import BDCS.Requirements(insertGroupRequirement, insertRequirement) +import qualified BDCS.ReqType as RT(ReqContext(..), ReqStrength(..)) +import BDCS.RPM.Requirements(mkGroupRequirement, mkRequirement) +import Utils(withDb) + +-- The solutions provided by depclose are super messy (depsolve is supposed to clean them up), +-- and any changes in depclose are likely to break these tests. +spec :: Spec +spec = describe "BDCS.Depclose Tests" $ do + let singleton_req = And [Atom (toSqlKey 1)] + let solution_1 = Right $ And [singleton_req] + it "depclose, singleton" $ + withDeps (depclose arches ["singleton-1.0-1.x86_64"]) >>= (`shouldBe` solution_1) + + let simple_req = And [Atom (toSqlKey 2), Or [singleton_req]] + let solution_2 = Right $ And [simple_req] + it "depclose, simple" $ + withDeps (depclose arches ["simple-1.0-1.x86_64"]) >>= (`shouldBe` solution_2) + + let simple_chain_req = And [Atom (toSqlKey 3), Or [simple_req]] + let solution_3 = Right $ And [simple_chain_req] + it "depclose, simple-chain" $ + withDeps (depclose arches ["simple-chain-1.0-1.x86_64"]) >>= (`shouldBe` solution_3) + + let provides_file_req = And [Atom (toSqlKey 4)] + let needs_file_req = And [Atom (toSqlKey 5), Or [provides_file_req]] + let solution_5 = Right $ And [needs_file_req] + it "depclose, needs-file" $ + withDeps (depclose arches ["needs-file-1.0-1.x86_64"]) >>= (`shouldBe` solution_5) + + let conflicts_req = And [Atom (toSqlKey 6), Not (toSqlKey 1)] + let solution_6 = Right $ And [conflicts_req] + it "depclose, conflicts" $ + withDeps (depclose arches ["conflicts-1.0-1.x86_64"]) >>= (`shouldBe` solution_6) + + let obsolete_req = And [Atom (toSqlKey 7), Not (toSqlKey 1)] + let solution_7 = Right $ And [obsolete_req] + it "depclose, obsoletes" $ + withDeps (depclose arches ["obsoletes-1.0-1.x86_64"]) >>= (`shouldBe` solution_7) + + let high_version_req = And [Atom (toSqlKey 10)] + let need_version_req = And [Atom (toSqlKey 11), Or [high_version_req]] + let solution_11 = Right $ And [need_version_req] + it "depclose, versioned requirement" $ + withDeps (depclose arches ["needs-version-1.0-1.x86_64"]) >>= (`shouldBe` solution_11) + + let obsolete_version_req = And [Atom (toSqlKey 12), Not (toSqlKey 9)] + let solution_12 = Right $ And [obsolete_version_req] + it "depclose, versioned obsolete" $ + withDeps (depclose arches ["obsoletes-version-1.0-1.x86_64"]) >>= (`shouldBe` solution_12) + + let loop_1_req = And [Atom (toSqlKey 14), Or [And [Atom (toSqlKey 15)]]] + let solution_15 = Right $ And [loop_1_req] + it "depclose, dependency cycle" $ + withDeps (depclose arches ["loop-1-1.0-1.x86_64"]) >>= (`shouldBe` solution_15) + + let choice_1_req = And [Atom (toSqlKey 17)] + let choice_2_req = And [Atom (toSqlKey 18)] + let choices_req = And [Atom (toSqlKey 16), Or [choice_1_req, choice_2_req]] + let solution_16 = Right $ And [choices_req] + it "depclose, multiple providers" $ + withDeps (depclose arches ["choices-1.0-1.x86_64"]) >>= (`shouldBe` solution_16) + + let solution_double = Right $ And [needs_file_req, singleton_req] + it "depclose, two things" $ + withDeps (depclose arches ["singleton-1.0-1.x86_64", "needs-file-1.0-1.x86_64"]) >>= (`shouldBe` solution_double) + + it "depclose, no such requirement" $ + withDeps (depclose arches ["no-such-requirement-1.0-1.x86_64"]) >>= (`shouldBe` Left "Unable to resolve requirement: DepRequirement \"does-not-exist\" Nothing") + + it "depclose, missing provides data" $ + withDeps (depclose arches ["broken-conflicts-1.0-1.x86_64"]) >>= (`shouldBe` Left "Invalid key/val data") + + it "depclose, no such package" $ + withDeps (depclose arches ["does-not-exist-1.0-1.x86_64"]) >>= (`shouldBe` Left "No such group does-not-exist-1.0-1.x86_64") + + -- run tests with (mostly) real data + -- this is more a demonstration of what's wrong with depclose than anything + let ncurses_base_req = And [Atom (toSqlKey 13)] + let tzdata_req = And [Atom (toSqlKey 10)] + let libgcc_req = And [Atom (toSqlKey 7)] + + let libstdcplusplus_req = And [Atom (toSqlKey 8) + -- glibc in parents + -- libgcc in parents + ] + + let xz_libs_req = And [Atom (toSqlKey 5) + -- glibc in parents + ] + + let pcre_req = And [Atom (toSqlKey 6), + -- glibc in parents + Or [libstdcplusplus_req], + Or [libgcc_req]] + + let libsepol_req = And [Atom (toSqlKey 9) + -- glibc in parents + ] + + let libselinux_req = And [Atom (toSqlKey 4), + -- glibc in parents + Or [libsepol_req], + Or [pcre_req], + Or [xz_libs_req]] + + let glibc_common_req = And [Atom (toSqlKey 3), + -- bash in parents + -- glibc in parents + Or [tzdata_req], + Or [libselinux_req]] + + let nss_softokn_freebl_req = And [Atom (toSqlKey 11) + -- bash in parents + -- glibc in parents + ] + + let glibc_req = And [Atom (toSqlKey 2), + Or [nss_softokn_freebl_req], + Or [glibc_common_req]] + + let ncurses_req = And [Atom (toSqlKey 12), + -- glibc in parents + -- libgcc in parents + -- libstdc++ in parents + Or [ncurses_base_req]] + + let bash_req = And [Atom (toSqlKey 1), + Or [ncurses_req], + Or [glibc_req]] + let bash_solution = Right $ And [bash_req] + it "depclose bash" $ + withRealDeps (depclose arches ["bash-4.2.46-12.el7.x86_64"]) >>= (`shouldBe` bash_solution) + + let glibc_req_2 = And [Atom (toSqlKey 1000), + Or [nss_softokn_freebl_req], + Or [glibc_common_req]] + let bash_req_2 = And [Atom (toSqlKey 1), + Or [ncurses_req], + Or [glibc_req, glibc_req_2]] + let bash_solution_2 = Right $ And [bash_req_2] + it "depclose bash, two glibcs" $ + withGlibcUpgrade (depclose arches ["bash-4.2.46-12.el7.x86_64"]) >>= (`shouldBe` bash_solution_2) + + -- tar requirements, minus requirements already pulled in by bash (glibc, libselinux) + let libattr_req = And [Atom (toSqlKey 16)] + let libacl_req = And [Atom (toSqlKey 15), + Or [libattr_req]] + let tar_with_bash_req = And [Atom (toSqlKey 14), + Or [libacl_req]] + let tar_with_bash_solution = Right $ And [tar_with_bash_req, bash_req] + it "depclose bash and tar at the same time" $ + withRealDeps (depclose arches ["bash-4.2.46-12.el7.x86_64", "tar-2:1.26-29.el7.x86_64"]) >>= (`shouldBe` tar_with_bash_solution) + where + arches :: [T.Text] + arches = ["x86_64"] + + addDeps :: MonadIO m => SqlPersistT m () + addDeps = do + -- singleton, provides itself, requires nothing + let groupid_1 = toSqlKey 1 + insertNEVRA groupid_1 "singleton" Nothing "1.0" "1" "x86_64" + + -- simple, requires singleton and nothing else + let groupid_2 = toSqlKey 2 + insertNEVRA groupid_2 "simple" Nothing "1.0" "1" "x86_64" + addReq groupid_2 "singleton" + + -- simple-chain, requires simple which requires singleton + let groupid_3 = toSqlKey 3 + insertNEVRA groupid_3 "simple-chain" Nothing "1.0" "1" "x86_64" + addReq groupid_3 "simple" + + -- provides-file and needs-file, for file-based requirements + let groupid_4 = toSqlKey 4 + insertNEVRA groupid_4 "provides-file" Nothing "1.0" "1" "x86_64" + addFile groupid_4 "/what/ever" + let groupid_5 = toSqlKey 5 + insertNEVRA groupid_5 "needs-file" Nothing "1.0" "1" "x86_64" + addReq groupid_5 "/what/ever" + + -- conflicts, conflicts with singleton + let groupid_6 = toSqlKey 6 + insertNEVRA groupid_6 "conflicts" Nothing "1.0" "1" "x86_64" + void $ insertGroupKeyValue (TextKey "rpm-conflict") "singleton" (Just "singleton") groupid_6 + + -- obsoletes, same thing + let groupid_7 = toSqlKey 7 + insertNEVRA groupid_7 "obsoletes" Nothing "1.0" "1" "x86_64" + void $ insertGroupKeyValue (TextKey "rpm-obsolete") "singleton" (Just "singleton") groupid_7 + + -- missing ext_val in a key/val that expects a version + let groupid_8 = toSqlKey 8 + insertNEVRA groupid_8 "broken-conflicts" Nothing "1.0" "1" "x86_64" + void $ insertGroupKeyValue (TextKey "rpm-conflict") "missing-ext-value" Nothing groupid_8 + + -- versioned requirement + let groupid_9 = toSqlKey 9 + insertNEVRA groupid_9 "versioned" Nothing "1.0" "1" "x86_64" + addProvide groupid_9 "version-test" (Just "= 1.0") + + let groupid_10 = toSqlKey 10 + insertNEVRA groupid_10 "versioned" Nothing "2.0" "1" "x86_64" + addProvide groupid_10 "version-test" (Just "= 2.0") + + let groupid_11 = toSqlKey 11 + insertNEVRA groupid_11 "needs-version" Nothing "1.0" "1" "x86_64" + addReq groupid_11 "versioned >= 2.0" + + -- obsolete with version + let groupid_12 = toSqlKey 12 + insertNEVRA groupid_12 "obsoletes-version" Nothing "1.0" "1" "x86_64" + void $ insertGroupKeyValue (TextKey "rpm-obsolete") "versioned" (Just "versioned < 2.0") groupid_12 + + -- unsatisfiable, package does not exist + let groupid_13 = toSqlKey 13 + insertNEVRA groupid_13 "no-such-requirement" Nothing "1.0" "1" "x86_64" + addReq groupid_13 "does-not-exist" + + -- create a loop + let groupid_14 = toSqlKey 14 + insertNEVRA groupid_14 "loop-1" Nothing "1.0" "1" "x86_64" + addReq groupid_14 "loop-2" + + let groupid_15 = toSqlKey 15 + insertNEVRA groupid_15 "loop-2" Nothing "1.0" "1" "x86_64" + addReq groupid_15 "loop-1" + + -- require something with multiple providers + let groupid_16 = toSqlKey 16 + insertNEVRA groupid_16 "choices" Nothing "1.0" "1" "x86_64" + addReq groupid_16 "choices-req" + + let groupid_17 = toSqlKey 17 + insertNEVRA groupid_17 "choice-1" Nothing "1.0" "1" "x86_64" + addProvide groupid_17 "choices-req" Nothing + + let groupid_18 = toSqlKey 18 + insertNEVRA groupid_18 "choice-2" Nothing "1.0" "1" "x86_64" + addProvide groupid_18 "choices-req" Nothing + + -- Real dependencies taken from CentOS 7 data + -- IDs: + -- 1: bash + -- 2: glibc + -- 3: glibc-common + -- 4: libselinux + -- 5: xz-libs + -- 6: pcre + -- 7: libgcc + -- 8: libstdc++ + -- 9: libsepol + -- 10: tzdata + -- 11: nss-softokn-freebl + -- 12: ncurses-libs + -- 13: ncurses-base + -- 14: tar + -- 15: libacl + -- 16: libattr + addRealDeps :: MonadIO m => SqlPersistT m () + addRealDeps = do + -- only the provides that are actually used are included, to try to keep things a little less out of control + + let groupid_1 = toSqlKey 1 + insertNEVRA groupid_1 "bash" Nothing "4.2.46" "12.el7" "x86_64" + addProvide groupid_1 "/bin/bash" Nothing + addProvide groupid_1 "/bin/sh" Nothing + addProvide groupid_1 "config(bash)" (Just "= 4.2.46-12.el7") + void $ insertGroupKeyValue (TextKey "rpm-conflict") "filesystem" (Just "filesystem < 3") groupid_1 + addFile groupid_1 "/usr/bin/bash" + + -- self-provided + addReq groupid_1 "/bin/sh" + addReq groupid_1 "config(bash) = 4.2.46-12.el7" + + -- provided by glibc (id 2) + addReq groupid_1 "libc.so.6()(64bit)" + addReq groupid_1 "libc.so.6(GLIBC_2.11)(64bit)" + addReq groupid_1 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_1 "libc.so.6(GLIBC_2.15)(64bit)" + addReq groupid_1 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_1 "libc.so.6(GLIBC_2.3)(64bit)" + addReq groupid_1 "libc.so.6(GLIBC_2.3.4)(64bit)" + addReq groupid_1 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_1 "libc.so.6(GLIBC_2.8)(64bit)" + addReq groupid_1 "libdl.so.2()(64bit)" + addReq groupid_1 "libdl.so.2(GLIBC_2.2.5)(64bit)" + addReq groupid_1 "rtld(GNU_HASH)" + + -- ncurses-libs (id 12) + addReq groupid_1 "libtinfo.so.5()(64bit)" + + let groupid_2 = toSqlKey 2 + insertNEVRA groupid_2 "glibc" Nothing "2.17" "78.el7" "x86_64" + addProvide groupid_2 "config(glibc)" (Just "= 2.17-78.el7") + addProvide groupid_2 "ld-linux-x86-64.so.2()(64bit)" Nothing + addProvide groupid_2 "ld-linux-x86-64.so.2(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_2 "ld-linux-x86-64.so.2(GLIBC_2.3)(64bit)" Nothing + addProvide groupid_2 "libCNS.so()(64bit)" Nothing + addProvide groupid_2 "libGB.so()(64bit)" Nothing + addProvide groupid_2 "libISOIR165.so()(64bit)" Nothing + addProvide groupid_2 "libJIS.so()(64bit)" Nothing + addProvide groupid_2 "libJISX0213.so()(64bit)" Nothing + addProvide groupid_2 "libKSC.so()(64bit)" Nothing + addProvide groupid_2 "libc.so.6()(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.10)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.11)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.12)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.13)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.14)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.15)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.17)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.3)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.3.2)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.3.3)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.3.4)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.4)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.6)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.7)(64bit)" Nothing + addProvide groupid_2 "libc.so.6(GLIBC_2.8)(64bit)" Nothing + addProvide groupid_2 "libdl.so.2()(64bit)" Nothing + addProvide groupid_2 "libdl.so.2(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_2 "libm.so.6()(64bit)" Nothing + addProvide groupid_2 "libm.so.6(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_2 "libnsl.so.1()(64bit)" Nothing + addProvide groupid_2 "libnsl.so.1(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_2 "libnss_files.so.2()(64bit)" Nothing + addProvide groupid_2 "libpthread.so.0()(64bit)" Nothing + addProvide groupid_2 "libpthread.so.0(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_2 "libpthread.so.0(GLIBC_2.3.2)(64bit)" Nothing + addProvide groupid_2 "libpthread.so.0(GLIBC_2.3.3)(64bit)" Nothing + addProvide groupid_2 "libresolv.so.2()(64bit)" Nothing + addProvide groupid_2 "libresolv.so.2(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_2 "libresolv.so.2(GLIBC_2.9)(64bit)" Nothing + addProvide groupid_2 "rtld(GNU_HASH)" Nothing + void $ insertGroupKeyValue (TextKey "rpm-conflict") "kernel" (Just "kernel < 2.6.32") groupid_2 + void $ insertGroupKeyValue (TextKey "rpm-conflict") "binutils" (Just "binutils < 2.19.51.0.10") groupid_2 + void $ insertGroupKeyValue (TextKey "rpm-conflict") "prelink" (Just "prelink < 0.4.2") groupid_2 + void $ insertGroupKeyValue (TextKey "rpm-obsolete") "glibc-profile" (Just "glibc-profile < 2.4") groupid_2 + void $ insertGroupKeyValue (TextKey "rpm-obsolete") "nss_db" (Just "nss_db") groupid_2 + + -- self-provided + addReq groupid_2 "config(glibc) = 2.17-78.el7" + addReq groupid_2 "ld-linux-x86-64.so.2()(64bit)" + addReq groupid_2 "ld-linux-x86-64.so.2(GLIBC_2.2.5)(64bit)" + addReq groupid_2 "ld-linux-x86-64.so.2(GLIBC_2.3)(64bit)" + addReq groupid_2 "libCNS.so()(64bit)" + addReq groupid_2 "libGB.so()(64bit)" + addReq groupid_2 "libISOIR165.so()(64bit)" + addReq groupid_2 "libJIS.so()(64bit)" + addReq groupid_2 "libJISX0213.so()(64bit)" + addReq groupid_2 "libKSC.so()(64bit)" + addReq groupid_2 "libc.so.6()(64bit)" + addReq groupid_2 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_2 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_2 "libc.so.6(GLIBC_2.3)(64bit)" + addReq groupid_2 "libc.so.6(GLIBC_2.3.2)(64bit)" + addReq groupid_2 "libc.so.6(GLIBC_2.3.3)(64bit)" + addReq groupid_2 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_2 "libdl.so.2()(64bit)" + addReq groupid_2 "libdl.so.2(GLIBC_2.2.5)(64bit)" + addReq groupid_2 "libnsl.so.1()(64bit)" + addReq groupid_2 "libnsl.so.1(GLIBC_2.2.5)(64bit)" + addReq groupid_2 "libnss_files.so.2()(64bit)" + addReq groupid_2 "libpthread.so.0()(64bit)" + addReq groupid_2 "libpthread.so.0(GLIBC_2.2.5)(64bit)" + addReq groupid_2 "libresolv.so.2()(64bit)" + addReq groupid_2 "libresolv.so.2(GLIBC_2.2.5)(64bit)" + addReq groupid_2 "libresolv.so.2(GLIBC_2.9)(64bit)" + + -- glibc-common (id 3) + addReq groupid_2 "glibc-common = 2.17-78.el7" + + -- nss-softokn-freebl (id 11) + addReq groupid_2 "libfreebl3.so()(64bit)" + addReq groupid_2 "libfreebl3.so(NSSRAWHASH_3.12.3)(64bit)" + + let groupid_3 = toSqlKey 3 + insertNEVRA groupid_3 "glibc-common" Nothing "2.17" "78.el7" "x86_64" + addProvide groupid_3 "config(glibc-common)" (Just "= 2.17-78.el7") + + -- self-provided + addReq groupid_3 "config(glibc-common) = 2.17-78.el7" + + -- provided by bash (id 1) + addReq groupid_3 "/bin/sh" + addReq groupid_3 "/usr/bin/bash" + + -- provided by glibc (id 2) + addReq groupid_3 "glibc = 2.17-78.el7" + addReq groupid_3 "libc.so.6()(64bit)" + addReq groupid_3 "libc.so.6(GLIBC_2.10)(64bit)" + addReq groupid_3 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_3 "libc.so.6(GLIBC_2.15)(64bit)" + addReq groupid_3 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_3 "libc.so.6(GLIBC_2.3)(64bit)" + addReq groupid_3 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_3 "libdl.so.2()(64bit)" + addReq groupid_3 "libdl.so.2(GLIBC_2.2.5)(64bit)" + + -- libselinux (id 4) + addReq groupid_3 "libselinux.so.1()(64bit)" + + -- tzdata (id 10) + addReq groupid_3 "tzdata >= 2003a" + + let groupid_4 = toSqlKey 4 + insertNEVRA groupid_4 "libselinux" Nothing "2.2.2" "6.el7" "x86_64" + addProvide groupid_4 "libselinux.so.1()(64bit)" Nothing + void $ insertGroupKeyValue (TextKey "rpm-conflict") "filesystem" (Just "filesystem < 3") groupid_4 + + -- self-provided + addReq groupid_4 "libselinux.so.1()(64bit)" + + -- glibc (id 2) + addReq groupid_4 "ld-linux-x86-64.so.2()(64bit)" + addReq groupid_4 "ld-linux-x86-64.so.2(GLIBC_2.3)(64bit)" + addReq groupid_4 "libc.so.6()(64bit)" + addReq groupid_4 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_4 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_4 "libc.so.6(GLIBC_2.3)(64bit)" + addReq groupid_4 "libc.so.6(GLIBC_2.3.2)(64bit)" + addReq groupid_4 "libc.so.6(GLIBC_2.3.4)(64bit)" + addReq groupid_4 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_4 "libc.so.6(GLIBC_2.7)(64bit)" + addReq groupid_4 "libc.so.6(GLIBC_2.8)(64bit)" + addReq groupid_4 "libdl.so.2()(64bit)" + addReq groupid_4 "libdl.so.2(GLIBC_2.2.5)(64bit)" + addReq groupid_4 "rtld(GNU_HASH)" + + -- xz-libs (id 5) + addReq groupid_4 "liblzma.so.5()(64bit)" + addReq groupid_4 "liblzma.so.5(XZ_5.0)(64bit)" + + -- pcre (id 6) + addReq groupid_4 "libpcre.so.1()(64bit)" + addReq groupid_4 "pcre" + + -- libsepol (id 9) + addReq groupid_4 "libsepol >= 2.1.9-1" + + let groupid_5 = toSqlKey 5 + insertNEVRA groupid_5 "xz-libs" Nothing "5.1.2" "9alpha.el7" "x86_64" + addProvide groupid_5 "liblzma.so.5()(64bit)" Nothing + addProvide groupid_5 "liblzma.so.5(XZ_5.0)(64bit)" Nothing + + -- provided by glibc (id 2) + addReq groupid_5 "libc.so.6()(64bit)" + addReq groupid_5 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_5 "libc.so.6(GLIBC_2.17)(64bit)" + addReq groupid_5 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_5 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_5 "libpthread.so.0()(64bit)" + addReq groupid_5 "libpthread.so.0(GLIBC_2.2.5)(64bit)" + addReq groupid_5 "libpthread.so.0(GLIBC_2.3.2)(64bit)" + addReq groupid_5 "libpthread.so.0(GLIBC_2.3.3)(64bit)" + addReq groupid_5 "rtld(GNU_HASH)" + + let groupid_6 = toSqlKey 6 + insertNEVRA groupid_6 "pcre" Nothing "8.32" "14.el7" "x86_64" + addProvide groupid_6 "libpcre.so.1()(64bit)" Nothing + + -- self-provided + addReq groupid_6 "libpcre.so.1()(64bit)" + + -- provided by glibc (id 2) + addReq groupid_6 "libc.so.6()(64bit)" + addReq groupid_6 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_6 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_6 "libc.so.6(GLIBC_2.3)(64bit)" + addReq groupid_6 "libc.so.6(GLIBC_2.3.4)(64bit)" + addReq groupid_6 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_6 "libm.so.6()(64bit)" + addReq groupid_6 "libpthread.so.0()(64bit)" + addReq groupid_6 "libpthread.so.0(GLIBC_2.2.5)(64bit)" + addReq groupid_6 "rtld(GNU_HASH)" + + -- libgcc (id 7) + addReq groupid_6 "libgcc_s.so.1()(64bit)" + addReq groupid_6 "libgcc_s.so.1(GCC_3.0)(64bit)" + + -- libstdc++ (id 8) + addReq groupid_6 "libstdc++.so.6()(64bit)" + addReq groupid_6 "libstdc++.so.6(CXXABI_1.3)(64bit)" + addReq groupid_6 "libstdc++.so.6(GLIBCXX_3.4)(64bit)" + addReq groupid_6 "libstdc++.so.6(GLIBCXX_3.4.9)(64bit)" + + let groupid_7 = toSqlKey 7 + insertNEVRA groupid_7 "libgcc" Nothing "4.8.3" "9.el7" "x86_64" + addProvide groupid_7 "libgcc_s.so.1()(64bit)" Nothing + addProvide groupid_7 "libgcc_s.so.1(GCC_3.0)(64bit)" Nothing + addProvide groupid_7 "libgcc_s.so.1(GCC_3.3)(64bit)" Nothing + addProvide groupid_7 "libgcc_s.so.1(GCC_4.2.0)(64bit)" Nothing + -- no requirements + + let groupid_8 = toSqlKey 8 + insertNEVRA groupid_8 "libstdc++" Nothing "4.8.3" "9.el7" "x86_64" + addProvide groupid_8 "libstdc++" (Just "= 4.8.2-16.el7") + addProvide groupid_8 "libstdc++.so.6()(64bit)" Nothing + addProvide groupid_8 "libstdc++.so.6(CXXABI_1.3)(64bit)" Nothing + addProvide groupid_8 "libstdc++.so.6(GLIBCXX_3.4)(64bit)" Nothing + addProvide groupid_8 "libstdc++.so.6(GLIBCXX_3.4.9)(64bit)" Nothing + + -- glibc (id 2) + addReq groupid_8 "glibc >= 2.10.90-7" + addReq groupid_8 "ld-linux-x86-64.so.2()(64bit)" + addReq groupid_8 "ld-linux-x86-64.so.2(GLIBC_2.3)(64bit)" + addReq groupid_8 "libc.so.6()(64bit)" + addReq groupid_8 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_8 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_8 "libc.so.6(GLIBC_2.3)(64bit)" + addReq groupid_8 "libc.so.6(GLIBC_2.3.2)(64bit)" + addReq groupid_8 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_8 "libm.so.6()(64bit)" + addReq groupid_8 "libm.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_8 "rtld(GNU_HASH)" + + -- libgcc (id 7) + addReq groupid_8 "libgcc_s.so.1()(64bit)" + addReq groupid_8 "libgcc_s.so.1(GCC_3.0)(64bit)" + addReq groupid_8 "libgcc_s.so.1(GCC_3.3)(64bit)" + addReq groupid_8 "libgcc_s.so.1(GCC_4.2.0)(64bit)" + + let groupid_9 = toSqlKey 9 + insertNEVRA groupid_9 "libsepol" Nothing "2.1.9" "3.el7" "x86_64" + addProvide groupid_9 "libsepol.so.1()(64bit)" Nothing + + -- provided by glibc (id 2) + addReq groupid_9 "libc.so.6()(64bit)" + addReq groupid_9 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_9 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_9 "libc.so.6(GLIBC_2.3)(64bit)" + addReq groupid_9 "libc.so.6(GLIBC_2.3.4)(64bit)" + addReq groupid_9 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_9 "rtld(GNU_HASH)" + + let groupid_10 = toSqlKey 10 + insertNEVRA groupid_10 "tzdata" Nothing "2015a" "1.el7" "noarch" + void $ insertGroupKeyValue (TextKey "rpm-conflict") "glibc-common" (Just "glibc-common <= 2.3.2-63") groupid_10 + -- no requirements + + let groupid_11 = toSqlKey 11 + insertNEVRA groupid_11 "nss-softokn-freebl" Nothing "3.16.2.3" "9.el7" "x86_64" + addProvide groupid_11 "libfreebl3.so()(64bit)" Nothing + addProvide groupid_11 "libfreebl3.so(NSSRAWHASH_3.12.3)(64bit)" Nothing + void $ insertGroupKeyValue (TextKey "rpm-conflict") "nss" (Just "nss < 3.12.2.99.3-5") groupid_11 + void $ insertGroupKeyValue (TextKey "rpm-conflict") "prelink" (Just "prelink < 0.4.3") groupid_11 + void $ insertGroupKeyValue (TextKey "rpm-conflict") "filesystem" (Just "filesystem < 3") groupid_11 + + -- bash (id 1) + addReq groupid_11 "/bin/bash" + + -- glibc (id 2) + addReq groupid_11 "libc.so.6()(64bit)" + addReq groupid_11 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_11 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_11 "libc.so.6(GLIBC_2.3)(64bit)" + addReq groupid_11 "libc.so.6(GLIBC_2.3.4)(64bit)" + addReq groupid_11 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_11 "libdl.so.2()(64bit)" + addReq groupid_11 "libdl.so.2(GLIBC_2.2.5)(64bit)" + addReq groupid_11 "rtld(GNU_HASH)" + + let groupid_12 = toSqlKey 12 + insertNEVRA groupid_12 "ncurses-libs" Nothing "5.9" "13.20130511.el7" "x86_64" + addProvide groupid_12 "libform.so.5()(64bit)" Nothing + addProvide groupid_12 "libformw.so.5()(64bit)" Nothing + addProvide groupid_12 "libmenu.so.5()(64bit)" Nothing + addProvide groupid_12 "libmenuw.so.5()(64bit)" Nothing + addProvide groupid_12 "libncurses.so.5()(64bit)" Nothing + addProvide groupid_12 "libncursesw.so.5()(64bit)" Nothing + addProvide groupid_12 "libpanel.so.5()(64bit)" Nothing + addProvide groupid_12 "libpanelw.so.5()(64bit)" Nothing + addProvide groupid_12 "libtinfo.so.5()(64bit)" Nothing + void $ insertGroupKeyValue (TextKey "rpm-conflict") "ncurses" (Just "ncurses < 5.6.13") groupid_12 + void $ insertGroupKeyValue (TextKey "rpm-obsolete") "ncurses" (Just "ncurses < 5.6.13") groupid_12 + void $ insertGroupKeyValue (TextKey "rpm-obsolete") "libtermcap" (Just "libtermcap < 2.0.8-48") groupid_12 + + -- self-provided + addReq groupid_12 "libform.so.5()(64bit)" + addReq groupid_12 "libformw.so.5()(64bit)" + addReq groupid_12 "libmenu.so.5()(64bit)" + addReq groupid_12 "libmenuw.so.5()(64bit)" + addReq groupid_12 "libncurses.so.5()(64bit)" + addReq groupid_12 "libncursesw.so.5()(64bit)" + addReq groupid_12 "libpanel.so.5()(64bit)" + addReq groupid_12 "libpanelw.so.5()(64bit)" + addReq groupid_12 "libtinfo.so.5()(64bit)" + + -- glibc (id 2) + addReq groupid_12 "libc.so.6()(64bit)" + addReq groupid_12 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_12 "libc.so.6(GLIBC_2.15)(64bit)" + addReq groupid_12 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_12 "libc.so.6(GLIBC_2.3)(64bit)" + addReq groupid_12 "libc.so.6(GLIBC_2.3.4)(64bit)" + addReq groupid_12 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_12 "libdl.so.2()(64bit)" + addReq groupid_12 "libdl.so.2(GLIBC_2.2.5)(64bit)" + addReq groupid_12 "libm.so.6()(64bit)" + addReq groupid_12 "rtld(GNU_HASH)" + + -- libgcc (id 7) + addReq groupid_12 "libgcc_s.so.1()(64bit)" + addReq groupid_12 "libgcc_s.so.1(GCC_3.0)(64bit)" + + -- libstdc++ (id 8) + addReq groupid_12 "libstdc++.so.6()(64bit)" + addReq groupid_12 "libstdc++.so.6(CXXABI_1.3)(64bit)" + addReq groupid_12 "libstdc++.so.6(GLIBCXX_3.4)(64bit)" + + -- ncurses-base (id 13) + addReq groupid_12 "ncurses-base = 5.9-13.20130511.el7" + + let groupid_13 = toSqlKey 13 + insertNEVRA groupid_13 "ncurses-base" Nothing "5.9" "13.20130511.el7" "noarch" + void $ insertGroupKeyValue (TextKey "rpm-conflict") "ncurses" (Just "ncurses < 5.6-13") groupid_13 + void $ insertGroupKeyValue (TextKey "rpm-conflict") "filesystem" (Just "filesystem < 3") groupid_13 + void $ insertGroupKeyValue (TextKey "rpm-obsolete") "termcap" (Just "termcap < 1:5.5-2") groupid_13 + -- no requirements + + let groupid_14 = toSqlKey 14 + insertNEVRA groupid_14 "tar" (Just "2") "1.26" "29.el7" "x86_64" + + -- glibc (id 2) + addReq groupid_14 "libc.so.6()(64bit)" + addReq groupid_14 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_14 "libc.so.6(GLIBC_2.17)(64bit)" + addReq groupid_14 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_14 "libc.so.6(GLIBC_2.3)(64bit)" + addReq groupid_14 "libc.so.6(GLIBC_2.3.4)(64bit)" + addReq groupid_14 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_14 "libc.so.6(GLIBC_2.6)(64bit)" + addReq groupid_14 "libc.so.6(GLIBC_2.7)(64bit)" + addReq groupid_14 "libc.so.6(GLIBC_2.8)(64bit)" + addReq groupid_14 "rtld(GNU_HASH)" + + -- libselinux (id 4) + addReq groupid_14 "libselinux.so.1()(64bit)" + + -- libacl (id 15) + addReq groupid_14 "libacl.so.1()(64bit)" + addReq groupid_14 "libacl.so.1(ACL_1.0)(64bit)" + + let groupid_15 = toSqlKey 15 + insertNEVRA groupid_15 "libacl" Nothing "2.2.51" "12.el7" "x86_64" + addProvide groupid_15 "libacl.so.1()(64bit)" Nothing + addProvide groupid_15 "libacl.so.1(ACL_1.0)(64bit)" Nothing + void $ insertGroupKeyValue (TextKey "rpm-conflict") "filesystem" (Just "filesystem < 3") groupid_15 + + -- glibc (id 2) + addReq groupid_15 "libc.so.6()(64bit)" + addReq groupid_15 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_15 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_15 "libc.so.6(GLIBC_2.3.4)(64bit)" + addReq groupid_15 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_15 "rtld(GNU_HASH)" + + -- libattr (id 16) + addReq groupid_15 "libattr.so.1()(64bit)" + addReq groupid_15 "libattr.so.1(ATTR_1.0)(64bit)" + + let groupid_16 = toSqlKey 16 + insertNEVRA groupid_16 "libattr" Nothing "2.4.46" "12.el7" "x86_64" + addProvide groupid_16 "libattr.so.1()(64bit)" Nothing + addProvide groupid_16 "libattr.so.1(ATTR_1.0)(64bit)" Nothing + void $ insertGroupKeyValue (TextKey "rpm-conflict") "filesystem" (Just "filesystem < 3") groupid_16 + + -- glibc (id 2) + addReq groupid_16 "libc.so.6()(64bit)" + addReq groupid_16 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_16 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_16 "rtld(GNU_HASH)" + + addFile :: MonadIO m => Key Groups -> T.Text -> SqlPersistT m () + addFile groupid path = do + fid <- insert $ Files path "root" "root" 0 (Just "checksum") 0 0 Nothing + void $ insert $ GroupFiles groupid fid + + addReq :: MonadIO m => Key Groups -> T.Text -> SqlPersistT m () + addReq groupid expr = do + reqid <- insertRequirement $ mkRequirement RT.Runtime RT.Must expr + void $ insertGroupRequirement $ mkGroupRequirement groupid reqid + + addProvide :: MonadIO m => Key Groups -> T.Text -> Maybe T.Text -> SqlPersistT m () + addProvide groupid depname depver = let + depext = depname <> maybe "" (" " `T.append`) depver + in + void $ insertGroupKeyValue (TextKey "rpm-provide") depname (Just depext) groupid + + insertNEVRA :: MonadIO m => Key Groups -> T.Text -> Maybe T.Text -> T.Text -> T.Text -> T.Text -> SqlPersistT m () + insertNEVRA gid name epoch version release arch = do + insertKey gid $ Groups name "rpm" Nothing + void $ insertGroupKeyValue (TextKey "name") name Nothing gid + void $ insertGroupKeyValue (TextKey "version") version Nothing gid + void $ insertGroupKeyValue (TextKey "release") release Nothing gid + void $ insertGroupKeyValue (TextKey "arch") arch Nothing gid + maybe (return ()) + (\e -> void $ insertGroupKeyValue (TextKey "epoch") e Nothing gid) + epoch + + -- Add the self-provide + let evr = maybe "" (T.append ":") epoch <> version <> "-" <> release + addProvide gid name (Just ("= " <> evr)) + when (arch /= "noarch") $ do + let archname = name <> "(" <> arch <> ")" + addProvide gid archname (Just ("= " <> evr)) + + withDeps :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT (NoLoggingT (ResourceT (ExceptT e m))) a -> m (Either e a) + withDeps action = (runExceptT . withDb) (addDeps >> action) + + withRealDeps :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT (NoLoggingT (ResourceT (ExceptT e m))) a -> m (Either e a) + withRealDeps action = (runExceptT . withDb) (addRealDeps >> action) + + -- Like withRealDeps, but with an extra glibc + addGlibcUpgrade :: MonadIO m => SqlPersistT m () + addGlibcUpgrade = do + addRealDeps + + let groupid_1000 = toSqlKey 1000 + insertNEVRA groupid_1000 "glibc-upgrade" Nothing "3.0" "1" "x86_64" + -- Add all of the same provides and requires as glibc-2.17-78.el7.x86_64 + addProvide groupid_1000 "glibc" (Just "= 2.17-78.el7") + addProvide groupid_1000 "glibc(x86_64)" (Just "= 2.17-78.el7") + addProvide groupid_1000 "config(glibc)" (Just "= 2.17-78.el7") + addProvide groupid_1000 "ld-linux-x86-64.so.2()(64bit)" Nothing + addProvide groupid_1000 "ld-linux-x86-64.so.2(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_1000 "ld-linux-x86-64.so.2(GLIBC_2.3)(64bit)" Nothing + addProvide groupid_1000 "libCNS.so()(64bit)" Nothing + addProvide groupid_1000 "libGB.so()(64bit)" Nothing + addProvide groupid_1000 "libISOIR165.so()(64bit)" Nothing + addProvide groupid_1000 "libJIS.so()(64bit)" Nothing + addProvide groupid_1000 "libJISX0213.so()(64bit)" Nothing + addProvide groupid_1000 "libKSC.so()(64bit)" Nothing + addProvide groupid_1000 "libc.so.6()(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.10)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.11)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.12)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.13)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.14)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.15)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.17)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.3)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.3.2)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.3.3)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.3.4)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.4)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.7)(64bit)" Nothing + addProvide groupid_1000 "libc.so.6(GLIBC_2.8)(64bit)" Nothing + addProvide groupid_1000 "libdl.so.2()(64bit)" Nothing + addProvide groupid_1000 "libdl.so.2(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_1000 "libm.so.6()(64bit)" Nothing + addProvide groupid_1000 "libm.so.6(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_1000 "libnsl.so.1()(64bit)" Nothing + addProvide groupid_1000 "libnsl.so.1(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_1000 "libnss_files.so.2()(64bit)" Nothing + addProvide groupid_1000 "libpthread.so.0()(64bit)" Nothing + addProvide groupid_1000 "libpthread.so.0(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_1000 "libpthread.so.0(GLIBC_2.3.2)(64bit)" Nothing + addProvide groupid_1000 "libpthread.so.0(GLIBC_2.3.3)(64bit)" Nothing + addProvide groupid_1000 "libresolv.so.2()(64bit)" Nothing + addProvide groupid_1000 "libresolv.so.2(GLIBC_2.2.5)(64bit)" Nothing + addProvide groupid_1000 "libresolv.so.2(GLIBC_2.9)(64bit)" Nothing + addProvide groupid_1000 "rtld(GNU_HASH)" Nothing + void $ insertGroupKeyValue (TextKey "rpm-conflict") "kernel" (Just "kernel < 2.6.32") groupid_1000 + void $ insertGroupKeyValue (TextKey "rpm-conflict") "binutils" (Just "binutils < 2.19.51.0.10") groupid_1000 + void $ insertGroupKeyValue (TextKey "rpm-conflict") "prelink" (Just "prelink < 0.4.2") groupid_1000 + void $ insertGroupKeyValue (TextKey "rpm-obsolete") "glibc-profile" (Just "glibc-profile < 2.4") groupid_1000 + void $ insertGroupKeyValue (TextKey "rpm-obsolete") "nss_db" (Just "nss_db") groupid_1000 + addReq groupid_1000 "config(glibc) = 2.17-78.el7" + addReq groupid_1000 "ld-linux-x86-64.so.2()(64bit)" + addReq groupid_1000 "ld-linux-x86-64.so.2(GLIBC_2.2.5)(64bit)" + addReq groupid_1000 "ld-linux-x86-64.so.2(GLIBC_2.3)(64bit)" + addReq groupid_1000 "libCNS.so()(64bit)" + addReq groupid_1000 "libGB.so()(64bit)" + addReq groupid_1000 "libISOIR165.so()(64bit)" + addReq groupid_1000 "libJIS.so()(64bit)" + addReq groupid_1000 "libJISX0213.so()(64bit)" + addReq groupid_1000 "libKSC.so()(64bit)" + addReq groupid_1000 "libc.so.6()(64bit)" + addReq groupid_1000 "libc.so.6(GLIBC_2.14)(64bit)" + addReq groupid_1000 "libc.so.6(GLIBC_2.2.5)(64bit)" + addReq groupid_1000 "libc.so.6(GLIBC_2.3)(64bit)" + addReq groupid_1000 "libc.so.6(GLIBC_2.3.2)(64bit)" + addReq groupid_1000 "libc.so.6(GLIBC_2.3.3)(64bit)" + addReq groupid_1000 "libc.so.6(GLIBC_2.4)(64bit)" + addReq groupid_1000 "libdl.so.2()(64bit)" + addReq groupid_1000 "libdl.so.2(GLIBC_2.2.5)(64bit)" + addReq groupid_1000 "libnsl.so.1()(64bit)" + addReq groupid_1000 "libnsl.so.1(GLIBC_2.2.5)(64bit)" + addReq groupid_1000 "libnss_files.so.2()(64bit)" + addReq groupid_1000 "libpthread.so.0()(64bit)" + addReq groupid_1000 "libpthread.so.0(GLIBC_2.2.5)(64bit)" + addReq groupid_1000 "libresolv.so.2()(64bit)" + addReq groupid_1000 "libresolv.so.2(GLIBC_2.2.5)(64bit)" + addReq groupid_1000 "libresolv.so.2(GLIBC_2.9)(64bit)" + addReq groupid_1000 "glibc-common = 2.17-78.el7" + addReq groupid_1000 "libfreebl3.so()(64bit)" + addReq groupid_1000 "libfreebl3.so(NSSRAWHASH_3.12.3)(64bit)" + + withGlibcUpgrade :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT (NoLoggingT (ResourceT (ExceptT e m))) a -> m (Either e a) + withGlibcUpgrade action = (runExceptT . withDb) (addGlibcUpgrade >> action) diff --git a/src/tests/BDCS/DepsolveSpec.hs b/src/tests/BDCS/DepsolveSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/BDCS/DepsolveSpec.hs @@ -0,0 +1,189 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +module BDCS.DepsolveSpec(spec) + where + +import Control.Monad.Except(runExceptT) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Test.Hspec + +import BDCS.Depsolve + +{-# ANN module "HLint: ignore Reduce duplication" #-} + +spec :: Spec +spec = do + describe "BDCS.Depsolve.formulaToCNF tests" $ do + it "atom" $ + formulaToCNF (Atom '1') `shouldBe` [[CNFAtom (CNFOriginal '1')]] + + it "not" $ + formulaToCNF (Not '1') `shouldBe` [[CNFNot (CNFOriginal '1')]] + + it "and" $ + formulaToCNF (And [Atom '1', Atom '2', Atom '3', Atom '4']) `shouldBe` [[CNFAtom (CNFOriginal '1')], + [CNFAtom (CNFOriginal '2')], + [CNFAtom (CNFOriginal '3')], + [CNFAtom (CNFOriginal '4')]] + + it "Or 0 items" $ + formulaToCNF (Or [] :: Formula ()) `shouldBe` ([[]] :: CNFFormula ()) + + it "Or 1 item" $ + formulaToCNF (Or [Atom '1']) `shouldBe` [[CNFAtom (CNFOriginal '1')]] + + -- See the comment in formulaToCNF for more detail. In short, for 1 OR 2 OR 3: + -- start with (1) OR (2 OR 3) ==> (sub 0 -> 1) AND (NOT(sub 0) -> (2 OR 3)) + -- the left half becomes (NOT(sub0) OR 1), which is the first part of the result + -- the right half becomes (sub0 OR (2 OR 3)) + -- recurse on (2 OR 3), adding sub0 to the front of each result + + it "Or 2 items" $ + formulaToCNF (Or [Atom '1', Atom '2']) `shouldBe` [[CNFNot (CNFSubstitute 0), + CNFAtom (CNFOriginal '1')], + [CNFAtom (CNFSubstitute 0), + CNFAtom (CNFOriginal '2')]] + it "Or 3 items" $ + formulaToCNF (Or [Atom '1', Atom '2', Atom '3']) `shouldBe` [[CNFNot (CNFSubstitute 0), + CNFAtom (CNFOriginal '1')], + [CNFAtom (CNFSubstitute 0), + CNFNot (CNFSubstitute 1), + CNFAtom (CNFOriginal '2')], + [CNFAtom (CNFSubstitute 0), + CNFAtom (CNFSubstitute 1), + CNFAtom (CNFOriginal '3')]] + + describe "BDCS.Depsolve.pureLiteralEliminate tests" $ do + it "pureLiteralEliminate, empty list" $ + pureLiteralEliminate Set.empty Map.empty ([] :: CNFFormula Char) `shouldBe` Map.empty + + it "already assigned, matches" $ do + let assignments = Map.singleton (CNFOriginal '1') True + let formula = [[CNFAtom (CNFOriginal '1')]] + let solution = assignments + pureLiteralEliminate Set.empty assignments formula `shouldBe` solution + + it "already assigned, does not match" $ do + let assignments = Map.singleton (CNFOriginal '1') True + let formula = [[CNFNot (CNFOriginal '1')]] + let solution = Map.empty + pureLiteralEliminate Set.empty assignments formula `shouldBe` solution + + it "pureLiteralEliminate, pure, appears once" $ do + let assignments = Map.empty + let formula = [[CNFAtom (CNFOriginal '1')]] + let solution = Map.singleton (CNFOriginal '1') True + pureLiteralEliminate Set.empty assignments formula `shouldBe` solution + + it "pure, appears once negative" $ do + let assignments = Map.empty + let formula = [[CNFNot (CNFOriginal '1')]] + let solution = Map.singleton (CNFOriginal '1') False + pureLiteralEliminate Set.empty assignments formula `shouldBe` solution + + it "pure, appears multiple times" $ do + let assignments = Map.empty + let formula = [[CNFAtom (CNFOriginal '1')], + [CNFAtom (CNFOriginal '1'), + CNFAtom (CNFOriginal '2')], + [CNFNot (CNFOriginal '2')]] + let solution = Map.singleton (CNFOriginal '1') True + pureLiteralEliminate Set.empty assignments formula `shouldBe` solution + + it "pure, appears multiple times negative" $ do + let assignments = Map.empty + let formula = [[CNFNot (CNFOriginal '1')], + [CNFNot (CNFOriginal '1'), + CNFAtom (CNFOriginal '2')], + [CNFNot (CNFOriginal '2')]] + let solution = Map.singleton (CNFOriginal '1') False + pureLiteralEliminate Set.empty assignments formula `shouldBe` solution + + it "unpure" $ do + let assignments = Map.empty + let formula = [[CNFAtom (CNFOriginal '1')], + [CNFNot (CNFOriginal '1')]] + let solution = Map.empty + pureLiteralEliminate Set.empty assignments formula `shouldBe` solution + + it "unpure 2" $ do + let assignments = Map.empty + let formula = [[CNFAtom (CNFOriginal '1'), + CNFNot (CNFOriginal '1')], + [CNFNot (CNFOriginal '1')]] + let solution = Map.empty + pureLiteralEliminate Set.empty assignments formula `shouldBe` solution + + describe "BDCS.Depsolve.unitPropagate tests" $ do + it "empty list" $ + runExceptT (unitPropagate Map.empty ([] :: CNFFormula Char)) >>= + (`shouldBe` Right (Map.empty, [])) + + it "one thing" $ + runExceptT (unitPropagate Map.empty [[CNFAtom (CNFOriginal '1')]]) >>= + (`shouldBe` Right (Map.singleton (CNFOriginal '1') True, [])) + + it "unit then elimate clause" $ do + let assignments = Map.empty + let formula = [[CNFAtom (CNFOriginal '1')], + [CNFAtom (CNFOriginal '1'), + CNFNot (CNFOriginal '2')]] + let assignments' = Map.singleton (CNFOriginal '1') True + let formula' = [] + runExceptT (unitPropagate assignments formula) >>= (`shouldBe` Right (assignments', formula')) + + it "unit then elimate impossible" $ do + let assignments = Map.empty + let formula = [[CNFAtom (CNFOriginal '1')], + [CNFAtom (CNFOriginal '2'), + CNFNot (CNFOriginal '1')]] + let assignments' = Map.singleton (CNFOriginal '1') True + let formula' = [[CNFAtom (CNFOriginal '2')]] + runExceptT (unitPropagate assignments formula) >>= (`shouldBe` Right (assignments', formula')) + + it "unit then repeated" $ do + let assignments = Map.empty + let formula = [[CNFAtom (CNFOriginal '1')], + [CNFAtom (CNFOriginal '1')]] + let assignments' = Map.singleton (CNFOriginal '1') True + let formula' = [] + runExceptT (unitPropagate assignments formula) >>= (`shouldBe` Right (assignments', formula')) + + it "unit then unsolvable unit" $ do + let assignments = Map.empty + let formula = [[CNFAtom (CNFOriginal '1')], + [CNFNot (CNFOriginal '1')]] + runExceptT (unitPropagate assignments formula) >>= (`shouldBe` Left "Unable to solve expression") + + it "units then unsolvable clause" $ do + let assignments = Map.empty + let formula = [[CNFAtom (CNFOriginal '1')], + [CNFAtom (CNFOriginal '2')], + [CNFNot (CNFOriginal '1'), + CNFNot (CNFOriginal '2')]] + runExceptT (unitPropagate assignments formula) >>= (`shouldBe` Left "Unable to solve expression") + + describe "BDCS.Depsolve.solveCNF tests" $ do + it "empty formula" $ do + let formula = [] :: (CNFFormula Char) + let solution = [] :: [DepAssignment Char] + runExceptT (solveCNF formula) >>= (`shouldBe` Right solution) + + it "singleton" $ do + let formula = [[CNFAtom (CNFOriginal '1')]] + let solution = [('1', True)] + runExceptT (solveCNF formula) >>= (`shouldBe` Right solution) diff --git a/src/tests/BDCS/Export/TmpFilesSpec.hs b/src/tests/BDCS/Export/TmpFilesSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/BDCS/Export/TmpFilesSpec.hs @@ -0,0 +1,65 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE OverloadedStrings #-} + +module BDCS.Export.TmpFilesSpec(spec) + where + +import BDCS.Export.TmpFiles + +import Test.Hspec + +spec :: Spec +spec = describe "Export.TmpFiles Tests" $ do + it "New Directory" $ + parseConfString "d /usr/sbin 0740 root root -\n" + `shouldBe` + Right [TmpFileEntry{tfeType=NewDirectory, tfePath="/usr/sbin", tfeMode=Just 0o740, tfeUid=Just "root", tfeGid=Just "root", tfeAge=Nothing, tfeArg=Nothing}] + + it "Modify Directory" $ + parseConfString "e /etc/pki/secrets 0700 pki pki -\n" + `shouldBe` + Right [TmpFileEntry{tfeType=ModifyDirectory, tfePath="/etc/pki/secrets", tfeMode=Just 0o700, tfeUid=Just "pki", tfeGid=Just "pki", tfeAge=Nothing, tfeArg=Nothing}] + + it "New File, no content" $ + parseConfString "f /etc/bdcs.conf 0700 weldr weldr -\n" + `shouldBe` + Right [TmpFileEntry{tfeType=NewFile, tfePath="/etc/bdcs.conf", tfeMode=Just 0o700, tfeUid=Just "weldr", tfeGid=Just "weldr", tfeAge=Nothing, tfeArg=Nothing}] + + it "New File, with content" $ + parseConfString "f /etc/weldr.conf - weldr weldr - I am the content\n" + `shouldBe` + Right [TmpFileEntry{tfeType=NewFile, tfePath="/etc/weldr.conf", tfeMode=Nothing, tfeUid=Just "weldr", tfeGid=Just "weldr", tfeAge=Nothing, tfeArg=Just "I am the content"}] + + it "New Symlink" $ + parseConfString "L /var/run - - - - ../run\n" + `shouldBe` + Right [TmpFileEntry{tfeType=NewSymlink, tfePath="/var/run", tfeMode=Nothing, tfeUid=Nothing, tfeGid=Nothing, tfeAge=Nothing, tfeArg=Just "../run"}] + + it "Replace Symlink" $ + parseConfString "L+ /var/lock - - - - ../run/lock\n" + `shouldBe` + Right [TmpFileEntry{tfeType=ReplaceSymlink, tfePath="/var/lock", tfeMode=Nothing, tfeUid=Nothing, tfeGid=Nothing, tfeAge=Nothing, tfeArg=Just "../run/lock"}] + + it "Parse multiple entries" $ + parseConfString "L+ /var/lock - - - - ../run/lock\nL /var/run - - - - ../run\nf /etc/bdcs.conf 0700 weldr weldr -\n" + `shouldBe` + Right [ + TmpFileEntry{tfeType=ReplaceSymlink, tfePath="/var/lock", tfeMode=Nothing, tfeUid=Nothing, tfeGid=Nothing, tfeAge=Nothing, tfeArg=Just "../run/lock"}, + TmpFileEntry{tfeType=NewSymlink, tfePath="/var/run", tfeMode=Nothing, tfeUid=Nothing, tfeGid=Nothing, tfeAge=Nothing, tfeArg=Just "../run"}, + TmpFileEntry{tfeType=NewFile, tfePath="/etc/bdcs.conf", tfeMode=Just 0o700, tfeUid=Just "weldr", tfeGid=Just "weldr", tfeAge=Nothing, tfeArg=Nothing} + ] + diff --git a/src/tests/BDCS/GroupsSpec.hs b/src/tests/BDCS/GroupsSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/BDCS/GroupsSpec.hs @@ -0,0 +1,88 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module BDCS.GroupsSpec(spec) + where + +import BDCS.DB(Groups(..)) +import BDCS.Groups(nevraToGroupId) +import BDCS.GroupKeyValue(insertGroupKeyValue) +import BDCS.KeyType(KeyType(..)) + +import Control.Monad(void) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Logger(NoLoggingT) +import Control.Monad.Trans.Resource(MonadBaseControl, ResourceT) +import Database.Persist.Sql(SqlPersistT, insertKey, toSqlKey) +import Test.Hspec + +import Utils(withDb) + +spec :: Spec +spec = describe "BDCS.Groups Tests" $ do + it "nevraToGroupId, has epoch" $ + -- gid <- withNevras $ nevraToGroupId ("hasEpoch", Just "7", "1.0", "1.el7", "x86_64") + -- gid `shouldBe` Just (toSqlKey 1) + withNevras (nevraToGroupId ("hasEpoch", Just "7", "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Just (toSqlKey 1)) + + it "nevraToGroupId, no epoch" $ + withNevras (nevraToGroupId ("noEpoch", Nothing, "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Just (toSqlKey 2)) + + it "nevraToGroupId, has epoch, not specified" $ + withNevras (nevraToGroupId ("hasEpoch", Nothing, "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Nothing) + + it "nevraToGroupId, no epoch, is specified" $ + withNevras (nevraToGroupId ("noEpoch", Just "7", "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Nothing) + + it "nevraToGroupId, has wrong epoch" $ + withNevras (nevraToGroupId ("hasEpoch", Just "8", "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Nothing) + + it "nevraToGroupId, wrong name" $ + withNevras (nevraToGroupId ("missingEpoch", Just "7", "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Nothing) + + it "nevraToGroupId, wrong version" $ + withNevras (nevraToGroupId ("hasEpoch", Just "7", "1.1", "1.el7", "x86_64")) >>= (`shouldBe` Nothing) + + it "nevraToGroupId, wrong release" $ + withNevras (nevraToGroupId ("hasEpoch", Just "7", "1.0", "2.el7", "x86_64")) >>= (`shouldBe` Nothing) + + it "nevraToGroupId, wrong arch" $ + withNevras (nevraToGroupId ("hasEpoch", Just "7", "1.0", "1.el7", "i686")) >>= (`shouldBe` Nothing) + + where + addNevras :: MonadIO m => SqlPersistT m () + addNevras = do + -- hasEpoch-7:1.0-1.el7.x86_64 + let gid_1 = toSqlKey 1 + insertKey gid_1 $ Groups "hasEpoch" "rpm" Nothing + void $ insertGroupKeyValue (TextKey "name") "hasEpoch" Nothing gid_1 + void $ insertGroupKeyValue (TextKey "epoch") "7" Nothing gid_1 + void $ insertGroupKeyValue (TextKey "version") "1.0" Nothing gid_1 + void $ insertGroupKeyValue (TextKey "release") "1.el7" Nothing gid_1 + void $ insertGroupKeyValue (TextKey "arch") "x86_64" Nothing gid_1 + + -- noEpoch-1.0-1.el7.x86_64 + let gid_2 = toSqlKey 2 + insertKey gid_2 $ Groups "noEpoch" "rpm" Nothing + void $ insertGroupKeyValue (TextKey "name") "noEpoch" Nothing gid_2 + void $ insertGroupKeyValue (TextKey "version") "1.0" Nothing gid_2 + void $ insertGroupKeyValue (TextKey "release") "1.el7" Nothing gid_2 + void $ insertGroupKeyValue (TextKey "arch") "x86_64" Nothing gid_2 + + withNevras :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT (NoLoggingT (ResourceT m)) a -> m a + withNevras action = withDb (addNevras >> action) diff --git a/src/tests/BDCS/RPM/BuildSpec.hs b/src/tests/BDCS/RPM/BuildSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/BDCS/RPM/BuildSpec.hs @@ -0,0 +1,44 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +module BDCS.RPM.BuildSpec(spec) + where + +import Codec.RPM.Tags(Tag(..)) +import Control.Exception(evaluate) +import Test.Hspec + +import BDCS.DB(Builds(..)) +import BDCS.Exceptions(DBException(..)) +import BDCS.RPM.Builds(mkBuild) + +import Utils(fakeKey) + +spec :: Spec +spec = describe "BDCS.RPM.Builds Tests" $ do + it "Handles no Epoch" $ + buildsEpoch (mkBuild [ Release "1", Arch "x86-64", BuildTime 0, ChangeLogText [""] ] fakeKey) `shouldBe` 0 + + it "No Release raises" $ + evaluate (mkBuild [ Arch "x86-64", BuildTime 0, ChangeLogText [""] ] fakeKey) `shouldThrow` (== MissingRPMTag "Release") + + it "No Arch raises" $ + evaluate (mkBuild [ Release "1", BuildTime 0, ChangeLogText [""] ] fakeKey) `shouldThrow` (== MissingRPMTag "Arch") + + it "No BuildTime raises" $ + evaluate (mkBuild [ Release "1", Arch "x86-64", ChangeLogText [""] ] fakeKey) `shouldThrow` (== MissingRPMTag "BuildTime") + + it "No ChangeLogText raises" $ + evaluate (mkBuild [ Release "1", Arch "x86-64", BuildTime 0 ] fakeKey) `shouldThrow` (== MissingRPMTag "ChangeLogText") diff --git a/src/tests/BDCS/RPM/ProjectsSpec.hs b/src/tests/BDCS/RPM/ProjectsSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/BDCS/RPM/ProjectsSpec.hs @@ -0,0 +1,40 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE OverloadedStrings #-} + +module BDCS.RPM.ProjectsSpec(spec) + where + +import Codec.RPM.Tags(Tag(..)) +import Control.Exception(evaluate) +import Test.Hspec + +import BDCS.Exceptions(DBException(..)) +import BDCS.RPM.Projects(mkProject) + +spec :: Spec +spec = describe "BDCS.RPM.Projects Tests" $ do + it "No SourceRPM raises" $ + evaluate (mkProject [ Summary "", Description "" ]) `shouldThrow` (== MissingRPMTag "SourceRPM") + + it "No Summary raises" $ + evaluate (mkProject [ SourceRPM "a-1-1.src.rpm", Description "" ]) `shouldThrow` (== MissingRPMTag "Summary") + + it "No Description raises" $ + evaluate (mkProject [ SourceRPM "a-1-1.src.rpm", Summary "" ]) `shouldThrow` (== MissingRPMTag "Description") + + -- FIXME: TESTS TO ADD: + -- * srpmToName in BDCS/RPM/Projects.hs assumes the string it's given is properly formatted diff --git a/src/tests/BDCS/RPM/SignaturesSpec.hs b/src/tests/BDCS/RPM/SignaturesSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/BDCS/RPM/SignaturesSpec.hs @@ -0,0 +1,33 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +module BDCS.RPM.SignaturesSpec(spec) + where + +import Control.Exception(evaluate) +import Test.Hspec + +import BDCS.Exceptions(DBException(..)) +import BDCS.RPM.Signatures(mkRSASignature, mkSHASignature) + +import Utils(fakeKey) + +spec :: Spec +spec = describe "BDCS.RPM.Signatures Tests" $ do + it "No RSAHeader raises" $ + evaluate (mkRSASignature [ ] fakeKey) `shouldThrow` (== MissingRPMTag "RSAHeader") + + it "No SHA1Header raises" $ + evaluate (mkSHASignature [ ] fakeKey) `shouldThrow` (== MissingRPMTag "SHA1Header") diff --git a/src/tests/BDCS/RPM/SourcesSpec.hs b/src/tests/BDCS/RPM/SourcesSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/BDCS/RPM/SourcesSpec.hs @@ -0,0 +1,35 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . +-- + +module BDCS.RPM.SourcesSpec(spec) + where + +import Codec.RPM.Tags(Tag(..)) +import Control.Exception(evaluate) +import Test.Hspec + +import BDCS.Exceptions(DBException(..)) +import BDCS.RPM.Sources(mkSource) + +import Utils(fakeKey) + +spec :: Spec +spec = describe "BDCS.RPM.Sources Tests" $ do + it "No License raises" $ + evaluate (mkSource [ Version "" ] fakeKey) `shouldThrow` (== MissingRPMTag "License") + + it "No Version raises" $ + evaluate (mkSource [ License "" ] fakeKey) `shouldThrow` (== MissingRPMTag "Version") diff --git a/src/tests/BDCS/RPM/UtilsSpec.hs b/src/tests/BDCS/RPM/UtilsSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/BDCS/RPM/UtilsSpec.hs @@ -0,0 +1,49 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE OverloadedStrings #-} + +module BDCS.RPM.UtilsSpec(spec) + where + +import Test.Hspec + +import BDCS.RPM.Utils(splitFilename) + +spec :: Spec +spec = describe "BDCS.RPM.Utils Tests" $ do + it "N-E:V-R.A.rpm" $ + splitFilename "libwhatever-7:1.0-1.el7.x86_64.rpm" `shouldBe` ("libwhatever", Just "7", "1.0", "1.el7", "x86_64") + + it "no .rpm" $ + splitFilename "libwhatever-7:1.0-1.el7.x86_64" `shouldBe` ("libwhatever", Just "7", "1.0", "1.el7", "x86_64") + + it "no epoch" $ + splitFilename "libwhatever-1.0-1.el7.x86_64.rpm" `shouldBe` ("libwhatever", Nothing, "1.0", "1.el7", "x86_64") + + it "no epoch or .rpm" $ + splitFilename "libwhatever-1.0-1.el7.x86_64" `shouldBe` ("libwhatever", Nothing, "1.0", "1.el7", "x86_64") + + it "hyphen in name, no epoch" $ + splitFilename "libwhatever-ng-1.0-1.el7.x86_64" `shouldBe` ("libwhatever-ng", Nothing, "1.0", "1.el7", "x86_64") + + it "hyphen in name with epoch" $ + splitFilename "libwhatever-ng-7:1.0-1.el7.x86_64" `shouldBe` ("libwhatever-ng", Just "7", "1.0", "1.el7", "x86_64") + + it "numbers in name, no epoch" $ + splitFilename "libwhatever-ng2-1.0-1.el7.x86_64" `shouldBe` ("libwhatever-ng2", Nothing, "1.0", "1.el7", "x86_64") + + it "numbers in name with epoch" $ + splitFilename "libwhatever-ng2-7:1.0-1.el7.x86_64" `shouldBe` ("libwhatever-ng2", Just "7", "1.0", "1.el7", "x86_64") diff --git a/src/tests/Spec.hs b/src/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/src/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/tests/Utils.hs b/src/tests/Utils.hs new file mode 100644 --- /dev/null +++ b/src/tests/Utils.hs @@ -0,0 +1,42 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . +-- +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Utils(fakeKey, + withDb) + where + +import Control.Monad(void) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Trans.Resource(MonadBaseControl, ResourceT) +import Control.Monad.Logger(NoLoggingT) +import Database.Persist.Sql(Key, SqlBackend, SqlPersistT, ToBackendKey, runMigrationSilent, toSqlKey) +import Database.Persist.Sqlite(runSqlite) + +import BDCS.DB + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +fakeKey :: ToBackendKey SqlBackend a => Key a +fakeKey = toSqlKey 0 + +-- Run a database action within an in-memory test database +withDb :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT (NoLoggingT (ResourceT m)) a -> m a +withDb action = runSqlite ":memory:" (initDb >> action) + where + initDb :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT m () + initDb = void $ runMigrationSilent migrateAll diff --git a/src/tools/Utils/GetOpt.hs b/src/tools/Utils/GetOpt.hs new file mode 100644 --- /dev/null +++ b/src/tools/Utils/GetOpt.hs @@ -0,0 +1,20 @@ +module Utils.GetOpt(OptClass, + commandLineArgs, + compilerOpts) + where + +import System.Console.GetOpt + +class OptClass a + +commandLineArgs :: [String] -> Maybe (String, FilePath, [String]) +commandLineArgs (db:repo:args) = Just (db, repo, args) +commandLineArgs _ = Nothing + +compilerOpts :: OptClass a => [OptDescr (a -> a)] -> a -> [String] -> String -> IO (a, [String]) +compilerOpts options defaults argv cmdName = + case getOpt Permute options argv of + (o, n, []) -> return (foldl (flip id) defaults o, n) + (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options)) + where + header = "Usage: " ++ cmdName ++ " [OPTIONS]" diff --git a/src/tools/Utils/Subcommands.hs b/src/tools/Utils/Subcommands.hs new file mode 100644 --- /dev/null +++ b/src/tools/Utils/Subcommands.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Utils.Subcommands(runSubcommand) + where + +import Control.Conditional(condM, ifM, otherwiseM) +import Control.Exception(SomeException, catch) +import Control.Monad.Loops(firstM) +import Data.Text(pack, splitOn, unpack) +import System.Directory(doesFileExist) +import System.Environment(lookupEnv) +import System.Exit(exitFailure) +import System.FilePath(()) +import System.Process(callProcess) + +import Paths_bdcs(getLibexecDir) + +getBasePath :: String -> IO FilePath +getBasePath masterCmdName = do + dir <- getLibexecDir + return $ dir masterCmdName + +findInPath :: FilePath -> IO (Maybe FilePath) +findInPath sought = lookupEnv "PATH" >>= \case + Nothing -> return Nothing + Just p -> do let searchPath = splitOn ":" (pack p) + fmap (\d -> unpack d sought) <$> + firstM (\d -> doesFileExist (unpack d sought)) searchPath + +existsInPath :: FilePath -> IO Bool +existsInPath sought = fmap (/= Nothing) (findInPath sought) + +runSubcommand :: String -> String -> [String] -> [(String, String)] -> IO () -> IO () +runSubcommand basecmdPrefix subcmd subcmdArgs knownSubcommands usage = do + basePath <- getBasePath basecmdPrefix + + let cmd1 = basePath ++ subcmd + let cmd2 = basecmdPrefix ++ subcmd + + case subcmd `lookup` knownSubcommands of + -- This is a subcommand we have built-in knowledge of. For ease of development, it + -- could be located in a couple different places: Installed in /usr/libexec/weldr, + -- or in the $PATH. The latter allows us to run "PATH=$PATH:dist/build/... cabal run" + -- without having to run "cabal install" every time we want to test something. + -- + -- While tryCallProcess will search the $PATH itself, we need to know if the file + -- exists somewhere in the $PATH first. This allows us to separate file not found + -- errors from the command failing. + Just _ -> condM [(doesFileExist cmd1, tryCallProcess cmd1 subcmdArgs), + (existsInPath cmd1, tryCallProcess cmd1 subcmdArgs), + (doesFileExist cmd2, tryCallProcess cmd2 subcmdArgs), + (existsInPath cmd2, tryCallProcess cmd2 subcmdArgs), + (otherwiseM, putStrLn ("subcommand " ++ subcmd ++ " does not exist\n") >> usage)] + + -- This is a subcommand we know nothing about. Check to see if it exists in + -- /usr/libexec/weldr, since it could have been installed by a third party. If so, + -- run that. If not, display an error message and quit. + Nothing -> ifM (doesFileExist cmd1) + (tryCallProcess cmd1 subcmdArgs) + (putStrLn ("subcommand " ++ subcmd ++ " does not exist\n") >> usage) + where + tryCallProcess cmd args = catch (callProcess cmd args) + -- We handled the case where an unknown subcommand was + -- given on the command line. For now, the only other + -- errors possible are when the subcommand ran, but + -- failed for some reason. Those are handled inside + -- the subcommand. Just quit. + (\(_ :: SomeException) -> exitFailure) diff --git a/src/tools/bdcs-tmpfiles.hs b/src/tools/bdcs-tmpfiles.hs new file mode 100644 --- /dev/null +++ b/src/tools/bdcs-tmpfiles.hs @@ -0,0 +1,42 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +import Control.Monad(when) +import System.Directory(createDirectoryIfMissing) +import System.Environment(getArgs) +import System.Exit(exitFailure) + +import BDCS.Export.TmpFiles(setupFilesystem) +import BDCS.Version + +usage :: IO () +usage = do + printVersion "bdcs-tmpfiles" + putStrLn "Usage: bdcs-tmpfiles " + putStrLn " config should be a systemd tmpfiles.d configuration file." + putStrLn " dest should be a destination directory." + exitFailure + +{-# ANN main ("HLint: ignore Use head" :: String) #-} +main :: IO () +main = do + argv <- getArgs + + when (length argv /= 2) usage + + let cfg = argv !! 0 + let dir = argv !! 1 + createDirectoryIfMissing True dir + setupFilesystem dir cfg diff --git a/src/tools/bdcs.hs b/src/tools/bdcs.hs new file mode 100644 --- /dev/null +++ b/src/tools/bdcs.hs @@ -0,0 +1,52 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad(forM_, when) +import System.Environment(getArgs) +import System.Exit(exitFailure) + +import BDCS.Version + +import Utils.Subcommands(runSubcommand) + +-- A mapping from a subcommand name to a brief description of what it does. +knownSubcommands :: [(String, String)] +knownSubcommands = [ + ("depsolve", "print a list of all the dependencies of some object"), + ("export", "extract objects from the content store and build an image"), + ("import", "load packages into the content store"), + ("inspect", "inspect the contents of the content store in various ways") + ] + +usage :: IO () +usage = do + printVersion "bdcs" + putStrLn "Usage: bdcs subcommand [args ...]" + putStrLn "- subcommands:" + forM_ knownSubcommands $ \(cmd, help) -> + putStrLn $ " " ++ cmd ++ " - " ++ help + exitFailure + +main :: IO () +main = do + argv <- getArgs + + when (length argv < 1) usage + let subcmd = head argv + subcmdArgs = tail argv + + runSubcommand "bdcs-" subcmd subcmdArgs knownSubcommands usage diff --git a/src/tools/depsolve.hs b/src/tools/depsolve.hs new file mode 100644 --- /dev/null +++ b/src/tools/depsolve.hs @@ -0,0 +1,60 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad.Except(runExceptT) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import System.Environment(getArgs) +import System.Exit(exitFailure) + +import BDCS.DB(checkAndRunSqlite) +import BDCS.Depclose(depclose) +import BDCS.Depsolve(formulaToCNF, solveCNF) +import BDCS.Groups(groupIdToNevra) +import BDCS.Utils.Monad(mapMaybeM) + +import Utils.GetOpt(commandLineArgs) + +runCommand :: FilePath -> [String] -> IO () +runCommand db things = do + let things' = map T.pack things + result <- runExceptT $ checkAndRunSqlite (T.pack db) $ do + formula <- depclose ["x86_64"] things' + solution <- solveCNF (formulaToCNF formula) + + -- solveCNF returns a list of (groupId, bool) assignments. Discard the False ones, + -- and convert the True ids to nevras + mapMaybeM groupIdToNevra $ map fst $ filter snd solution + + case result of + Left e -> putStrLn ("error: " ++ e) >> exitFailure + -- Print the NEVRAs one per line + Right assignments -> mapM_ TIO.putStrLn assignments + +usage :: IO () +usage = do + putStrLn "Usage: depsolve metadata.db NEVRA [NEVRA ...]" + exitFailure + +main :: IO () +main = commandLineArgs <$> getArgs >>= \case + -- The depsolve command doesn't need a content store argument, but that's what commandLineArgs + -- returns. Thus, "repo" here is really the first nevra being passed to depsolve. It's + -- easiest to just continue to use that function and reassemble a correct args list here. + Just (db, repo, args) -> runCommand db (repo : args) + _ -> usage diff --git a/src/tools/export.hs b/src/tools/export.hs new file mode 100644 --- /dev/null +++ b/src/tools/export.hs @@ -0,0 +1,131 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +import Control.Conditional(cond, ifM) +import Control.Monad(unless, when) +import Control.Monad.Except(MonadError, runExceptT) +import Control.Monad.IO.Class(MonadIO, liftIO) +import Data.Conduit(Consumer, (.|), runConduit) +import qualified Data.Conduit.List as CL +import Data.ContentStore(openContentStore, runCsMonad) +import Data.List(isSuffixOf, isPrefixOf, partition) +import qualified Data.Text as T +import System.Directory(doesFileExist, removePathForcibly) +import System.Environment(getArgs) +import System.Exit(exitFailure) + +import qualified BDCS.CS as CS +import BDCS.DB(Files, checkAndRunSqlite) +import qualified BDCS.Export.Directory as Directory +import qualified BDCS.Export.Qcow2 as Qcow2 +import qualified BDCS.Export.Ostree as Ostree +import qualified BDCS.Export.Tar as Tar +import BDCS.Export.Utils(runHacks, runTmpfiles) +import BDCS.Files(groupIdToFilesC) +import BDCS.Groups(getGroupIdC) +import BDCS.Utils.Either(whenLeft) +import BDCS.Utils.Monad(concatMapM) +import BDCS.Version + +import Utils.GetOpt(commandLineArgs) + +-- | Check a list of strings to see if any of them are files +-- If it is, read it and insert its contents in its place +expandFileThings :: [String] -> IO [String] +expandFileThings = concatMapM isThingFile + where + isThingFile :: String -> IO [String] + isThingFile thing = ifM (doesFileExist thing) + (lines <$> readFile thing) + (return [thing]) + +usage :: IO () +usage = do + printVersion "export" + putStrLn "Usage: export metadata.db repo dest thing [thing ...]" + putStrLn "dest can be:" + putStrLn "\t* A directory (which may or may not already exist)" + putStrLn "\t* The name of a .tar file to be created" + putStrLn "\t* The name of a .qcow2 image to be created" + putStrLn "\t* A directory ending in .repo, which will create a new ostree repo" + putStrLn "thing can be:" + putStrLn "\t* The NEVRA of an RPM, e.g. filesystem-3.2-21.el7.x86_64" + putStrLn "\t* A path to a file containing NEVRA of RPMs, 1 per line." + -- TODO group id? + exitFailure + +needFilesystem :: IO () +needFilesystem = do + printVersion "export" + putStrLn "ERROR: The tar needs to have the filesystem package included" + exitFailure + +needKernel :: IO () +needKernel = do + printVersion "export" + putStrLn "ERROR: ostree exports need a kernel package included" + exitFailure + +runCommand :: FilePath -> FilePath -> [String] -> IO () +runCommand db repo args = do + let out_path = head args + allThings <- expandFileThings $ tail args + + cs <- runCsMonad (openContentStore repo) >>= \case + Left e -> print e >> exitFailure + Right r -> return r + + let (match, otherThings) = partition (isPrefixOf "filesystem-") allThings + when (length match < 1) needFilesystem + let things = map T.pack $ head match : otherThings + + when (".repo" `isSuffixOf` out_path) $ + unless (any ("kernel-" `T.isPrefixOf`) things) needKernel + + let (handler, objectSink) = cond [(".tar" `isSuffixOf` out_path, (cleanupHandler out_path, CS.objectToTarEntry .| Tar.tarSink out_path)), + (".qcow2" `isSuffixOf` out_path, (cleanupHandler out_path, Qcow2.qcow2Sink out_path)), + (".repo" `isSuffixOf` out_path, (cleanupHandler out_path, Ostree.ostreeSink out_path)), + (otherwise, (print, directoryOutput out_path))] + + result <- runExceptT $ checkAndRunSqlite (T.pack db) $ runConduit $ CL.sourceList things + .| getGroupIdC + .| groupIdToFilesC + .| CS.filesToObjectsC cs + .| objectSink + + whenLeft result (\e -> handler e >> exitFailure) + where + directoryOutput :: (MonadError String m, MonadIO m) => FilePath -> Consumer (Files, CS.Object) m () + directoryOutput path = do + -- Apply tmpfiles.d to the directory first + liftIO $ runTmpfiles path + + Directory.directorySink path + liftIO $ runHacks path + + cleanupHandler :: Show a => FilePath -> a -> IO () + cleanupHandler path e = print e >> removePathForcibly path + +main :: IO () +main = commandLineArgs <$> getArgs >>= \case + Nothing -> usage + Just (db, repo, args) -> do + when (length args < 2) usage + runCommand db repo args diff --git a/src/tools/import.hs b/src/tools/import.hs new file mode 100644 --- /dev/null +++ b/src/tools/import.hs @@ -0,0 +1,86 @@ +-- Copyright (C) 2016-2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.Conditional(unlessM) +import Control.Exception(catch) +import Control.Monad(forM_) +import Control.Monad.Except(MonadError, runExceptT, throwError) +import Control.Monad.IO.Class(MonadIO, liftIO) +import Control.Monad.Reader(ReaderT, runReaderT) +import Data.ContentStore(CsError(..), mkContentStore) +import Data.List(isSuffixOf) +import Network.URI(URI(..), parseURI) +import System.Directory(doesFileExist) +import System.Environment(getArgs) +import System.Exit(exitFailure) + +import BDCS.Exceptions(DBException) +import qualified BDCS.Import.Comps as Comps +import qualified BDCS.Import.NPM as NPM +import qualified BDCS.Import.RPM as RPM +import qualified BDCS.Import.Repodata as Repodata +import BDCS.Import.URI(isCompsFile, isPrimaryXMLFile) +import BDCS.Import.State(ImportState(..)) +import BDCS.Utils.Either(whenLeft) +import BDCS.Version + +import Utils.GetOpt(commandLineArgs) + +processThing :: String -> ReaderT ImportState IO () +processThing url = case parseURI url of + Just uri@URI{..} -> if | isPrimaryXMLFile uri -> Repodata.loadFromURI uri + | isCompsFile uri -> Comps.loadFromURI uri + | ".rpm" `isSuffixOf` uriPath -> RPM.loadFromURI uri + | uriScheme == "npm:" -> NPM.loadFromURI uri + | otherwise -> Repodata.loadRepoFromURI uri + _ -> liftIO usage + +runCommand :: (MonadError CsError m, MonadIO m) => FilePath -> FilePath -> [String] -> m () +runCommand db repo things = do + cs <- mkContentStore repo + let st = ImportState { stDB=db, stRepo=cs } + + unlessM (liftIO $ doesFileExist db) $ + throwError $ CsError "Database must already exist - create with sqlite3 schema.sql" + + forM_ things $ \path -> + liftIO $ runReaderT (processThing path) st + +usage :: IO () +usage = do + printVersion "import" + putStrLn "Usage: import output.db repo thing [thing ...]" + putStrLn "- repo is the path to an already existing content store repo or " + putStrLn " the path to a repo to be created" + putStrLn "- thing can be:" + putStrLn "\t* An HTTP, HTTPS, or file: URL to an RPM" + putStrLn "\t* A URL to a yum repo primary.xml.gz file" + putStrLn "\t* A URL to a yum repo comps.xml.gz file" + exitFailure + +main :: IO () +main = commandLineArgs <$> getArgs >>= \case + Nothing -> usage + Just (db, repo, args) -> do + result <- catch (runExceptT $ runCommand db repo args) + (\(e :: DBException) -> return $ Left $ CsError $ show e) + whenLeft result (\e -> putStrLn $ "error: " ++ show e) diff --git a/src/tools/inspect/Utils/Exceptions.hs b/src/tools/inspect/Utils/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/tools/inspect/Utils/Exceptions.hs @@ -0,0 +1,11 @@ +module Utils.Exceptions(InspectErrors(..)) + where + +import Control.Exception(Exception) + +data InspectErrors = InvalidLabelError String + | MissingCSError + | MissingDBError + deriving(Eq, Show) + +instance Exception InspectErrors diff --git a/src/tools/inspect/Utils/IO.hs b/src/tools/inspect/Utils/IO.hs new file mode 100644 --- /dev/null +++ b/src/tools/inspect/Utils/IO.hs @@ -0,0 +1,9 @@ +module Utils.IO(liftedPutStrLn) + where + +import Control.Monad.IO.Class(MonadIO, liftIO) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +liftedPutStrLn :: MonadIO m => T.Text -> m () +liftedPutStrLn = liftIO . TIO.putStrLn diff --git a/src/tools/inspect/Utils/KeyVal.hs b/src/tools/inspect/Utils/KeyVal.hs new file mode 100644 --- /dev/null +++ b/src/tools/inspect/Utils/KeyVal.hs @@ -0,0 +1,13 @@ +module Utils.KeyVal(formatKeyValList) + where + +import Data.List(intercalate) +import qualified Data.Text as T +import Text.Printf(printf) + +import BDCS.DB(KeyVal) +import BDCS.KeyValue(formatKeyValue) + +formatKeyValList :: [KeyVal] -> String +formatKeyValList [] = "" +formatKeyValList lst = printf " [%s]" (intercalate ", " (map (T.unpack . formatKeyValue) lst)) diff --git a/src/tools/inspect/inspect.hs b/src/tools/inspect/inspect.hs new file mode 100644 --- /dev/null +++ b/src/tools/inspect/inspect.hs @@ -0,0 +1,57 @@ +-- Copyright (C) 2017 Red Hat, Inc. +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, see . + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad(forM_, when) +import System.Environment(getArgs) +import System.Exit(exitFailure) + +import BDCS.Version + +import Utils.GetOpt(commandLineArgs) +import Utils.Subcommands(runSubcommand) + +-- A mapping from a subcommand name to a brief description of what it does. +knownSubcommands :: [(String, String)] +knownSubcommands = [ + ("groups", "List groups (RPM packages, etc.) in the content store"), + ("ls", "List files in the content store"), + ("nevras", "List NEVRAs of RPM packages in the content store") + ] + +usage :: IO () +usage = do + printVersion "inspect" + putStrLn "Usage: inspect output.db repo subcommand [args ...]" + putStrLn "- output.db is the path to a metadata database" + putStrLn "- repo is the path to a content store repo" + putStrLn "- subcommands:" + forM_ knownSubcommands $ \(cmd, help) -> + putStrLn $ " " ++ cmd ++ " - " ++ help + exitFailure + +main :: IO () +main = commandLineArgs <$> getArgs >>= \case + Just (db, repo, args) -> do + when (null args) usage + + let subcmd = head args + subcmdArgs = [db, repo] ++ tail args + + runSubcommand "inspect-" subcmd subcmdArgs knownSubcommands usage + + _ -> usage diff --git a/src/tools/inspect/subcommands/groups.hs b/src/tools/inspect/subcommands/groups.hs new file mode 100644 --- /dev/null +++ b/src/tools/inspect/subcommands/groups.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.Conditional(unlessM) +import Control.Exception(Handler(..), catches, throw) +import Control.Monad.Except(runExceptT) +import Data.Aeson((.=), ToJSON, object, toJSON) +import Data.Aeson.Encode.Pretty(encodePretty) +import Data.ByteString.Lazy(toStrict) +import qualified Data.Text as T +import Data.Text.Encoding(decodeUtf8) +import Data.Conduit((.|), runConduit) +import qualified Data.Conduit.List as CL +import Database.Persist.Sqlite(Key) +import System.Console.GetOpt +import System.Directory(doesFileExist) +import System.Environment(getArgs) +import System.Exit(exitFailure) +import Text.Printf(printf) +import Text.Regex.PCRE((=~)) + +import BDCS.DB(Groups(..), KeyVal(..), checkAndRunSqlite) +import BDCS.GroupKeyValue(getKeyValuesForGroup) +import BDCS.Groups(groupsC) +import BDCS.KeyValue(keyValueListToJSON) +import BDCS.Utils.Either(whenLeft) +import BDCS.Version + +import Utils.Exceptions(InspectErrors(..)) +import Utils.GetOpt(OptClass, commandLineArgs, compilerOpts) +import Utils.IO(liftedPutStrLn) +import Utils.KeyVal(formatKeyValList) + +data GroupsOptions = GroupsOptions { grpJSONOutput :: Bool, + grpKeyVals :: Bool, + grpMatches :: String } + +instance OptClass GroupsOptions + +defaultGroupsOptions :: GroupsOptions +defaultGroupsOptions = GroupsOptions { grpJSONOutput = False, + grpKeyVals = False, + grpMatches = ".*" } + +data GroupsRow = GroupsRow { rowId :: Key Groups, + rowKeyVals :: Maybe [KeyVal], + rowName :: T.Text } + +instance ToJSON GroupsRow where + toJSON r = let namePair = T.pack "groupName" .= toJSON (rowName r) + keyvals = maybe [] keyValueListToJSON (rowKeyVals r) + in + object (namePair : keyvals) + +initRow :: (Key Groups, T.Text) -> GroupsRow +initRow (key, name) = GroupsRow { rowId=key, + rowKeyVals=Nothing, + rowName=name } + +runCommand :: T.Text -> FilePath -> [String] -> IO (Either String ()) +runCommand db _ args = do + (opts, _) <- compilerOpts options defaultGroupsOptions args "groups" + let printer = if grpJSONOutput opts then jsonPrinter else textPrinter + + runExceptT $ checkAndRunSqlite db $ runConduit $ + -- Grab all the Groups, filtering out any whose name does not match what we want. + groupsC .| CL.filter (\(_, n) -> T.unpack n =~ grpMatches opts) + -- Convert them into GroupsRow records. + .| CL.map initRow + -- If we were asked for keyval output, add that to the GroupsRow. + .| CL.mapM (\row -> if grpKeyVals opts then do + kvs <- getKeyValuesForGroup (rowId row) Nothing + return $ row { rowKeyVals=Just kvs } + else return row) + -- Finally, pass it to the printer. + .| CL.mapM_ (liftedPutStrLn . printer) + where + options :: [OptDescr (GroupsOptions -> GroupsOptions)] + options = [ + Option [] ["json"] + (NoArg (\opts -> opts { grpJSONOutput = True })) + "format output as JSON", + Option ['k'] ["keyval"] + (NoArg (\opts -> opts { grpKeyVals = True })) + "add key/val pairs to output", + Option ['m'] ["matches"] + (ReqArg (\d opts -> opts { grpMatches = d }) "REGEX") + "return only results that match REGEX" + ] + + -- Note: The docs say that toStrict is an expensive operation that should be used carefully. + -- I think it's okay here because we are only dealing with one row of output at a time, so + -- it should be pretty small amounts of data to convert. + jsonPrinter :: GroupsRow -> T.Text + jsonPrinter = decodeUtf8 . toStrict . encodePretty + + textPrinter :: GroupsRow -> T.Text + textPrinter GroupsRow{..} = T.pack $ + printf "%s%s" + rowName + (maybe "" formatKeyValList rowKeyVals) + +usage :: IO () +usage = do + printVersion "inspect-groups" + putStrLn "Usage: inspect-groups output.db repo [args ...]" + putStrLn " List groups (RPM packages, etc.) in the content store" + putStrLn "- output.db is the path to a metadata database" + putStrLn "- repo is the path to a content store repo" + exitFailure + +runMain :: IO () +runMain = do + argv <- getArgs + case commandLineArgs argv of + Nothing -> usage + Just (db, repo, args) -> do + unlessM (doesFileExist db) $ + throw MissingDBError + + result <- runCommand (T.pack db) repo args + whenLeft result (\e -> print $ "error: " ++ e) + +main :: IO () +main = + -- Add handlers for other exception types (IOException, whatever) here. + runMain `catches` [Handler (\(e :: InspectErrors) -> handleInspectErrors e)] + where + -- And then add handlers for the various kinds of InspectErrors here. + handleInspectErrors :: InspectErrors -> IO () + handleInspectErrors MissingDBError = putStrLn "Metadata database does not exist\n" >> usage + + handleInspectErrors _ = usage diff --git a/src/tools/inspect/subcommands/ls.hs b/src/tools/inspect/subcommands/ls.hs new file mode 100644 --- /dev/null +++ b/src/tools/inspect/subcommands/ls.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.Conditional(unlessM) +import Control.Exception(Handler(..), catches, throw) +import Control.Monad(forM_) +import Control.Monad.Except(runExceptT) +import Data.Aeson((.=), ToJSON, object, toJSON) +import Data.Aeson.Encode.Pretty(encodePretty) +import Data.ByteString.Lazy(toStrict) +import Data.Conduit((.|), runConduit) +import qualified Data.Conduit.List as CL +import Data.Maybe(catMaybes, fromMaybe, isJust, mapMaybe) +import qualified Data.Text as T +import Data.Text.Encoding(decodeUtf8) +import Data.Time.Clock.POSIX(getCurrentTime, posixSecondsToUTCTime) +import Data.Time.Format(defaultTimeLocale, formatTime) +import System.Console.GetOpt +import System.Directory(doesFileExist) +import System.Environment(getArgs) +import System.Exit(exitFailure) +import Text.Printf(printf) +import Text.Regex.PCRE((=~)) + +import BDCS.DB(Files(..), KeyVal(..), checkAndRunSqlite) +import BDCS.Files(filesC, getKeyValuesForFile) +import BDCS.KeyType(KeyType(..)) +import BDCS.KeyValue(keyValueListToJSON) +import BDCS.Label.Types(Label, labelDescriptions) +import BDCS.Utils.Either(whenLeft) +import BDCS.Utils.Mode(modeAsText) +import BDCS.Version + +import Utils.Exceptions(InspectErrors(..)) +import Utils.GetOpt(OptClass, commandLineArgs, compilerOpts) +import Utils.IO(liftedPutStrLn) +import Utils.KeyVal(formatKeyValList) + +data LsOptions = LsOptions { lsJSONOutput :: Bool, + lsKeyVal :: Bool, + lsLabelMatches :: Maybe Label, + lsMatches :: String, + lsVerbose :: Bool } + +instance OptClass LsOptions + +defaultLsOptions :: LsOptions +defaultLsOptions = LsOptions { lsJSONOutput = False, + lsKeyVal = False, + lsLabelMatches = Nothing, + lsMatches = ".*", + lsVerbose = False } + +data LsRow = LsRow { rowFiles :: Files, + rowKeyVals :: Maybe [KeyVal], + rowUseMetadata :: Bool } + +instance ToJSON LsRow where + toJSON r = let namePair = T.pack "path" .= toJSON (filesPath $ rowFiles r) + keyvals = maybe [] keyValueListToJSON (rowKeyVals r) + optional = if not (rowUseMetadata r) then [] else catMaybes [ + fileTypeString (rowFiles r) >>= \ty -> Just $ T.pack "fileType" .= toJSON ty, + Just $ T.pack "mode" .= toJSON (filesMode $ rowFiles r), + Just $ T.pack "size" .= toJSON (filesSize $ rowFiles r), + symlinkTarget (rowFiles r) >>= \target -> Just $ T.pack "symlinkTarget" .= toJSON target, + + Just $ T.pack "user" .= toJSON (filesFile_user $ rowFiles r), + Just $ T.pack "group" .= toJSON (filesFile_group $ rowFiles r), + + -- Don't do any special formatting of the mtime - leave that up to the consumer. + Just $ T.pack "mtime" .= toJSON (filesMtime $ rowFiles r) + ] + in + object $ [namePair] ++ keyvals ++ optional + +initRow :: Files -> LsRow +initRow f = LsRow { rowFiles=f, + rowUseMetadata=False, + rowKeyVals=Nothing } + +fileType :: Files -> Maybe Char +fileType Files{filesCs_object=Nothing, ..} = Just 'd' +fileType Files{filesTarget=Just _, ..} = Just 'l' +fileType _ = Nothing + +fileTypeString :: Files -> Maybe String +fileTypeString Files{filesCs_object=Nothing, ..} = Just "Directory" +fileTypeString Files{filesTarget=Just _, ..} = Just "Symlink" +fileTypeString _ = Just "File" + +-- Figure out how to format the file's time. If the time is in the current year, display +-- month, day, and hours/minutes. If the time is in any other year, display that year +-- instead of hours and minutes. This is not quite how ls does it - it appears to use +-- the threshold of if the file is more than a year old. That's more time manipulation +-- than I am willing to do. +showTime :: Real t => String -> t -> String +showTime currentYear mtime = let + utcMtime = posixSecondsToUTCTime $ realToFrac mtime + mtimeYear = formatTime defaultTimeLocale "%Y" utcMtime + fmt = "%b %e " ++ if currentYear == mtimeYear then "%R" else "%Y" + in + formatTime defaultTimeLocale fmt utcMtime + +symlinkTarget :: Files -> Maybe String +symlinkTarget Files{filesTarget=Just x, ..} = Just $ T.unpack x +symlinkTarget _ = Nothing + +keyValToLabel :: KeyVal -> Maybe Label +keyValToLabel KeyVal {keyValKey_value=LabelKey x} = Just x +keyValToLabel _ = Nothing + +runCommand :: T.Text -> [String] -> IO (Either String ()) +runCommand db args = do + (opts, _) <- compilerOpts options defaultLsOptions args "ls" + + printer <- if | lsJSONOutput opts -> return $ liftedPutStrLn . jsonPrinter + | lsVerbose opts -> do currentYear <- formatTime defaultTimeLocale "%Y" <$> getCurrentTime + return $ liftedPutStrLn . verbosePrinter currentYear + | otherwise -> return $ liftedPutStrLn . simplePrinter + + runExceptT $ checkAndRunSqlite db $ runConduit $ + -- Grab all the Files, filtering out any whose path does not match what we want. + filesC .| CL.filter (\f -> T.unpack (filesPath f) =~ lsMatches opts) + -- Convert them into LsRow records containing only the Files record. + .| CL.map initRow + -- If we were asked for verbose output, add that to the LsRow. + .| CL.mapM (\row -> if lsVerbose opts then return row { rowUseMetadata=True } + else return row) + -- keyval output comes up in two different ways: If we were + -- given the --keyval flag, we want to add them to the LsRow, + -- If we were given the --label flag, we want to grab the keyvals + -- from the database and check for a match. Note that both flags + -- could be given at the same time. + .| CL.mapMaybeM (\row -> do kvs <- if lsKeyVal opts || isJust (lsLabelMatches opts) + then getKeyValuesForFile (filesPath $ rowFiles row) + else return [] + + let labels = mapMaybe keyValToLabel kvs + + if | maybe False (`notElem` labels) (lsLabelMatches opts) -> return Nothing + | lsKeyVal opts -> return $ Just $ row { rowKeyVals=Just kvs } + | otherwise -> return $ Just row) + -- Finally, pass it to the appropriate printer. + .| CL.mapM_ printer + where + options :: [OptDescr (LsOptions -> LsOptions)] + options = [ + Option [] ["json"] + (NoArg (\opts -> opts { lsJSONOutput = True })) + "format output as JSON", + Option ['k'] ["keyval"] + (NoArg (\opts -> opts { lsKeyVal = True })) + "add key/val pairs to output", + Option ['l'] [] + (NoArg (\opts -> opts { lsVerbose = True })) + "use a long listing format", + Option [] ["label"] + (ReqArg (\d opts -> case reads d :: [(Label, String)] of + [(lbl, _)] -> opts { lsLabelMatches = Just lbl } + _ -> throw $ InvalidLabelError d) "LABEL") + "return only results with the given LABEL", + Option ['m'] ["matches"] + (ReqArg (\d opts -> opts { lsMatches = d }) "REGEX") + "return only results that match REGEX" + ] + + jsonPrinter :: LsRow -> T.Text + jsonPrinter = decodeUtf8 . toStrict . encodePretty + + simplePrinter :: LsRow -> T.Text + simplePrinter LsRow{..} = T.pack $ + printf "%s%s" + (filesPath rowFiles) + (maybe "" formatKeyValList rowKeyVals) + + verbosePrinter :: String -> LsRow -> T.Text + verbosePrinter currentYear LsRow{..} = T.pack $ + printf "%c%s %8s %8s %10Ld %s %s%s%s" + (fromMaybe '-' (fileType rowFiles)) + (if rowUseMetadata then T.unpack $ modeAsText $ fromIntegral $ filesMode rowFiles else "--ghost--") + (T.unpack $ filesFile_user rowFiles) (T.unpack $ filesFile_group rowFiles) + (if rowUseMetadata then filesSize rowFiles else 0) + (showTime currentYear $ filesMtime rowFiles) + (filesPath rowFiles) (maybe "" (" -> " ++) (symlinkTarget rowFiles)) + (maybe "" formatKeyValList rowKeyVals) + +usage :: IO () +usage = do + printVersion "inspect-ls" + putStrLn "Usage: inspect-ls output.db repo [args ...]" + putStrLn " List files in the content store" + putStrLn "- output.db is the path to a metadata database" + putStrLn "- repo is the path to a content store repo" + exitFailure + +runMain :: IO () +runMain = do + argv <- getArgs + case commandLineArgs argv of + Nothing -> usage + Just (db, _, args) -> do + unlessM (doesFileExist db) $ + throw MissingDBError + + result <- runCommand (T.pack db) args + whenLeft result print + +main :: IO () +main = + -- Add handlers for other exception types (IOException, whatever) here. + runMain `catches` [Handler (\(e :: InspectErrors) -> handleInspectErrors e)] + where + -- And then add handlers for the various kinds of InspectErrors here. + handleInspectErrors :: InspectErrors -> IO () + handleInspectErrors (InvalidLabelError lbl) = do + putStrLn $ lbl ++ " is not a recognized file label\n" + putStrLn "Recognized labels:\n" + forM_ labelDescriptions $ \(l, d) -> + putStrLn $ " " ++ l ++ " - " ++ d + exitFailure + + handleInspectErrors MissingCSError = putStrLn "Content store does not exist\n" >> usage + + handleInspectErrors MissingDBError = putStrLn "Metadata database does not exist\n" >> usage diff --git a/src/tools/inspect/subcommands/nevras.hs b/src/tools/inspect/subcommands/nevras.hs new file mode 100644 --- /dev/null +++ b/src/tools/inspect/subcommands/nevras.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.Conditional(unlessM) +import Control.Exception(Handler(..), catches, throw) +import Control.Monad.Except(runExceptT) +import Data.Conduit((.|), runConduit) +import qualified Data.Conduit.List as CL +import qualified Data.Text as T +import System.Console.GetOpt +import System.Directory(doesFileExist) +import System.Environment(getArgs) +import System.Exit(exitFailure) +import Text.Regex.PCRE((=~)) + +import BDCS.DB(checkAndRunSqlite) +import BDCS.Groups(groupsC, groupIdToNevra) +import BDCS.Utils.Either(whenLeft) +import BDCS.Version + +import Utils.Exceptions(InspectErrors(..)) +import Utils.GetOpt(OptClass, commandLineArgs, compilerOpts) +import Utils.IO(liftedPutStrLn) + +-- These warnings are coming from options records that only have one field. +-- As options are added, these warnings will go away. Until then, ignore +-- them. +{-# ANN module "HLint: ignore Use newtype instead of data" #-} + +data NevrasOptions = NevrasOptions { nevraMatches :: String } + +instance OptClass NevrasOptions + +defaultNevrasOptions :: NevrasOptions +defaultNevrasOptions = NevrasOptions { nevraMatches = ".*" } + +runCommand :: T.Text -> FilePath -> [String] -> IO (Either String ()) +runCommand db _ args = do + (opts, _) <- compilerOpts options defaultNevrasOptions args "nevras" + runExceptT $ checkAndRunSqlite db $ runConduit $ + groupsC .| CL.map fst + .| CL.mapMaybeM groupIdToNevra + .| CL.filter (\g -> T.unpack g =~ nevraMatches opts) + .| CL.mapM_ liftedPutStrLn + where + options :: [OptDescr (NevrasOptions -> NevrasOptions)] + options = [ + Option ['m'] ["matches"] + (ReqArg (\d opts -> opts { nevraMatches = d }) "REGEX") + "return only results that match REGEX" + ] + +usage :: IO () +usage = do + printVersion "inspect-nevras" + putStrLn "Usage: inspect-nevras output.db repo [args ...]" + putStrLn " List NEVRAs of RPM packages in the content store" + putStrLn "- output.db is the path to a metadata database" + putStrLn "- repo is the path to a content store repo" + exitFailure + +runMain :: IO () +runMain = do + argv <- getArgs + case commandLineArgs argv of + Nothing -> usage + Just (db, repo, args) -> do + unlessM (doesFileExist db) $ + throw MissingDBError + + result <- runCommand (T.pack db) repo args + whenLeft result (\e -> print $ "error: " ++ e) + +main :: IO () +main = + -- Add handlers for other exception types (IOException, whatever) here. + runMain `catches` [Handler (\(e :: InspectErrors) -> handleInspectErrors e)] + where + -- And then add handlers for the various kinds of InspectErrors here. + handleInspectErrors :: InspectErrors -> IO () + handleInspectErrors MissingDBError = putStrLn "Metadata database does not exist\n" >> usage + + handleInspectErrors _ = usage diff --git a/tests/test_depsolve.sh b/tests/test_depsolve.sh new file mode 100644 --- /dev/null +++ b/tests/test_depsolve.sh @@ -0,0 +1,54 @@ +#!/bin/bash +# Note: execute from the project root directory + +set -x + +BDCS="./dist/build/bdcs/bdcs" + +# when executed without parameters shows usage +if [[ `$BDCS depsolve` != "Usage: depsolve metadata.db NEVRA [NEVRA ...]" ]]; then + exit 1 +fi + +# when executed with non-existing DB returns non-zero +$BDCS depsolve /tmp/none.db httpd +if [[ $? == 0 ]]; then + echo "FAIL: Return code is zero" + exit 1 +fi + +### Prepare for testing depsolve against recipes + +METADATA_DB="metadata.db" +CS_REPO="/tmp/depsolve.repo" +sqlite3 $METADATA_DB < ../schema.sql + +DNF_ROOT=`mktemp -d /tmp/dnf.root.XXXXXX` +DNF_DOWNLOAD=`mktemp -d /tmp/dnf.download.XXXXXX` + +# first depsolve via dnf and download all the RPMs +sudo dnf install -y --nogpgcheck --releasever=26 --downloadonly --downloaddir=$DNF_DOWNLOAD --installroot=$DNF_ROOT httpd + +# then import all RPMs +for F in $DNF_DOWNLOAD/*.rpm; do + $BDCS import $METADATA_DB $CS_REPO file://$F +done + +# figure out the exact NEVRA for the httpd package +HTTPD_NEVRA=`find $DNF_DOWNLOAD -type f -name "httpd-2*.rpm" | cut -f4 -d/ | sed 's/\.rpm//'` + + +# when called with correct parameters +# then output contains input nevra +# and the return code is 0 +OUTPUT=`$BDCS depsolve $METADATA_DB $HTTPD_NEVRA` +if [[ $? != 0 ]]; then + echo "FAIL: Return code is not zero" + exit 1 +fi + +echo "$OUTPUT" | grep $HTTPD_NEVRA +if [ $? != 0 ]; then + echo "FAIL: httpd not included in depsolved list" + exit 1 +fi diff --git a/tests/test_export.sh b/tests/test_export.sh new file mode 100644 --- /dev/null +++ b/tests/test_export.sh @@ -0,0 +1,194 @@ +#!/bin/bash +# Note: execute from the project root directory + +set -x + +BDCS="./dist/build/bdcs/bdcs" + +function compare_with_rpm() { + # Verify that contents of an exported directory have the same files as if + # RPMs were installed via rpm. + EXPORT_DIR=$1 + shift + + RPMS=$@ + RPM_CHROOT=`mktemp -d /tmp/rpm-chroot.XXXXXX` + + # install the RPMs with rpm + sudo rpm -Uhv --root $RPM_CHROOT --nodeps --noscripts $RPMS + if [[ $? != 0 ]]; then + echo "ERROR: rpm exit code should be zero" + exit 1 + fi + + for BASE_FILE in `find $RPM_CHROOT -type f`; do + ### skip some files because the rpm -Uhv will produce + ### different content for them and cause the test to fail + + if [[ "$BASE_FILE" == */etc/shadow ]]; then + echo "INFO: skipping $BASE_FILE ..." + continue + fi + + if [[ "$BASE_FILE" == */etc/gshadow ]]; then + echo "INFO: skipping $BASE_FILE ..." + continue + fi + + if [[ "$BASE_FILE" == */etc/passwd ]]; then + echo "INFO: skipping $BASE_FILE ..." + continue + fi + + if [[ "$BASE_FILE" == */etc/group ]]; then + echo "INFO: skipping $BASE_FILE ..." + continue + fi + + if [[ "$BASE_FILE" == */var/lib/rpm/* ]]; then + echo "INFO: skipping $BASE_FILE ..." + continue + fi + + if [[ "$BASE_FILE" == *.pyc ]]; then + echo "INFO: skipping $BASE_FILE ..." + continue + fi + + echo "INFO: examining $BASE_FILE ..." + EXPECTED_FILE=`echo $BASE_FILE | sed "s|$RPM_CHROOT|$EXPORT_DIR|" | tr -s '/'` + + if [[ ! -f "$EXPECTED_FILE" ]]; then + echo "ERROR: $EXPECTED_FILE doesn't exist" + exit 1 + fi + + BASE_SHA256=`sha256sum $BASE_FILE | cut -f1 -d' '` + EXPECTED_SHA256=`sha256sum $EXPECTED_FILE | cut -f1 -d' '` + + if [[ $BASE_SHA256 != $EXPECTED_SHA256 ]]; then + echo "ERROR: $BASE_SHA256($BASE_FILE) != $EXPECTED_SHA256($EXPECTED_FILE)" + diff -u $BASE_FILE $EXPECTED_FILE + exit 1 + fi + done + + sudo rm -rf $RPM_CHROOT +} + + +# when executed without parameters shows usage +if [[ `$BDCS export | head -n 2 | tail -n 1` != "Usage: export metadata.db repo dest thing [thing ...]" ]]; then + exit 1 +fi + +############################################################ +### Prepare for testing export functionality + +CS_REPO="./export.repo" +METADATA_DB="./export_metadata.db" +EXPORT_DIR="./exported-content.d/" + +sqlite3 $METADATA_DB < ../schema.sql + +# filesystem package is required by the exporter +wget http://mirror.centos.org/centos/7/os/x86_64/Packages/filesystem-3.2-21.el7.x86_64.rpm && \ + $BDCS import $METADATA_DB $CS_REPO file://`pwd`/filesystem-3.2-21.el7.x86_64.rpm +# setup package is required since 5834760 +wget http://mirror.centos.org/centos/7/os/x86_64/Packages/setup-2.8.71-7.el7.noarch.rpm && \ + $BDCS import $METADATA_DB $CS_REPO file://`pwd`/setup-2.8.71-7.el7.noarch.rpm + +############################################################ +## When exporting a non-existing package +## Then returns an error + +OUTPUT=`sudo $BDCS export $METADATA_DB $CS_REPO $EXPORT_DIR filesystem-3.2-21.el7.x86_64 NON-EXISTING` +if [[ $? == 0 ]]; then + echo "ERROR: On error exit code should not be zero" + exit 1 +fi + +if [[ "$OUTPUT" != '"No such group NON-EXISTING"' ]]; then + echo "ERROR: Error output doesn't match" + exit 1 +fi + +sudo rm -rf $EXPORT_DIR + +############################################################ +## When exporting existing package +## Then exported contents match what's inside the RPM package + +wget http://mirror.centos.org/centos/7/os/x86_64/Packages/yum-rhn-plugin-2.0.1-9.el7.noarch.rpm && \ + $BDCS import $METADATA_DB $CS_REPO file://`pwd`/yum-rhn-plugin-2.0.1-9.el7.noarch.rpm + +sudo $BDCS export $METADATA_DB $CS_REPO $EXPORT_DIR filesystem-3.2-21.el7.x86_64 setup-2.8.71-7.el7.noarch yum-rhn-plugin-2.0.1-9.el7.noarch +if [[ $? != 0 ]]; then + echo "ERROR: Exit code should be zero" + exit 1 +fi + +compare_with_rpm $EXPORT_DIR filesystem-3.2-21.el7.x86_64.rpm setup-2.8.71-7.el7.noarch.rpm yum-rhn-plugin-2.0.1-9.el7.noarch.rpm +sudo rm -rf $EXPORT_DIR + +############################################################ +## When exporting existing package into .tar image +## Then untarred contents match the contents of RPM + +sudo $BDCS export $METADATA_DB $CS_REPO exported.tar filesystem-3.2-21.el7.x86_64 setup-2.8.71-7.el7.noarch yum-rhn-plugin-2.0.1-9.el7.noarch +if [[ $? != 0 ]]; then + echo "ERROR: Exit code should be zero" + exit 1 +fi + +mkdir tar_contents && pushd tar_contents/ && tar xvf ../exported.tar && popd +compare_with_rpm tar_contents/ filesystem-3.2-21.el7.x86_64.rpm setup-2.8.71-7.el7.noarch.rpm yum-rhn-plugin-2.0.1-9.el7.noarch.rpm +sudo rm -rf tar_contents/ exported.tar + + +############################################################ +## When exporting two conflicting packages +## And they conflict on a symlink +## Then (since 5834760) the first symlink to be exported wins + +# in libcmpiCppImpl0: +# libcmpiCppImpl.so and libcmpiCppImpl.so.0 are symlinks to libcmpiCppImpl.so.0.0.0 + +# in tog-pegasus-libs: +# libcmpiCppImpl.so is a symlink to libcmpiCppImpl.so.1 + +# the conflicting file is the libcmpiCppImpl.so symlink + + +# these two packages both provide /usr/lib64/libcmpiCppImpl.so +# normally libcmpiCppImpl0 lives in the @conflicts group +wget http://mirror.centos.org/centos/7/os/x86_64/Packages/tog-pegasus-libs-2.14.1-5.el7.x86_64.rpm && \ + $BDCS import $METADATA_DB $CS_REPO file://`pwd`/tog-pegasus-libs-2.14.1-5.el7.x86_64.rpm +wget http://mirror.centos.org/centos/7/os/x86_64/Packages/libcmpiCppImpl0-2.0.3-5.el7.x86_64.rpm && \ + $BDCS import $METADATA_DB $CS_REPO file://`pwd`/libcmpiCppImpl0-2.0.3-5.el7.x86_64.rpm + + +# first libcmpiCppImpl0, second tog-pegasus-libs +sudo $BDCS export $METADATA_DB $CS_REPO $EXPORT_DIR filesystem-3.2-21.el7.x86_64 setup-2.8.71-7.el7.noarch libcmpiCppImpl0-2.0.3-5.el7.x86_64 tog-pegasus-libs-2:2.14.1-5.el7.x86_64 2>&1 +if [[ $? != 0 ]]; then + echo "ERROR: Exit code should be zero" + exit 1 +fi + +# conflict is in tog-pegasus-libs which is the second package in the list +# make sure libcmpiCppImpl0 wins +compare_with_rpm $EXPORT_DIR filesystem-3.2-21.el7.x86_64.rpm setup-2.8.71-7.el7.noarch.rpm libcmpiCppImpl0-2.0.3-5.el7.x86_64.rpm +sudo rm -rf $EXPORT_DIR + + +# first tog-pegasus-libs, second libcmpiCppImpl0 +sudo $BDCS export $METADATA_DB $CS_REPO $EXPORT_DIR filesystem-3.2-21.el7.x86_64 setup-2.8.71-7.el7.noarch tog-pegasus-libs-2:2.14.1-5.el7.x86_64 libcmpiCppImpl0-2.0.3-5.el7.x86_64 +if [[ $? != 0 ]]; then + echo "ERROR: Exit code should be zero" + exit 1 +fi + +# conflict is in libcmpiCppImpl0 which is the second package in the list +# make sure tog-pegasus wins +compare_with_rpm $EXPORT_DIR filesystem-3.2-21.el7.x86_64.rpm setup-2.8.71-7.el7.noarch.rpm tog-pegasus-libs-2.14.1-5.el7.x86_64.rpm +sudo rm -rf $EXPORT_DIR diff --git a/tests/test_import.sh b/tests/test_import.sh new file mode 100644 --- /dev/null +++ b/tests/test_import.sh @@ -0,0 +1,37 @@ +#!/bin/bash +# Note: execute from the project root directory + +set -x + +BDCS="./dist/build/bdcs/bdcs" + +# when executed without parameters shows usage +if [[ `$BDCS import | head -n 2 | tail -n 1` != "Usage: import output.db repo thing [thing ...]" ]]; then + exit 1 +fi + +METADATA_DB="./import_metadata.db" +sqlite3 $METADATA_DB < ../schema.sql +CENTOS_REPO="centos.repo" + +### test that we can import a single RPM from local disk +wget http://mirror.centos.org/centos/7/os/x86_64/Packages/setup-2.8.71-7.el7.noarch.rpm && \ + $BDCS import $METADATA_DB $CENTOS_REPO file://`pwd`/setup-2.8.71-7.el7.noarch.rpm +if [ $? -ne 0 ]; then + echo "ERROR: importing from local disk failed" + exit 1 +fi + +### test that we can import a single RPM from HTTPS URL +$BDCS import $METADATA_DB $CENTOS_REPO https://download-ib01.fedoraproject.org/pub/epel/7/x86_64/Packages/a/abc-1.01-9.hg20160905.el7.x86_64.rpm +if [ $? -ne 0 ]; then + echo "ERROR: importing from HTTPS URL failed" + exit 1 +fi + +### test that we can import entire repository from HTTPS URL +$BDCS import $METADATA_DB $CENTOS_REPO https://s3.amazonaws.com/weldr/https-import-repo/ +if [ $? -ne 0 ]; then + echo "ERROR: importing from HTTPS REPO failed" + exit 1 +fi diff --git a/tests/test_tmpfiles.sh b/tests/test_tmpfiles.sh new file mode 100644 --- /dev/null +++ b/tests/test_tmpfiles.sh @@ -0,0 +1,21 @@ +#!/bin/bash +# Note: execute from the project root directory + +set -x + +CMD="./dist/build/bdcs-tmpfiles/bdcs-tmpfiles" +CFG="./data/tmpfiles-default.conf" +TMPDIR="./test-tmpfiles-$$" + +err_cleanup() { + rm -rf "$TMPDIR" + exit 1 +} + +$CMD $CFG $TMPDIR || err_cleanup + +[ -d "$TMPDIR" ] || err_cleanup +[ -e "$TMPDIR/var/run" ] || err_cleanup +[ -d "$TMPDIR/usr/lib/debug/usr/lib64" ] || err_cleanup + +rm -rf "$TMPDIR"