packages feed

bdcs (empty) → 0.1.0

raw patch · 107 files changed

+10300/−0 lines, 107 filesdep +HUnitdep +aesondep +aeson-prettybuild-type:Customsetup-changed

Dependencies added: HUnit, aeson, aeson-pretty, base, bdcs, bytestring, codec-rpm, cond, conduit, conduit-combinators, conduit-extra, containers, content-store, cpio-conduit, cryptonite, directory, esqueleto, exceptions, filepath, gi-gio, gi-glib, gi-ostree, gitrev, hspec, http-conduit, memory, monad-control, monad-logger, monad-loops, mtl, network-uri, parsec, parsec-numbers, persistent, persistent-sqlite, persistent-template, process, regex-pcre, resourcet, split, tar, tar-conduit, temporary, text, time, unix, unordered-containers, xml-conduit

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+## 0.1.0++* Initial release.
+ Dockerfile view
@@ -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
+ Dockerfile.build view
@@ -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
+ Dockerfile.integration-test view
@@ -0,0 +1,8 @@+FROM welder/bdcs-build-img:latest+MAINTAINER Alexander Todorov <atodorov@redhat.com>++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"]
+ LICENSE view
@@ -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.++    <one line to give the library's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    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.++  <signature of Ty Coon>, 1 April 1990+  Ty Coon, President of Vice++That's all there is to it!
+ Makefile view
@@ -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
+ README.md view
@@ -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/
+ Setup.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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')
+ bdcs.cabal view
@@ -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
+ cabal.config view
@@ -0,0 +1,1 @@+constraints: persistent-sqlite +systemlib
+ data/nsswitch-altfiles.conf view
@@ -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
+ data/sysusers-default.conf view
@@ -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
+ data/tmpfiles-default.conf view
@@ -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 -
+ data/tmpfiles-ostree.conf view
@@ -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
+ entrypoint-integration-test.sh view
@@ -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/
+ entrypoint.sh view
@@ -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
+ queries view
@@ -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
+ schema.sql view
@@ -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
+ src/BDCS/Build/NPM.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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 <module-name>@<module-version> instead of just <module-name>,+        -- 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/<module-name> directory.+        let module_dir = "/" </> "usr" </> "lib" </> "node_modules" </> T.unpack (T.concat [name, "@", ver])++        -- Create the /usr/lib/node_modules/<package> 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/<name>@<version> 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
+ src/BDCS/Builds.hs view
@@ -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
+ src/BDCS/CS.hs view
@@ -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 }
+ src/BDCS/DB.hs view
@@ -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
+ src/BDCS/Depclose.hs view
@@ -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 <matching-ids>+        --+        -- 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
+ src/BDCS/Depsolve.hs view
@@ -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 <cnf-of-head> AND <cnf-of-tail>, 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
+ src/BDCS/Exceptions.hs view
@@ -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
+ src/BDCS/Export/Directory.hs view
@@ -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
+ src/BDCS/Export/Ostree.hs view
@@ -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-<CHECKSUM>+        -- and /boot/initramfs-<CHECKSUM>, 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)
+ src/BDCS/Export/Qcow2.hs view
@@ -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"]+        )
+ src/BDCS/Export/Tar.hs view
@@ -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)
+ src/BDCS/Export/TmpFiles.hs view
@@ -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
+ src/BDCS/Export/Utils.hs view
@@ -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
+ src/BDCS/Files.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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
+ src/BDCS/GroupKeyValue.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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
+ src/BDCS/Groups.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/Import/Comps.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/Import/Conduit.hs view
@@ -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]
+ src/BDCS/Import/NPM.hs view
@@ -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 <bindir>/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 (<bin name>, <path>) pairs+    -- Insert as k=bin, v=<binname>, e=<path>+    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 <bindir>/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
+ src/BDCS/Import/RPM.hs view
@@ -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
+ src/BDCS/Import/Repodata.hs view
@@ -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 <location href=""> 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 /<root>/data[@type=<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
+ src/BDCS/Import/State.hs view
@@ -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+                               }
+ src/BDCS/Import/URI.hs view
@@ -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)
+ src/BDCS/KeyType.hs view
@@ -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
+ src/BDCS/KeyValue.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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]
+ src/BDCS/Label/Docs.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/Label/FileLabels.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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
+ src/BDCS/Label/Fonts.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/Label/InfoPage.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/Label/Library.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/Label/License.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/Label/ManPage.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/Label/Service.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/Label/Translation.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/Label/Types.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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")+ ]
+ src/BDCS/Label/Utils.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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)
+ src/BDCS/NPM/SemVer.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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 <version> - <version>+    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.<patch>: 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 [] []
+ src/BDCS/Packages.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/Projects.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/RPM/Builds.hs view
@@ -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
+ src/BDCS/RPM/Files.hs view
@@ -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
+ src/BDCS/RPM/Groups.hs view
@@ -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
+ src/BDCS/RPM/Projects.hs view
@@ -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
+ src/BDCS/RPM/Requirements.hs view
@@ -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
+ src/BDCS/RPM/Scripts.hs view
@@ -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)
+ src/BDCS/RPM/Signatures.hs view
@@ -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
+ src/BDCS/RPM/Sources.hs view
@@ -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
+ src/BDCS/RPM/Utils.hs view
@@ -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)
+ src/BDCS/ReqType.hs view
@@ -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"
+ src/BDCS/Requirements.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/BDCS/Scripts.hs view
@@ -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)
+ src/BDCS/Signatures.hs view
@@ -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
+ src/BDCS/Sources.hs view
@@ -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
+ src/BDCS/Utils/Conduit.hs view
@@ -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
+ src/BDCS/Utils/Either.hs view
@@ -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 ()
+ src/BDCS/Utils/Error.hs view
@@ -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
+ src/BDCS/Utils/Filesystem.hs view
@@ -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
+ src/BDCS/Utils/Mode.hs view
@@ -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                       -> '-'+ ]
+ src/BDCS/Utils/Monad.hs view
@@ -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
+ src/BDCS/Version.hs view
@@ -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
+ src/tests/BDCS/DepcloseSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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)
+ src/tests/BDCS/DepsolveSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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)
+ src/tests/BDCS/Export/TmpFilesSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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}+        ]+
+ src/tests/BDCS/GroupsSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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)
+ src/tests/BDCS/RPM/BuildSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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")
+ src/tests/BDCS/RPM/ProjectsSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/tests/BDCS/RPM/SignaturesSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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")
+ src/tests/BDCS/RPM/SourcesSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.+--++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")
+ src/tests/BDCS/RPM/UtilsSpec.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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")
+ src/tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ src/tests/Utils.hs view
@@ -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 <http://www.gnu.org/licenses/>.+--+{-# 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
+ src/tools/Utils/GetOpt.hs view
@@ -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]"
+ src/tools/Utils/Subcommands.hs view
@@ -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)
+ src/tools/bdcs-tmpfiles.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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 <config> <dest>"+    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
+ src/tools/bdcs.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/tools/depsolve.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/tools/export.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/tools/import.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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)
+ src/tools/inspect/Utils/Exceptions.hs view
@@ -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
+ src/tools/inspect/Utils/IO.hs view
@@ -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
+ src/tools/inspect/Utils/KeyVal.hs view
@@ -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))
+ src/tools/inspect/inspect.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ src/tools/inspect/subcommands/groups.hs view
@@ -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
+ src/tools/inspect/subcommands/ls.hs view
@@ -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
+ src/tools/inspect/subcommands/nevras.hs view
@@ -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
+ tests/test_depsolve.sh view
@@ -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
+ tests/test_export.sh view
@@ -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
+ tests/test_import.sh view
@@ -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
+ tests/test_tmpfiles.sh view
@@ -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"