diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + + A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + + The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + + An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing under +this license. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU Affero General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Remote Network Interaction; Use with the GNU General Public License. + + Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your version +supports such interaction) an opportunity to receive the Corresponding +Source of your version by providing access to the Corresponding Source +from a network server at no charge, through some standard or customary +means of facilitating copying of software. This Corresponding Source +shall include the Corresponding Source for any work covered by version 3 +of the GNU General Public License that is incorporated pursuant to the +following paragraph. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the work with which it is combined will remain governed by version +3 of the GNU General Public License. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU Affero General Public License from time to time. Such new versions +will be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU Affero General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU Affero General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU Affero General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for the +specific requirements. + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU AGPL, see +. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,19 @@ +-- This file is part of khph. +-- +-- Copyright 2016 Bryan Gardiner +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +import Distribution.Simple +main = defaultMain diff --git a/khph.cabal b/khph.cabal new file mode 100644 --- /dev/null +++ b/khph.cabal @@ -0,0 +1,57 @@ +name: khph +version: 0.1.0 +synopsis: Command-line file tagging and organization tool +homepage: http://khumba.net/projects/khph +license: AGPL-3 +license-file: LICENSE +author: Bryan Gardiner +maintainer: Bryan Gardiner +copyright: Bryan Gardiner +category: System +build-type: Simple +cabal-version: >=1.10 +description: + Khph is a tool for managing collections of files from the command line. It + allows you to tag files via symlinks, and query your collection with a simple + query language. + +bug-reports: https://gitlab.com/khumba/issues +source-repository head + type: git + location: https://gitlab.com/khumba/khph.git + +executable khph + default-language: Haskell2010 + ghc-options: -W -fwarn-incomplete-patterns -fwarn-unused-do-bind + hs-source-dirs: src + main-is: Main.hs + other-modules: + Khph.Args + , Khph.Config + , Khph.Project.Base + , Khph.Project.Impl + , Khph.Project.Monad + , Khph.Query.Base + , Khph.Query.Eval + , Khph.Query.Parse + , Khph.Util + default-extensions: + TypeFamilies + other-extensions: + CPP + , OverloadedStrings + build-depends: + aeson >=0.8 && <0.12 + , base >=4.7 && <4.9 + , bytestring >=0.10 && <0.11 + , cmdargs >=0.10 && <0.11 + , containers >=0.5 && <0.6 + , directory >=1.2 && <1.3 + , filepath >=1.3 && <1.5 + , mtl >=2.1 && <2.3 + , parsec >=3.1 && <3.2 + , text >=1.1 && <1.3 + , transformers >=0.3 && <0.5 + , unix >=2.7 && <2.8 + , unordered-containers >=0.2 && <0.3 + , yaml >=0.8 && <0.9 diff --git a/src/Khph/Args.hs b/src/Khph/Args.hs new file mode 100644 --- /dev/null +++ b/src/Khph/Args.hs @@ -0,0 +1,247 @@ +-- This file is part of khph. +-- +-- Copyright 2016 Bryan Gardiner +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP #-} + +-- | Command-line argument parsing. +module Khph.Args ( + description, + CommonArgs (..), + Request (..), + parseFlags, + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$), (<*), (*>)) +#endif +import Data.Functor.Identity (Identity) +import Khph.Util +import System.Console.CmdArgs.Explicit ( + Flag, + HelpFormat, + Mode, + flagArg, + flagBool, + flagHelpFormat, + flagNone, + flagReq, + helpText, + mode, + processArgs, + ) +import System.Console.CmdArgs.Text (TextFormat, showText) +import Text.Parsec ((<|>), (), ParsecT, anyToken, choice, eof, many, parse, try) + +-- | A summary string describing khph. +description :: String +description = "Command-line file tagging and organization tool" + +data CommonArgs = CommonArgs + { caProject :: String + , caPrintSummaries :: Bool + , caPrintFileActions :: Bool + } + +data Request = + FileCount + | List {listQuery :: Maybe String} + | TagList {tagListSpec :: Maybe String} + | TagCreate {tags :: [String]} + | TagAdd {tags :: [String], files :: [FilePath]} + | TagRemove {tags :: [String], files :: [FilePath]} + | Realize {tag :: String, query :: String, tagsInName :: Bool} + | Help + deriving (Show) + +data Term = TermFlag String | TermValue String + deriving (Eq) + +instance Show Term where + show (TermFlag str) = str + show (TermValue str) = concat ["non-flag argument \"", str, "\""] + +data Flags = Flags + { fProject :: String + , fTerms :: [Term] + , fPrintSummaries :: Bool + , fPrintFileActions :: Bool + , fHelp :: Maybe (HelpFormat, TextFormat) + , fTagsInName :: Bool + } deriving (Show) + +defaultFlags = Flags + { fProject = "" + , fTerms = [] + , fPrintSummaries = True + , fPrintFileActions = False + , fHelp = Nothing + , fTagsInName = False + } + +projectUpdater :: String -> Flags -> Either String Flags +projectUpdater value flags = case fProject flags of + "" -> Right flags {fProject = value} + _ -> Left "--project flag specified multiple times." + +printSummariesUpdater :: Bool -> Flags -> Flags +printSummariesUpdater value flags = flags {fPrintSummaries = value} + +printFileActionsUpdater :: Bool -> Flags -> Flags +printFileActionsUpdater value flags = flags {fPrintFileActions = value} + +tagsInNameUpdater :: Bool -> Flags -> Flags +tagsInNameUpdater value flags = flags {fTagsInName = value} + +-- | Creates a cmdargs 'Flag' that parses a no-argument @--flag@ with the given +-- name into a 'Term' in 'fTerms' +flagTerm :: String -> String -> Flag Flags +flagTerm name help = + flagNone [name] (\flags -> flags {fTerms = TermFlag ('-':'-':name) : fTerms flags}) help + +parameters :: Mode Flags +parameters = + mode "khph" defaultFlags + (unlines [ description + , " ><>" + , "Exactly one command must be provided. Command arguments indicate" + , "their syntax in their description. Other arguments are optional." + , " ><>" + , "ENTRY : /foo/bar - Absolute, refers to /foo/bar." + , " foo/bar - Absolute, refers to /foo/bar." + , " ./foo/bar - Relative, refers to $PWD/foo/bar." + , " foo - By-name, refers to all entries named foo." + , "TAG : Same as ENTRY, except by-name results match tags instead." + , "QUERY : A predicate to apply to entries. See README.md." + ]) + (flagArg (\x f -> Right f {fTerms = TermValue x : fTerms f}) "COMMAND") + [ flagHelpFormat $ \helpFormat textFormat f -> f {fHelp = Just (helpFormat, textFormat)} + , flagReq ["p", "project"] projectUpdater "PATH" "The project root directory or project file." + , flagBool ["print-summaries"] printSummariesUpdater "Print out summaries of actions performed." + , flagBool ["print-file-actions"] printFileActionsUpdater "Print out individual file actions." + , flagBool ["tags-in-name"] tagsInNameUpdater "Include tags in --realize'd link names." + , flagTerm "list" $ + concat [ "--list [QUERY]: Lists one hard link (else soft link) for each " + , "entry matching the query (defaults to matching all entries)." + ] + , flagTerm "tags" "--tags [TAG]: Lists all tags (matching the given tag specification)." + , flagTerm "tag-create" $ + concat [ "--tag-create TAG...: Creates the named tags, if they don't exist. " + , "TAG must not be by-name." + ] + , flagTerm "tag-add" "--tag-add TAG... --files ENTRY...: Adds tags to entries." + , flagTerm "tag-remove" "--tag-remove TAG... --files ENTRY...: Removes tags from entries." + , flagTerm "realize" $ + concat [ "--realize TAG QUERY: Creates TAG, removes it from all entries, then " + , "assigns entries matching QUERY to it." + ] + , flagTerm "files" "" + ] + +postProcessFlags :: Flags -> Flags +postProcessFlags flags = flags {fTerms = reverse $ fTerms flags} + +parseFlags :: IO (Either String (CommonArgs, Maybe Request)) +parseFlags = do + flags <- fmap postProcessFlags $ processArgs parameters + let commonArgs = + CommonArgs + { caProject = fProject flags + , caPrintSummaries = fPrintSummaries flags + , caPrintFileActions = fPrintFileActions flags + } + case fHelp flags of + Just (helpFormat, textFormat) -> do + printHelp helpFormat textFormat + return $ Right (commonArgs, Just Help) + Nothing -> case parse requestParser "command line arguments" $ fTerms flags of + Left err -> return $ Left $ show err + Right maybeRequest -> + let postprocessedRequest = case maybeRequest of + Just request@(Realize {}) -> + Just $ request {tagsInName = fTagsInName flags} + _ -> maybeRequest + in return $ Right (commonArgs, postprocessedRequest) + -- TODO Validate common args. + + where printHelp helpFormat textFormat = + putStrLn $ showText textFormat $ helpText [] helpFormat parameters + +type TermParser = ParsecT [Term] () Identity + +valueParser :: TermParser String +valueParser = + try (do t <- anyToken + case t of + TermValue str -> return str + _ -> fail "") + "non-flag argument" + +requestParser :: TermParser (Maybe Request) +requestParser = + Nothing <$ eof <|> + Just <$> choice [ listParser + , tagListParser + , tagCreateParser + , tagAddParser + , tagRemoveParser + , realizeParser + ] + +listParser :: TermParser Request +listParser = + parserEq (TermFlag "--list") *> + (List {listQuery = Nothing} <$ eof <|> + do q <- valueParser <* eof + return List {listQuery = Just q}) + +tagListParser :: TermParser Request +tagListParser = + parserEq (TermFlag "--tags") *> + (TagList {tagListSpec = Nothing} <$ eof <|> + do spec <- valueParser <* eof + return TagList {tagListSpec = Just spec}) + +tagCreateParser :: TermParser Request +tagCreateParser = do + parserEq $ TermFlag "--tag-create" + tags <- many valueParser + return TagCreate {tags = tags} + +tagAddParser :: TermParser Request +tagAddParser = do + parserEq $ TermFlag "--tag-add" + tags <- many valueParser + parserEq $ TermFlag "--files" + files <- many valueParser + eof + return TagAdd {tags = tags, files = files} + +tagRemoveParser :: TermParser Request +tagRemoveParser = do + parserEq $ TermFlag "--tag-remove" + tags <- many valueParser + parserEq $ TermFlag "--files" + files <- many valueParser + eof + return TagRemove {tags = tags, files = files} + +realizeParser :: TermParser Request +realizeParser = do + parserEq $ TermFlag "--realize" + tag <- valueParser + query <- valueParser + return Realize {tag = tag, query = query, tagsInName = False} diff --git a/src/Khph/Config.hs b/src/Khph/Config.hs new file mode 100644 --- /dev/null +++ b/src/Khph/Config.hs @@ -0,0 +1,105 @@ +-- This file is part of khph. +-- +-- Copyright 2016 Bryan Gardiner +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP, OverloadedStrings #-} + +-- | Project configuration data types and parser. +module Khph.Config ( + Config, + defaultConfig, + configSourceDirs, + configIgnoredPaths, + readProjectFile, + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad (unless, when) +import Data.Aeson.Types (typeMismatch) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Set as Set +import Data.Set (Set) +import Data.Text (Text) +import Data.Yaml ( + (.:?), + (.!=), + FromJSON (parseJSON), + Object, + ParseException (UnexpectedEvent, _received, _expected), + Parser, + Value (Object), + decodeFileEither, + ) +import Khph.Project.Base +import Khph.Util +import System.FilePath (isAbsolute) +import Text.Libyaml (Event (EventDocumentStart, EventStreamEnd)) + +data Config = Config + { configSourceDirs :: Set ProjectPath + , configIgnoredPaths :: [ProjectPath] + } deriving (Show) + +-- | Used when the config file is empty or absent. +defaultConfig :: Config +defaultConfig = Config Set.empty [] + +instance FromJSON Config where + parseJSON (Object o) = do + [sourceDirsKey, ignoredPathsKey] <- expectKeys "Config" o ["sourceDirs", "ignore"] + sourceDirs <- map stripTrailingPathSeparators <$> o .:? sourceDirsKey .!= [] + ignoredPaths <- map stripTrailingPathSeparators <$> o .:? ignoredPathsKey .!= [] + + let absoluteSourceDirs = filter isAbsolute sourceDirs + when (not $ null absoluteSourceDirs) $ + fail $ concat + ["sourceDirs: Source directories must be relative paths (to the project root): ", + show absoluteSourceDirs] + + let absoluteIgnoredPaths = filter isAbsolute ignoredPaths + when (not $ null absoluteIgnoredPaths) $ + fail $ concat + ["ignore: Ignored paths must be relative paths (to the project root): ", + show absoluteIgnoredPaths] + + return Config + { configSourceDirs = Set.fromList $ map toProjectPath sourceDirs + , configIgnoredPaths = map toProjectPath ignoredPaths + } + + parseJSON value = typeMismatch "Config" value + +readProjectFile :: FilePath -> IO (Either String Config) +readProjectFile path = + either checkError Right <$> decodeFileEither path + where checkError err = + let isEmptyFile = case err of + UnexpectedEvent {_received = r, _expected = e} -> + r == Just EventStreamEnd && e == Just EventDocumentStart + _ -> False + in if isEmptyFile then Right defaultConfig else Left $ show err + +-- | Returns the given list of keys, but first checks that an object doesn't +-- contain more keys than those in the list. If it does, then the parse is +-- failed with a message containing the extraneous keys. +expectKeys :: String -> Object -> [Text] -> Parser [Text] +expectKeys typeName o keys = do + let extraKeys = Set.fromList (HashMap.keys o) `Set.difference` Set.fromList keys + unless (Set.null extraKeys) $ + fail $ typeName ++ " has unknown keys: " ++ show (Set.toList extraKeys) + return keys diff --git a/src/Khph/Project/Base.hs b/src/Khph/Project/Base.hs new file mode 100644 --- /dev/null +++ b/src/Khph/Project/Base.hs @@ -0,0 +1,168 @@ +-- This file is part of khph. +-- +-- Copyright 2016 Bryan Gardiner +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings #-} + +-- | Core data types for a project. +module Khph.Project.Base ( + -- * Project paths + ProjectPath, + toProjectPath, + projectPathFromComponents, + projectPathToComponents, + projectPathToRelativePath, + projectPathAppend, + projectPathAppendComponents, + projectPathDropLastComponent, + projectPathIsPrefixOf, + -- * Tags + Tag, + toTag, + tagToProjectPath, + tagToComponents, + tagToRelativePath, + -- * Entry lookup + EntrySpec (..), + toEntrySpec, + ) where + +import Data.Function (on) +import Data.List (intercalate, intersperse, isPrefixOf) +import Khph.Util +import System.FilePath (isPathSeparator, isRelative, pathSeparator) + +-- | A project path is a relative path from a project's root directory, +-- normalized so that there are no @.@ or @..@ components. +data ProjectPath = ProjectPath + { projectPathToComponents :: [String] + -- ^ Returns the individual path components. + } deriving (Eq, Ord) + +instance Show ProjectPath where + show x = concat $ + ""] + +-- | Converts a project-relative 'FilePath' into a 'ProjectPath'. Errors if +-- given an absolute path. +toProjectPath :: FilePath -> ProjectPath +toProjectPath path = + if isRelative path + then projectPathFromComponents $ splitPath path + else error $ concat + ["toProjectPath: Expected a relative path, got ", show path, "."] + +-- | Creates a 'ProjectPath' from a list of path components. Removes empty +-- components. +projectPathFromComponents :: [String] -> ProjectPath +projectPathFromComponents = + ProjectPath . filter (not . null) -- The filter here is defensive. + +-- | Converts a 'ProjectPath' to a 'FilePath' relative to the project root. +projectPathToRelativePath :: ProjectPath -> FilePath +projectPathToRelativePath projectPath = + case intercalate [pathSeparator] $ projectPathToComponents projectPath of + "" -> "." + path -> path + +-- | Appends the components from a 'FilePath' on to the end of a 'ProjectPath'. +projectPathAppend :: ProjectPath -> FilePath -> ProjectPath +projectPathAppend projectPath suffix = + projectPathAppendComponents projectPath $ splitPath suffix + +-- | Appends path components onto a 'ProjectPath'. +projectPathAppendComponents :: ProjectPath -> [String] -> ProjectPath +projectPathAppendComponents projectPath components = + projectPathFromComponents $ + (++ components) $ + projectPathToComponents projectPath + +-- | Drops the last component of a file path. +projectPathDropLastComponent :: ProjectPath -> ProjectPath +projectPathDropLastComponent (ProjectPath xs) = ProjectPath $ butLast xs + +-- | @projectPathIsPrefixOf p1 p2@ returns whether @p1@ is either equal to @p2@ +-- or is an ancestor of @p2@. +projectPathIsPrefixOf :: ProjectPath -> ProjectPath -> Bool +projectPathIsPrefixOf = isPrefixOf `on` projectPathToComponents + +-- | A tag is a link outside of all project source directories to a file inside +-- a source directory. Both the link and the file may be either hard or soft +-- links. +newtype Tag = Tag + { tagToProjectPath :: ProjectPath + -- ^ Returns the 'ProjectPath' underlying a 'Tag'. + } deriving (Eq, Ord) + +instance Show Tag where + show tag = concat [""] + +-- | You should probably use 'tagParse' instead of this function. +toTag :: ProjectPath -> Either String Tag +toTag projectPath@(ProjectPath components) = case components of + [] -> Left "toTag: An empty project path may not be a tag." + _ -> Right $ Tag projectPath + +-- | Shortcut for @'projectPathToComponents' . 'tagToProjectPath'@. +tagToComponents :: Tag -> [String] +tagToComponents = projectPathToComponents . tagToProjectPath + +-- | Shortcut for @'projectPathToRelativePath' . 'tagToProjectPath'@. +tagToRelativePath :: Tag -> String +tagToRelativePath = projectPathToRelativePath . tagToProjectPath + +-- | A textual, user-friendly pattern that matches zero or more entries in a +-- project. A 'EntrySpec' can be absolute, relative, or by-name. Absolute +-- 'EntrySpec's represent a single path from the root of the project to a +-- possible entry. Relative 'EntrySpec's represent a single path from the +-- current working directory to a possible entry. By-name 'EntrySpec's store +-- only a single file name, and refer to all entries that have that name in +-- their last component of some path. +-- +-- The textual format for a 'EntrySpec' is as follows. The string may not be +-- empty. Strings that begin with a path separator (see 'isPathSeparator') are +-- absolute. Strings that begin with @.@ then a path separator are relative. +-- Otherwise, strings that contain a path separator are absolute and strings +-- that do not are relative. This may be relaxed in the future by making +-- additional strings not starting with a path separator to be not absolute. +data EntrySpec = + EntrySpecAbsolute [String] + | EntrySpecRelative [String] + | EntrySpecByName String + deriving (Eq) + +instance Show EntrySpec where + show spec = case spec of + EntrySpecAbsolute components -> + concat $ ""] + EntrySpecRelative components -> + concat $ ""] + EntrySpecByName name -> + concat [""] + +-- | Parses an 'EntrySpec', returning an error message if the parse fails. +toEntrySpec :: String -> Either String EntrySpec +toEntrySpec str = case str of + [] -> Left "toEntrySpec: An empty entry specification is invalid." + c:[] | isPathSeparator c -> Right $ EntrySpecAbsolute [] + c:rest | isPathSeparator c -> Right $ EntrySpecAbsolute $ splitPath rest + '.':[] -> Right $ EntrySpecRelative [] + '.':c:rest | isPathSeparator c -> Right $ EntrySpecRelative $ splitPath rest + _ -> if any isPathSeparator str + then Right $ EntrySpecAbsolute $ splitPath str + else Right $ EntrySpecByName str diff --git a/src/Khph/Project/Impl.hs b/src/Khph/Project/Impl.hs new file mode 100644 --- /dev/null +++ b/src/Khph/Project/Impl.hs @@ -0,0 +1,559 @@ +-- This file is part of khph. +-- +-- Copyright 2016 Bryan Gardiner +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP #-} + +-- | Implementation of the project monad. +module Khph.Project.Impl (Project, ProjectT, run) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>), Applicative, pure) +#endif +import Control.Monad (ap, filterM, forM, forM_, liftM, unless, when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Control.Monad.State as State +import Control.Monad.State (StateT, evalStateT) +import Control.Monad.Trans (MonadTrans, lift) +import Data.Function (on) +import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef) +import Data.List (intercalate, isSuffixOf, partition) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (fromJust, fromMaybe, isNothing, listToMaybe) +import qualified Data.Set as Set +import Data.Set (Set) +import Khph.Args (CommonArgs (..)) +import Khph.Config +import Khph.Project.Base +import Khph.Project.Monad +import Khph.Query.Eval +import Khph.Util +import System.Directory ( + canonicalizePath, + createDirectoryIfMissing, + doesFileExist, + getCurrentDirectory, + getDirectoryContents, + removeFile, + ) +import System.Exit (exitFailure) +import System.FilePath ((), makeRelative, pathSeparator, takeFileName) +import System.IO (hPutStrLn, stderr) +import System.IO.Error (catchIOError, isDoesNotExistError) +import System.Posix ( + DeviceID, + FileID, + FileStatus, + createSymbolicLink, + deviceID, + fileID, + getFileStatus, + getSymbolicLinkStatus, + isDirectory, + isSymbolicLink, + ) + +-- TODO This should be controllable. +basicIgnoredSuffixes :: [String] +basicIgnoredSuffixes = ["~"] + +data Project = Project + { projectRoot :: FilePath + , projectFileName :: Maybe FilePath + , projectConfig :: Config + , projectCommonArgs :: CommonArgs + , projectEntriesById :: Map EntryId EntryImpl + , projectEntriesByPath :: Map ProjectPath EntryId + , projectEntriesByTag :: Map Tag (Set EntryId) + , projectTags :: Set Tag + } + +data EntryImpl = EntryImpl + { entryImplId :: EntryId + , entryImplStat :: FileStatus + , entryImplHardLinks :: Set ProjectPath + , entryImplSoftLinks :: Set ProjectPath + , entryImplSourcePath :: Maybe ProjectPath + , entryImplTags :: Map Tag ProjectPath + } + +instance Eq EntryImpl where + (==) = (==) `on` entryImplId + +instance Ord EntryImpl where + compare = compare `on` entryImplId + +instance Show EntryImpl where + show entry = + let softLinksMsg = case Set.toList $ entryImplSoftLinks entry of + [] -> ">" + [x] -> concat ["; soft link ", projectPathToRelativePath x, ">"] + xs -> concat ["; ", show $ length xs, " soft links>"] + + in case Set.toList $ entryImplHardLinks entry of + [] -> concat [" concat [" concat ["Entry ", projectPathToRelativePath x, "; ", show xs, + " hard links", softLinksMsg] + +entryImplLinks :: EntryImpl -> [ProjectPath] +entryImplLinks entry = + Set.toList (entryImplHardLinks entry) ++ + Set.toList (entryImplSoftLinks entry) + +newtype EntryId = EntryId (DeviceID, FileID) + deriving (Eq, Ord, Show) + +data ProjectT m a = ProjectT { runProjectT' :: StateT Project m a } + +instance Monad m => Functor (ProjectT m) where + fmap = liftM + +instance Monad m => Applicative (ProjectT m) where + pure = return + (<*>) = ap + +instance Monad m => Monad (ProjectT m) where + return = ProjectT . return + + (ProjectT x) >>= f = ProjectT $ runProjectT' . f =<< x + +instance MonadTrans ProjectT where + lift = ProjectT . lift + +instance MonadIO m => MonadIO (ProjectT m) where + liftIO = ProjectT . liftIO + +instance MonadIO m => MonadProject (ProjectT m) where + type Entry (ProjectT m) = EntryImpl + + projectWarn msg = liftIO $ hPutStrLn stderr $ "khph: Warning: " ++ msg + + projectDie msg = liftIO $ do + hPutStrLn stderr $ "khph: Error: " ++ msg + exitFailure + + printSummary msg = do + proceed <- caPrintSummaries . projectCommonArgs <$> get + when proceed $ liftIO $ hPutStrLn stderr msg + + printFileAction msg = do + proceed <- caPrintFileActions . projectCommonArgs <$> get + when proceed $ liftIO $ hPutStrLn stderr msg + + getConfig = projectConfig <$> get + + getCurrentPathOrDie reason = do + root <- projectRoot <$> get + dir <- liftIO $ canonicalizePath =<< getCurrentDirectory + if pathIsAncestor root dir + then return $ toProjectPath $ makeRelative root dir + else projectDie $ concat $ + "getCurrentPath: Expected the current path " : show dir : + " to be below the project root " : show root : + if null reason then ["."] else [", ", reason, "."] + + parseRealPath path = do + root <- projectRoot <$> get + liftIO $ parseRealPath' root path + + pathRealize projectPath = do + root <- projectRoot <$> get + return $ pathRealize' root projectPath + + entrySpecLookup entrySpec = case entrySpec of + EntrySpecAbsolute components -> return [projectPathFromComponents components] + + EntrySpecRelative components -> do + currentPath <- getCurrentPathOrDie $ "looking for tags matching " ++ show entrySpec + return [projectPathAppendComponents currentPath components] + + EntrySpecByName name -> + filter (\path -> maybeLast (projectPathToComponents path) == Just name) . + Map.keys . + projectEntriesByPath <$> + get + + entryAtPath projectPath = do + project <- get + return $ + flip Map.lookup (projectEntriesById project) =<< + flip Map.lookup (projectEntriesByPath project) projectPath + + queryEntries query = filterM (queryApply query) . Map.elems . projectEntriesById =<< get + + entryHardLinks = return . Set.toList . entryImplHardLinks + + entrySoftLinks = return . Set.toList . entryImplSoftLinks + + entrySourcePath = return . entryImplSourcePath + + entryTags = return . Map.keys . entryImplTags + + tagList = projectTags <$> get + + -- TODO Reuse entrySpecLookup? + tagLookup entrySpec = case entrySpec of + EntrySpecAbsolute components -> case toTag $ projectPathFromComponents components of + Left err -> oops err + Right tag -> doLookup tag + + EntrySpecRelative components -> do + currentPath <- getCurrentPathOrDie $ "looking for tags matching " ++ show entrySpec + case toTag $ projectPathAppendComponents currentPath components of + Left err -> oops err + Right tag -> doLookup tag + + EntrySpecByName name -> + filter (\tag -> maybeLast (tagToComponents tag) == Just name) . + Set.toList <$> + tagList + + where doLookup tag = do + found <- Set.member tag <$> tagList + return $ if found then [tag] else [] + + oops err = + projectDie $ concat + ["tagLookup: Failed to create tag object from ", show entrySpec, ": ", err] + + tagCreate entrySpec = do + -- By-name EntrySpecs are not allowed for tag creation. + case entrySpec of + EntrySpecByName name -> + projectDie $ concat + ["tagCreate: By-name tag specifications are not allowed, ", + "please use an absolute or relative specification (", + pathSeparator:name, " or .", pathSeparator:name, ")."] + _ -> return () + + -- If the tag exists, we don't need to do anything. + existingTags <- tagLookup entrySpec + case existingTags of + [] -> do + -- The tag doesn't exist, let's create it! Determine a project path for + -- the tag. EntrySpecByName doesn't make any sense here, we need a + -- concrete path. + projectPath <- case entrySpec of + EntrySpecAbsolute components -> return $ projectPathFromComponents components + EntrySpecRelative components -> do + currentPath <- getCurrentPathOrDie $ "creating tag for " ++ show entrySpec + return $ projectPathAppendComponents currentPath components + EntrySpecByName _ -> + projectDie $ concat + ["tagCreate: Internal error, still have a by-name spec ", show entrySpec, "."] + -- Calculate a valid Tag object. + tag <- case toTag projectPath of + Left err -> + projectDie $ concat + ["tagCreate: Couldn't create tag object from ", show entrySpec, ": ", err] + Right tag -> return tag + -- Create the necessary directories. + path <- pathRealize projectPath + printFileAction $ concat ["mkdir -p ", path] + liftIO $ createDirectoryIfMissing True path + -- Update internal state. + modify $ \project -> project {projectTags = Set.insert tag $ projectTags project} + return (tag, True) + [tag] -> return (tag, False) -- The tag already exists. + _ -> projectDie $ concat + ["tagCreate: Internal error, ", show entrySpec, + " matches multiple existing tags: ", show existingTags] + + tagAdd entries tags = do + ensureSourcePathsExist entries + forM_ tags $ \tag -> tagAdd' tag $ map (\entry -> (entry, Nothing)) entries + + tagAdd1 entry tag baseNameMaybe = do + ensureSourcePathsExist [entry] + tagAdd' tag [(entry, baseNameMaybe)] + + tagRemove entries tags = do + ensureSourcePathsExist entries + + forM_ tags $ \tag -> + forM_ entries $ \entry -> case Map.lookup tag $ entryImplTags entry of + Nothing -> return () + Just projectPath -> do + path <- pathRealize projectPath + -- Sanity check: Ensure that this is a soft link. + lstat <- liftIO $ getSymbolicLinkStatus path + if isSymbolicLink lstat + then do -- Remove the tag on disk. + printFileAction $ concat ["rm ", path] + liftIO $ removeFile path + + -- Update the project in memory. + let entry' = entry { entryImplSoftLinks = Set.delete projectPath $ + entryImplSoftLinks entry + , entryImplTags = Map.delete tag $ entryImplTags entry + } + entryId = entryImplId entry' + modify $ \project -> + project { projectEntriesById = Map.insert entryId entry' $ + projectEntriesById project + , projectEntriesByPath = Map.delete projectPath $ + projectEntriesByPath project + , projectEntriesByTag = Map.adjust (Set.delete entryId) tag $ + projectEntriesByTag project + } + + else projectWarn $ concat + ["tagRemove: Want to remove ", show tag, " from ", show projectPath, + ", but the file is not a soft link. Not removing."] + +get :: Monad m => ProjectT m Project +get = ProjectT State.get + +modify :: Monad m => (Project -> Project) -> ProjectT m () +modify = ProjectT . State.modify + +-- | Ensures that we have at least one source path for all given entries. +ensureSourcePathsExist :: MonadIO m => [EntryImpl] -> ProjectT m () +ensureSourcePathsExist entries = + case filter (isNothing . entryImplSourcePath) entries of + [] -> return () + xs -> projectDie $ concat $ + "tagAdd: The following entries aren't linked in source directories: " : + map (("\n- " ++) . show) xs + +run :: MonadIO m => CommonArgs -> FilePath -> Maybe FilePath -> ProjectT m a -> m a +run commonArgs projectDir maybeProjectFile action = do + loaded <- load commonArgs projectDir maybeProjectFile + case loaded of + Left err -> die err + Right project -> evalStateT (runProjectT' action) project + +load :: MonadIO m => CommonArgs -> FilePath -> Maybe FilePath -> m (Either String Project) +load commonArgs projectRootRaw maybeProjectFileName = do + projectRoot <- liftIO $ canonicalizePath projectRootRaw + let maybeProjectFilePath = (projectRoot ) <$> maybeProjectFileName + configResult <- case maybeProjectFilePath of + Nothing -> return $ Right defaultConfig + Just projectFilePath -> do + projectFileExists <- liftIO $ doesFileExist projectFilePath + if projectFileExists + then liftIO $ readProjectFile projectFilePath + else return $ Right defaultConfig + case configResult of + Left err -> return $ Left $ "Error parsing project file: " ++ err + Right config -> do + let sourceDirs = Set.toList $ configSourceDirs config + basicIgnoredPaths = (maybe id (:) maybeProjectFilePath) [projectRoot] + customIgnoredPaths = Set.fromList $ + map (pathRealize' projectRoot) $ + configIgnoredPaths config + + entriesByIdRef <- liftIO $ newIORef Map.empty + entriesByTagRef <- liftIO $ newIORef Map.empty + tagsRef <- liftIO $ newIORef Set.empty + + forAllEntriesRecursively projectRoot $ \path -> do + let (process, recur) = case undefined of + _ | Set.member path customIgnoredPaths -> (False, False) + _ | elem path basicIgnoredPaths || + any (`isSuffixOf` path) basicIgnoredSuffixes -> (False, True) + _ -> (True, True) + + when process $ do + maybeStat <- liftIO $ catchIOError (Just <$> getFileStatus path) $ \e -> + if isDoesNotExistError e + then return Nothing + else ioError e + lstat <- liftIO $ getSymbolicLinkStatus path + + case maybeStat of + Nothing -> return () -- Dead soft link, ignore it. + Just stat -> case (isDirectory lstat, isDirectory stat) of + -- Ignore soft links to directories. + (False, True) -> return () + + (True, _) -> do + projectPath <- liftIO $ + either (\err -> + die $ concat + ["load: Couldn't parse a project path for ", + show path, ": ", err]) + return =<< + parseRealPath' projectRoot path + when (not (any (\src -> projectPathIsPrefixOf src projectPath) sourceDirs)) $ do + tag <- either (\err -> + die $ concat ["load: Error parsing tag from directory ", + show path, ":", err]) + return $ + toTag projectPath + liftIO $ do + modifyIORef tagsRef $ Set.insert tag + modifyIORef entriesByTagRef $ Map.insert tag Set.empty + + (False, False) -> do + let entryId = EntryId (deviceID stat, fileID stat) + projectPath = toProjectPath $ makeRelative projectRoot path + + liftIO $ do + entriesById <- readIORef entriesByIdRef + + let maybeEntry = Map.lookup entryId entriesById + + entryInitial = + flip fromMaybe maybeEntry $ + EntryImpl + { entryImplId = entryId + , entryImplStat = stat + , entryImplHardLinks = Set.empty + , entryImplSoftLinks = Set.empty + , entryImplSourcePath = Nothing + , entryImplTags = Map.empty + } + + entryWithLinks = + if isSymbolicLink lstat + then entryInitial + { entryImplSoftLinks = + Set.insert projectPath $ entryImplSoftLinks entryInitial + } + else entryInitial + { entryImplHardLinks = + Set.insert projectPath $ entryImplHardLinks entryInitial + } + + isSourcePath path = + any (\sourceDir -> projectPathIsPrefixOf sourceDir path) sourceDirs + + (sourcePaths, tagPaths) = + partition isSourcePath $ entryImplLinks entryWithLinks + + -- If we have no source paths for a file, then ignore any tag + -- (i.e. non-source) paths for the file, since it doesn't make + -- sense to have a bunch of tags on a file we don't manage. + entryWithTags <- + if null sourcePaths + then return entryWithLinks + else do tags <- forM tagPaths $ \tagPath -> + case toTag $ projectPathDropLastComponent tagPath of + Left err -> + die $ concat ["load: Error parsing tag from path ", + show tagPath, ": ", err] + Right tag -> return (tag, tagPath) + return entryWithLinks + { entryImplSourcePath = listToMaybe sourcePaths + , entryImplTags = Map.fromList tags + } + + -- Update entriesById. + writeIORef entriesByIdRef $ Map.insert entryId entryWithTags entriesById + -- Update entriesByTag. + case Map.keys $ entryImplTags entryWithTags of + [] -> return () + tags -> modifyIORef entriesByTagRef $ \entriesByTag -> + foldr (\tag entriesByTag' -> + Map.alter (Just . Set.insert entryId . fromMaybe Set.empty) + tag + entriesByTag') + entriesByTag + tags + + return recur + + entriesById <- liftIO $ readIORef entriesByIdRef + entriesByTag <- liftIO $ readIORef entriesByTagRef + tags <- liftIO $ readIORef tagsRef + + let entries :: [EntryImpl] + entries = Map.elems entriesById + + entriesByPath :: Map ProjectPath EntryId + entriesByPath = foldr (\entry m -> foldr (\path -> Map.insert path $ entryImplId entry) + m + (Set.toList (entryImplHardLinks entry) ++ + Set.toList (entryImplSoftLinks entry))) + Map.empty + entries + + project :: Project + project = + Project + { projectRoot = projectRoot + , projectFileName = maybeProjectFileName + , projectConfig = config + , projectCommonArgs = commonArgs + , projectEntriesById = entriesById + , projectEntriesByPath = entriesByPath + , projectEntriesByTag = entriesByTag + , projectTags = tags + } + + return $ Right project + +parseRealPath' :: FilePath -> FilePath -> IO (Either String ProjectPath) +parseRealPath' root path = do + canonicalPath <- canonicalizePath path + if pathIsAncestor root canonicalPath + then return $ Right $ toProjectPath $ makeRelative root canonicalPath + else return $ Left $ concat + ["parseRealPath: Path ", show canonicalPath, + " is not below the project root ", show root, "."] + +pathRealize' :: FilePath -> ProjectPath -> FilePath +pathRealize' root path = root projectPathToRelativePath path + +tagAdd' :: MonadIO m => Tag -> [(EntryImpl, Maybe String)] -> ProjectT m () +tagAdd' tag entriesAndBaseNames = do + let tagComponents = tagToComponents tag + upToRoot = intercalate [pathSeparator] $ replicate (length tagComponents) ".." + + forM_ entriesAndBaseNames $ \(entry, baseNameMaybe) -> + unless (Map.member tag $ entryImplTags entry) $ do + tagDir <- pathRealize $ tagToProjectPath tag + let entryPath = projectPathToRelativePath $ fromJust $ entryImplSourcePath entry + entryBaseName = takeFileName entryPath + linkSourcePath = tagDir fromMaybe entryBaseName baseNameMaybe + linkTargetPath = upToRoot entryPath + + -- Add the tag on disk. + printFileAction $ concat ["ln -s ", linkTargetPath, " ", linkSourcePath] + liftIO $ createSymbolicLink linkTargetPath linkSourcePath + + -- Update the project in memory. + let linkSourceProjectPath = projectPathAppend (tagToProjectPath tag) entryBaseName + entry' = entry { entryImplSoftLinks = Set.insert linkSourceProjectPath $ + entryImplSoftLinks entry + , entryImplTags = Map.insert tag linkSourceProjectPath $ + entryImplTags entry + } + entryId = entryImplId entry' + modify $ \project -> + project { projectEntriesById = Map.insert entryId entry' $ + projectEntriesById project + , projectEntriesByPath = Map.insert linkSourceProjectPath entryId $ + projectEntriesByPath project + , projectEntriesByTag = + Map.alter (Just . Set.insert entryId . fromMaybe Set.empty) tag $ + projectEntriesByTag project + } + +forAllEntriesRecursively :: MonadIO m => FilePath -> (FilePath -> m Bool) -> m () +forAllEntriesRecursively root action = go root + where go path = do + recur <- action path + when recur $ do + typ <- liftIO $ getFileType path + when (typ == Directory) $ do + droppingIOErrors (getDirectoryContents path) $ \contents -> + forM_ contents $ \entry -> + unless (entry `elem` [".", ".."]) $ + go $ path entry diff --git a/src/Khph/Project/Monad.hs b/src/Khph/Project/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Khph/Project/Monad.hs @@ -0,0 +1,177 @@ +-- This file is part of khph. +-- +-- Copyright 2016 Bryan Gardiner +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP #-} + +-- | A monad for performing operations on a project. +module Khph.Project.Monad ( + MonadProject (..), + dumpProjectContents, + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative) +#endif +import Control.Monad (forM_) +import Control.Monad.Trans (lift) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Set (Set) +import Khph.Config (Config) +import Khph.Project.Base +import Khph.Query.Base +import Text.Parsec (ParsecT) + +-- | A monad for performing operations on a project. +class (Functor m, Applicative m, Monad m) => MonadProject m where + -- | A data type representing an entry in the project. + type Entry m + + -- | Prints out a warning message. + projectWarn :: String -> m () + + -- | Prints out an error message, then aborts execution. + projectDie :: String -> m a + + -- | Prints out a summary message. + printSummary :: String -> m () + + -- | Prints out notification of a file action. + printFileAction :: String -> m () + + -- | Returns the project's configuration. + getConfig :: m Config + + -- | If the program's current path is within the project, then this returns + -- the corresponding 'ProjectPath', calling 'projectDie' otherwise. The + -- argument is a sentence fragment explaing the cause, starting with "because + -- ...", "for ...", etc. and not ending in punctuation. + getCurrentPathOrDie :: String -> m ProjectPath + + -- | Takes a file path and canonicalizes it. If this path is below the + -- project root then a 'ProjectPath' is returned, otherwise an error message + -- is returned. + parseRealPath :: FilePath -> m (Either String ProjectPath) + + -- | Converts a 'ProjectPath' to an absolute 'FilePath'. + pathRealize :: ProjectPath -> m FilePath + + -- | Converts an 'EntrySpec' into 'ProjectPaths' as follows. Absolute and + -- relative 'EntrySpec's get converted to the single path that they point to, + -- __whether or not it exists__. By-name 'EntrySpec's get converted to the + -- list of paths that __actually exist__. + entrySpecLookup :: EntrySpec -> m [ProjectPath] + + -- | Checks whether there is an entry at a specific path, and returns it, if + -- found. + entryAtPath :: ProjectPath -> m (Maybe (Entry m)) + + -- | Runs a query over entries in the project. + queryEntries :: Query -> m [Entry m] + + -- | Returns all of an entry's hard links. + entryHardLinks :: Entry m -> m [ProjectPath] + + -- | Returns all of an entry's soft links. + entrySoftLinks :: Entry m -> m [ProjectPath] + + -- | Returns an arbitrary source path for an entry, if it has one. + entrySourcePath :: Entry m -> m (Maybe ProjectPath) + + -- | Returns all of the tags associated with an entry. + entryTags :: Entry m -> m [Tag] + + -- | Returns all tags. + tagList :: m (Set Tag) + + -- | Returns all tags that match a specification. + tagLookup :: EntrySpec -> m [Tag] + + -- | @'tagLookup1' caller spec@ calls @'tagLookup' spec@. If 'tagLookup' + -- returns a single tag, then so does 'tagLookup1'. If 'tagLookup' returns + -- zero or multiple entries, then 'tagLookup1' calls 'projectDie' with an + -- error message that includes @caller@. + tagLookup1 :: String -> EntrySpec -> m Tag + tagLookup1 caller spec = do + tags <- tagLookup spec + case tags of + [tag] -> return tag + _ -> do + let count = length tags + projectDie $ concat + ["tagLookup1 via ", caller, ": ", show spec, + " should match one tag but matched ", + show count, ": ", show (take 10 tags), + if count > 10 then ", ..." else ""] + + -- | Creates a tag, if it doesn't exist. Returns the tag, and whether the tag + -- was newly created. By-name specifications are not allowed here. + tagCreate :: EntrySpec -> m (Tag, Bool) + + -- | Associates each entry with each tag given. + tagAdd :: [Entry m] -> [Tag] -> m () + + -- | Associates an entry with a single tag. If given a @Just String@, the string will be + -- used for the file name of the soft link created (but if the entry already + -- has this tag, then a link already exists and this link won't be created). + tagAdd1 :: Entry m -> Tag -> Maybe String -> m () + + -- | Disassociates each entry from each tag given. + tagRemove :: [Entry m] -> [Tag] -> m () + +instance MonadProject m => MonadProject (ParsecT s u m) where + type Entry (ParsecT s u m) = Entry m + + projectWarn = lift . projectWarn + projectDie = lift . projectDie + printSummary = lift . printSummary + printFileAction = lift . printFileAction + getConfig = lift getConfig + getCurrentPathOrDie = lift . getCurrentPathOrDie + parseRealPath = lift . parseRealPath + pathRealize = lift . pathRealize + entrySpecLookup = lift . entrySpecLookup + entryAtPath = lift . entryAtPath + queryEntries = lift . queryEntries + entryHardLinks = lift . entryHardLinks + entrySoftLinks = lift . entrySoftLinks + entrySourcePath = lift . entrySourcePath + entryTags = lift . entryTags + tagList = lift tagList + tagLookup = lift . tagLookup + tagLookup1 = (lift .) . tagLookup1 + tagCreate = lift . tagCreate + tagAdd = (lift .) . tagAdd + tagAdd1 = ((lift .) .) . tagAdd1 + tagRemove = (lift .) . tagRemove + +dumpProjectContents :: (MonadIO m, MonadProject m) => m () +dumpProjectContents = do + liftIO $ putStrLn "<<< Project contents dump" + entries <- queryEntries LogicTrue + forM_ entries $ \entry -> do + liftIO $ putStrLn "- Entry" + hardLinks <- entryHardLinks entry + softLinks <- entrySoftLinks entry + tags <- entryTags entry + forM_ hardLinks $ showLink "Hard" + forM_ softLinks $ showLink "Soft" + forM_ tags $ \tag -> liftIO $ putStrLn $ concat [" - Tag: ", tagToRelativePath tag] + liftIO $ putStrLn ">>> Project contents dump" + + where showLink label projectPath = do + let path = projectPathToRelativePath projectPath + liftIO $ putStrLn $ concat [" - ", label, " link: ", show path] diff --git a/src/Khph/Query/Base.hs b/src/Khph/Query/Base.hs new file mode 100644 --- /dev/null +++ b/src/Khph/Query/Base.hs @@ -0,0 +1,120 @@ +-- This file is part of khph. +-- +-- Copyright 2016 Bryan Gardiner +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +-- | Data types for constructing predicates. +module Khph.Query.Base ( + Logic (..), + ListPredicate (..), + Query, Query' (..), + StringQuery, StringQuery' (..), + LinkQuery, LinkQuery' (..), + ProjectPathComponent (..), + TreeQuery, TreeQuery' (..), + TagQuery, + ) where + +import Khph.Project.Base +import Khph.Util + +-- | Wraps a query of type @q@ in Boolean logic. +data Logic q = + LogicQuery q + | LogicTrue + | LogicFalse + | LogicNot (Logic q) + | LogicAnd [Logic q] + | LogicOr [Logic q] + deriving (Eq, Show) + +-- | Represent a fold of a query @q@ over a list. +-- +-- TODO Count lt/gt operators? Useful for e.g. "more than one place tag." +data ListPredicate q = + All q + -- ^ All items in the list must match @q@. + | All1 q + -- ^ All items in the list must match @q@, and the list must be nonempty. + | Some q + -- ^ Some item in the list must match @q@. + | None q + -- ^ All items in the list must not match @q@. + | Exists + -- ^ The list must be nonempty. + | DoesNotExist + -- ^ The list must be empty. + deriving (Eq, Show) + +-- | A query on an entry. +type Query = Logic Query' + +data Query' = + QueryLink (ListPredicate LinkQuery) + | QueryTag (ListPredicate TagQuery) + deriving (Eq, Show) + +-- | A query on a string. +type StringQuery = Logic StringQuery' + +data StringQuery' = + StringEq String + | StringContains String + | StringStartsWith String + | StringEndsWith String + deriving (Eq, Show) + +-- | A query on one of an entry's links. +type LinkQuery = Logic LinkQuery' + +data LinkQuery' = + LinkTypeIs LinkType + -- ^ Matches based on whether the link is hard or soft. + | LinkMatchesEntrySpec EntrySpec + -- ^ Matches based on an 'EntrySpec'. + | LinkIsSourcePath + -- ^ Matches if the link is at or below one of the project's source + -- directories. + | LinkStringQuery (Maybe ProjectPathComponent) StringQuery + -- ^ Matches if a 'StringQuery' matches the project-relative path's textual + -- representation. 'ProjectPathComponent' may be used to select only the + -- directory or file name components of the path. + | LinkTreeQuery (TreeQuery [String]) + -- ^ Matches if a 'TreeQuery' matches the link's position in the directory + -- tree. + deriving (Eq, Show) + +data ProjectPathComponent = DirectoryComponent | FileComponent + deriving (Eq, Show) + +-- | A query on a position in a tree. @a@ may be an arbitrary data type, that +-- must be convertible into a @Eq b => [b]@ for comparison. +type TreeQuery a = Logic (TreeQuery' a) + +data TreeQuery' a = + TreeAt a + -- ^ The position must be at the exact location given. + | TreeAtAbove a + -- ^ The position must either at or be an ancestor of the location given. + | TreeAbove a + -- ^ The position must be an ancestor (not at) the location given. + | TreeAtBelow a + -- ^ The position must either at or be a child of the location given. + | TreeBelow a + -- ^ The position must be a child (not at) the location given. + deriving (Eq, Show) + +-- | A tag query is just a query on the tag's position in the tag hierarchy. +type TagQuery = TreeQuery Tag diff --git a/src/Khph/Query/Eval.hs b/src/Khph/Query/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Khph/Query/Eval.hs @@ -0,0 +1,109 @@ +-- This file is part of khph. +-- +-- Copyright 2016 Bryan Gardiner +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP #-} + +-- | Evaluator for a parsed query. +module Khph.Query.Eval (queryApply) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif +import Data.List (intercalate, isInfixOf, isPrefixOf, isSuffixOf) +import qualified Data.Set as Set +import Khph.Config (configSourceDirs) +import Khph.Project.Base +import Khph.Project.Monad +import Khph.Query.Base +import Khph.Util +import System.FilePath (pathSeparator) + +-- | Evaluates a query for a specific entry, returning whether the query matches +-- the entry. +queryApply :: MonadProject m => Query -> Entry m -> m Bool +queryApply logic entry = logicApply logic $ \query -> case query of + QueryLink listPredicate -> do + links <- (++) <$> + (map (\path -> (path, HardLink)) <$> entryHardLinks entry) <*> + (map (\path -> (path, SoftLink)) <$> entrySoftLinks entry) + listPredicateApply listPredicate queryLink links + QueryTag listPredicate -> do + tags <- entryTags entry + listPredicateApply listPredicate (\q xs -> queryTree tagToComponents q xs) $ + map tagToComponents tags + +queryLink :: MonadProject m => LinkQuery -> (ProjectPath, LinkType) -> m Bool +queryLink logic (projectPath, linkType) = logicApply logic $ \query -> case query of + LinkTypeIs typ -> return $ typ == linkType + LinkMatchesEntrySpec entrySpec -> case entrySpec of + EntrySpecAbsolute components -> + return $ projectPathToComponents projectPath == components + EntrySpecRelative components -> do + currentPath <- getCurrentPathOrDie $ "running query " ++ show query + return $ projectPath == projectPathAppendComponents currentPath components + EntrySpecByName name -> + return $ maybeLast (projectPathToComponents projectPath) == Just name + LinkIsSourcePath -> + any (\sourceDir -> projectPathIsPrefixOf sourceDir projectPath) . + Set.toList . + configSourceDirs <$> + getConfig + LinkStringQuery maybeComponent stringQuery -> + queryString stringQuery $ + intercalate [pathSeparator] $ + (case maybeComponent of + Nothing -> id + Just DirectoryComponent -> butLast + Just FileComponent -> (:[]) . last) $ + projectPathToComponents projectPath + LinkTreeQuery treeQuery -> + queryTree id treeQuery $ projectPathToComponents projectPath + +queryString :: MonadProject m => StringQuery -> String -> m Bool +queryString logic xs = logicApply logic $ \query -> return $ case query of + StringEq ys -> xs == ys + StringContains ys -> ys `isInfixOf` xs -- TODO This is terribly inefficient. + StringStartsWith ys -> ys `isPrefixOf` xs + StringEndsWith ys -> ys `isSuffixOf` xs + +queryTree :: MonadProject m => Eq b => (a -> [b]) -> TreeQuery a -> [b] -> m Bool +queryTree resolve logic xs = logicApply logic $ \query -> return $ case query of + TreeAt ys' -> xs == resolve ys' + TreeAtAbove ys' -> xs `isPrefixOf` resolve ys' + TreeAbove ys' -> let ys = resolve ys' + in xs `isPrefixOf` ys && length xs < length ys + TreeAtBelow ys' -> resolve ys' `isPrefixOf` xs + TreeBelow ys' -> let ys = resolve ys' + in ys `isPrefixOf` xs && length ys < length xs + +logicApply :: MonadProject m => Logic q -> (q -> m Bool) -> m Bool +logicApply logic eval = case logic of + LogicQuery query -> eval query + LogicTrue -> return True + LogicFalse -> return False + LogicNot logic' -> not <$> logicApply logic' eval + LogicAnd logics -> allM (flip logicApply eval) logics + LogicOr logics -> anyM (flip logicApply eval) logics + +listPredicateApply :: MonadProject m => ListPredicate q -> (q -> a -> m Bool) -> [a] -> m Bool +listPredicateApply p f xs = case p of + All q -> allM (f q) xs + All1 q -> if null xs then return False else allM (f q) xs + Some q -> anyM (f q) xs + None q -> not <$> anyM (f q) xs + Exists -> return $ not $ null xs + DoesNotExist -> return $ null xs diff --git a/src/Khph/Query/Parse.hs b/src/Khph/Query/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Khph/Query/Parse.hs @@ -0,0 +1,247 @@ +-- This file is part of khph. +-- +-- Copyright 2016 Bryan Gardiner +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP #-} + +-- | Query language parser. +module Khph.Query.Parse (parseQuery) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$), (<$>), (<*), (*>)) +#endif +import Data.Char (toLower) +import Data.List (intercalate) +import Khph.Project.Base +import Khph.Project.Monad +import Khph.Query.Base +import Khph.Util +import Text.Parsec ( + (<|>), + (), + ParsecT, + anyToken, + char, + digit, + eof, + letter, + many, + many1, + noneOf, + option, + optional, + parse, + runParserT, + sepBy, + space, + try, + ) +import Text.ParserCombinators.Parsec (Parser) + +data Term = + TWord String + | TLiteralString String + | TLiteralInteger Integer + | TParenL + | TParenR + deriving (Eq, Show) + +-- | Parses a query from a string. Returns an error message if parsing fails. +parseQuery :: MonadProject m => String -> m (Either String Query) +parseQuery str = + case parse (terms <* eof) "" str of + Left err -> return $ Left $ show err + Right terms -> either (Left . show) return <$> + if null terms + then return $ Right LogicTrue + else runParserT (query <* eof) () "" terms + +terms :: Parser [Term] +terms = term `sepBy` many space + +term :: Parser Term +term = + word <|> + string <|> + integer <|> + TParenL <$ char '(' <|> + TParenR <$ char ')' + +word :: Parser Term +word = TWord . map toLower <$> many1 letter + +string :: Parser Term +string = + TLiteralString <$> + (char '"' *> many (stringChar '"') <* char '"' <|> + char '\'' *> many (stringChar '\'') <* char '\'') + where stringChar :: Char -> Parser Char + stringChar delim = do + ch <- noneOf [delim] + case ch of + '\\' -> do + ch2 <- anyToken + if ch2 == delim + then return delim + else case ch2 of + '\\' -> return '\\' + '0' -> return '\0' + 'n' -> return '\n' + 'r' -> return '\r' + 't' -> return '\t' + 'v' -> return '\v' + _ -> fail $ concat + ["Unknown escape sequence \\", [ch2], " in khph string."] + _ -> return ch + +integer :: Parser Term +integer = + TLiteralInteger <$> + ((char '-' *> (negate . read <$> digits)) <|> + read <$> digits) + where digits = many1 digit + +type TermParserT = ParsecT [Term] () + +logic :: MonadProject m => TermParserT m q -> TermParserT m (Logic q) +logic q = disjunction q + +disjunction :: MonadProject m => TermParserT m q -> TermParserT m (Logic q) +disjunction q = + (\ls -> case ls of + [l] -> l + _ -> LogicOr ls) <$> + conjunction q `mySepBy1` w "or" + +conjunction :: MonadProject m => TermParserT m q -> TermParserT m (Logic q) +conjunction q = + (\ls -> case ls of + [l] -> l + _ -> LogicAnd ls) <$> + negation q `mySepBy1` w "and" + +negation :: MonadProject m => TermParserT m q -> TermParserT m (Logic q) +negation q = + w "not" *> (LogicNot <$> negation q) <|> + logicQuery q + +logicQuery :: MonadProject m => TermParserT m q -> TermParserT m (Logic q) +logicQuery q = + pl *> logic q <* pr <|> + LogicTrue <$ w "true" <|> + LogicFalse <$ w "false" <|> + LogicQuery <$> q + +listPredicate :: MonadProject m + => TermParserT m () + -> TermParserT m a + -> TermParserT m (ListPredicate a) +listPredicate word subparser = + try (w "all" *> word *> (All <$> subparser)) <|> + try (w "all1" *> word *> (All1 <$> subparser)) <|> + try (optional (w "some") *> word *> (option Exists $ Some <$> subparser)) <|> + try (w "no" *> word *> (option DoesNotExist $ None <$> subparser)) + +query :: MonadProject m => TermParserT m Query +query = + logic $ + QueryLink <$> listPredicate (w "link" <|> w "links" <|> + w "path" <|> w "paths") + linkQuery <|> + QueryTag <$> listPredicate (w "tag" <|> w "tags") tagQuery + +stringQuery :: MonadProject m => TermParserT m StringQuery +stringQuery = + logic $ + StringEq <$> (w "eq" *> stringTerm) <|> + StringContains <$> ((w "contains" <|> w "contain") *> stringTerm) <|> + StringStartsWith <$> ((w "starts" <|> w "start") *> w "with" *> stringTerm) <|> + StringEndsWith <$> ((w "ends" <|> w "end") *> w "with" *> stringTerm) + +linkQuery :: MonadProject m => TermParserT m LinkQuery +linkQuery = + logic $ + try (LinkTypeIs <$> (isAre *> (HardLink <$ w "hard" <|> + SoftLink <$ w "soft"))) <|> + LinkMatchesEntrySpec <$> (w "matches" *> entrySpec) <|> + LinkIsSourcePath <$ isAre <* w "source" <|> + try (w "file" *> (LinkStringQuery (Just FileComponent) <$> stringQuery) <|> + w "directory" *> (LinkStringQuery (Just DirectoryComponent) <$> stringQuery) <|> + LinkStringQuery Nothing <$> stringQuery) <|> + LinkTreeQuery <$> treeQuery (do spec <- entrySpec + paths <- entrySpecLookup spec + let count = length paths + limit = 10 + case paths of + [path] -> return $ projectPathToComponents path + _ -> fail $ concat + ["The EntrySpec given to a LinkTreeQuery should match ", + "a single entry, but we found ", show count, ": ", + intercalate ", " $ map show $ take limit paths, + if count > limit then ", ..." else ""]) + +tagQuery :: MonadProject m => TermParserT m TagQuery +tagQuery = treeQuery $ tagLookup1 "tagQuery" =<< entrySpec + +treeQuery :: MonadProject m => TermParserT m a -> TermParserT m (TreeQuery a) +treeQuery valueParser = + logic $ + (w "at" *> (TreeAt <$> valueParser)) <|> + (w "atabove" *> (TreeAtAbove <$> valueParser)) <|> + (w "atbelow" *> (TreeAtBelow <$> valueParser)) <|> + (w "above" *> (TreeAbove <$> valueParser)) <|> + (w "below" *> (TreeBelow <$> valueParser)) + +entrySpec :: MonadProject m => TermParserT m EntrySpec +entrySpec = do + str <- stringTerm + case toEntrySpec str of + Left err -> fail $ concat + ["Couldn't parse an EntrySpec from ", show str, ": ", err] + Right entrySpec -> return entrySpec + +stringTerm :: Monad m => TermParserT m String +stringTerm = + try (do t <- anyToken + case t of + TLiteralString str -> return str + _ -> fail "") + "string" + +w :: Monad m => String -> TermParserT m () +w = parserEq . TWord . map toLower + +pl :: Monad m => TermParserT m () +pl = parserEq TParenL + +pr :: Monad m => TermParserT m () +pr = parserEq TParenR + +isAre :: Monad m => TermParserT m () +isAre = w "is" <|> w "are" + +-- | Similar to 'sepBy1', @mySepBy1 body separator@ parses a series of @body@s +-- separated by @separator@. However, unlike 'sepBy1', this function wraps each +-- @separator >> mySepBy1 body separator@ recursive call in a 'try', so seeing a +-- separator but failing to parse a subsequent body doesn't cause the parse to +-- fail, because the same separator may be used at a higher level in the syntax +-- tree. +mySepBy1 :: TermParserT m a -> TermParserT m b -> TermParserT m [a] +mySepBy1 body separator = do + x <- body + -- Instead of the next line, sepBy1 uses "xs <- many (separator body)". + xs <- try (separator *> mySepBy1 body separator) <|> return [] + return $ x:xs diff --git a/src/Khph/Util.hs b/src/Khph/Util.hs new file mode 100644 --- /dev/null +++ b/src/Khph/Util.hs @@ -0,0 +1,153 @@ +-- This file is part of khph. +-- +-- Copyright 2016 Bryan Gardiner +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +-- | Miscellaneous utilities. +module Khph.Util ( + butLast, + maybeLast, + splitOn, + stripTrailingPathSeparators, + anyM, + allM, + warn, + die, + rightOrDie, + splitPath, + pathIsAncestor, + droppingIOErrors, + LinkType (..), + FileType (..), + getFileType, + parserEq, + ) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.List (findIndex, isPrefixOf) +import System.Exit (exitFailure) +import System.FilePath (isPathSeparator, normalise, splitDirectories) +import System.IO (hPrint, hPutStrLn, stderr) +import System.IO.Error ( + catchIOError, + doesNotExistErrorType, + ioeGetErrorType, + tryIOError, + ) +import System.Posix ( + getFileStatus, + getSymbolicLinkStatus, + isDirectory, + isRegularFile, + isSymbolicLink, + ) +import Text.Parsec ((), ParsecT, anyToken, try) + +butLast :: [a] -> [a] +butLast [] = [] +butLast xs = take (length xs - 1) xs + +maybeLast :: [a] -> Maybe a +maybeLast [] = Nothing +maybeLast (x:[]) = Just x +maybeLast (_:xs) = maybeLast xs + +-- | Splits a list at elements for which a predicate returns true. The matching +-- elements themselves are dropped. +splitWhen :: (a -> Bool) -> [a] -> [[a]] +splitWhen _ [] = [] +splitWhen f xs = case findIndex f xs of + Just index -> let (term, _:rest) = splitAt index xs + in term : splitWhen f rest + Nothing -> [xs] + +-- | Splits a string on a specified character. +splitOn :: Char -> String -> [String] +splitOn ch = splitWhen (== ch) + +stripTrailingPathSeparators :: FilePath -> FilePath +stripTrailingPathSeparators "" = "" +stripTrailingPathSeparators str = + if isPathSeparator $ last str + then reverse $ dropWhile isPathSeparator $ reverse str + else str + +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM _ [] = return False +anyM f (x:xs) = do b <- f x + if b then return True else anyM f xs + +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM _ [] = return True +allM f (x:xs) = do b <- f x + if b then allM f xs else return False + +warn :: MonadIO m => String -> m () +warn msg = liftIO $ hPutStrLn stderr $ "khph: Warning: " ++ msg + +die :: MonadIO m => String -> m a +die msg = liftIO $ do + hPutStrLn stderr $ "khph: Error: " ++ msg + exitFailure + +rightOrDie :: MonadIO m => Either String a -> m a +rightOrDie = either (liftIO . die) return + +splitPath :: FilePath -> [String] +splitPath = splitDirectories . normalise + +pathIsAncestor :: FilePath -> FilePath -> Bool +pathIsAncestor path1 path2 = splitPath path1 `isPrefixOf` splitPath path2 + +-- | Executes an IO action, calling the handler function if the action succeeds, +-- and printing the error message to stderr if the action throws an exception. +droppingIOErrors :: MonadIO m => IO a -> (a -> m ()) -> m () +droppingIOErrors action onSuccess = do + result <- liftIO $ tryIOError action + case result of + Left err -> liftIO $ hPrint stderr err + Right x -> onSuccess x + +data LinkType = HardLink | SoftLink + deriving (Eq, Show) + +data FileType = + Nonexistant + | File + | Directory + | SymlinkTo FileType + | Other + deriving (Eq, Show) + +getFileType :: FilePath -> IO FileType +getFileType = query getSymbolicLinkStatus + where query f path = flip catchIOError handler $ do + stat <- f path + case undefined of + _ | isRegularFile stat -> return File + _ | isDirectory stat -> return Directory + _ | isSymbolicLink stat -> fmap SymlinkTo $ query getFileStatus path + _ -> return Other + + handler e = + if ioeGetErrorType e == doesNotExistErrorType + then return Nonexistant + else ioError e + +parserEq :: (Eq a, Show a, Monad m) => a -> ParsecT [a] u m () +parserEq t = + try (do t' <- anyToken + if t == t' then return () else fail "") + show t diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,237 @@ +-- This file is part of khph. +-- +-- Copyright 2016 Bryan Gardiner +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP #-} + +module Main (main) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad ((<=<), forM_, unless) +import Control.Monad.IO.Class (liftIO) +import Data.Either (partitionEithers) +import Data.List (intercalate, isSuffixOf) +import Data.Maybe (catMaybes, isNothing) +import qualified Data.Set as Set +import qualified Khph.Args as Args +import Khph.Project.Base +import qualified Khph.Project.Impl as ProjectImpl +import Khph.Project.Monad +import Khph.Query.Base +import Khph.Query.Parse +import Khph.Util +import System.Directory ( + canonicalizePath, + getCurrentDirectory, + getDirectoryContents, + ) +import System.Exit (exitFailure) +import System.FilePath ( + (), + pathSeparator, + replaceBaseName, + takeBaseName, + takeDirectory, + takeFileName, + ) +import System.IO (hPutStrLn, stderr) +import System.Posix.Files (getFileStatus, isDirectory, isRegularFile) + +main :: IO () +main = do + flagsResult <- Args.parseFlags + case flagsResult of + Left err -> do + hPutStrLn stderr $ "khph: " ++ err + exitFailure + Right (commonArgs, maybeRequest) -> do + initialDirectory <- canonicalizePath =<< getCurrentDirectory + + -- Find a project file to use. + (projectRoot, maybeProjectFile) <- case Args.caProject commonArgs of + "" -> do + result <- findProjectFile True initialDirectory + case result of + Nothing -> die "Couldn't find a project." + Just path -> return (takeDirectory path, Just $ takeFileName path) + pathRaw -> do + path <- canonicalizePath pathRaw + stat <- getFileStatus path + case undefined of + _ | isRegularFile stat -> + return (takeDirectory path, Just $ takeFileName path) + _ | isDirectory stat -> do + maybeProjectFile <- findProjectFile False path + return (path, maybeProjectFile) + _ -> die $ concat + ["--project expects a regular file or directory. Got ", show path, "."] + + ProjectImpl.run commonArgs projectRoot maybeProjectFile $ do + request <- case maybeRequest of + Just request -> return request + Nothing -> liftIO $ do + putStr $ unlines + [ "khph: " ++ Args.description + , "See --help for more information." + ] + exitFailure + + case request of + Args.Help -> + -- Printing the help message is handled by the argument parser. + return () + + Args.List {Args.listQuery = queryStrMaybe} -> do + query <- case queryStrMaybe of + Nothing -> return LogicTrue + Just queryStr -> parseQueryOrDie queryStr + printSummary $ "Query: " ++ show query + + entries <- queryEntries query + forM_ entries $ \entry -> do + hardLinks <- entryHardLinks entry + links <- if not $ null hardLinks + then return hardLinks + else entrySoftLinks entry + path <- case links of + [] -> projectDie $ concat + ["list: Internal error, should have links for ", show entry, " but don't."] + link:_ -> return link + liftIO . putStrLn =<< pathRealize path + + let entryCount = length entries + printSummary $ concat + ["Found ", show entryCount, if entryCount == 1 then " entry." else " entries."] + + Args.TagList {Args.tagListSpec = entrySpecStrMaybe} -> do + tags <- case entrySpecStrMaybe of + Nothing -> Set.toList <$> tagList + Just entrySpecStr -> tagLookup =<< parseEntrySpecOrDie entrySpecStr + forM_ tags $ liftIO . putStrLn . tagToRelativePath + + Args.TagCreate {Args.tags = tagStrs} -> + forM_ tagStrs $ tagCreate <=< parseEntrySpecOrDie + + Args.TagAdd { Args.files = files + , Args.tags = tagStrs + } -> do + projectPaths <- parsePathsOrDie files + entries <- findEntriesOrDie projectPaths + tags <- findTagsOrDie tagStrs + tagAdd entries tags + + Args.TagRemove { Args.files = files + , Args.tags = tagStrs + } -> do + projectPaths <- parsePathsOrDie files + entries <- findEntriesOrDie projectPaths + tags <- findTagsOrDie tagStrs + tagRemove entries tags + + Args.Realize { Args.tag = tagStr + , Args.query = queryStr + , Args.tagsInName = tagsInName + } -> do + -- Parse inputs. + entrySpec <- parseEntrySpecOrDie tagStr + query <- parseQueryOrDie queryStr + + -- Look up (or create) the tag, and remove the tag's existing + -- association with all entries. If you're realizing a query for + -- entries with a tag, you don't want the target tag contributing to + -- that! + (tag, tagIsNew) <- tagCreate entrySpec + unless tagIsNew $ do + entriesOld <- queryEntries $ LogicQuery $ QueryTag $ Some $ LogicQuery $ TreeAt tag + tagRemove entriesOld [tag] + + entriesNew <- queryEntries query + forM_ entriesNew $ \entry -> do + etags <- entryTags entry + sourcePath <- maybe (projectDie $ concat + ["realize: ", show entry, " should have a source path."]) + return =<< + entrySourcePath entry + + -- If requested, then we add tags into link file names. + let linkFileName = if tagsInName + then Just $ replaceBaseName targetFileName newBaseName + else Nothing + -- The following are only used when tagsInName is true. + renderedTags = + map (map (\c -> if c == pathSeparator then '-' else c) . + tagToRelativePath) etags + targetFileName = takeFileName $ projectPathToRelativePath sourcePath + newBaseName = intercalate " " $ takeBaseName targetFileName : renderedTags + + tagAdd1 entry tag linkFileName + + let entryCount = length entriesNew + printSummary $ concat + ["Found ", show entryCount, if entryCount == 1 then " entry." else " entries."] + + _ -> projectDie "khph: Unimplemented command." + +findProjectFile :: Bool -> FilePath -> IO (Maybe FilePath) +findProjectFile recur startingDirectory = do + contents <- getDirectoryContents startingDirectory + let projectFiles = filter (".khph" `isSuffixOf`) contents + case projectFiles of + projectFile:_ -> return $ Just $ startingDirectory projectFile + [] -> if recur + then let parent = takeDirectory startingDirectory + in if parent == startingDirectory + then return Nothing + else findProjectFile recur parent + else return Nothing + +parsePathsOrDie :: MonadProject m => [FilePath] -> m [ProjectPath] +parsePathsOrDie pathStrs = do + (errors, projectPaths) <- partitionEithers <$> mapM parseRealPath pathStrs + if null errors + then return projectPaths + else projectDie $ concat $ + "parsePathsOrDie: Couldn't parse some paths: " : map ("\n- " ++) errors + +findEntriesOrDie :: MonadProject m => [ProjectPath] -> m [Entry m] +findEntriesOrDie projectPaths = do + entriesResult <- mapM (\p -> (,) p <$> entryAtPath p) projectPaths + case filter (isNothing . snd) entriesResult of + [] -> return $ catMaybes $ map snd entriesResult + xs -> projectDie $ concat $ + "findEntriesOrDie: Couldn't find some entries: " : + map (("\n- " ++) . projectPathToRelativePath . fst) xs + +findTagsOrDie :: MonadProject m => [String] -> m [Tag] +findTagsOrDie = mapM $ tagLookup1 "main" <=< parseEntrySpecOrDie + +parseEntrySpecOrDie :: MonadProject m => String -> m EntrySpec +parseEntrySpecOrDie specStr = case toEntrySpec specStr of + Left err -> + projectDie $ concat + ["parseEntrySpecOrDie: Couldn't parse EntrySpec from ", show specStr, ": ", err] + Right entrySpec -> return entrySpec + +parseQueryOrDie :: MonadProject m => String -> m Query +parseQueryOrDie queryStr = do + queryResult <- parseQuery queryStr + case queryResult of + Left err -> + projectDie $ concat + ["parseQueryOrDie: Error parsing query from ", show queryStr, ": ", err] + Right query -> return query